DECLARE EXTERNAL NUMERIC md2d.sysTime ! system time
DECLARE EXTERNAL SUB md2d.setInitialCondition
DECLARE EXTERNAL SUB md2d.moveParticles
DECLARE EXTERNAL SUB md2d.drawParticles
DECLARE EXTERNAL FUNCTION md2d.sysTemp
!
CALL setInitialCondition
CALL drawParticles(100)
!
FOR it=1 TO 1000
FOR i=1 TO 20
CALL moveParticles
NEXT i
CALL drawParticles(100)
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
!END IF
NEXT it
!
END
!
! ---------- md2d module ----------
!
MODULE md2d
PUBLIC NUMERIC sysTime
PUBLIC SUB setInitialCondition,moveParticles,drawParticles
PUBLIC FUNCTION sysTemp
SHARE NUMERIC dt,Nmt, xMax, yMax, sigm, mass, epsi, mag
SHARE NUMERIC xx(100),yy(100),vx(100),vy(100),ffx(100),ffy(100)
! xx(i),yy(i) : position of i-th paryicle
! vx(i),vy(i) : velocity of i-th paryicle
! ffx(i),ffy(i): force of i-th paryicle
LET sysTime = 0.0 ! system time (s)
LET dt = 20.0*1.0e-15 ! time step (s)
LET Nmt=36 ! number of particles
LET xMax =6.0E-9 ! x-Box size (m)
LET yMax =6.0E-9 ! y-Box size (m)
LET mass = 39.95*1.67e-27 ! mass of Ar (kg)
LET sigm = 3.40e-10 ! L-J potential sigma for Ar (m)
LET epsi = 1.67e-21 ! L-J potential epsilon FOR Ar (J)
LET mag = 1.0E9 ! (view scale(m)) = mag x (particle scale(nm))
!
EXTERNAL SUB setInitialCondition
DECLARE EXTERNAL SUB ajustV
! set particles
RANDOMIZE
LET s = xMax/7.0
FOR i=1 TO Nmt
LET xx(i) = s*MOD((i-1),6)+1.0*s
LET yy(i) = s*int((i-1)/6)+1.0*s
LET vx(i) = 500.0*(RND-0.5)
LET vy(i) = 500.0*(RND-0.5)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
CALL ajustV(150)
! set window
LET b=2
SET WINDOW -b,xMax*mag+b,-b,yMax*mag+b
!
END SUB
!
EXTERNAL SUB moveParticles
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO Nmt
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO Nmt
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
! set boundary
FOR i=1 TO Nmt
if (xx(i) < 0.0) then
LET xx(i) = 0.0 ! -xx(i)
LET vx(i) = -vx(i)
END IF
IF (xx(i) > xMax) THEN
LET xx(i) = xMax ! 2*xMax-xx(i)
LET vx(i) = -vx(i)
END IF
if (yy(i) < 0.0) then
LET yy(i) = 0.0 ! -yy(i)
LET vy(i) = -vy(i)
END IF
if (yy(i) > yMax) then
LET yy(i) = yMax ! 2*yMax-yy(i)
LET vy(i) = -vy(i)
END IF
NEXT i
LET sysTime=sysTime+dt
END sub
!
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force
FOR i=1 TO Nmt
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO Nmt-1
FOR j=i+1 TO Nmt
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
NEXT j
NEXT i
END sub
!
EXTERNAL function force(r) ! force(r) = -dV(r)/dr
LET ri = sigm/r
LET r6 = ri^6
LET force = (24.0*epsi*r6*(2.0*r6-1.0)/r)
END function
!
! utility
!
EXTERNAL FUNCTION sysTemp
LET k = 1.38e-23 ! Boltzman's constant (J/K)
LET totalEnergy = 0.0
FOR i=1 TO Nmt
LET totalEnergy = totalEnergy + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET sysTemp = totalEnergy/(Nmt*k)
END FUNCTION
!
EXTERNAL SUB ajustV(temp)
DECLARE EXTERNAL FUNCTION sysTemp
LET r = sqr(temp/sysTemp)
FOR i=1 TO Nmt
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END sub
!
! display
!
EXTERNAL SUB drawParticles(vmag)
DECLARE EXTERNAL FUNCTION sysTemp
LET t1 = vmag*dt
LET b = (sigm/2)*mag
!
SET DRAW MODE HIDDEN
CLEAR
SET LINE COLOR 1 ! black : wall
PLOT LINES: -b,-b; xMax*mag+b,-b; xMax*mag+b,yMax*mag+b; -b,yMax*mag+b; -b,-b
!
FOR i=1 TO Nmt
SET COLOR 2 ! blue : position
DRAW circle WITH SCALE(sigm/2.0*1E9)*SHIFT(xx(i)*mag,yy(i)*mag)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xx(i)*mag,yy(i)*mag;
PLOT LINES: (xx(i)+vx(i)*t1)*mag,(yy(i)+vy(i)*t1)*mag
SET LINE COLOR 1 ! black : force
PLOT LINES: xx(i)*mag,yy(i)*mag;
PLOT LINES: (xx(i)+0.1*ffx(i)*t1*t1/mass)*mag,(yy(i)+0.1*ffy(i)*t1*t1/mass)*mag
NEXT i
!
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,-0.7,USING "box size =##.# x ##.# (nm)":xMax*mag,yMax*mag
PLOT TEXT, AT 0,-1 ,USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
PLOT TEXT, AT 0,-1.3 :"Ar in the box (2-dimensional molecular dynamics)"
!
SET LINE COLOR 4 ! red : velocity
LET xPos = xMax*mag*0.5+1
LET yPos = yMax*mag+1
PLOT LINES: xPos,yPos;xPos+0.5,yPos
SET TEXT COLOR 4 ! red
PLOT TEXT, AT xPos+0.7,yPos-0.05: "velosity"
SET LINE COLOR 1 ! black : velocity
PLOT LINES: xPos,yPos-0.3;xPos+0.5,yPos-0.3
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xPos+0.7,yPos-0.35: "force"
!
SET DRAW MODE EXPLICIT
END SUB
!
END MODULE
!
!
! end of file
> 初投稿です。
>
> 分子動力学法による箱の中のArの運動のシミュレーションをしています。
> 以下に添付したdecimal basicのプログラムを動かしてみると、
> windows (ver 7.7.8)では比較的滑らかに粒子が動くのですが、
> mac (ver 0.6.5.2)では、ぎくしゃくとした動きをします。
> 対策はあるのでしょうか？
> ご教示いただければ幸いです。
>
> ---------------
>
> !
> ! ========= molecular dynamics 2D ==========
> !
> ! ArGasMD2D.bas
> ! Mitsuru Ikeuchi
> !
> ! ver 0.0.0 2017.01.11
> !
>
> DECLARE EXTERNAL NUMERIC md2d.sysTime ! system time
> DECLARE EXTERNAL SUB md2d.setInitialCondition
> DECLARE EXTERNAL SUB md2d.moveParticles
> DECLARE EXTERNAL SUB md2d.drawParticles
> DECLARE EXTERNAL FUNCTION md2d.sysTemp
> !
> CALL setInitialCondition
> CALL drawParticles(100)
> !
> FOR it=1 TO 1000
> FOR i=1 TO 20
> CALL moveParticles
> NEXT i
> CALL drawParticles(100)
> !IF (MOD(it,10)=0) THEN
> ! PRINT USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
> !END IF
> NEXT it
> !
> END
>
> !
> ! ---------- md2d module ----------
> !
> MODULE md2d
> PUBLIC NUMERIC sysTime
> PUBLIC SUB setInitialCondition,moveParticles,drawParticles
> PUBLIC FUNCTION sysTemp
> SHARE NUMERIC dt,Nmt, xMax, yMax, sigm, mass, epsi, mag
> SHARE NUMERIC xx(100),yy(100),vx(100),vy(100),ffx(100),ffy(100)
> ! xx(i),yy(i) : position of i-th paryicle
> ! vx(i),vy(i) : velocity of i-th paryicle
> ! ffx(i),ffy(i): force of i-th paryicle
> LET sysTime = 0.0 ! system time (s)
> LET dt = 20.0*1.0e-15 ! time step (s)
> LET Nmt=36 ! number of particles
> LET xMax =6.0E-9 ! x-Box size (m)
> LET yMax =6.0E-9 ! y-Box size (m)
> LET mass = 39.95*1.67e-27 ! mass of Ar (kg)
> LET sigm = 3.40e-10 ! L-J potential sigma for Ar (m)
> LET epsi = 1.67e-21 ! L-J potential epsilon FOR Ar (J)
> LET mag = 1.0E9 ! (view scale(m)) = mag x (particle scale(nm))
> !
> EXTERNAL SUB setInitialCondition
> DECLARE EXTERNAL SUB ajustV
> ! set particles
> RANDOMIZE
> LET s = xMax/7.0
> FOR i=1 TO Nmt
> LET xx(i) = s*MOD((i-1),6)+1.0*s
> LET yy(i) = s*int((i-1)/6)+1.0*s
> LET vx(i) = 500.0*(RND-0.5)
> LET vy(i) = 500.0*(RND-0.5)
> LET ffx(i) = 0.0
> LET ffy(i) = 0.0
> NEXT i
> CALL ajustV(150)
> ! set window
> LET b=2
> SET WINDOW -b,xMax*mag+b,-b,yMax*mag+b
> !
> END SUB
> !
> EXTERNAL SUB moveParticles
> DECLARE EXTERNAL SUB calcForce
> LET a = 0.5*dt/mass
> FOR i=1 TO Nmt
> !LET a = 0.5*dt/mass
> LET vx(i) = vx(i)+a*ffx(i)
> LET vy(i) = vy(i)+a*ffy(i)
> LET xx(i) = xx(i)+vx(i)*dt
> LET yy(i) = yy(i)+vy(i)*dt
> NEXT i
> CALL calcForce
> FOR i=1 TO Nmt
> !LET a = 0.5*dt/mass
> LET vx(i) = vx(i)+a*ffx(i)
> LET vy(i) = vy(i)+a*ffy(i)
> NEXT i
> ! set boundary
> FOR i=1 TO Nmt
> if (xx(i) < 0.0) then
> LET xx(i) = 0.0 ! -xx(i)
> LET vx(i) = -vx(i)
> END IF
> IF (xx(i) > xMax) THEN
> LET xx(i) = xMax ! 2*xMax-xx(i)
> LET vx(i) = -vx(i)
> END IF
> if (yy(i) < 0.0) then
> LET yy(i) = 0.0 ! -yy(i)
> LET vy(i) = -vy(i)
> END IF
> if (yy(i) > yMax) then
> LET yy(i) = yMax ! 2*yMax-yy(i)
> LET vy(i) = -vy(i)
> END IF
> NEXT i
> LET sysTime=sysTime+dt
> END sub
> !
> EXTERNAL SUB calcForce
> DECLARE EXTERNAL FUNCTION force
> FOR i=1 TO Nmt
> LET ffx(i) = 0.0
> LET ffy(i) = 0.0
> NEXT i
> FOR i=1 TO Nmt-1
> FOR j=i+1 TO Nmt
> LET xij = xx(i)-xx(j)
> LET yij = yy(i)-yy(j)
> LET rij = SQR(xij*xij+yij*yij)
> LET f = force(rij)
> LET fxij = f*xij/rij
> LET fyij = f*yij/rij
> LET ffx(i) = ffx(i)+fxij
> LET ffy(i) = ffy(i)+fyij
> LET ffx(j) = ffx(j)-fxij
> LET ffy(j) = ffy(j)-fyij
> NEXT j
> NEXT i
> END sub
> !
> EXTERNAL function force(r) ! force(r) = -dV(r)/dr
> LET ri = sigm/r
> LET r6 = ri^6
> LET force = (24.0*epsi*r6*(2.0*r6-1.0)/r)
> END function
> !
> ! utility
> !
> EXTERNAL FUNCTION sysTemp
> LET k = 1.38e-23 ! Boltzman's constant (J/K)
> LET totalEnergy = 0.0
> FOR i=1 TO Nmt
> LET totalEnergy = totalEnergy + 0.5*mass*(vx(i)^2+vy(i)^2)
> NEXT i
> LET sysTemp = totalEnergy/(Nmt*k)
> END FUNCTION
> !
> EXTERNAL SUB ajustV(temp)
> DECLARE EXTERNAL FUNCTION sysTemp
> LET r = sqr(temp/sysTemp)
> FOR i=1 TO Nmt
> LET vx(i) = r*vx(i)
> LET vy(i) = r*vy(i)
> NEXT i
> END sub
> !
> ! display
> !
> EXTERNAL SUB drawParticles(vmag)
> DECLARE EXTERNAL FUNCTION sysTemp
> LET t1 = vmag*dt
> LET b = (sigm/2)*mag
> !
> SET DRAW MODE HIDDEN
> CLEAR
> SET LINE COLOR 1 ! black : wall
> PLOT LINES: -b,-b; xMax*mag+b,-b; xMax*mag+b,yMax*mag+b; -b,yMax*mag+b; -b,-b
> !
> FOR i=1 TO Nmt
> SET COLOR 2 ! blue : position
> DRAW circle WITH SCALE(sigm/2.0*1E9)*SHIFT(xx(i)*mag,yy(i)*mag)
> SET LINE COLOR 4 ! red : velocity
> PLOT LINES: xx(i)*mag,yy(i)*mag;
> PLOT LINES: (xx(i)+vx(i)*t1)*mag,(yy(i)+vy(i)*t1)*mag
> SET LINE COLOR 1 ! black : force
> PLOT LINES: xx(i)*mag,yy(i)*mag;
> PLOT LINES: (xx(i)+0.1*ffx(i)*t1*t1/mass)*mag,(yy(i)+0.1*ffy(i)*t1*t1/mass)*mag
> NEXT i
> !
> SET TEXT COLOR 1 ! black
> PLOT TEXT, AT 0,-0.7,USING "box size =##.# x ##.# (nm)":xMax*mag,yMax*mag
> PLOT TEXT, AT 0,-1 ,USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
> PLOT TEXT, AT 0,-1.3 :"Ar in the box (2-dimensional molecular dynamics)"
> !
> SET LINE COLOR 4 ! red : velocity
> LET xPos = xMax*mag*0.5+1
> LET yPos = yMax*mag+1
> PLOT LINES: xPos,yPos;xPos+0.5,yPos
> SET TEXT COLOR 4 ! red
> PLOT TEXT, AT xPos+0.7,yPos-0.05: "velosity"
> SET LINE COLOR 1 ! black : velocity
> PLOT LINES: xPos,yPos-0.3;xPos+0.5,yPos-0.3
> SET TEXT COLOR 1 ! black
> PLOT TEXT, AT xPos+0.7,yPos-0.35: "force"
> !
> SET DRAW MODE EXPLICIT
> END SUB
> !
> END MODULE
> !
> !
> ! end of file
>
OPTION ARITHMETIC COMPLEX !複素数モード
LET wb=400 !枠の幅
LET hb=400 !枠の高さ
SET bitmap SIZE wb+101, hb+101
SET WINDOW -50,wb+50, -50,hb+50 !左端,右端, 下端,上端
!------------------------------------------------------
RANDOMIZE 5 !引数を取ると、再現しない。
!
LET n=36 !球の数
DIM p(n) !球の座標
DIM vp(n), vpb(n), cnt(n),fce(n) !球の速度, １ステップ前の球の速度, force保持タイマ, force記憶
DIM m(n), r(n) !球の重量、半径
FOR i=1 TO n
LET m(i)=INT(RND*2)+.5 !球の重量データー ( .5 と 1.5 の２種類 )
LET r(i)=10*m(i)^(1/3) !半径 r ∝ 重量の３乗根。
NEXT i
!
SET COLOR MIX(0) 0,0,0 !CLEAR 文で黒にする。
SET COLOR MIX(1) 1,1,1 !text,line, 初期カラーを白にする。
LET dt=0.2 !サンプリングタイム ※調整 小さくする→遅くなる
!
!----- 重ならない初期位置のランダム設定
LET j=1
DO
LET p(j)=COMPLEX( r(j)+2+(wb-2*r(j)-4)*RND, r(j)+2+(hb-2*r(j)-4)*RND)
FOR i=1 TO j-1
IF ABS(p(i)-p(j))< r(i)+r(j)+3 THEN EXIT FOR !オーバーラップ: 再試行
NEXT i
IF j<=i THEN LET j=j+1 !Ok: j+1
LOOP UNTIL n< j
!-----
DO
LET j=0
FOR i=1 TO n
LET vp(i)=COMPLEX((RND-0.5)*40, (RND-0.5)*40) !初期速度設定
LET j=j+ABS(vp(i))
NEXT i
LOOP UNTIL SQR(n)*20< j
!-----
DO
MAT vpb=vp ! $$$ force
FOR i=1 TO n
LET p(i)=p(i)+vp(i)*dt
!---
IF re(p(i))< r(i) AND re(vp(i))< 0 THEN !左の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(r(i),im(p(i)))
ELSEIF wb-r(i)< re(p(i)) AND 0< re(vp(i)) THEN !右の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(wb-r(i),im(p(i)))
ELSEIF im(p(i))< r(i) AND im(vp(i))< 0 THEN !下の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),r(i))
ELSEIF hb-r(i)< im(p(i)) AND 0< im(vp(i)) THEN !上の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),hb-r(i))
END IF
!---
CALL collide !球同士の衝突
NEXT i
!
SET DRAW mode hidden !表示画、更新の一時停止。
CLEAR !全画面、黒で、塗りつぶす
PLOT TEXT,AT wb*.8,hb+20:"右クリック終了"
SET LINE width 2 ! $$$ velocity, force
FOR i=1 TO n
SET AREA COLOR i
DRAW disk WITH SCALE(r(i))*SHIFT(p(i)) !球の表示
SET LINE COLOR 4 ! $$$ velocity
PLOT LINES: p(i); p(i)+vp(i) ! $$$ velocity
!--
LET cnt(i)=cnt(i)-1 ! $$$
IF cnt(i)<=0 OR EPS(0)< ABS(vp(i)-vpb(i)) THEN ! $$$
LET fce(i)=(vp(i)-vpb(i))*m(i) ! $$$ force 表示の更新
LET cnt(i)=10 ! $$$ force 表示の保持時間 ※大→長い
END IF ! $$$
!--
SET LINE COLOR 1 ! $$$ force
PLOT LINES: p(i); p(i)+fce(i) ! $$$ force
NEXT i
SET LINE width 4
SET LINE COLOR 6
PLOT LINES: 0; wb; COMPLEX(wb,hb); COMPLEX(0,hb); 0 !枠の表示
SET DRAW mode explicit !表示画、常時更新の再開。
!
WAIT DELAY .01 !節電。削除すると、かなり速くなる
mouse poll mox,moy,mlb,mrb
LOOP UNTIL 0< mrb
!-----------------------------------------------------------
! 球同士の衝突( 表面摩擦０、異なる質量)
!
! ※反射速度は、法線ベクトルの内外向き、接線ベクトルの回転向き、
! などの影響を受けないが、法線上の 相対的速さ は、極性に反映。
!-----------------------------------------------------------
SUB collide
FOR j=1 TO n
IF i<>j THEN
LET l=ABS( p(i) -p(j) ) !球(i)(j)間距離
IF l<=r(i)+r(j) THEN !距離が範囲内、衝突の前 後？
LET np=(p(j)-p(i))/l !接触点 法線単位ベクトル
LET vni=re(conj(np)*vp(i)) !接触点 法線方向の 球(i)速さ(+-)
LET vnj=re(conj(np)*vp(j)) ! 〃 球(j)速さ(+-)
IF vnj-vni< 0 THEN !法線上、相対的速さ(+-)、衝突の前、確定。
LET w=((m(i)-m(j))*vni+2*m(j)*vnj)/(m(i)+m(j)) !球(i)
LET vnj=((m(j)-m(i))*vnj+2*m(i)*vni)/(m(i)+m(j)) !球(j) 反射後の速さ
LET vni=w
LET tp=np*COMPLEX(0,1) ! 〃 接線単位ベクトル
LET vti=re(conj(tp)*vp(i)) ! 接線方向の 球(i)速さ(+-)
LET vtj=re(conj(tp)*vp(j)) ! 〃 球(j)速さ(+-)
!--
LET vp(i)= vni*np +vti*tp !球(i)速度ベクトル
LET vp(j)= vnj*np +vtj*tp !球(j)速度ベクトル
END IF
END IF
END IF
NEXT j
END SUB
OPTION ARITHMETIC COMPLEX !複素数モード
LET wb=400 !枠の幅
LET hb=400 !枠の高さ
SET bitmap SIZE wb+101, hb+101
SET WINDOW -50,wb+50, -50,hb+50 !左端,右端, 下端,上端
!------------------------------------------------------
RANDOMIZE 5 !引数を取ると、再現しない。
!
LET n=36 !球の数
DIM p(n) !球の座標
DIM vp(n), vpb(n), cnt(n),fce(n) !球の速度, １ステップ前の球の速度, force保持タイマ, force記憶
DIM m(n), r(n) !球の重量、半径
FOR i=1 TO n
LET m(i)=INT(RND*2)+.5 !球の重量データー ( .5 と 1.5 の２種類 )
LET r(i)=10*m(i)^(1/3) !半径 r ∝ 重量の３乗根。
NEXT i
!
SET COLOR MIX(0) 0,0,0 !CLEAR 文で黒にする。
SET COLOR MIX(1) 1,1,1 !text,line, 初期カラーを白にする。
LET dt=0.01 !サンプリングタイム ※調整 小さくする→遅くなる ************ change 0.2->0.01
!
!----- 重ならない初期位置のランダム設定
LET j=1
DO
LET p(j)=COMPLEX( r(j)+2+(wb-2*r(j)-4)*RND, r(j)+2+(hb-2*r(j)-4)*RND)
FOR i=1 TO j-1
IF ABS(p(i)-p(j))< r(i)+r(j)+3 THEN EXIT FOR !オーバーラップ: 再試行
NEXT i
IF j<=i THEN LET j=j+1 !Ok: j+1
LOOP UNTIL n< j
!-----
DO
LET j=0
FOR i=1 TO n
LET vp(i)=COMPLEX((RND-0.5)*40, (RND-0.5)*40) !初期速度設定
LET j=j+ABS(vp(i))
NEXT i
LOOP UNTIL SQR(n)*20< j
!-----
DO
MAT vpb=vp ! $$$ force
FOR ii=1 TO 20 !************************ change
FOR i=1 TO n
LET p(i)=p(i)+vp(i)*dt
!---
IF re(p(i))< r(i) AND re(vp(i))< 0 THEN !左の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(r(i),im(p(i)))
ELSEIF wb-r(i)< re(p(i)) AND 0< re(vp(i)) THEN !右の枠に衝突
LET vp(i)= -conj(vp(i))
LET p(i)= COMPLEX(wb-r(i),im(p(i)))
ELSEIF im(p(i))< r(i) AND im(vp(i))< 0 THEN !下の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),r(i))
ELSEIF hb-r(i)< im(p(i)) AND 0< im(vp(i)) THEN !上の枠に衝突
LET vp(i)= conj(vp(i))
LET p(i)= COMPLEX(re(p(i)),hb-r(i))
END IF
!---
CALL collide !球同士の衝突
NEXT i
NEXT ii !************************ change
!
SET DRAW mode hidden !表示画、更新の一時停止。
CLEAR !全画面、黒で、塗りつぶす
PLOT TEXT,AT wb*.8,hb+20:"右クリック終了"
SET LINE width 2 ! $$$ velocity, force
FOR i=1 TO n
SET AREA COLOR i
DRAW disk WITH SCALE(r(i))*SHIFT(p(i)) !球の表示
SET LINE COLOR 4 ! $$$ velocity
PLOT LINES: p(i); p(i)+vp(i) ! $$$ velocity
!--
LET cnt(i)=cnt(i)-1 ! $$$
IF cnt(i)<=0 OR EPS(0)< ABS(vp(i)-vpb(i)) THEN ! $$$
LET fce(i)=(vp(i)-vpb(i))*m(i) ! $$$ force 表示の更新
LET cnt(i)=10 ! $$$ force 表示の保持時間 ※大→長い
END IF ! $$$
!--
SET LINE COLOR 1 ! $$$ force
PLOT LINES: p(i); p(i)+fce(i) ! $$$ force
NEXT i
SET LINE width 4
SET LINE COLOR 6
PLOT LINES: 0; wb; COMPLEX(wb,hb); COMPLEX(0,hb); 0 !枠の表示
SET DRAW mode explicit !表示画、常時更新の再開。
!
!WAIT DELAY .01 !節電。削除すると、かなり速くなる ****** change
mouse poll mox,moy,mlb,mrb
LOOP UNTIL 0< mrb
!-----------------------------------------------------------
! 球同士の衝突( 表面摩擦０、異なる質量)
!
! ※反射速度は、法線ベクトルの内外向き、接線ベクトルの回転向き、
! などの影響を受けないが、法線上の 相対的速さ は、極性に反映。
!-----------------------------------------------------------
SUB collide
FOR j=1 TO n
IF i<>j THEN
LET l=ABS( p(i) -p(j) ) !球(i)(j)間距離
IF l<=r(i)+r(j) THEN !距離が範囲内、衝突の前 後？
LET np=(p(j)-p(i))/l !接触点 法線単位ベクトル
LET vni=re(conj(np)*vp(i)) !接触点 法線方向の 球(i)速さ(+-)
LET vnj=re(conj(np)*vp(j)) ! 〃 球(j)速さ(+-)
IF vnj-vni< 0 THEN !法線上、相対的速さ(+-)、衝突の前、確定。
LET w=((m(i)-m(j))*vni+2*m(j)*vnj)/(m(i)+m(j)) !球(i)
LET vnj=((m(j)-m(i))*vnj+2*m(i)*vni)/(m(i)+m(j)) !球(j) 反射後の速さ
LET vni=w
LET tp=np*COMPLEX(0,1) ! 〃 接線単位ベクトル
LET vti=re(conj(tp)*vp(i)) ! 接線方向の 球(i)速さ(+-)
LET vtj=re(conj(tp)*vp(j)) ! 〃 球(j)速さ(+-)
!--
LET vp(i)= vni*np +vti*tp !球(i)速度ベクトル
LET vp(j)= vnj*np +vtj*tp !球(j)速度ベクトル
END IF
END IF
END IF
NEXT j
END SUB
ASK directory dir$
PRINT dir$
OPEN #1: NAME dir$&"/looptime2file01.txt"
LET time0=time
FOR it=1 TO 100
FOR i=1 TO 20
CALL moveParticles
NEXT i
CALL drawParticles(100)
PRINT #1: it, TIME-time0
LET time0=TIME
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
!END IF
NEXT it
CLOSE #1
!
END
LET time0=time
FOR it=1 TO 100
FOR i=1 TO 20
CALL moveParticles
NEXT i
CALL drawParticles(100)
PRINT it, TIME-time0
LET time0=TIME
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
!END IF
NEXT it
!
END
ASK directory dir$
PRINT dir$
OPEN #1: NAME dir$&"/looptime2file02.txt"
LET time0=time
FOR it=1 TO 100
FOR i=1 TO 20
CALL moveParticles
NEXT i
!CALL drawParticles(100) *******
PRINT #1: it, TIME-time0
LET time0=TIME
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
!END IF
NEXT it
CLOSE #1
!
END
LET time0=time
FOR it=1 TO 100
FOR i=1 TO 20
CALL moveParticles
NEXT i
CALL drawParticles(100)
PRINT it, TIME-time0
LET time0=TIME
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =####.## (ps) temp =####.## (K)":sysTime*1.0E12,sysTemp
!END IF
NEXT it
!
END
decimal BASIC Ver 7.7.8
FMV-C8230 windows XP pro
CPU intel Celeron M410 (1.46GHz) メインメモリ 1GB
原因が描画系にあるのか調べるためにループ内では描画しないようにして実行してみました。
CALL setInitialCondition
CALL drawParticles(100)
DIM times(1 TO 1000)
FOR it=1 TO 1000
LET time0=time
FOR i=1 TO 20
CALL moveParticles
NEXT i
!CALL drawParticles(100)
LET times(it)= TIME-time0
NEXT it
ASK directory dir$
PRINT dir$
OPEN #1: NAME dir$&"/test008.txt"
ERASE #1
FOR it=1 TO 1000
PRINT #1,USING "#### ##.##":it, times(it)
NEXT it
CLOSE #1
END
DIM tCalc(100),tDraw(100)
FOR it=1 TO 100
LET time0 = TIME
FOR i=1 TO 20
CALL moveParticles
NEXT i
LET tCalc(it) = TIME - time0
LET time0 = TIME
CALL drawParticles(100)
LET tDraw(it) = TIME - time0
NEXT it
!
FOR it=1 TO 100
PRINT USING "it=#### tCalc=#.### tDraw=#.###":it,tCalc(it),tDraw(it)
NEXT it
END
procedure TPaintForm.PaintBox1Paint(Sender: TObject);
begin
if not HiddenDrawMode then
begin
{$IFNDEF WINDOWS} SetFPUMask(OriginalCW); {$ENDIF}
PaintBox1.Canvas. Draw(0,0,BitMap1);
{$IFNDEF WINDOWS}SetFPUMask(controlword); {$ENDIF}
end;
end;
procedure TPaintForm.Timer1Timer(Sender: TObject);
begin
{$IFNDEF WINDOWS}
if not hiddenDrawMode then
paintBox1.repaint;
{$ENDIF}
end;
試験環境：
本プログラムは十進BASIC 0.6.5.2 / macOS 10.7.5と
十進BASICBASIC Ver 7.7.8 / windows 10でテストしました。
------------------------
!
! ========= molecular dynamics 2D ==========
!
! ArGasMD2D001.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.01.19 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB md2d.setInitialCondition, md2d.moveParticles, md2d.drawParticles
DECLARE EXTERNAL FUNCTION md2d.systemTime, md2d.systemTemprature
!
CALL setInitialCondition
CALL drawParticles
!
FOR it=1 TO 1000
FOR i=1 TO 20
CALL moveParticles
NEXT i
CALL drawParticles
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =####.## (ps) temp =####.## (K)":systemTime*1.0E12,systemTemprature
!END IF
NEXT it
!
END
!
! ---------- md2d module ----------
!
! method: velocity Verlet
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
MODULE md2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition,moveParticles,drawParticles
PUBLIC FUNCTION systemTime, systemTemprature
SHARE NUMERIC sysTime, dt, nMolec, xMax, yMax, sigma, mass, epsilon, boxSize
SHARE NUMERIC xx(100),yy(100) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(100),vy(100) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(100),ffy(100) ! (ffx(i),ffy(i)): total force of i-th particle
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 36 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET mass = 39.95*1.67e-27 ! mass of Ar (kg)
LET sigma = 3.40e-10 ! Lennard-Jones potential sigma for Ar (m)
LET epsilon = 1.67e-21 ! Lennard-Jones potential epsilon FOR Ar (J)
LET boxSize = 6 ! world box size in the graphic window
!
EXTERNAL SUB setInitialCondition
DECLARE EXTERNAL SUB ajustVelocity
! set particles
RANDOMIZE
LET s = xMax/7.0
FOR i=1 TO nMolec
LET xx(i) = s*MOD((i-1),6)+1.0*s
LET yy(i) = s*int((i-1)/6)+1.0*s
LET vx(i) = 500.0*(RND-0.5)
LET vy(i) = 500.0*(RND-0.5)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
CALL ajustVelocity(150) !(temp)
! set window
LET b=2
SET WINDOW -b,boxSize+b,-b,boxSize+b
END SUB
!
EXTERNAL SUB moveParticles ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
!
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*sigma
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR j=i+1 TO nMolec
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
NEXT j
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)-boundaryForce(xMax+s-xx(i))
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)-boundaryForce(yMax+s-yy(i))
NEXT i
END SUB
!
EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
LET ri = sigma/r
LET r6 = ri^6
LET force = (24.0*epsilon*r6*(2.0*r6-1.0)/r)
END FUNCTION
!
EXTERNAL FUNCTION boundaryForce(r)
LET ri = sigma/r
LET r6 = ri^6
LET boundaryForce = (24.0*(0.5*epsilon)*r6*(2.0*r6-1.0)/r)
END FUNCTION
!
! utility
!
EXTERNAL FUNCTION systemTime
LET systemTime = sysTime
END FUNCTION
!
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB)
END FUNCTION
!
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
!
! display
!
EXTERNAL SUB drawParticles
DECLARE EXTERNAL FUNCTION systemTemprature
LET mag = boxSize/xMax
LET vScate = 100*dt
LET fScale = 1000*dt*dt/mass
!
SET DRAW MODE HIDDEN
CLEAR
SET LINE COLOR 1 ! black : wall
PLOT LINES: 0,0; boxSize,0; boxSize,boxSize; 0,boxSize; 0,0
!draw Balls, velocity and force
FOR i=1 TO nMolec
SET COLOR 2 ! blue : molecule
DRAW circle WITH SCALE(sigma/2.0*mag)*SHIFT(xx(i)*mag,yy(i)*mag)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xx(i)*mag,yy(i)*mag;
PLOT LINES: (xx(i)+vx(i)*vScate)*mag,(yy(i)+vy(i)*vScate)*mag
SET LINE COLOR 1 ! black : force
PLOT LINES: xx(i)*mag,yy(i)*mag;
PLOT LINES: (xx(i)+ffx(i)*fScale)*mag,(yy(i)+ffy(i)*fScale)*mag
NEXT i
!draw caption
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,-0.5 ,USING "time =####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 0,-1.0 ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
PLOT TEXT, AT 0,-1.5 :"Ar in the box (2-dimensional molecular dynamics)"
!
LET xp = boxSize*0.5+1
LET yp = boxSize+1
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp,yp;xp+0.5,yp
SET TEXT COLOR 4 ! red
PLOT TEXT, AT xp+0.7,yp-0.05: "velosity"
SET LINE COLOR 1 ! black : force
PLOT LINES: xp,yp-0.3;xp+0.5,yp-0.3
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp+0.7,yp-0.35: "force"
!
SET DRAW MODE EXPLICIT
END SUB
!
END MODULE
実変数xと時間tの複素関数psi(x,t)をグラフィック画面上plotするため、
3次元の直交座標系(x,y,z)に
x -> x
Re(psi(x,t0)) -> y
Im(psi(x,t0)) -> z
を対応させ、これをグラフィック画面上に(x',y')の所にplotし、
時間tを少しずつ動かして、動画として表現したいのです。
白石先生、プログラムをありがとうございます。
MATの計算で MAT POINT=POINT*m のように左からベクトルPOINTをかけるということは
POINTは行ベクトルなのでしょうか？
また、 MAT m=TRANSFORM ステートメントは the current transformation matrix can be obtained
とありますので、MAT m=TRANSFORMに代入されのは時点の変換行列ということになりますが
どこで定義されたものなのでしょうか？
! ========= Quantum Electron Dynamics 1D ==========
!
! wavePacketQED1D.bas
! Mitsuru Ikeuchi
! ver 0.0.0 2017.01.25
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB QED1D.setInitialCondition,QED1D.evolveWave,QED1D.drawWave
DECLARE EXTERNAL FUNCTION QED1D.systemTime,QED1D.norm
!
CALL setInitialCondition(1) !(menu)
!
FOR it=1 TO 1000
FOR i=1 TO 10
CALL evolveWave
NEXT i
CALL drawWave
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =#####.## (au) norm =#.###############":systemTime,norm
!END IF
NEXT it
!
END
! ---------- QED1D module (QED: Quantum Electron Dynamics) ----------
!
! - time dependent Schrodinger equation: i(d/dt)psi(r,t) = H psi(r,t)
! - time evolution
! psi(r,t+dt) = exp(-i dt H) psi(r,t), (H:Hamiltonian of the system)
! H = -delta/2 + V(r), delta = d^2/dx^2 + d^2/dy^2 + d^2/dz^2
! psi(r,t+dt) = exp(-i dt H) psi(r,t) nearly=
! {exp(-i(dt/2)V} {exp(i dt(delta/2)} {exp(-i(dt/2)V} psi(r,t)
! - algorism: {exp(i dt(delta/2)}
! QED: Watanabe's algorism (semi-implicit method)
! Naoki Watanabe, Masaru Tsukada; arXiv:physics/0011068v1
! (Published from Physical Review E. 62, 2914, (2000).)
!
MODULE QED1D
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, evolveWave, drawWave
PUBLIC FUNCTION systemTime, norm
SHARE NUMERIC sysTime, dt, dx, auLength, auTime, auEnergy, NNx
SHARE NUMERIC phRe(500),phIm(500) ! wave function
SHARE NUMERIC vv(500) ! external potential
SHARE NUMERIC bRe(500),bIm(500) ! b vector in kxStep
SHARE NUMERIC uRe(500),uIm(500) ! u vector in kxStep
LET sysTime = 0.0 ! (au) au : atomic unit (hbar=1, me=1, e=1)
LET dx = 0.5 ! (au) x division
LET dt = 1.0*dx*dx ! (au) time division dt/(dx*dx)>2 ~ unstable
LET auLength = 5.29177e-11 ! (m) 1(au) = auLength (m)
LET auTime = 2.41888e-17 ! (s) 1(au) = auTime (s)
LET auEnergy = 4.38975e-18 ! (J) 1(au) = auEnergy (J) (= 27.2114 eV)
LET NNx = 400 ! x division
!
! ----- set initial condition
!
EXTERNAL SUB setInitialCondition(menu) !public
DECLARE EXTERNAL SUB setGaussianWave,setparabolicPotential
LET sysTime = 0.0
IF menu=1 THEN
CALL setGaussianWave(50.0,10.0,0.0) !(wavePos,waveWidth,momentum)
CALL setparabolicPotential(0.5*(NNx-1)*dx,0.0001) ! v(x)=k*(x-x0)^2
ELSEIF menu=2 THEN
CALL setGaussianWave(50.0,10.0,1.0) !(wavePos,waveWidth,momentum)
CALL setparabolicPotential(0.5*(NNx-1)*dx,0.0) ! v(x)=k*(x-x0)^2
END IF
! set window
LET w = NNx*dx
LET b = 20
SET WINDOW -b,w+b,-b,w+b
END SUB
!
EXTERNAL SUB setGaussianWave(wavePos,waveWidth,momentum)
DECLARE EXTERNAL SUB normalize
FOR i=1 TO NNx-2
LET x = i*dx
LET phAb = EXP(-((x-wavePos)/(2.0*waveWidth))^2)
LET phPh = momentum*x
LET phRe(i) = phAb*cos(phPh)
LET phIm(i) = phAb*sin(phPh)
NEXT i
LET phRe(0) = 0.0
LET phIm(0) = 0.0
LET phRe(NNx-1) = 0.0
LET phIm(NNx-1) = 0.0
CALL normalize
END SUB
!
EXTERNAL SUB setparabolicPotential(x0,k) ! v(x)=k*(x-x0)^2
FOR i=0 TO NNx-1
LET x = i*dx
LET vv(i) = k*(x-x0)^2
NEXT i
END SUB
!
! ----- evolve Wave
!
EXTERNAL SUB evolveWave !piblic
DECLARE EXTERNAL SUB phaseStep,kxStep
CALL phaseStep
CALL kxStep
CALL phaseStep
LET sysTime = sysTime + dt
END SUB
!
EXTERNAL SUB kxStep !{exp(i dt(delta/2)} semi-implicit method
LET ai = 4*dx*dx/dt
LET aaAb = 4+ai*ai
FOR i=1 TO NNx-2 !set b-vector
LET bRe(i) = 2*phRe(i)-ai*phIm(i) - phRe(i+1) - phRe(i-1)
LET bIm(i) = 2*phIm(i)+ai*phRe(i) - phIm(i+1) - phIm(i-1)
NEXT i
! forward elimination
LET uRe(1) = -2/aaAb
LET uIm(1) = -ai/aaAb
LET phRe(1) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET phIm(1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR i=2 TO NNx-2
LET auAb = (-2-uRe(i-1))*(-2-uRe(i-1))+(ai-uIm(i-1))*(ai-uIm(i-1))
LET uRe(i) = (-2-uRe(i-1))/auAb
LET uIm(i) = -(ai-uIm(i-1))/auAb
LET phRe(i) = (bRe(i)-phRe(i-1))*uRe(i) - (bIm(i)-phIm(i-1))*uIm(i)
LET phIm(i) = (bRe(i)-phRe(i-1))*uIm(i) + (bIm(i)-phIm(i-1))*uRe(i)
NEXT i
! backward substitution
FOR i=NNx-3 TO 1 STEP -1
LET phRe(i) = phRe(i) - (phRe(i+1)*uRe(i) - phIm(i+1)*uIm(i))
LET phIm(i) = phIm(i) - (phRe(i+1)*uIm(i) + phIm(i+1)*uRe(i))
NEXT i
END SUB
!
EXTERNAL SUB phaseStep !{exp(-i(dt/2)V} evolve 0.5dt
FOR i=1 TO NNx-2
LET th = 0.5*dt*vv(i)
LET cs = COS(th)
LET sn = SIN(th)
LET phr = phRe(i)
LET phi = phIm(i)
LET phRe(i) = cs*phr+sn*phi
LET phIm(i) = cs*phi-sn*phr
NEXT i
END SUB
!
! ----- utility
!
EXTERNAL FUNCTION systemTime !public
LET systemTime = sysTime
END FUNCTION
!
EXTERNAL SUB normalize
LET a = norm !public function
FOR i=1 TO NNx-2
LET phRe(i) = phRe(i)/a
LET phIm(i) = phIm(i)/a
NEXT i
END SUB
!
EXTERNAL FUNCTION norm !public <psi|psi>
!LOCAL i,a2
LET a2 = 0.0
FOR i=1 TO NNx-2
LET a2 = a2 + (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
NEXT i
LET norm = SQR(a2)
END FUNCTION
!
EXTERNAL FUNCTION kineticEnergy !<psi| d^2/dx^2 |psi>
LET s = 0.0
FOR i=1 TO NNx-2
LET hphRe = (2.0*phRe(i)-phRe(i+1)-phRe(i-1))/(2.0*dx*dx)
LET hphIm = (2.0*phIm(i)-phIm(i+1)-phIm(i-1))/(2.0*dx*dx)
LET s = s + (phRe(i)*hphRe + phIm(i)*hphIm)*dx
NEXT i
LET kineticEnergy = s
END FUNCTION
!
EXTERNAL FUNCTION potentialEnergy !<psi| V(x) |psi>
LET s = 0.0
FOR i=1 TO NNx-2
LET s = s + vv(i)*(phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
NEXT i
LET potentialEnergy = s
END FUNCTION
!
! ----- draw wave
!
EXTERNAL SUB drawWave !LOCAL i,yh,sth,cth,ph2,pe,ke
DECLARE EXTERNAL FUNCTION kineticEnergy,potentialEnergy
LET yh = (NNx*dx+40)*0.4
LET sth = SIN(PI/6) !****************
LET cth = COS(PI/6) !****************
SET DRAW MODE HIDDEN
CLEAR
!plot V(x),{psi>,<psi|psi>
SET LINE COLOR 1 ! black : PLOT potential V(x);
FOR i=0 TO NNx-1
PLOT LINES: dx*i, vv(i)*100+yh;
NEXT i
PLOT LINES
SET LINE COLOR 4 ! red : plot probability <psi|psi>
FOR i=0 TO NNx-1
LET ph2 = (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
PLOT LINES: dx*i, ph2*1000+yh;
NEXT i
PLOT LINES
SET LINE COLOR 2 ! blue : PLOT wave function |psi> !****************
FOR i=0 TO NNx-1
PLOT LINES: dx*i-sth*phIm(i)*50, (phRe(i)-cth*phIm(i))*50+yh; !****************
NEXT i
PLOT LINES
!caption
LET ke = kineticEnergy
LET pe = potentialEnergy
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,48 ,USING "time =#####.## (au) =####.#### (femto s)":sysTime,sysTime*auTime*1e15
PLOT TEXT, AT 0,40 ,USING "norm of wave function =#.###############":norm
PLOT TEXT, AT 0,32 ,USING "kinetic energy =#.###### (au) =##.### (eV)":ke,ke*27.2114
PLOT TEXT, AT 0,24 ,USING "potential energy =#.###### (au) =##.### (eV)":pe,pe*27.2114
PLOT TEXT, AT 0,16 ,USING "total energy =#.###### (au) =##.### (eV)":ke+pe,(ke+pe)*27.2114
PLOT TEXT, AT 0, 8 ,USING "xLength =####.# (au) =###.### (nm)":NNx*dx,NNx*dx*auLength*1e9
PLOT TEXT, AT 0, 0 :"wave packet - quantum electron dynamics 1D"
!
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0, yh+22 :"potential V(x)"
SET TEXT COLOR 4 ! red
PLOT TEXT, AT 0, yh+6 :"<psi|psi>"
SET TEXT COLOR 2 ! blue
PLOT TEXT, AT 0, yh-10 :"|psi(x,t)>"
SET DRAW MODE EXPLICIT
END SUB
!
END MODULE
> MATの計算で MAT POINT=POINT*m のように左からベクトルPOINTをかけるということは
> POINTは行ベクトルなのでしょうか？
Full BASICの座標変換は行ベクトルです。左から右に演算を行う流儀です。
> また、 MAT m=TRANSFORM ステートメントは the current transformation matrix can be obtained
> とありますので、MAT m=TRANSFORMに代入されのは時点の変換行列ということになりますが
> どこで定義されたものなのでしょうか？
変換行列は、DRAW文でPICTUREを呼び出したときにBASICの内部で定義されます。
PICTUREを再帰呼び出しすると、変換行列の積が計算されます。
!
! ----- draw wave
!
EXTERNAL SUB drawWave
DECLARE EXTERNAL FUNCTION kineticEnergy,potentialEnergy
!rotate th around x-axis and rotate fi around y-axis !*************
DEF xRot(x,y,z,th,fi) = COS(fi)*x+SIN(fi)*(SIN(th)*y+COS(th)*z) !*************
DEF yRot(x,y,z,th,fi) = COS(th)*y-SIN(th)*z !*************
!DEF zRot(x,y,z,th,fi) = -SIN(fi)*x+COS(fi)*(SIN(th)*y+COS(th)*z) !*************
LET x0 = dx*NNx/2 !LET y0 = 0
LET yh = (NNx*dx+40)*0.4
SET DRAW MODE HIDDEN
CLEAR
!plot V(x),{psi>,<psi|psi>
SET LINE COLOR 1 ! black : PLOT potential V(x);
FOR i=0 TO NNx-1
PLOT LINES: dx*i, vv(i)*100+yh;
NEXT i
PLOT LINES
SET LINE COLOR 4 ! red : plot probability <psi|psi>
FOR i=0 TO NNx-1
LET ph2 = (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
PLOT LINES: dx*i, ph2*1000+yh;
NEXT i
PLOT LINES
SET LINE COLOR 2 ! blue : PLOT wave function |psi>
LET fi = PI/12 !*************
FOR i=0 TO NNx-1
LET rx = xRot(dx*i-x0,phRe(i)*50,phIm(i)*50,0,fi) !*************
LET ry = yRot(dx*i-x0,phRe(i)*50,phIm(i)*50,0,fi) !*************
!LET rz = zRot(dx*i-x0,phRe(i)*50,phIm(i)*50,0,fi) !*************
PLOT LINES: rx+x0,ry+yh; !*************
NEXT i
PLOT LINES
!caption
LET ke = kineticEnergy
LET pe = potentialEnergy
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,48 ,USING "time =#####.## (au) =####.#### (femto s)":sysTime,sysTime*auTime*1e15
PLOT TEXT, AT 0,40 ,USING "norm of wave function =#.###############":norm
PLOT TEXT, AT 0,32 ,USING "kinetic energy =#.###### (au) =##.### (eV)":ke,ke*27.2114
PLOT TEXT, AT 0,24 ,USING "potential energy =#.###### (au) =##.### (eV)":pe,pe*27.2114
PLOT TEXT, AT 0,16 ,USING "total energy =#.###### (au) =##.### (eV)":ke+pe,(ke+pe)*27.2114
PLOT TEXT, AT 0, 8 ,USING "xLength =####.# (au) =###.### (nm)":NNx*dx,NNx*dx*auLength*1e9
PLOT TEXT, AT 0, 0 :"wave packet - quantum electron dynamics 1D"
!
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0, yh+22 :"potential V(x)"
SET TEXT COLOR 4 ! red
PLOT TEXT, AT 0, yh+6 :"<psi|psi>"
SET TEXT COLOR 2 ! blue
PLOT TEXT, AT 0, yh-10 :"|psi(x,t)>"
SET DRAW MODE EXPLICIT
END SUB
DIM tCalc(100),tDraw(100)
FOR it=1 TO 100
LET time0 = TIME
FOR i=1 TO 20
CALL moveParticles
NEXT i
LET tCalc(it) = TIME - time0
LET time0 = TIME
CALL drawParticles(100)
LET tDraw(it) = TIME - time0
NEXT it
!
FOR it=1 TO 100
PRINT USING "it=#### tCalc=#.### tDraw=#.###":it,tCalc(it),tDraw(it)
NEXT it
END
DECLARE FUNCTION sysTemp
!
LET side=3
LET Nmt=side^3 ! number of particles
LET vss = 1.0E-9 ! m : view scale step
LET xMax = side * vss ! : x-Box size
LET yMax = side * vss ! : y-Box size
LET zMax = side * vss ! : z-Box size
!
DIM q1(Nmt),q2(Nmt), Dpxy(Nmt),Dvxy(Nmt),Dfxy(Nmt), apex(8,3),Dape(8,2),Dlin(12,2)
DIM Vi(4),Vo(4),Axys(4,4),Mxys(4,4),rotx(4,4),shxyz(4,4),shres(4,4)
DIM pxy(Nmt),pz(Nmt), vxy(Nmt),vz(Nmt), fxy(Nmt),fz(Nmt)
!
! pxy(),pz() : position of i-th paryicle
! vxy(),vz() : velocity of i-th paryicle
! fxy(),fz() : force of i-th paryicle
!
LET temp=150 ! K : initial temperature
LET sysTime = 0 ! s : system time
LET dt =0.02e-12 ! s : time step
!
LET mass = 39.95*1.67e-27 ! kg : mass of Ar
LET sigm = 3.40e-10 ! m : Lennard-Jones potential sigma for Ar
LET epsi = 1.67e-21 ! J : Lennard-Jones potential epsilon for Ar
LET k_ = 1.38e-23 ! J/K : Boltzman's constant
!
LET a_ = 0.5*dt/mass !s/kg : ⊿(m/s) / (kg・m/s^2) trans force to velocity
!
LET vmag = 100 ! view magnitude of velocity & force
LET t1 = vmag*dt ! view size /velocity
LET t2 = 0.1*t1^2 /mass ! view size /force
LET note0 = COMPLEX( xMax*0.9, yMax*1.35 ) ! view Notes Anchor
LET text0 = COMPLEX( -0.9*vss, -1.0*vss ) ! view Text Anchor
!
!--------------
MAT Axys=IDN
MAT rotx=IDN
MAT shxyz=IDN
MAT shres=IDN
LET Vi(4)=1
CALL mat_shxyz(shxyz,-xMax/2,-yMax/2,-zMax/2) !重心を原点へ移動する行列 shxyz 作成
CALL mat_shxyz(shres, xMax/2, yMax/2, zMax/2) !重心を原点から元へ戻す行列 shres 作成
!
LET Ax=-PI/2.5 !開始のｚ軸方向( 画面垂直０度からｘ軸回転成分)
LET Ay=0 ! 〃 〃 ( 〃 〃 ｙ軸回転成分)
LET Az=PI/6 !ｚ軸回転成分
!
!-----------------------
LET b=2*vss
SET WINDOW -b, xMax+b, -b, yMax+b
CALL setInitialCondition
CALL drawParticles
!
PRINT USING "time =####.## (ps) temp =####.## (K)" :sysTime*1e12, sysTemp
LET t0=TIME
DO
FOR i_=1 TO 10
IF mlb=0 THEN CALL moveParticles
NEXT i_
CALL drawParticles
!------------------ print / 2.0 psec.
IF mlb=0 AND MOD( ROUND(sysTime*10e12), 20)=0 THEN PRINT USING "time =####.## (ps) temp =####.## (K)" :sysTime*1e12, sysTemp
mouse poll mx,my,mlb,mrb
!--
WAIT DELAY t22 !t22: 制御出力の休止秒。
LET t11=TIME !t11: 直前の周期の終り。
LET t22=MAX(0,t22+(.08-MOD(t11-t00,86400))/20) !80ms－検出周期(t11-t00)＝偏差 →t22(積分 Gain=1/20)
LET t00=t11 !t00: 次の周期の始め＝ 前の周期の終り
!--
LOOP UNTIL mrb=1 !Right Click to Stop
PRINT TIME-t0
SUB setInitialCondition
! set particles
RANDOMIZE 5
LET s = xMax/(side+1)
LET n=0
FOR z=1 TO side
FOR y=1 TO side
FOR x=1 TO side
LET n=n+1
LET pxy(n) = s*COMPLEX( x, y)
LET pz(n) = s*COMPLEX( 0, z)
LET vxy(n) = 500*COMPLEX( RND-0.5, RND-0.5)
LET vz(n) = 500*COMPLEX( 0, RND-0.5)
LET fxy(n) = 0
LET fz(n) = 0
NEXT x
NEXT y
NEXT z
!-- ajust V to temp --
LET w=SQR( temp / sysTemp)
MAT vxy= w*vxy
MAT vz= w*vz
!-- wall cube apex --
LET i=1
FOR z=0 TO zMax STEP zMax
LET apex(i,1)=0
LET apex(i,2)=0
LET apex(i,3)=z
LET i=i+1
LET apex(i,1)=xMax
LET apex(i,2)=0
LET apex(i,3)=z
LET i=i+1
LET apex(i,1)=xMax
LET apex(i,2)=yMax
LET apex(i,3)=z
LET i=i+1
LET apex(i,1)=0
LET apex(i,2)=yMax
LET apex(i,3)=z
LET i=i+1
NEXT z
END SUB
FUNCTION sysTemp
LET v2 = 0
FOR i=1 TO Nmt
LET v2 = v2 + ABS(vxy(i))^2-vz(i)^2 ! vx^2 + vy^2 + vz^2
!LET v2 = v2 + ABS(ABS(vxy(i))+vz(i))^2 ! vx^2 + vy^2 + vz^2
NEXT i
LET sysTemp = mass*v2/Nmt/3/k_ ! {∑(.5*m*v^2) /N} *2/3 /k
END FUNCTION
SUB moveParticles
FOR i=1 TO Nmt
LET vxy(i) = vxy(i)+a_*fxy(i) !a_ = 0.5*dt/mass
LET vz(i) = vz(i)+ a_*fz(i)
LET pxy(i) = pxy(i)+vxy(i)*dt
LET pz(i) = pz(i)+vz(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO Nmt
LET vxy(i) = vxy(i)+a_*fxy(i) !a_ = 0.5*dt/mass
LET vz(i) = vz(i)+ a_*fz(i)
NEXT i
LET sysTime=sysTime+dt
LET Az=Az+dt*1e11
END SUB
SUB calcForce
MAT fxy=ZER
MAT fz=ZER
FOR i=1 TO Nmt-1
FOR j=i+1 TO Nmt
LET Rij = pxy(i)-pxy(j)
LET Rzij = pz(i)-pz(j)
!--
LET r= ABS( ABS(Rij)+Rzij )
LET r6 = (sigm/r)^6
LET f = 24*epsi*r6*(2*r6-1)/r ! f(r) = (-dφ(r)/dr)
!--
LET fxy(i) = fxy(i) + f*Rij/r
LET fz(i) = fz(i) + f*Rzij/r
LET fxy(j) = fxy(j) - f*Rij/r
LET fz(j) = fz(j) - f*Rzij/r
NEXT j
NEXT i
!--
LET s = sigm *0.5
FOR i=1 TO Nmt ! boundary force
CALL force2( -s, -s, -s)
CALL force2( xMax+s, yMax+s, zMax+s)
NEXT i
END SUB
SUB force2( wx, wy, wz)
LET xy = pxy(i) - COMPLEX( wx, wy)
LET r = re(xy)
LET j = im(xy)
LET z = im( pz(i) - COMPLEX( 0, wz) )
LET r6 = (sigm/r)^6
LET j6 = (sigm/j)^6
LET z6 = (sigm/z)^6
LET fxy(i) = fxy(i) + 24*epsi*COMPLEX( r6*(2*r6-1)/r, j6*(2*j6-1)/j)
LET fz(i) = fz(i) + 24*epsi*COMPLEX( 0, z6*(2*z6-1)/z)
END SUB
SUB edge(z1,z2, p1,p2) !z1,z2：両端のｚ座標。 p1,p2：両端の x+yi 座標
IF z1+z2< zMAx THEN
PLOT LINES: p1;p2 !draw Far edge ：最初に描く。
ELSE
LET j9=j9+1
LET Dlin(j9,1)=p1 !save Near edge ：最後に描く。
LET Dlin(j9,2)=p2
END IF
END SUB
! display
SUB drawParticles
SET DRAW MODE HIDDEN
CLEAR
CALL control_
!--
FOR i=1 TO 8 !rotate box 8 apex
LET Vi(1)=apex(i,1)
LET Vi(2)=apex(i,2)
LET Vi(3)=apex(i,3)
MAT Vo=Vi*Mxys
LET Dape(i,1)=COMPLEX(Vo(1),Vo(2))
LET Dape(i,2)=Vo(3)
NEXT i
!--
SET LINE width 2
LET j9=0 !priority box 12 lines
FOR i=1 TO 3
CALL edge(Dape(i ,2),Dape(i+1,2), Dape(i ,1),Dape(i+1,1))
CALL edge(Dape(i ,2),Dape(i+4,2), Dape(i ,1),Dape(i+4,1))
CALL edge(Dape(i+4,2),Dape(i+5,2), Dape(i+4,1),Dape(i+5,1))
NEXT i
CALL edge(Dape(i ,2),Dape(i-3,2), Dape(i ,1),Dape(i-3,1))
CALL edge(Dape(i ,2),Dape(i+4,2), Dape(i ,1),Dape(i+4,1))
CALL edge(Dape(i+4,2),Dape(i+1,2), Dape(i+4,1),Dape(i+1,1))
SET LINE width 1
!--
FOR i=1 TO Nmt !rotate particles Nmt points
LET w=pxy(i)+fxy(i)*t2
LET Vi(1)=re(w)
LET Vi(2)=im(w)
LET Vi(3)=im( pz(i)+fz(i)*t2 )
MAT Vo=Vi*Mxys
LET Dfxy(i)=COMPLEX(Vo(1),Vo(2))
!--
LET w=pxy(i)+vxy(i)*t1
LET Vi(1)=re(w)
LET Vi(2)=im(w)
LET Vi(3)=im( pz(i)+vz(i)*t1 )
MAT Vo=Vi*Mxys
LET Dvxy(i)=COMPLEX(Vo(1),Vo(2))
!--
LET Vi(1)=re(pxy(i))
LET Vi(2)=im(pxy(i))
LET Vi(3)=im(pz(i))
MAT Vo=Vi*Mxys
LET Dpxy(i)=COMPLEX(Vo(1),Vo(2))
!--
LET q1(i)=Vo(3)
LET q2(i)=i
NEXT i
CALL Qsort00(1,Nmt) !priority particles Nmt points
!--
FOR n=1 TO Nmt !draw particles Nmt disk,verocity,force
LET i=q2(n) !i= ｚ最小(奥) からの particle 番号。
SET AREA COLOR i
DRAW disk WITH SCALE(.5*sigm)*SHIFT(Dpxy(i))
SET LINE COLOR 4 ! red : velocity
PLOT LINES: Dpxy(i); Dvxy(i)
SET LINE COLOR 1 ! black : force
PLOT LINES: Dpxy(i); Dfxy(i)
NEXT n
!--
SET LINE width 2
FOR i=1 TO j9 !draw Near edge
PLOT LINES: Dlin(i,1); Dlin(i,2)
NEXT i
SET LINE width 1
!--
SET COLOR 4 ! red : velocity line & text
PLOT LINES: note0; note0+vss*COMPLEX(0.5, 0)
PLOT label,AT note0+vss*COMPLEX(0.7 ,-0.1) : "velosity"
SET COLOR 1 ! black : force line & text
PLOT LINES: note0+vss*COMPLEX(0,-0.3); note0+vss*COMPLEX(0.5 ,-0.3)
PLOT label,AT note0+vss*COMPLEX(0.7,-0.4): "force"
!--
PLOT label, AT text0 ,USING "box size =##.# x##.# x##.# (nm)" :xMax*1e9,yMax*1e9,zMax*1e9
PLOT label, AT text0-vss*COMPLEX(0,0.30),USING "time =####.## (ps) temp =####.## (K)" :sysTime*1e12, sysTemp
PLOT label, AT text0-vss*COMPLEX(0,0.6 ) :"Ar in the box (3-dimensional molecular dynamics)"
!--
SET DRAW MODE EXPLICIT
END SUB
SUB control_
PLOT label,AT -vss, yMax+1.5*vss:"左 click 一時停止、drag 手動回転。右 click 終了。"
!-----click_drag-----
IF mlb=1 THEN
LET Ax= -(my-mybak)*PI/2E-9 !ドラッグ方向から、軸方向と回転量
LET Ay= +(mx-mxbak)*PI/2E-9
END IF
LET mxbak=mx
LET mybak=my
!-----
LET ar0=SQR(Ax^2+Ay^2) !回転の角度(∝マウス・ドラッグの長さ)
IF ar0<>0 THEN
LET DIRar0=ANGLE(Ax,Ay) !軸の角度
CALL mat_rotx(rotx, ar0)
MAT Axys=Axys*ROTATE(-DIRar0)*rotx*ROTATE(DIRar0) !ドラッグ累積 (方向,回転)
LET Ax=0
LET Ay=0
END IF
MAT Mxys=shxyz*ROTATE(Az)*Axys*shres
END SUB
!---------------------------------
! ｘ軸で 回転する行列 → 配列引数
!(x,y,z,1)| 1, 0, 0, 0 |
! | 0, cos(a), sin(a), 0 |
! | 0,-sin(a), cos(a), 0 |
! | 0, 0, 0, 1 |
!---------------------------------
SUB mat_rotx(m(,), a)
LET m(2,2)=COS(a)
LET m(3,2)=-SIN(a)
LET m(2,3)=SIN(a)
LET m(3,3)=COS(a) !他の要素は、呼出し側で管理
END SUB
!-----------------------------
! 平行移動。(sx,sy,sz)
!(x,y,z,1)| 1, 0, 0, 0 |
! | 0, 1, 0, 0 |
! | 0, 0, 1, 0 |
! | sx, sy, sz, 1 |
!-----------------------------
SUB mat_shxyz(m(,), sx,sy,sz)
LET m(4,1)=sx
LET m(4,2)=sy
LET m(4,3)=sz !他の要素は、呼出し側で管理
END SUB
!---------------------------
! Quick Sort q2() by q1()
!---------------------------
SUB Qsort00(L,R) !昇順にセット。
local i,j
LET i=L
LET j=R
LET w=q1((L+R)/2)
DO
DO WHILE q1(i)< w ![< ]昇順 [>]降順
LET i=i+1
LOOP
DO WHILE w< q1(j) ![< ]昇順 [>]降順
LET j=j-1
LOOP
IF j< i THEN EXIT DO !等号付 j<=i は、暴走。
SWAP q1(i),q1(j)
SWAP q2(i),q2(j)
LET i=i+1
LET j=j-1
LOOP UNTIL j< i !等号付 j<=i は、低速。
IF L< j THEN CALL Qsort00(L,j)
IF i< R THEN CALL Qsort00(i,R)
END SUB
SUB moveParticles
FOR i=1 TO Nmt
LET vxy(i) = vxy(i)+a_*fxy(i)
LET vz(i) = vz(i)+ a_*fz(i)
LET pxy(i) = pxy(i)+vxy(i)*dt
LET pz(i) = pz(i)+ vz(i)*dt
NEXT i
CALL calcForce
LET sysTime=sysTime+dt
LET Az=Az+dt*1e11
END SUB
これはオイラー法であり、誤差の累積で、真の解からだんだん離れていきます。
EXTERNAL SUB moveParticles ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
は速度Verlet法であり、本来は
EXTERNAL SUB moveParticles ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt !xx(t+0.5dt) <-- xx(t-0.5dt)
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
LET sysTime=sysTime+0.5*dt
CALL calcForce ！ ffx,ffy <--xx(t+0.5dt),yy(t+0.5dt)
FOR i=1 TO nMolec
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+0.5*dt
END SUB
SUB ajustVelocity(temp)
LET w=SQR( temp / sysTemp)
MAT vxy= w*vxy
MAT vz= w*vz
END SUB
（６）温度を返す関数として
FUNCTION sysTemp
LET v2 = 0
FOR i=1 TO Nmt
LET v2 = v2 + ABS(vxy(i))^2-vz(i)^2 ! vx^2 + vy^2 + vz^2
!LET v2 = v2 + ABS(ABS(vxy(i))+vz(i))^2 ! vx^2 + vy^2 + vz^2
NEXT i
LET sysTemp = 0.5*mass*v2/Nmt/k_ !(totalEnergy/Nmt)/k
END FUNCTION
を定義されていますが、
統計力学によると、粒子1個あたり、1自由度あたり (1/2)*k*TTempのエネルギーを分配されますから
2D : Ek = (2/2)k*Temp*Nmt ,
3D : Ek = (3/2)k*Temp*Nmt
となりますので、3Dの場合は Temp = (2/3)*Ek/(Nmt*k) となります。
試験環境：
本プログラムは十進BASIC 0.6.6.0 / macOS 10.7.5と
十進BASIC Ver 7.7.8 / windows 10でテストしました。
!
! ========= Quantum Electron Dynamics 1D ==========
!
! wavePacketQED1D.bas
!
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.01.31 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB qed1d.setInitialCondition,qed1d.evolveWave,qed1d.drawWave
DECLARE EXTERNAL FUNCTION qed1d.systemTime,qed1d.norm
!
CALL setInitialCondition(1) !(menu)
!
FOR it=1 TO 1000
FOR i=1 TO 10
CALL evolveWave
NEXT i
CALL drawWave
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =#####.## (au) norm =#.###############":systemTime,norm
!END IF
NEXT it
!
END
! ---------- QED1D module (QED: Quantum Electron Dynamics) ----------
!
! - time dependent Schrodinger equation: i(d/dt)psi(r,t) = H psi(r,t)
! - time evolution
! psi(r,t+dt) = exp(-i dt H) psi(r,t), (H:Hamiltonian of the system)
! H = -delta/2 + V(r), delta = d^2/dx^2 + d^2/dy^2 + d^2/dz^2
! psi(r,t+dt) = exp(-i dt H) psi(r,t) nearly=
! {exp(-i(dt/2)V} {exp(i dt(delta/2)} {exp(-i(dt/2)V} psi(r,t)
! - algorism: {exp(i dt(delta/2)}
! QED: Watanabe's algorism (semi-implicit method)
! Naoki Watanabe, Masaru Tsukada; arXiv:physics/0011068v1
! (Published from Physical Review E. 62, 2914, (2000).)
!
MODULE qed1d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, evolveWave, drawWave
PUBLIC FUNCTION systemTime, norm
SHARE NUMERIC NNx,sysTime, dt, dx, auLength, auTime, auEnergy
SHARE NUMERIC phRe(500),phIm(500) ! wave function
SHARE NUMERIC vv(500) ! external potential
SHARE NUMERIC bRe(500),bIm(500) ! b vector in kxStep
SHARE NUMERIC uRe(500),uIm(500) ! u vector in kxStep
LET NNx = 400 ! max number of phRe(),phIm(),..
LET sysTime = 0.0 ! (au) au : atomic unit (hbar=1, me=1, e=1)
LET dx = 0.5 ! (au) x division
LET dt = 1.0*dx*dx ! (au) time division dt/(dx*dx)>3 ~ unstable?
LET auLength = 5.29177e-11 ! (m) 1(au) = auLength (m)
LET auTime = 2.41888e-17 ! (s) 1(au) = auTime (s)
LET auEnergy = 4.38975e-18 ! (J) 1(au) = auEnergy (J) (= 27.2114 eV)
!
! ----- set initial condition
!
EXTERNAL SUB setInitialCondition(menu) !public
DECLARE EXTERNAL SUB setGaussianWave,setparabolicPotential
LET sysTime = 0.0
IF menu=1 THEN
CALL setGaussianWave(50.0,10.0,0.0) !(wavePos,waveWidth,momentum)
CALL setparabolicPotential(0.5*(NNx-1)*dx,0.0001) ! v(x)=k*(x-x0)^2
ELSEIF menu=2 THEN
CALL setGaussianWave(50.0,10.0,1.0) !(wavePos,waveWidth,momentum)
CALL setparabolicPotential(0.5*(NNx-1)*dx,0.0) ! v(x)=k*(x-x0)^2
END IF
! set window
LET w = NNx*dx
LET b = 20
SET WINDOW -b,w+b,-b,w+b
END SUB
!
EXTERNAL SUB setGaussianWave(wavePos,waveWidth,momentum)
DECLARE EXTERNAL SUB normalize
FOR i=1 TO NNx-2
LET x = i*dx
LET phAb = EXP(-((x-wavePos)/(2.0*waveWidth))^2)
LET phPh = momentum*x
LET phRe(i) = phAb*cos(phPh)
LET phIm(i) = phAb*sin(phPh)
NEXT i
LET phRe(0) = 0.0
LET phIm(0) = 0.0
LET phRe(NNx-1) = 0.0
LET phIm(NNx-1) = 0.0
CALL normalize
END SUB
!
EXTERNAL SUB setparabolicPotential(x0,k) ! v(x)=k*(x-x0)^2
FOR i=0 TO NNx-1
LET x = i*dx
LET vv(i) = k*(x-x0)^2
NEXT i
END SUB
!
! ----- evolve Wave
!
EXTERNAL SUB evolveWave !public
DECLARE EXTERNAL SUB phaseStep,kxStep
CALL phaseStep
CALL kxStep
CALL phaseStep
LET sysTime = sysTime + dt
END SUB
!
EXTERNAL SUB kxStep !{exp(i dt(delta/2)} semi-implicit method
LET ai = 4*dx*dx/dt
LET aaAb = 4+ai*ai
FOR i=1 TO NNx-2 !set b-vector
LET bRe(i) = 2*phRe(i)-ai*phIm(i) - phRe(i+1) - phRe(i-1)
LET bIm(i) = 2*phIm(i)+ai*phRe(i) - phIm(i+1) - phIm(i-1)
NEXT i
! forward elimination
LET uRe(1) = -2/aaAb
LET uIm(1) = -ai/aaAb
LET phRe(1) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET phIm(1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR i=2 TO NNx-2
LET auAb = (-2-uRe(i-1))*(-2-uRe(i-1))+(ai-uIm(i-1))*(ai-uIm(i-1))
LET uRe(i) = (-2-uRe(i-1))/auAb
LET uIm(i) = -(ai-uIm(i-1))/auAb
LET phRe(i) = (bRe(i)-phRe(i-1))*uRe(i) - (bIm(i)-phIm(i-1))*uIm(i)
LET phIm(i) = (bRe(i)-phRe(i-1))*uIm(i) + (bIm(i)-phIm(i-1))*uRe(i)
NEXT i
! backward substitution
FOR i=NNx-3 TO 1 STEP -1
LET phRe(i) = phRe(i) - (phRe(i+1)*uRe(i) - phIm(i+1)*uIm(i))
LET phIm(i) = phIm(i) - (phRe(i+1)*uIm(i) + phIm(i+1)*uRe(i))
NEXT i
END SUB
!
EXTERNAL SUB phaseStep !{exp(-i(dt/2)V} evolve 0.5dt
FOR i=1 TO NNx-2
LET th = 0.5*dt*vv(i)
LET cs = COS(th)
LET sn = SIN(th)
LET phr = phRe(i)
LET phi = phIm(i)
LET phRe(i) = cs*phr+sn*phi
LET phIm(i) = -sn*phr+cs*phi
NEXT i
END SUB
!
! ----- utility
!
EXTERNAL FUNCTION systemTime !public
LET systemTime = sysTime
END FUNCTION
!
EXTERNAL SUB normalize
LET a = norm !public function
FOR i=1 TO NNx-2
LET phRe(i) = phRe(i)/a
LET phIm(i) = phIm(i)/a
NEXT i
END SUB
!
EXTERNAL FUNCTION norm !public SQR(<psi|psi>)
!LOCAL i,a2
LET a2 = 0.0
FOR i=1 TO NNx-2
LET a2 = a2 + (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
NEXT i
LET norm = SQR(a2)
END FUNCTION
!
EXTERNAL FUNCTION kineticEnergy !<psi| d^2/dx^2 |psi>
LET s = 0.0
FOR i=1 TO NNx-2
LET hphRe = (2.0*phRe(i)-phRe(i+1)-phRe(i-1))/(2.0*dx*dx)
LET hphIm = (2.0*phIm(i)-phIm(i+1)-phIm(i-1))/(2.0*dx*dx)
LET s = s + (phRe(i)*hphRe + phIm(i)*hphIm)*dx
NEXT i
LET kineticEnergy = s
END FUNCTION
!
EXTERNAL FUNCTION potentialEnergy !<psi| V(x) |psi>
LET s = 0.0
FOR i=1 TO NNx-2
LET s = s + vv(i)*(phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
NEXT i
LET potentialEnergy = s
END FUNCTION
!
! ----- draw wave
!
EXTERNAL SUB drawWave
DECLARE EXTERNAL FUNCTION kineticEnergy,potentialEnergy
LET yh = (NNx*dx+40)*0.4
LET sth = SIN(PI/12)
SET DRAW MODE HIDDEN
CLEAR
!---plot V(x),<psi|psi>,|psi>
SET LINE COLOR 1 ! black : PLOT potential V(x);
FOR i=0 TO NNx-1
PLOT LINES: dx*i, vv(i)*100+yh;
NEXT i
PLOT LINES
SET LINE COLOR 4 ! red : plot probability <psi|psi>
FOR i=0 TO NNx-1
LET ph2 = (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
PLOT LINES: dx*i, ph2*1000+yh;
NEXT i
PLOT LINES
FOR i=0 TO NNx-1 !plot wave function |psi(x,t)>
LET x = i*dx
LET y = phRe(i)*50
LET z = phIm(i)*50
IF phIm(i)>=0 THEN SET LINE COLOR 2 ELSE SET LINE COLOR 10
PLOT LINES: x-sth*z, y+yh;
!PLOT LINES: dx*i-sth*phIm(i)*50, phRe(i)*50+yh;
NEXT i
PLOT LINES
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0, yh+22 :"potential V(x)"
SET TEXT COLOR 4 ! red
PLOT TEXT, AT 0, yh+6 :"<psi|psi>"
SET TEXT COLOR 2 ! blue
PLOT TEXT, AT 0, yh-10 :"|psi(x,t)>"
!---caption
LET ke = kineticEnergy
LET pe = potentialEnergy
SET TEXT HEIGHT 5
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,48 ,USING "time =#####.## (au) =####.#### (femto s)":sysTime,sysTime*auTime*1e15
PLOT TEXT, AT 0,40 ,USING "norm of wave function =#.###############":norm
PLOT TEXT, AT 0,32 ,USING "kinetic energy =#.###### (au) =##.### (eV)":ke,ke*27.2114
PLOT TEXT, AT 0,24 ,USING "potential energy =#.###### (au) =##.### (eV)":pe,pe*27.2114
PLOT TEXT, AT 0,16 ,USING "total energy =#.###### (au) =##.### (eV)":ke+pe,(ke+pe)*27.2114
PLOT TEXT, AT 0, 8 ,USING "xLength =####.# (au) =###.### (nm)":NNx*dx,NNx*dx*auLength*1e9
PLOT TEXT, AT 0, 0 :"wave packet - quantum electron dynamics 1D"
SET DRAW MODE EXPLICIT
END SUB
!
END MODULE
! ========= Quantum Electron Dynamics 1D ==========
!
! wavePacketQED1D.bas
!
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.01.31 created
!
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DECLARE FUNCTION systemTime,norm
DECLARE FUNCTION kineticEnergy,potentialEnergy
!
! ---------- QED1D module (QED: Quantum Electron Dynamics) ----------
!
! - time dependent Schrodinger equation: i(d/dt)psi(r,t) = H psi(r,t)
! - time evolution
! psi(r,t+dt) = exp(-i dt H) psi(r,t), (H:Hamiltonian of the system)
! H = -delta/2 + V(r), delta = d^2/dx^2 + d^2/dy^2 + d^2/dz^2
! psi(r,t+dt) = exp(-i dt H) psi(r,t) nearly=
! {exp(-i(dt/2)V} {exp(i dt(delta/2)} {exp(-i(dt/2)V} psi(r,t)
! - algorism: {exp(i dt(delta/2)}
! QED: Watanabe's algorism (semi-implicit method)
! Naoki Watanabe, Masaru Tsukada; arXiv:physics/0011068v1
! (Published from Physical Review E. 62, 2914, (2000).)
!
!--------------
DIM pV(1 TO 4),Axys(1 TO 4,1 TO 4),P3D(1 TO 4,1 TO 4)
DIM rotx(1 TO 4,1 TO 4),shxyz(1 TO 4,1 TO 4),shres(1 TO 4,1 TO 4)
MAT Axys=IDN
MAT rotx=IDN
MAT shxyz=IDN
MAT shres=IDN
LET pV(4)=1
!
LET Sx=1
LET Sy=1
LET Sz=1
LET Ax=0 !開始のｚ軸方向( 画面垂直０度からｘ軸回転成分)
LET Ay=0 ! 〃 〃 ( 〃 〃 ｙ軸回転成分)
LET Az=0 !ｚ軸回転成分
!
DIM phRe(500),phIm(500) ! wave function
DIM vv(500) ! external potential
DIM bRe(500),bIm(500) ! b vector in kxStep
DIM uRe(500),uIm(500) ! u vector in kxStep
LET NNx = 400 ! max number of phRe(),phIm(),..
LET sysTime = 0.0 ! (au) au : atomic unit (hbar=1, me=1, e=1)
LET dx = 0.5 ! (au) x division
LET dt = 1.0*dx*dx ! (au) time division dt/(dx*dx)>3 ~ unstable?
LET auLength = 5.29177e-11 ! (m) 1(au) = auLength (m)
LET auTime = 2.41888e-17 ! (s) 1(au) = auTime (s)
LET auEnergy = 4.38975e-18 ! (J) 1(au) = auEnergy (J) (= 27.2114 eV)
!
CALL setInitialCondition(1) !(menu)
!
FOR it=1 TO 1000
FOR i9=1 TO 10
IF mlb=0 THEN CALL evolveWave
NEXT i9
CALL drawWave
!IF (MOD(it,10)=0) THEN
! PRINT USING "time =#####.## (au) norm =#.###############":systemTime,norm
!END IF
mouse poll mx,my,mlb,mrb
IF mrb=1 THEN EXIT FOR
! LET Ay=Ay+1e-2 !trim. ｙ軸で、自動で回す場合
NEXT it
! ----- set initial condition
!
SUB setInitialCondition(menu) !public
LET sysTime = 0.0
IF menu=1 THEN
CALL setGaussianWave(50.0,10.0,0.0) !(wavePos,waveWidth,momentum)
CALL setparabolicPotential(0.5*(NNx-1)*dx,0.0001) ! v(x)=k*(x-x0)^2
ELSEIF menu=2 THEN
CALL setGaussianWave(50.0,10.0,1.0) !(wavePos,waveWidth,momentum)
CALL setparabolicPotential(0.5*(NNx-1)*dx,0.0) ! v(x)=k*(x-x0)^2
END IF
! set window
LET w = NNx*dx
LET b = 20
SET WINDOW -b,w+b,-b,w+b
!--
CALL mat_shxyz(shxyz,-w/2,-w/2, 0) !画面中心を原点へ移動する行列 shxyz 作成
CALL mat_shxyz(shres, w/2, w/2, 0) !画面中心を原点から元へ戻す行列 shres 作成
END SUB
SUB setGaussianWave(wavePos,waveWidth,momentum)
FOR i=1 TO NNx-2
LET x = i*dx
LET phAb = EXP(-((x-wavePos)/(2.0*waveWidth))^2)
LET phPh = momentum*x
LET phRe(i) = phAb*cos(phPh)
LET phIm(i) = phAb*sin(phPh)
NEXT i
LET phRe(0) = 0.0
LET phIm(0) = 0.0
LET phRe(NNx-1) = 0.0
LET phIm(NNx-1) = 0.0
CALL normalize
END SUB
SUB setparabolicPotential(x0,k) ! v(x)=k*(x-x0)^2
FOR i=0 TO NNx-1
LET x = i*dx
LET vv(i) = k*(x-x0)^2
NEXT i
END SUB
! ----- evolve Wave
!
SUB evolveWave !public
DECLARE EXTERNAL SUB phaseStep,kxStep
CALL phaseStep
CALL kxStep
CALL phaseStep
LET sysTime = sysTime + dt
END SUB
SUB kxStep !{exp(i dt(delta/2)} semi-implicit method
LET ai = 4*dx*dx/dt
LET aaAb = 4+ai*ai
FOR i=1 TO NNx-2 !set b-vector
LET bRe(i) = 2*phRe(i)-ai*phIm(i) - phRe(i+1) - phRe(i-1)
LET bIm(i) = 2*phIm(i)+ai*phRe(i) - phIm(i+1) - phIm(i-1)
NEXT i
! forward elimination
LET uRe(1) = -2/aaAb
LET uIm(1) = -ai/aaAb
LET phRe(1) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET phIm(1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR i=2 TO NNx-2
LET auAb = (-2-uRe(i-1))*(-2-uRe(i-1))+(ai-uIm(i-1))*(ai-uIm(i-1))
LET uRe(i) = (-2-uRe(i-1))/auAb
LET uIm(i) = -(ai-uIm(i-1))/auAb
LET phRe(i) = (bRe(i)-phRe(i-1))*uRe(i) - (bIm(i)-phIm(i-1))*uIm(i)
LET phIm(i) = (bRe(i)-phRe(i-1))*uIm(i) + (bIm(i)-phIm(i-1))*uRe(i)
NEXT i
! backward substitution
FOR i=NNx-3 TO 1 STEP -1
LET phRe(i) = phRe(i) - (phRe(i+1)*uRe(i) - phIm(i+1)*uIm(i))
LET phIm(i) = phIm(i) - (phRe(i+1)*uIm(i) + phIm(i+1)*uRe(i))
NEXT i
END SUB
SUB phaseStep !{exp(-i(dt/2)V} evolve 0.5dt
FOR i=1 TO NNx-2
LET th = 0.5*dt*vv(i)
LET cs = COS(th)
LET sn = SIN(th)
LET phr = phRe(i)
LET phi = phIm(i)
LET phRe(i) = cs*phr+sn*phi
LET phIm(i) = -sn*phr+cs*phi
NEXT i
END SUB
! ----- utility
!
FUNCTION systemTime
LET systemTime = sysTime
END FUNCTION
SUB normalize
LET a = norm
FOR i=1 TO NNx-2
LET phRe(i) = phRe(i)/a
LET phIm(i) = phIm(i)/a
NEXT i
END SUB
FUNCTION norm !public SQR(<psi|psi>)
LOCAL i,a2
LET a2 = 0.0
FOR i=1 TO NNx-2
LET a2 = a2 + (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
NEXT i
LET norm = SQR(a2)
END FUNCTION
FUNCTION kineticEnergy !<psi| d^2/dx^2 |psi>
LET s = 0.0
FOR i=1 TO NNx-2
LET hphRe = (2.0*phRe(i)-phRe(i+1)-phRe(i-1))/(2.0*dx*dx)
LET hphIm = (2.0*phIm(i)-phIm(i+1)-phIm(i-1))/(2.0*dx*dx)
LET s = s + (phRe(i)*hphRe + phIm(i)*hphIm)*dx
NEXT i
LET kineticEnergy = s
END FUNCTION
FUNCTION potentialEnergy !<psi| V(x) |psi>
LET s = 0.0
FOR i=1 TO NNx-2
LET s = s + vv(i)*(phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
NEXT i
LET potentialEnergy = s
END FUNCTION
! ----- draw wave
!
SUB drawWave
LET yh = (NNx*dx+40)*0.4
LET sth = SIN(PI/12)
!
SET DRAW MODE HIDDEN
CLEAR
CALL control_
!---plot V(x),<psi|psi>,|psi>
SET LINE COLOR 1 ! black : PLOT potential V(x);
FOR i=0 TO NNx-1
CALL line3D(dx*i, vv(i)*100+yh, 0) !PLOT LINES: dx*i, vv(i)*100+yh;
NEXT i
PLOT LINES
!--
SET LINE COLOR 4 ! red : plot probability <psi|psi>
FOR i=0 TO NNx-1
LET ph2 = (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
CALL line3D( dx*i, ph2*1000+yh, 0) !PLOT LINES: dx*i, ph2*1000+yh;
NEXT i
PLOT LINES
!--
FOR i=0 TO NNx-1 !plot wave function |psi(x,t)>
LET x = i*dx
LET y = phRe(i)*50
LET z = phIm(i)*50
IF phIm(i)>=0 THEN SET LINE COLOR 2 ELSE SET LINE COLOR 10
CALL line3D( x, y+yh, z) !PLOT LINES: x-sth*z, y+yh;
!PLOT LINES: dx*i-sth*phIm(i)*50, phRe(i)*50+yh;
NEXT i
PLOT LINES
!--
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0, yh+22 :"potential V(x)"
SET TEXT COLOR 4 ! red
PLOT TEXT, AT 0, yh+6 :"<psi|psi>"
SET TEXT COLOR 2 ! blue
PLOT TEXT, AT 0, yh-10 :"|psi(x,t)>"
!---caption
LET ke = kineticEnergy
LET pe = potentialEnergy
SET TEXT HEIGHT 5
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,48 ,USING "time =#####.## (au) =####.#### (femto s)":sysTime,sysTime*auTime*1e15
PLOT TEXT, AT 0,40 ,USING "norm of wave function =#.###############":norm
PLOT TEXT, AT 0,32 ,USING "kinetic energy =#.###### (au) =##.### (eV)":ke,ke*27.2114
PLOT TEXT, AT 0,24 ,USING "potential energy =#.###### (au) =##.### (eV)":pe,pe*27.2114
PLOT TEXT, AT 0,16 ,USING "total energy =#.###### (au) =##.### (eV)":ke+pe,(ke+pe)*27.2114
PLOT TEXT, AT 0, 8 ,USING "xLength =####.# (au) =###.### (nm)":NNx*dx,NNx*dx*auLength*1e9
PLOT TEXT, AT 0, 0 :"wave packet - quantum electron dynamics 1D"
SET DRAW MODE EXPLICIT
END SUB
SUB control_
PLOT label,AT 20, 210:"左 click 一時停止、drag 手動回転。右 click 終了。"
!-----click_drag-----
IF mlb=1 THEN
!!LET Ax= -(my-mybak)*PI/100 !※Ｙ軸回転のみにする。 !ドラッグ方向から、軸方向と回転量
LET Ay= +(mx-mxbak)*PI/100
END IF
LET mxbak=mx
LET mybak=my
!-----
LET ar0=SQR(Ax^2+Ay^2) !回転の角度(∝マウス・ドラッグの長さ)
IF ar0<>0 THEN
LET DIRar0=ANGLE(Ax,Ay) !軸の角度
CALL mat_rotx(rotx, ar0)
MAT Axys=Axys*ROTATE(-DIRar0)*rotx*ROTATE(DIRar0) !ドラッグ累積 (方向,回転)
LET Ax=0
LET Ay=0
END IF
MAT P3D=shxyz*ROTATE(Az)*Axys*shres
END SUB
SUB axes3D(x1,y1,z1, x2,y2,z2, a$ )
CALL line3D(x1,y1,z1)
CALL line3D(x2,y2,z2)
PLOT TEXT,AT pV(1),pV(2) :a$ ! PEN-off
END SUB
SUB line3D(x,y,z)
LET pV(1)=x*Sx !描画目盛は、全方向等しくないと、回転で、形が保てない。
LET pV(2)=y*Sy !スケール Sx,Sy,Sz の違いは、入力の倍率として、行なう。
LET pV(3)=z*Sz !入力 z 座標は 出力 x,y に反映。出力ｚは 描画不可。
LET pV(4)=1 ! shxyzM …shxyzP で必要。
MAT pV=pV*P3D
PLOT LINES: pV(1),pV(2); ! PEN-on
END SUB
!---------------------------------
! ｘ軸で 回転する行列 → 配列引数
!(x,y,z,1)| 1, 0, 0, 0 |
! | 0, cos(a), sin(a), 0 |
! | 0,-sin(a), cos(a), 0 |
! | 0, 0, 0, 1 |
!---------------------------------
SUB mat_rotx(m(,), a)
LET m(2,2)=COS(a)
LET m(3,2)=-SIN(a)
LET m(2,3)=SIN(a)
LET m(3,3)=COS(a) !他の要素は、呼出し側で管理
END SUB
!-----------------------------
! 平行移動。(sx,sy,sz)
!(x,y,z,1)| 1, 0, 0, 0 |
! | 0, 1, 0, 0 |
! | 0, 0, 1, 0 |
! | sx, sy, sz, 1 |
!-----------------------------
SUB mat_shxyz(m(,), sx,sy,sz)
LET m(4,1)=sx
LET m(4,2)=sy
LET m(4,3)=sz !他の要素は、呼出し側で管理
END SUB
SUB drawWave
LET yh = (NNx*dx+40)*0.4
LET sth = SIN(PI/12)
!
SET DRAW MODE HIDDEN
CLEAR
CALL control_
!---plot V(x),<psi|psi>,|psi>
SET LINE COLOR 1 ! black : PLOT potential V(x);
FOR i=0 TO NNx-1
CALL line3D(dx*i, vv(i)*100+yh, 0) !PLOT LINES: dx*i, vv(i)*100+yh;
NEXT i
PLOT LINES
!--
SET LINE COLOR 4 ! red : plot probability <psi|psi>
FOR i=0 TO NNx-1
LET ph2 = (phRe(i)*phRe(i)+phIm(i)*phIm(i))*dx
CALL line3D( dx*i, ph2*1000+yh, 0) !PLOT LINES: dx*i, ph2*1000+yh;
NEXT i
PLOT LINES
!--
FOR i=0 TO NNx-1 !plot wave function |psi(x,t)>
LET x = i*dx
LET y = phRe(i)*50
LET z = phIm(i)*50
IF phIm(i)>=0 THEN SET LINE COLOR 2 ELSE SET LINE COLOR 10
!CALL line3D( x-sth*z, y+yh, z) !PLOT LINES: x-sth*z, y+yh; !****************
CALL line3D( x, y+yh, z) !PLOT LINES: x-sth*z, y+yh; !************
!PLOT LINES: dx*i-sth*phIm(i)*50, phRe(i)*50+yh;
NEXT i
PLOT LINES
> mikeさんへのお返事です。
>
> 速度が落ちて、早く終了する。バグを、作っていました。すみません。
> 外部副プログラムが、原則、全ローカル変数なので、内側に移すときに、
> 重なっているのに気が付きませんでした。
>
> メインの、FOR i=1 TO 10 の、iを、 FOR i9=1 TO 10 の様に変えないと・・、
>
> FOR i=1 TO 10
> IF mlb=0 THEN CALL evolveWave
> NEXT i
>
> ↓
>
> FOR i9=1 TO 10
> IF mlb=0 THEN CALL evolveWave
> NEXT i9
>
試験環境：
本プログラムは十進BASIC 0.6.6.0 / macOS 10.7.5と
十進BASIC Ver 7.7.8 / windows 10でテストしました。
!
! ========= FDTD 2D ==========
!
! waveFDTD2D.bas
! Mitsuru Ikeuchi (c) copyleft
!
! ver 0.0.1 2017.02.06
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB fdtd2d.setInitialCondition, fdtd2d.evolveField, fdtd2d.drawField
DECLARE EXTERNAL FUNCTION fdtd2d.systemTime
!
!CALL setInitialCondition(epsilon,mue,sigma)
CALL setInitialCondition(4.0,1.0,0.0) !dielectric material
!CALL setInitialCondition(1.0,4.0,0.0) !Magnetic material
!CALL setInitialCondition(1.0,1.0,0.01) !resistor
!CALL setInitialCondition(1.0,1.0,0.0) !vacuum or air
!CALL setInitialCondition(1000.0,1.0,0.1) ! metal
!
FOR it=1 TO 1000
CALL evolveField
CALL evolveField
CALL drawField
NEXT it
!
END
! ---------- FDTD2D module ----------
!
! time evolution : from Maxwell equation,
! d(mu H)/dt = - rot E (B = mu H)
! d(ep E)/dt = -j + rot H (D=ep E, j=sg E)
! FDTD:Finite-difference time-domain method
! 2D subset: Ez,Hx,Hy - finite difference approximation
!
MODULE fdtd2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, evolveField, drawField
PUBLIC FUNCTION systemTime
SHARE NUMERIC sysTime, dt,epsilon,reg,sgm,Jz,omega,theta,NNx,NNy
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC Ez(320,320) ! electric field
SHARE NUMERIC Hx(320,320),Hy(320,320) ! magnetic field
SHARE NUMERIC ep(320,320) ! dielectric constant
SHARE NUMERIC mu(320,320) ! permeability
SHARE NUMERIC sg(320,320) ! conductivity
LET sysTime = 0 ! system time
LET dt = 1 ! time step
LET dx = 1 ! x-division dx=dy=dz=1 no use
LET omega = PI/32 ! generator wave phase angle change
LET theta = 0 ! generator phase angle
LET NNx = 241 ! max number of Ez(i,) etc.
LET NNy = 241 ! max number of Ez(,j) etc.
!
! set initial condition
!
EXTERNAL SUB setInitialCondition(epsilon,mue,sigma)
LET theta = 0.0
!clear field
FOR i=0 TO NNx
FOR j=0 TO NNy
LET Ez(i,j) = 0
LET Hx(i,j) = 0
LET Hy(i,j) = 0
LET ep(i,j) = 1
LET mu(i,j) = 1
LET sg(i,j) = 0
NEXT j
NEXT i
!set material
FOR i=0 TO NNx
FOR j=0 TO NNy
IF (i>=60 AND i<140 AND j>=50 AND j<150) THEN
LET ep(i,j) = epsilon
LET mu(i,j) = mue
LET sg(i,j) = sigma
END IF
NEXT j
NEXT i
! set window
LET xmargin = 60
LET ymargin = 100
SET WINDOW -xmargin,400-xmargin,-ymargin,400-ymargin
END SUB
!
! evolve Field Ez,Hx,Hy
!
EXTERNAL SUB evolveField
DECLARE EXTERNAL SUB generateEz,evolveEz,evolveHxHy
LET sysTime = sysTime + dt
CALL evolveEz
CALL generateEz(2)
CALL evolveHxHy
END SUB
!
EXTERNAL SUB generateEz(nwave)
LET theta = theta + omega*dt
LET Ezt = SIN(theta)
LET a = 0
IF theta<2*PI*nwave THEN
LET a=1
ELSEIF theta<2*PI*nwave+0.13*PI THEN
LET a=COS(theta)
END IF
IF theta<2*PI*nwave+0.5*PI THEN
FOR j=0 TO NNy
LET Ez(0,j) = a*a*Ezt
NEXT j
END IF
END SUB
!
EXTERNAL SUB evolveEz ! dD/dt=rotH + J ,D=epsi*E
LET a = 1/(2*SQR(2))
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET Ez(i,j)=Ez(i,j)-sg(i,j)*0.5*dt*Ez(i,j)+(a/ep(i,j))*((Hy(i+1,j)-Hy(i,j))-(Hx(i,j+1)-Hx(i,j)))
NEXT j
NEXT i
END SUB
!
EXTERNAL SUB evolveHxHy ! dB/dt=-rotE ,B=mue*H
!no reflection boundary
LET a = 1/(2*SQR(2))
LET c = (1-a)/(1+a)
FOR i=0 TO NNx-1
LET Hx(i,0) = c*Hx(i,0) + Hx(i,1)
LET Hx(i,NNy) = c*Hx(i,NNy) + Hx(i,NNy-1)
NEXT i
FOR j=0 TO NNy-1
LET Hy(0,j) = c*Hy(0,j) + Hy(1,j)
LET Hy(NNx,j) = c*Hy(NNx,j) + Hy(NNx-1,j)
NEXT j
!
FOR i=0 TO NNx-1
FOR j=1 TO NNy-1
LET Hx(i,j) = Hx(i,j) - (a/mu(i,j))*(Ez(i,j)-Ez(i,j-1))
NEXT j
NEXT i
FOR i=1 TO NNx-1
FOR j=0 TO NNy-1
LET Hy(i,j) = Hy(i,j) + (a/mu(i,j))*(Ez(i,j)-Ez(i-1,j))
NEXT j
NEXT i
!no reflection boundary
FOR i=0 TO NNx-1
LET Hx(i,0) = Hx(i,0) - c*Hx(i,1)
LET Hx(i,NNy) = Hx(i,NNy) - c*Hx(i,NNy-1)
NEXT i
FOR j=0 TO NNy-1
LET Hy(0,j) = Hy(0,j) - c*Hy(1,j)
LET Hy(NNx,j) = Hy(NNx,j) - c*Hy(NNx-1,j)
NEXT j
END SUB
!
! utility
!
EXTERNAL FUNCTION systemTime
LET systemTime = sysTime
END FUNCTION
!
! 3D graphics
!
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z) !shift*xRotateAx*yRotateAy*(shift^-1)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0, y1+cy0; !z=z1+cz0
END SUB
!
! draw field Ez,Hx,Hy
!
EXTERNAL SUB drawField
DECLARE EXTERNAL SUB drawEz
!
SET DRAW MODE HIDDEN
CLEAR
!CALL setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
CALL drawEz(-PI/6,-PI/12) !(xRotateAngle,yRotateAngle)
!draw caption
SET TEXT HEIGHT 8
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,-20 ,USING "time =#####.# ":sysTime
PLOT TEXT, AT 0,-35 ,USING "field size = #### x ####":NNx,NNy
PLOT TEXT, AT 0,-50 :"2-dimensional FDTD"
!
SET DRAW MODE EXPLICIT
END SUB
!
EXTERNAL SUB drawEz(xRotateAngle,yRotateAngle)
DECLARE EXTERNAL SUB setRotate,plotLines3D
LET sc = 1.0
LET zMag = 20
!CALL setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
CALL setRotateXYParameters(xRotateAngle,yRotateAngle,NNx/2,NNy/2,0)
SET COLOR 2 ! blue : Ez
FOR j=0 TO NNy-1 STEP 5
FOR i=0 TO NNx-1
IF Ez(i,j)>=0 THEN SET COLOR 2 ELSE SET COLOR 9 !>=0:bule <0:dark blue
IF ep(i,j)>1 OR mu(i,j)>1 OR sg(i,j)>0 THEN SET COLOR 4 !something material
CALL plotLines3D(i*sc,j*sc,zMag*Ez(i,j)) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 5
FOR j=0 TO NNy-1
IF Ez(i,j)>=0 THEN SET COLOR 2 ELSE SET COLOR 9
IF ep(i,j)>1 OR mu(i,j)>1 OR sg(i,j)>0 THEN SET COLOR 4
CALL plotLines3D(i*sc,j*sc,zMag*Ez(i,j))
NEXT j
PLOT LINES
NEXT i
END SUB
!
END MODULE
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4),ROTZ(4,4)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
LOCATE VALUE NOWAIT(1),RANGE -180 TO 180,AT 0:XTH
LOCATE VALUE NOWAIT(2),RANGE -180 TO 180,AT 0:YTH
LOCATE VALUE NOWAIT(3),RANGE -180 TO 180,AT 0:ZTH
LOCATE VALUE NOWAIT(4),RANGE -500 TO 500,AT 0:XMOVE
LOCATE VALUE NOWAIT(5),RANGE -500 TO 500,AT 0:YMOVE
DO
LOCATE VALUE NOWAIT(1):XTH
LOCATE VALUE NOWAIT(2):YTH
LOCATE VALUE NOWAIT(3):ZTH
LOCATE VALUE NOWAIT(4):XMOVE
LOCATE VALUE NOWAIT(5):YMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT ROTZ=IDN ! z軸のまわりの回転
LET ROTZ(1,1)=COS(ZTH)
LET ROTZ(1,2)=SIN(ZTH)
LET ROTZ(2,1)=-SIN(ZTH)
LET ROTZ(2,2)=COS(ZTH)
MAT M=ROTX*ROTY*ROTZ
SET DRAW MODE HIDDEN
CLEAR
CALL CUBE(XMOVE,YMOVE,ZMOVE,L)
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X
LET POINT(2)=Y
LET POINT(3)=Z
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1),POINT(2);
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
SUB CUBE(X,Y,Z,L)
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z+L/2)
CALL PLOT(X-L/2,Y+L/2,Z+L/2)
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
PLOT LINES
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
CALL PLOT(X+L/2,Y-L/2,Z-L/2)
CALL PLOT(X+L/2,Y-L/2,Z+L/2)
CALL PLOT(X-L/2,Y-L/2,Z+L/2)
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
PLOT LINES
CALL PLOTLINE(X-L/2,Y+L/2,Z-L/2,X-L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z-L/2,X+L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z+L/2,X+L/2,Y-L/2,Z+L/2)
CALL PLOTLINE(X-L/2,Y+L/2,Z+L/2,X-L/2,Y-L/2,Z+L/2)
END SUB
END
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4),ROTZ(4,4)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
LOCATE VALUE NOWAIT(1),RANGE -1 TO 1,AT 0:X0
LOCATE VALUE NOWAIT(2),RANGE -1 TO 1,AT 1:Y0
LOCATE VALUE NOWAIT(3),RANGE -1 TO 1,AT 0:Z0
LOCATE VALUE NOWAIT(4),RANGE -180 TO 180,AT 0:THETA
LOCATE VALUE NOWAIT(5),RANGE -100 TO 100,AT 0:XMOVE
DO
LOCATE VALUE NOWAIT(1):X0
LOCATE VALUE NOWAIT(2):Y0
LOCATE VALUE NOWAIT(3):Z0
LOCATE VALUE NOWAIT(4):THETA
LOCATE VALUE NOWAIT(5):XMOVE
SET DRAW MODE HIDDEN
CLEAR
CALL CUBE(XMOVE,YMOVE,ZMOVE,L)
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
LOOP
SUB PLOT(X,Y,Z)
CALL ROTATE(X,Y,Z,X0,Y0,Z0,THETA,XX,YY,ZZ)
IF FL=0 THEN
LET LMIN=MIN(LMIN,XX)
LET LMAX=MAX(LMAX,XX)
LET LMIN=MIN(LMIN,YY)
LET LMAX=MAX(LMAX,YY)
ELSE
PLOT LINES:XX,YY;
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
SUB ROTATE(XX,YY,ZZ,X0,Y0,Z0,TH,NX,NY,NZ) !'ロドリゲスの回転公式
!'原点と点(X0,Y0,Z0)を通る回転軸
!'点 P(XX,YY,ZZ) TH度回転 P'(NX,NY,NZ)
DIM A(3,3)
LET S=SQR(X0*X0+Y0*Y0+Z0*Z0)
IF S>0 THEN
LET X=X0/S
LET Y=Y0/S
LET Z=Z0/S
LET A(1,1)=X*X*(1-COS(TH))+COS(TH)
LET A(1,2)=X*Y*(1-COS(TH))+Z*SIN(TH)
LET A(1,3)=X*Z*(1-COS(TH))-Y*SIN(TH)
LET A(2,1)=Y*X*(1-COS(TH))-Z*SIN(TH)
LET A(2,2)=Y*Y*(1-COS(TH))+COS(TH)
LET A(2,3)=Y*Z*(1-COS(TH))+X*SIN(TH)
LET A(3,1)=Z*X*(1-COS(TH))+Y*SIN(TH)
LET A(3,2)=Z*Y*(1-COS(TH))-X*SIN(TH)
LET A(3,3)=Z*Z*(1-COS(TH))+COS(TH)
LET NX=XX*A(1,1)+YY*A(1,2)+ZZ*A(1,3)
LET NY=XX*A(2,1)+YY*A(2,2)+ZZ*A(2,3)
LET NZ=XX*A(3,1)+YY*A(3,2)+ZZ*A(3,3)
END IF
END SUB
END
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
LOCATE VALUE NOWAIT(1),RANGE 1 TO 500,AT 100:K !'視点(0,0,K)
LOCATE VALUE NOWAIT(2),RANGE -500 TO 500,AT 0:XMOVE
LOCATE VALUE NOWAIT(3),RANGE -500 TO 500,AT 0:YMOVE
LOCATE VALUE NOWAIT(4),RANGE -500 TO -1,AT -1:ZMOVE
DO
LOCATE VALUE NOWAIT(1):K
LOCATE VALUE NOWAIT(2):XMOVE
LOCATE VALUE NOWAIT(3):YMOVE
LOCATE VALUE NOWAIT(4):ZMOVE
SET DRAW MODE HIDDEN
CLEAR
CALL CUBE(XMOVE,YMOVE,ZMOVE,L)
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
LOOP
SUB PLOT(X,Y,Z)
LET XX=X/(1-Z/K)
LET YY=Y/(1-Z/K)
IF FL=0 THEN
LET LMIN=MIN(LMIN,XX)
LET LMAX=MAX(LMAX,XX)
LET LMIN=MIN(LMIN,YY)
LET LMAX=MAX(LMAX,YY)
ELSE
PLOT LINES:XX,YY;
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
SUB CUBE(X,Y,Z,L)
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z+L/2)
CALL PLOT(X-L/2,Y+L/2,Z+L/2)
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
PLOT LINES
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
CALL PLOT(X+L/2,Y-L/2,Z-L/2)
CALL PLOT(X+L/2,Y-L/2,Z+L/2)
CALL PLOT(X-L/2,Y-L/2,Z+L/2)
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
PLOT LINES
CALL PLOTLINE(X-L/2,Y+L/2,Z-L/2,X-L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z-L/2,X+L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z+L/2,X+L/2,Y-L/2,Z+L/2)
CALL PLOTLINE(X-L/2,Y+L/2,Z+L/2,X-L/2,Y-L/2,Z+L/2)
END SUB
END
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
LET F=100 !'視点から投影面までの距離
LOCATE VALUE NOWAIT(1),RANGE -90 TO 90,AT 0:BETA
LOCATE VALUE NOWAIT(2),RANGE -180 TO 0,AT -90:GAMMA
LOCATE VALUE NOWAIT(3),RANGE 0 TO 1000,AT 100:D1
LOCATE VALUE NOWAIT(4),RANGE -500 TO 1000,AT 0:D2
LOCATE VALUE NOWAIT(5),RANGE -500 TO 1000,AT 0:D3
DO
LOCATE VALUE NOWAIT(1):BETA
LOCATE VALUE NOWAIT(2):GAMMA
LOCATE VALUE NOWAIT(3):D1
LOCATE VALUE NOWAIT(4):D2
LOCATE VALUE NOWAIT(5):D3
SET DRAW MODE HIDDEN
CLEAR
CALL CUBE(0,0,0,L)
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
LOOP
SUB PLOT(X,Y,Z)
LET SY=SIN(BETA)
LET CY=COS(BETA)
LET SZ=SIN(GAMMA)
LET CZ=COS(GAMMA)
LET X1=CY*SZ*(X-D1)-CY*CZ*(Y-D2)-SY*(Z-D3)
LET Y1=CZ*(X-D1)+SZ*(Y-D2)
LET Z1=SY*SZ*(X-D1)-SY*CZ*(Y-D2)-CY*(Z-D3)
LET XX=-F*Y1/X1
LET YY=-F*Z1/X1
IF FL=0 THEN
LET LMIN=MIN(LMIN,XX)
LET LMAX=MAX(LMAX,XX)
LET LMIN=MIN(LMIN,YY)
LET LMAX=MAX(LMAX,YY)
ELSE
PLOT LINES:XX,YY;
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
SUB CUBE(X,Y,Z,L)
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z+L/2)
CALL PLOT(X-L/2,Y+L/2,Z+L/2)
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
PLOT LINES
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
CALL PLOT(X+L/2,Y-L/2,Z-L/2)
CALL PLOT(X+L/2,Y-L/2,Z+L/2)
CALL PLOT(X-L/2,Y-L/2,Z+L/2)
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
PLOT LINES
CALL PLOTLINE(X-L/2,Y+L/2,Z-L/2,X-L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z-L/2,X+L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z+L/2,X+L/2,Y-L/2,Z+L/2)
CALL PLOTLINE(X-L/2,Y+L/2,Z+L/2,X-L/2,Y-L/2,Z+L/2)
END SUB
END
!6n±1篩 1億までの素数をカウント
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k=1E4 !SQR(1E8)
LET k2=1229
DIM P(k)
DIM A(k2) !素数
SUB prime(v) !エラトステネスの奇数列篩
LET k9=v
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k9 STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k9+1 THEN EXIT SUB
END IF
FOR k1=n1 TO k9 STEP 2
LET m1=n1*k1
IF m1>k9 THEN EXIT FOR
LET P(m1)=1
NEXT k1
NEXT n1
END SUB
CALL prime(k)
LET k6=1E8 !篩の計算範囲
LET k5=IP(k6/6)+1
DIM A6(k5),A7(k5)
MAT A6 = ZER !(6*n-1)
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN
LET r6=(P6+1)/6
FOR i=1 TO k5
IF P6*i+r6>k5 THEN EXIT FOR
LET A6(P6*i+r6)=1
NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=1 TO k5
IF P6*i-r6>k5 THEN EXIT FOR
LET A6(P6*i-r6)=1
NEXT i
END IF
NEXT n
MAT A7 = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN
LET r6=(P6+1)/6
FOR i=1 TO k5
IF P6*i-r6>k5 THEN EXIT FOR
LET A7(P6*i-r6)=1
NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=1 TO k5
IF P6*i+r6>k5 THEN EXIT FOR
LET A7(P6*i+r6)=1
NEXT i
END IF
NEXT n
FOR n=1 TO k5
IF A6(n)=1 THEN GOTO 100
LET c1=c1+1
100 IF A7(n)=1 THEN GOTO 200
LET c1=c1+1
200 NEXT n
PRINT c1+2
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
DECLARE EXTERNAL FUNCTION cprime
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k6=1E8
DATA 14143,17321,20011,22367,24499,26459,28289,30011,31627,33179
DATA 34649,36061,37423,38729,40009,41231,42433,43591,44729,45827
DATA 46919,47963,48989,50021,50993,51971,52919,53857,54773,55681
DATA 56569,57457,58309,59167,60013,60859,61651,62459,63247,64033
DATA 64811,65579,66337,67103,67829,68567,69313,70001,70717,71419
DATA 72139,72817,73517,74161,74843,75503,76157,76819,77471,78121
DATA 78779,79379,80021,80627,81281,81853,82463,83071,83689,84263
DATA 84857,85447,86027,86627,87179,87751,88321,88883,89443,90001
DATA 90583,91121,91673,92203,92737,93281,93809,94343,94873,95393
DATA 95917,96443,96953,97499,97987,98491,98999,99523,100003,100501
DIM Ba(100)
MAT READ Ba
DATA 1664,1991,2263,2503,2718,2907,3081,3246,3402,3555
DATA 3700,3830,3962,4082,4204,4317,4436,4541,4649,4747
DATA 4847,4943,5034,5134,5222,5316,5400,5486,5572,5651
DATA 5737,5824,5903,5983,6058,6132,6203,6270,6338,6417
DATA 6478,6549,6614,6685,6757,6818,6881,6936,7005,7074
DATA 7141,7199,7258,7316,7380,7436,7497,7552,7609,7671
DATA 7725,7779,7838,7889,7953,8004,8059,8113,8167,8215
DATA 8266,8317,8365,8422,8465,8523,8564,8611,8661,8714
DATA 8768,8810,8860,8904,8959,9010,9051,9099,9148,9195
DATA 9244,9287,9331,9375,9418,9459,9505,9548,9593,9633
DIM Bb(100)
MAT READ Bb
DATA 1177,1922,2497,2979,3400,3778,4122,4441,4741,5022
DATA 5289,5544,5788,6023,6247,6466,6676,6880,7078,7272
DATA 7458,7643,7823,7995,8169,8336,8502,8663,8823,8978
DATA 9132,9281,9431,9576,9718,9857,10001,10138,10276,10410
DATA 10542,10672,10802,10927,11056,11180,11300,11427,11547,11667
DATA 11781,11900,12014,12134,12246,12360,12473,12582,12691,12799
DATA 12914,13021,13124,13232,13337,13438,13552,13642,13741,13848
DATA 13944,14043,14142,14237,14338,14434,14530,14625,14720,14814
DATA 14903,14998,15089,15183,15276,15365,15456,15545,15634,15724
DATA 15812,15916,15986,16068,16158,16244,16329,16411,16411,16499
DIM Bc(100)
MAT READ Bc
LET c1=5761455
PRINT " 1";":";c1
FOR n=1 TO 100
LET k=Ba(n) !SQR(1E8)
LET k2=Bb(n) !π(x)
LET S=Bc(n)
LET k6=k6+1E8
LET C=cprime(k,k2,k6,S)
LET c1=c1+c
PRINT n+1;":";c1;":";c
NEXT n
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
EXTERNAL FUNCTION cprime (k,k2,k6,S)
OPTION ARITHMETIC NATIVE
LET k4=k6-1E8
LET U=IP(k6/6)+1
LET W=IP(k4/6)-1
DIM x(w TO u)
DIM y(w TO u)
!エラトステネスの篩
DIM P(k)
DIM A(k2) !素数
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k+1 THEN GOTO 20
END IF
FOR k1=n1 TO k STEP 2
LET m1=n1*k1
IF m1>k THEN GOTO 10
LET P(m1)=1
NEXT k1
10 NEXT n1
20
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r=(P6+1)/6
FOR i=S TO u
IF P6*i+r>u THEN EXIT FOR
IF P6*i+r<w THEN GOTO 30
LET x(P6*i+r)=1
30 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r=(P6-1)/6
FOR i=S TO u
IF P6*i-r>u THEN EXIT FOR
IF P6*i-r<w THEN GOTO 40
LET x(P6*i-r)=1
40 NEXT i
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r=(P6+1)/6
FOR i=S TO u
IF P6*i-r>u THEN EXIT FOR
IF P6*i-r<w THEN GOTO 50
LET y(P6*i-r)=1
50 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r=(P6-1)/6
FOR i=S TO u
IF P6*i+r>u THEN EXIT FOR
IF P6*i+r<w THEN GOTO 60
LET y(P6*i+r)=1
60 NEXT i
END IF
NEXT n
FOR n=w TO u
IF x(n)=1 THEN
GOTO 100
ELSE
IF k6-1E8>n*6-1 OR k6<n*6-1 THEN GOTO 100
LET cc=cc+1
END IF
100 IF y(n)=1 THEN
GOTO 200
ELSE
IF k6-1E8>n*6+1 OR k6<n*6+1 THEN GOTO 200
LET cc=cc+1
END IF
200 NEXT n
LET cprime=cc
END FUNCTION
LET T=TIME
LET k=1e+8
LET K2=1E+7
DIM P(k)
DIM A(k2) !素数
LET h1=1
LET A(h1)=2
LET h1=2
FOR n1=3 TO k STEP 2
IF P(n1)=0 THEN
LET A(h1)=n1
LET h1=h1+1
IF h1>k+1 THEN GOTO 20
END IF
FOR k1=n1 TO k STEP 2
LET m1=n1*k1
IF m1>k THEN GOTO 10
LET P(m1)=1
NEXT k1
10 NEXT n1
20 PRINT TIME-T
PRINT H1
MAT P=ZER
MAT A=ZER
LET T=TIME
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
PRINT TIME-T
PRINT H1
MAT P=ZER
MAT A=ZER
LET T=TIME
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
END IF
NEXT I
PRINT TIME-T
PRINT H1
END
!6n±1篩 1億までの素数をカウント
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k=1E4 !SQR(1E8)
LET k2=1229
DIM P(k)
DIM A(k2) !素数
SUB prime(k) !エラトステネスの篩
MAT P=ZER
MAT A=ZER
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
END IF
NEXT I
END SUB
CALL prime(k)
LET k6=1E8 !篩の計算範囲
LET k5=IP(k6/6)+1
DIM A6(k5),A7(k5)
MAT A6 = ZER !(6*n-1)
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN
LET r6=(P6+1)/6
FOR i=1 TO k5
IF P6*i+r6>k5 THEN EXIT FOR
LET A6(P6*i+r6)=1
NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=1 TO k5
IF P6*i-r6>k5 THEN EXIT FOR
LET A6(P6*i-r6)=1
NEXT i
END IF
NEXT n
MAT A7 = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN
LET r6=(P6+1)/6
FOR i=1 TO k5
IF P6*i-r6>k5 THEN EXIT FOR
LET A7(P6*i-r6)=1
NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=1 TO k5
IF P6*i+r6>k5 THEN EXIT FOR
LET A7(P6*i+r6)=1
NEXT i
END IF
NEXT n
FOR n=1 TO k5
IF A6(n)=1 THEN GOTO 100
LET c1=c1+1
100 IF A7(n)=1 THEN GOTO 200
LET c1=c1+1
200 NEXT n
PRINT c1+2
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
-------------------------------------------------
6n±1篩は、サンダラムの篩の出力部 2n+1 の例に倣って
6n±1 のnを篩っています。
EXTERNAL FUNCTION PrimeQ(n)のネットのダウンロードサイトlink切れです。
5+6n = 6n-1 , 7+6n = 6n+1 とても効率的な方法です。
DECLARE EXTERNAL FUNCTION count
DECLARE EXTERNAL FUNCTION PrimeQ
FOR n=1 TO 100
LET S=n*100-100
IF S=0 THEN LET S=1
LET T=n*100
PRINT S;"TO";T
PRINT count(S,T);"個"
PRINT
NEXT n
END
EXTERNAL FUNCTION count(S,T)
DIM A(S TO T)
MAT A=ZER
FOR n=S TO T
LET v=n+1
IF MOD(v,6)=0 AND PrimeQ(n)=1 THEN
LET C=C+1
LET A(n)=1
PRINT c;":";n
END IF
NEXT n
PRINT
LET count=C
END FUNCTION
EXTERNAL FUNCTION PrimeQ(n) !素数判定 1:素数、0:素数でない
LET PrimeQ=0
IF n<2 OR n<>INT(n) THEN EXIT FUNCTION !引数を確認する
!２以上の自然数なら
IF MOD(n,2)=0 THEN !２の倍数
IF n=2 THEN LET PrimeQ=1 !２は素数
ELSEIF MOD(n,3)=0 THEN !３の倍数
IF n=3 THEN LET PrimeQ=1 !３は素数
ELSE
LET k=5
DO WHILE k*k<=n !√nまで検証する
IF MOD(n,k)=0 THEN !5,11,17,23,29,…
EXIT FUNCTION
ELSEIF MOD(n,k+2)=0 THEN !7,13,19,25,31,…
EXIT FUNCTION
END IF !+1,+3,+5は２の倍数（偶数）、+1,+4は３の倍数、+5は５の倍数
LET k=k+6
LOOP
LET PrimeQ=1 !最後まで割り切れなければ、素数である
END IF
END FUNCTION
DECLARE EXTERNAL SUB prep,slide.init,slide.bar_operation,slide.scales,global_graphic.asks,global_graphic.sets
!
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4),ROTZ(4,4)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
!
LET slb_n=6 ! スライドバー本数(最大12本)
DIM slb_x0(slb_n),slb_y0(slb_n),slb_init_v(slb_n)
LET slb_area_pix=45 ! スライドバー1本を描くために必要な幅の画素数
SET BITMAP SIZE 641+slb_area_pix*slb_n+5+1,641
ASK DEVICE WINDOW slb_x1,slb_x2,slb_y1,slb_y2
SET VIEWPORT 641/(641+slb_area_pix*slb_n+5),1,0,1
SET WINDOW 0,slb_area_pix*slb_n+5,0,640/slb_y2
CALL prep(slb_n,slb_x0,slb_y0,slb_init_v)
FOR slb_i=1 TO slb_n
CALL result(slb_i,slb_init_v(slb_i))
NEXT slb_i
!
DO !! メインルーチン
!
SET VIEWPORT 641/(641+slb_area_pix*slb_n+5),1,0,1
SET WINDOW 0,slb_area_pix*slb_n+5,0,640/slb_y2
LET ms_l9=ms_ll ! ms_l9=マウスの左ボタンの直前の状態
MOUSE POLL ms_xx,ms_yy,ms_ll,ms_rr
SET DRAW MODE HIDDEN
CALL slide.bar_operation(slb_num,slb_v,ms_l9,ms_ll,ms_xx,ms_yy) ! **バー操作**
! slb_num=操作したバーの番号(0or1～n,戻り値), slb_v=バーの値(戻り値)
IF slb_num<>0 THEN CALL result(slb_num,slb_v) ! 結果
SET DRAW MODE EXPLICIT
!
SET VIEWPORT 0,640/(641+slb_area_pix*slb_n+5),0,1*slb_y2
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT ROTZ=IDN ! z軸のまわりの回転
LET ROTZ(1,1)=COS(ZTH)
LET ROTZ(1,2)=SIN(ZTH)
LET ROTZ(2,1)=-SIN(ZTH)
LET ROTZ(2,2)=COS(ZTH)
MAT M=ROTX*ROTY*ROTZ
SET DRAW MODE HIDDEN
SET AREA COLOR 0
PLOT AREA :LMIN*2,LMIN*2;LMAX*2,LMIN*2;LMAX*2,LMAX*2;LMIN*2,LMAX*2
CALL CUBE(XMOVE,YMOVE,ZMOVE,L)
IF FL=0 THEN
SET VIEWPORT 0,640/(641+slb_area_pix*slb_n+5),0,1*slb_y2
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
!
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X
LET POINT(2)=Y
LET POINT(3)=Z
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1),POINT(2);
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,X2,Y2,Z2)
PLOT LINES
CALL PLOT(X1,Y1,Z1)
CALL PLOT(X2,Y2,Z2)
PLOT LINES
END SUB
SUB CUBE(X,Y,Z,L)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
CALL PLOT(X+L/2,Y+L/2,Z-L/2)
SET LINE COLOR 4
CALL PLOT(X+L/2,Y+L/2,Z+L/2)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y+L/2,Z+L/2)
SET LINE COLOR 4
CALL PLOT(X-L/2,Y+L/2,Z-L/2)
PLOT LINES
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
SET LINE COLOR 2
CALL PLOT(X+L/2,Y-L/2,Z-L/2)
SET LINE COLOR 4
CALL PLOT(X+L/2,Y-L/2,Z+L/2)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y-L/2,Z+L/2)
SET LINE COLOR 4
CALL PLOT(X-L/2,Y-L/2,Z-L/2)
PLOT LINES
SET LINE COLOR 3
CALL PLOTLINE(X-L/2,Y+L/2,Z-L/2,X-L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z-L/2,X+L/2,Y-L/2,Z-L/2)
CALL PLOTLINE(X+L/2,Y+L/2,Z+L/2,X+L/2,Y-L/2,Z+L/2)
CALL PLOTLINE(X-L/2,Y+L/2,Z+L/2,X-L/2,Y-L/2,Z+L/2)
END SUB
!
SUB result(c,v_bar) ! 結果
CALL global_graphic.asks
SET TEXT JUSTIFY "LEFT","BOTTOM"
SET TEXT HEIGHT 14
SET TEXT COLOR "BLUE"
SET TEXT BACKGROUND "OPAQUE"
SELECT CASE c
CASE 1
LET XTH=v_bar
PLOT TEXT ,AT slb_x0(c)-24,slb_y0(c)+552 ,USING "---%" : XTH
CASE 2
LET YTH=v_bar
PLOT TEXT ,AT slb_x0(c)-24,slb_y0(c)+552 ,USING "---%" : YTH
CASE 3
LET ZTH=v_bar
PLOT TEXT ,AT slb_x0(c)-24,slb_y0(c)+552 ,USING "---%" : ZTH
CASE 4
LET XMOVE=v_bar
PLOT TEXT ,AT slb_x0(c)-24,slb_y0(c)+612 ,USING "---%" : XMOVE
CASE 5
LET YMOVE=v_bar
PLOT TEXT ,AT slb_x0(c)-24,slb_y0(c)+612 ,USING "---%" : YMOVE
CASE 6
LET ZMOVE=v_bar
PLOT TEXT ,AT slb_x0(c)-24,slb_y0(c)+612 ,USING "---%" : ZMOVE
CASE ELSE
END SELECT
CALL global_graphic.sets
END SUB
END
EXTERNAL SUB prep(n,x0(),y0(),v_init()) ! 準備(nはスライドバーの本数,最大12本)
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB slide.init,slide.scales
FOR i=1 TO n
READ x0(i),y0(i),x9,y9,bar,terminal,v_min,v_max,v_interval,v_init(i)
CALL slide.init(i,x0(i),y0(i),x9,y9,bar,terminal,v_min,v_max,v_interval,v_init(i))
READ scl_posi,grad,unit$,texth
CALL slide.scales(i,scl_posi,grad,unit$,texth) ! **目盛描画**
NEXT i
! バー描画データ
!DATA ｽﾗｲﾄﾞﾊﾞｰ全体の左下座標x,y,右上座標x,y,バー長さ,端子長さ,最小値,最大値,バー移動間隔,バー初期値
!DATA 目盛位置(0=下or左,1=上or右),目盛間隔(0=目盛描画せず),単位記号,数字高さ(0=数字描画せず)
DATA 35,2,45,542 , 20,0 , -180,180,0,0
DATA 0,15,"XTH",10
DATA 80,2,90,542 , 20,0 , -180,180,0,0
DATA 0,15,"YTH",10
DATA 125,2,135,542 , 20,0 , -180,180,0,0
DATA 0,15,"ZTH",10
DATA 170,2,180,602 , 20,0 , -500,500,0,0
DATA 0,50,"XMOVE",10
DATA 215,2,225,602 , 20,0 , -500,500,0,0
DATA 0,50,"YMOVE",10
DATA 260,2,270,602 , 20,0 , -500,500,0,0
DATA 0,50,"ZMOVE",10
END SUB
!! スライドバー
MODULE slide
DECLARE EXTERNAL SUB global_graphic.asks,global_graphic.sets
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB init,bar_operation,scales
SHARE NUMERIC barcol,markcol,tcol,amc
CALL bar_col_set
SHARE NUMERIC k,bp(12),mn(12),mx(12),rg(12),siv(12),ivr(12),x0(12),y0(12),px(12),py(12),l(12),w(12),br(12),tr(12)
SHARE NUMERIC sln,cp(12),cp9(12),ap(4,4),a(4,4) ! 12=バーの最大本数(拡張可)
LET sln=0
MAT READ ap ! 縦バー変形行列
DATA 0,1,0,0 , -1,0,0,0 , 0,0,1,0 , 0,0,0,1
!
!! バー色
EXTERNAL SUB bar_col_set
CALL global_graphic.asks
SET COLOR MODE "REGULAR"
READ barcol,markcol,tcol ! バー色,マーク色,トラック色
DATA 196,129,73 ! 薄青,濃灰,薄灰
ASK COLOR MIX(barcol) r,g,b
ASK MAX COLOR amc ! amc=255(色指標最大値)
SET COLOR MIX(amc) MIN(1.5*r,1),MIN(1.5*g,1),MIN(1.5*b,1) ! 枠線明色(255)
SET COLOR MIX(amc-1) 0.5*r,0.5*g,0.5*b ! 枠線暗色(254)
SET COLOR MIX(amc-2) 0.8*r,0.8*g,0.8*b ! 枠線中間色(253)
SET COLOR MIX(amc-3) MIN(1.3*r,1),MIN(1.3*g,1),MIN(1.3*b,1) ! バー待機色(252)
ASK COLOR MIX(markcol) rm,gm,bm
SET COLOR MIX(amc-4) MIN(1.3*rm,1),MIN(1.3*gm,1),MIN(1.3*bm,1) ! マーク待機色(251)
CALL global_graphic.sets
END SUB
!
!! **スライドバー初期登録**
EXTERNAL SUB init(slk,slx0,sly0,slx9,sly9,slbl,sltl,vmin,vmax,vinterval,vinit)
!slk=番号(1～12),(slx0,sly0)=ｽﾗｲﾄﾞﾊﾞｰ全体の左下座標,(slx9,sly9)=ｽﾗｲﾄﾞﾊﾞｰ全体の右上座標
!slbl=ﾊﾞｰ長さ,sltl=端子長さ(非表示は0)
!vmin=最小値,vmax=最大値,vinterval=バー移動間隔(連続移動は0),vinit=バー初期値
DECLARE EXTERNAL SUB bar_pict,terminal_pict
LET k=slk ! バー番号
LET mn(k)=vmin ! 最小値
LET mx(k)=vmax ! 最大値
LET rg(k)=vmax-vmin ! バー値範囲
LET siv(k)=vinterval ! バー移動間隔,vinterval=0で連続移動
LET ivr(k)=vinterval/rg(k) ! バー移動間隔比(0<=ivr<1)
LET x0(k)=slx0 ! ｽﾗｲﾄﾞﾊﾞｰ全体の左下x座標
LET y0(k)=sly0 ! ｽﾗｲﾄﾞﾊﾞｰ全体の左下y座標
LET px(k)=MIN(x0(k),slx9)
LET py(k)=MIN(y0(k),sly9)
IF ABS(slx9-slx0)>ABS(sly9-sly0) THEN LET bp(k)=0 ELSE LET bp(k)=1 ! 0=横バー,1=縦バー
IF bp(k)=0 THEN LET l(k)=slx9-x0(k) ELSE LET l(k)=sly9-y0(k) ! ｽﾗｲﾄﾞﾊﾞｰ全体の長さ
IF bp(k)=0 THEN LET w(k)=sly9-y0(k) ELSE LET w(k)=slx9-x0(k) ! ｽﾗｲﾄﾞﾊﾞｰ全体の幅
LET br(k)=ABS(slbl/l(k)) ! ｽﾗｲﾄﾞﾊﾞｰ全長に対するバー長さ比
LET tr(k)=ABS(sltl/l(k)) ! ｽﾗｲﾄﾞﾊﾞｰ全長に対する端子1個の長さ比,非表示はsltl=0
LET cp(k)=(vinit-mn(k))/rg(k) ! バー位置(0<=cp<=1)
LET cp9(k)=cp(k)
CALL bar_pict(cp(k),amc-3,amc-4)
IF sltl<>0 then
CALL terminal_pict(0,amc-3,amc-4)
CALL terminal_pict(1,amc-3,amc-4)
END IF
LET sln=sln+1 ! バー総本数
END SUB
!
!! **バー操作**
EXTERNAL SUB bar_operation(bar_on,bar_val,l9,ll,x,y) ! 引数bar_onとbar_valは参照渡し
! bar_on=バーON(0=OFF,1～n=ON),bar_val=バー値(mn(k)～mx(k)),l9=直前の左ボタン,ll=左ボタン,(x,y)=ポインタ座標
DECLARE EXTERNAL FUNCTION bar_position
DECLARE EXTERNAL SUB bar_pict,terminal_pict
IF ll=0 THEN
IF l9=1 AND bar_on>0 THEN ! バーOFF処理
CALL bar_pict(cp9(k),amc-3,amc-4) ! バー色を待機色に
IF tr(k)<>0 AND (cp9(k)=0 OR cp9(k)=1) THEN CALL terminal_pict(cp9(k),amc-3,amc-4)
END IF
LET bar_on=0
EXIT SUB
END IF
IF l9=0 THEN
FOR i=1 TO sln
IF x>px(i) AND x<px(i)+ABS(l(i)*(1-bp(i))+w(i)*bp(i)) AND y>py(i) AND y<py(i)+ABS(w(i)*(1-bp(i))+l(i)*bp(i)) THEN
LET bar_on=i
EXIT FOR
END IF
NEXT i
END IF
IF bar_on=0 THEN EXIT SUB
LET cp9(k)=cp(k)
LET k=bar_on
IF bp(k)=0 THEN LET mp=x ELSE LET mp=y ! mp=マウスポインタの座標
LET cp(k)=bar_position(mp) ! 0<=cp<=1
CALL bar_pict(cp(k),barcol,markcol)
IF tr(k)<>0 THEN
IF (cp(k)=0 OR cp(k)=1) AND cp(k)<>cp9(k) THEN
CALL terminal_pict(cp(k),barcol,markcol)
ELSEIF cp(k)>0 AND cp(k)<1 AND (cp9(k)=0 OR cp9(k)=1) THEN
CALL terminal_pict(cp9(k),amc-3,amc-4)
END IF
END IF
IF ivr(k)=0 OR cp(k)=1 THEN
LET bar_val=cp(k)*rg(k)+mn(k)
ELSE
LET bar_val=ROUND(cp(k)*rg(k)/siv(k),0)*siv(k)+mn(k)
END IF
!! PRINT bar_val
END SUB
!
!! バー中心位置
EXTERNAL FUNCTION bar_position(mp) ! mp=マウスポインタの座標
IF bp(k)=0 THEN LET sl0=x0(k) ELSE LET sl0=y0(k)
LET pp=((mp-sl0)/l(k)-tr(k)-br(k)/2)/(1-2*tr(k)-br(k))
IF ivr(k)<>0 AND pp>0 AND pp<1 THEN LET pp=pp-MOD(pp+ivr(k)/2,ivr(k))+ivr(k)/2 !バーの移動間隔をivrに固定
IF pp<=0 OR (mp-sl0)/l(k)<=tr(k) THEN
LET bar_position=0
ELSEIF pp>=1 OR (mp-sl0)/l(k)>=1-tr(k) THEN
LET bar_position=1
ELSE
LET bar_position=pp ! バー移動範囲での位置(0<=pp<=1)
END IF
END FUNCTION
!
!! バー描画
EXTERNAL SUB bar_pict(pp,bcol,mcol) ! pp=バー中心位置(0<=pp<=1)
DECLARE EXTERNAL SUB global_graphic.asks,global_graphic.sets
DECLARE EXTERNAL PICTURE button_sl
CALL global_graphic.asks
SET COLOR MODE "REGULAR"
SET DRAW MODE HIDDEN
IF bp(k)=0 THEN MAT a=IDN ELSE MAT a=ap
DRAW bar WITH SCALE(l(k),w(k)*(-2*bp(k)+1))*a*SHIFT(x0(k),y0(k))
SET DRAW MODE EXPLICIT
CALL global_graphic.sets
PICTURE bar
SET AREA COLOR tcol
SET LINE STYLE 1
PLOT AREA : tr(k),0;1-tr(k),0;1-tr(k),1;tr(k),1
LET b0=pp*(1-2*tr(k)-br(k))+tr(k) ! バーの描画基準位置(バー左下)
DRAW button_sl(bcol) WITH SCALE(br(k),1)*SHIFT(b0,0)
DRAW b_mark WITH SCALE(br(k),1)*SHIFT(b0,0)
IF tr(k)<>0 THEN
SET LINE WIDTH 1
SET LINE COLOR amc-1+bp(k) ! amc=255
PLOT LINES : tr(k),0;tr(k),1 ! 端子境界線(小側)
SET LINE COLOR amc-bp(k)
PLOT LINES : 1-tr(k),0;1-tr(k),1 ! 端子境界線(大側)
SET LINE COLOR amc ! 明色
PLOT LINES : bp(k),1-bp(k);bp(k)+(1-2*bp(k))*tr(k),1-bp(k) ! 補正
END IF
END PICTURE
PICTURE b_mark ! マーク(3本線)
SET LINE COLOR mcol
SET LINE WIDTH 1
PLOT LINES : 0.3,0.3;0.3,0.7
PLOT LINES : 0.5,0.1;0.5,0.9
PLOT LINES : 0.7,0.3;0.7,0.7
END PICTURE
END SUB
!
!! 端子描画
EXTERNAL SUB terminal_pict(pp,bcol,mcol) ! pp=0,1
DECLARE EXTERNAL SUB global_graphic.asks,global_graphic.sets
DECLARE EXTERNAL PICTURE button_sl
CALL global_graphic.asks
SET COLOR MODE "REGULAR"
IF bp(k)=0 THEN MAT a=IDN ELSE MAT a=ap
IF pp=0 THEN
DRAW terminal0 WITH SCALE(l(k),w(k)*(-2*bp(k)+1))*a*SHIFT(x0(k),y0(k))
ELSE
DRAW terminal1 WITH SCALE(l(k),w(k)*(-2*bp(k)+1))*a*SHIFT(x0(k),y0(k))
END IF
CALL global_graphic.sets
PICTURE terminal0
DRAW button_sl(bcol) WITH SCALE(tr(k),1)
SET AREA COLOR mcol
DRAW t_mark WITH SCALE(tr(k),1)
END PICTURE
PICTURE terminal1
DRAW button_sl(bcol) WITH SCALE(tr(k),1)*SHIFT(1-tr(k),0)
SET AREA COLOR mcol
DRAW t_mark WITH SCALE(-tr(k),1)*SHIFT(1,0)
END PICTURE
PICTURE t_mark ! マーク(三角)
SET LINE COLOR mcol
SET LINE STYLE 1
SET LINE WIDTH 1
PLOT AREA : 0.25,0.5;0.75,0.25;0.75,0.75
PLOT LINES : 0.25,0.8;0.25,0.2
END PICTURE
END SUB
!
!! ボタン描画
EXTERNAL PICTURE button_sl(buttoncol)
SET LINE STYLE 1
SET AREA COLOR buttoncol
PLOT AREA : 0,0;1,0;1,1;0,1
SET LINE COLOR amc-2 ! 中間色(amc=255)
SET LINE WIDTH 2
PLOT LINES : bp(k),bp(k);1-bp(k),bp(k);1-bp(k),1-bp(k)
SET LINE WIDTH 1
SET LINE COLOR amc-1 ! 右下線(暗色)
PLOT LINES : bp(k),bp(k);1-bp(k),bp(k);1-bp(k),1-bp(k)
SET LINE COLOR amc ! 左上線(明色)
PLOT LINES : 1-bp(k),1-bp(k);bp(k),1-bp(k);bp(k),bp(k)
END PICTURE
!
!! **目盛描画**
EXTERNAL SUB scales(k,d,grad,u$,texth)
!k=番号,d=目盛位置(0=下or左,1=上or右),grad=目盛間隔(0で目盛表示せず),u$=単位,texth=文字高さ(0で表示せず)
DECLARE EXTERNAL SUB global_graphic.asks,global_graphic.sets
IF grad=0 THEN EXIT SUB ! キャンセル
CALL global_graphic.asks
IF bp(k)=0 THEN MAT a=IDN ELSE MAT a=ap
DRAW scl WITH SCALE(l(k),w(k)*(1-2*bp(k)))*a*SHIFT(x0(k)+w(k)*bp(k)*(2*d-1),y0(k)+w(k)*(1-bp(k))*(2*d-1))
CALL global_graphic.sets
PICTURE scl
SET LINE STYLE 1
SET LINE WIDTH 1
IF texth>0 THEN
SET TEXT HEIGHT texth ! 文字高さ(問題座標の値で指定)
IF bp(k)=0 AND d=0 THEN SET TEXT JUSTIFY "CENTER","TOP"
IF bp(k)=0 AND d=1 THEN SET TEXT JUSTIFY "CENTER","BOTTOM"
IF bp(k)=1 AND d=0 THEN SET TEXT JUSTIFY "RIGHT","HALF"
IF bp(k)=1 AND d=1 THEN SET TEXT JUSTIFY "LEFT","HALF"
END IF
IF d=0 THEN LET s=1 ELSE LET s=-1
LET m=(mx(k)-mn(k))/grad ! 目盛本数(整数でなくとも可)
FOR j=0 TO m
LET pp=j*(1-2*tr(k)-br(k))/m+tr(k)+br(k)/2
PLOT LINES : pp,0.5+0.25*s;pp,0.5+0.45*s
IF texth>0 THEN PLOT LABEL ,AT pp,0.5+0.2*s : LEFT$(STR$(j*grad+mn(k)),4)
NEXT j
IF m-INT(m)>1/(10*m) THEN
PLOT LINES : 1-tr(k)-br(k)/2,0.5+0.25*s;1-tr(k)-br(k)/2,0.5+0.45*s
IF texth>0 THEN PLOT LABEL ,AT 1-tr(k)-br(k)/2,0.5+0.2*s : LEFT$(STR$(mx(k)),4)
END IF
IF tr(k)<>0 THEN
IF bp(k)=0 AND d=0 THEN SET TEXT JUSTIFY "LEFT","TOP"
IF bp(k)=0 AND d=1 THEN SET TEXT JUSTIFY "LEFT","BOTTOM"
IF bp(k)=1 AND d=0 THEN SET TEXT JUSTIFY "RIGHT","BOTTOM"
IF bp(k)=1 AND d=1 THEN SET TEXT JUSTIFY "LEFT","BOTTOM"
END IF
IF texth>0 THEN PLOT LABEL ,AT 1-tr(k)+.012,0.5+0.2*s+1.5 : u$ !!!
END PICTURE
END SUB
!
END MODULE
!! グラフィックス設定の一時記憶
MODULE global_graphic
MODULE OPTION ARITHMETIC NATIVE
MODULE OPTION ANGLE DEGREES
PUBLIC SUB asks,sets
SHARE NUMERIC apc,aps,alc,als,alw,aac,aasi,atc,ath,ata
SHARE STRING acmd$,aas$,atjx$,atjy$
EXTERNAL SUB asks
ASK COLOR MODE acmd$
ASK POINT COLOR apc
ASK POINT STYLE aps
ASK LINE COLOR alc
ASK LINE STYLE als
ASK LINE WIDTH alw
ASK AREA COLOR aac
ASK AREA STYLE aas$
ASK AREA STYLE INDEX aasi
ASK TEXT COLOR atc
ASK TEXT JUSTIFY atjx$,atjy$
ASK TEXT HEIGHT ath
ASK TEXT ANGLE ata
END SUB
EXTERNAL SUB sets
SET COLOR MODE acmd$
SET POINT COLOR apc
SET POINT STYLE aps
SET LINE COLOR alc
SET LINE STYLE als
SET LINE WIDTH alw
SET AREA COLOR aac
SET AREA STYLE aas$
SET AREA STYLE INDEX aasi
SET TEXT COLOR atc
SET TEXT JUSTIFY atjx$,atjy$
SET TEXT HEIGHT ath
SET TEXT ANGLE ata
END SUB
END MODULE
------------------------------------------------
!6n±1篩 3億までの素数をカウント
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k=17321 !SQR(3E8)
LET k2=1991
DIM P(k)
DIM A(k2) !素数
SUB prime(k) !エラトステネスの篩
MAT P=ZER
MAT A=ZER
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
END IF
NEXT I
END SUB
CALL prime(k)
LET k6=3E8 !篩の計算範囲
LET B6=IP(k6/30)+1
LET k5=IP(k6/6)+1
DIM A6(k5),A7(k5)
MAT A6 = ZER !(6*n-1)
MAT A7 = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN
LET r6=(P6+1)/6
CALL nap(P6,r6)
CALL napi(P6,r6*(-1))
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
CALL nap(P6,r6*(-1))
CALL napi(P6,r6)
END IF
NEXT n
SUB nap(z,r6)
FOR i=1 TO B6
IF z*i+r6>k5 THEN EXIT SUB
LET A6(z*i+r6)=1
NEXT i
END SUB
SUB napi(z,r6)
FOR i=1 TO B6
IF z*i+r6>k5 THEN EXIT SUB
LET A7(z*i+r6)=1
NEXT i
END SUB
LET C1=2
FOR n=1 TO k5
IF A6(n)=1 THEN GOTO 100
LET c1=c1+1
IF c1>=16252325 THEN PRINT n*6-1
100 IF A7(n)=1 THEN GOTO 200
LET c1=c1+1
IF c1>=16252325 THEN PRINT n*6+1
200 NEXT n
PRINT c1
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
!6n±1篩 6億までの素数をカウント
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k=24499 !SQR(3E8)
LET k2=2718
DIM P(k)
DIM A(k2) !素数
SUB prime(k) !エラトステネスの篩
MAT P=ZER
MAT A=ZER
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
END IF
NEXT I
END SUB
CALL prime(k)
LET k6=6E8 !篩の計算範囲
LET B6=IP(k6/30)+1
LET k5=IP(k6/6)+1
DIM A6(k5),A7(k5)
MAT A6 = ZER !(6*n-1)
MAT A7 = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=A(n)
IF MOD(P6+1,6)=0 THEN
LET r6=(P6+1)/6
CALL nap(P6,r6)
CALL napi(P6,r6*(-1))
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
CALL nap(P6,r6*(-1))
CALL napi(P6,r6)
END IF
NEXT n
SUB nap(z,r6)
FOR i=1 TO B6
IF z*i+r6>k5 THEN EXIT SUB
LET A6(z*i+r6)=1
NEXT i
END SUB
SUB napi(z,r6)
FOR i=1 TO B6
IF z*i+r6>k5 THEN EXIT SUB
LET A7(z*i+r6)=1
NEXT i
END SUB
LET C1=2
FOR n=1 TO k5
IF A6(n)=1 THEN GOTO 100
LET c1=c1+1
IF c1>=31324703 THEN PRINT n*6-1
100 IF A7(n)=1 THEN GOTO 200
LET c1=c1+1
IF c1>=31324703 THEN PRINT n*6+1
200 NEXT n
PRINT c1
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
!
! ========= molecular dynamics 2D ==========
!
! 004registerLJMD2D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.02.12 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB md2d.setInitialCondition, md2d.moveParticles, md2d.drawParticles
DECLARE EXTERNAL FUNCTION md2d.systemTime, md2d.systemTemprature,INKEY$
LET tempMode = 0 !tempMode: 0:adiabatic 1:constant temperature
LET contTemp = 150 !contTemp: controled constant temperature(K)
LET drawMode = 1 !drawMode: 0:ball 1:ball+v+f 2:velocitySpace
DIM menu$(8)
LET menu$(1) = "Ar 36 6x6"
LET menu$(2) = "Ar100 8x8"
LET menu$(3) = "Ar300 12x12"
LET menu$(4) = "Kr100 8x8"
let menu$(5) = "Xe100 8x8"
LET menu$(6) = "Hg100 8x8"
let menu$(7) = "Ar500 15x15"
LET menu$(8) = "continue"
!
!setInitialCondition(molecKind,nMolecule,xMaximum,yMaximum,contTemp)
CALL setInitialCondition(2,100,8,8,contTemp) !molecKind: 1:Ne 2:Ar 3:Kr 4:Xe 5:Hg
!
DO
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode,menu)
LET S$=INKEY$
IF S$="." THEN
EXIT DO
ELSEIF S$="0" THEN
!LOCATE VALUE (1),RANGE 10 TO 300 , AT 150 : temp
LOCATE VALUE (1),RANGE 0 TO 300 : temp
IF temp>1 THEN
LET tempMode = 1
LET contTemp = temp
ELSE
LET tempMode = 0
END IF
ELSEIF S$="1" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$="9" THEN
LOCATE CHOICE (menu$) :nmenu
IF nmenu=1 THEN !--- Ar N=36 box=6x6nm
CALL setInitialCondition(2,36,6,6,contTemp)
ELSEIF nmenu=2 THEN !--- Ar N=100 box=8x8nm
CALL setInitialCondition(2,100,8,8,contTemp)
ELSEIF nmenu=3 THEN !--- Ar N=300 box=12x12nm
CALL setInitialCondition(2,300,12,12,contTemp)
ELSEIF nmenu=4 THEN !--- Kr N=100 box=8x8nm
CALL setInitialCondition(3,100,8,8,contTemp)
ELSEIF nmenu=5 THEN !--- Xe N=100 box=8x8nm
CALL setInitialCondition(4,100,8,8,contTemp)
ELSEIF nmenu=6 THEN !--- Hg N=100 box=8x8nm
CALL setInitialCondition(5,100,8,8,contTemp)
ELSEIF nmenu=7 THEN !--- Ar N=500 box=15x15nm
CALL setInitialCondition(2,500,15,15,contTemp)
ELSEIF nmenu=8 THEN !contine
!
END IF
END IF
LOOP
!
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
!
! ---------- md2d module ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
! = 24*epsilon*r6*(2*r6-1)/r, r6 = (sigma/r)^6
MODULE md2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molecKind,nMolecule,xMaximum,yMaximum,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
PUBLIC FUNCTION systemTime, systemTemprature
SHARE NUMERIC sysTime, dt, nMolec, xMax, yMax, sigma, mass, epsilon, boxSize
SHARE NUMERIC xx(500),yy(500) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC reg(500,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 12,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 36 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET mass = 39.95*1.67e-27 ! mass of Ar (kg)
LET sigma = 3.40e-10 ! Lennard-Jones potential sigma for Ar (m)
LET epsilon = 1.67e-21 ! Lennard-Jones potential epsilon FOR Ar (J)
LET boxSize = 300 ! world box size in the graphic window
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
!
! ---------- set initial condition
!
EXTERNAL SUB setInitialCondition(molecKind,nMolecule,xMaximum,yMaximum,contTemp)
DECLARE EXTERNAL SUB setMoreculesData,setMorecule,ajustVelocity
RANDOMIZE
! set particles
CALL setMoreculesData
CALL setMorecule(molecKind) !molecKind 1:Ne 2:Ar 5:Hg
LET sysTime = 0.0
LET nMolec = nMolecule
LET xMax = xMaximum*1e-9
LET yMax = yMaximum*1e-9
FOR j=1 TO nMolec
DO
LET xx(j) = (xMax-2*sigma)*RND + sigma
LET yy(j) = (yMax-2*sigma)*RND + sigma
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2 < 2*sigma^2 THEN EXIT FOR
NEXT i
LOOP UNTIL i>=j
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
CALL ajustVelocity(contTemp)
! set window
LET xMargin = 100
LET yMargin = 100
SET WINDOW -xMargin,500-xMargin,-yMargin,500-yMargin
END SUB
!
EXTERNAL SUB setMoreculesData
! 0:mass(in AU) 1:eps(in kB) 2:sigma(m) 3:dt(s)
DATA 4.003 , 10.2 , 2.576e-10 , 5.0e-15 ! 0 He
DATA 20.183 , 36.2 , 2.976e-10 , 10.0e-15 ! 1 Ne
DATA 39.948 , 124.0 , 3.418e-10 , 20.0e-15 ! 2 Ar
DATA 83.50 , 190.0 , 3.610e-10 , 20.0e-15 ! 3 Kr
DATA 131.30 , 229.0 , 4.055e-10 , 20.0e-15 ! 4 Xe
DATA 200.59 , 851.0 , 2.898e-10 , 20.0e-15 ! 5 Hg
DATA 2.016 , 33.3 , 2.968e-10 , 5.0e-15 ! 6 H2
DATA 28.013 , 91.5 , 3.681e-10 , 10.0e-15 ! 7 N2
DATA 31.999 , 113.0 , 3.433e-10 , 10.0e-15 ! 8 O2
DATA 18.015 , 809.1 , 2.641e-10 , 10.0e-15 ! 9 H2O
DATA 16.043 , 137.0 , 3.822e-10 , 10.0e-15 ! 10 CH4
DATA 44.010 , 190.0 , 3.996e-10 , 20.0e-15 ! 11 CO2
DATA 28.011 , 110.0 , 3.590e-10 , 10.0e-15 ! 12 CO
!
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 12
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.38e-23 !eps(kB) --> (J)
NEXT i
END IF
END SUB
!
EXTERNAL SUB setMorecule(iMolec)
LET mass = molecData(iMolec,0)
LET epsilon = molecData(iMolec,1)
LET sigma = molecData(iMolec,2)
LET dt = molecData(iMolec,3)
END SUB
!
! ---------- move particles
!
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB registerNearMolec,moveParticlesDT,ajustVelocity
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
!
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
!
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*sigma
LET rCut2 = (3*sigma)^2 ! force cutoff rij>3*sigma
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET r2ij = xij*xij+yij*yij
IF (r2ij<rCut2) THEN
LET rij = SQR(r2ij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)-boundaryForce(xMax+s-xx(i))
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)-boundaryForce(yMax+s-yy(i))
NEXT i
END SUB
!
EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
LET ri = sigma/r
LET r6 = ri^6
LET force = (24.0*epsilon*r6*(2.0*r6-1.0)/r)
END FUNCTION
!
EXTERNAL FUNCTION boundaryForce(r)
LET adsorp = 0.5*1.67e-21 ! epsilon(Ar)=1.67e-21
LET ri = sigma/r
LET r6 = ri^6
LET boundaryForce = (24.0*adsorp*r6*(2.0*r6-1.0)/r)
END FUNCTION
!
EXTERNAL SUB registerNearMolec
LET rCut = 3*sigma+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
!
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
!
! ---------- utility
!
EXTERNAL FUNCTION systemTime
LET systemTime = sysTime
END FUNCTION
!
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
!
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
!
! draw particles
!
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode,menu)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL PICTURE realSpace,velocitySpace
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:disk 1:circle+V+F
DRAW realSpace(drawMode)
ELSEIF drawMode=2 THEN
DRAW velocitySpace
END IF
!--- control key guide
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT -90,380 :"'.':exit '0':Temp control (Temp<1 adiabatic mode)"
PLOT TEXT, AT -90,360 :"'1':changeGraph '9':select theme "
PLOT TEXT, AT -90,345 :"------------------------------------------------------"
!--- draw caption
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT -50,-30 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT -50,-45 ,USING "N =#### max reg =###":nMolec,maxNearMolec
PLOT TEXT, AT -50,-60 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 100,-60 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT -50,-75 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT -50,-90 :"2-dimensional molecular dynamics"
SET DRAW MODE EXPLICIT
END SUB
!
EXTERNAL PICTURE realSpace(drawMode)
LET deltat = 2e-14 !(s)
LET mag = boxSize/xMax
LET vScate = 100*deltat !velocity line length = v*100*deltat
LET fScale = 1000*deltat*deltat/mass
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: 0,0; boxSize,0; boxSize,boxSize; 0,boxSize; 0,0
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,boxSize+2 ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
IF drawMode=1 THEN !--- draw circle, velocity and force
SET LINE COLOR 2 ! blue : molecule
DRAW circle WITH SCALE(sigma/2.0*mag)*SHIFT(xx(i)*mag,yy(i)*mag)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xx(i)*mag,yy(i)*mag;
PLOT LINES: (xx(i)+vx(i)*vScate)*mag,(yy(i)+vy(i)*vScate)*mag
SET LINE COLOR 1 ! black : force
PLOT LINES: xx(i)*mag,yy(i)*mag;
PLOT LINES: (xx(i)+ffx(i)*fScale)*mag,(yy(i)+ffy(i)*fScale)*mag
ELSE !--- draw disk
SET AREA COLOR 2 ! blue : molecule
DRAW disk WITH SCALE(sigma/2.0*mag)*SHIFT(xx(i)*mag,yy(i)*mag)
END IF
NEXT i
IF drawMode=1 THEN
LET xp = boxSize*0.6
LET yp = boxSize+25
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp,yp;xp+23,yp
SET TEXT COLOR 4 ! red
PLOT TEXT, AT xp+30,yp-4: "velosity"
SET LINE COLOR 1 ! black : force
PLOT LINES: xp,yp-15;xp+23,yp-15
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp+30,yp-19: "force"
END IF
END PICTURE
!
EXTERNAL PICTURE velocitySpace
LET xp = boxSize/2
LET yp = boxSize/2
SET LINE COLOR 1 !black : axis
PLOT LINES: 0,yp; boxSize,yp !vx-axis
PLOT LINES: xp,0; xp,boxSize !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize,yp: "vx"
PLOT TEXT, AT boxSize,yp-12: "1000m/s"
PLOT TEXT, AT xp-12,boxSize: "vy 1000m/s"
PLOT TEXT, AT xp-8,yp-10: "0"
PLOT TEXT, AT 0,boxSize+8: "velocity space (vx,vy)"
LET mag = boxSize/2000
FOR i=1 TO nMolec
SET LINE COLOR 2 ! blue
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+xp,vy(i)*mag+yp)
NEXT i
END PICTURE
!
END MODULE
!
! ========= steepest descent method 3D ==========
!
! eigenFunctionSD2D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.0 2017.01.31 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB sd3d.setInitialCondition,sd3d.SDiteration,sd3d.drawState
DECLARE EXTERNAL FUNCTION sd3d.iterationCount,sd3d.stateEnergy,INKEY$
LET Ax = -PI/24
LET Ay = -PI/12
LET drawMode = 0
!setInitialCondition(stateMax,kx0,ky0)
CALL setInitialCondition(10,2.0,2.0)
!
LET ist = 0
FOR it=1 TO 1000
LET Ay=Ay +PI/180
LET dump = 0.05
CALL SDiteration(6, 2, dump) !(stateMax, iterMax, dump)
CALL drawState(ist,Ax,Ay,drawMode) !(state,xRotateAngle,yRotateAngle,drawMode)
LET S$=INKEY$
IF S$="0" THEN LET ist = MOD(ist+1,6)
IF S$="1" THEN LET drawMode = MOD(drawMode+1,3)
IF S$="." THEN EXIT FOR
NEXT it
!
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
!
! ---------- steepest descent method 3D ----------
!
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy Ei, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dumpingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
!
MODULE sd3d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
PUBLIC FUNCTION iterationCount, stateEnergy
SHARE NUMERIC NNx, NNy, NNz, dx, dy, dz, iterCount
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(10) ! electron state energy
SHARE NUMERIC sdState(10,65,65,65) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(65,65,65) ! state work space in steepestDescent
SHARE NUMERIC vv(65,65,65) ! external potential
SHARE NUMERIC boxApex(0 TO 7,0 TO 2) ! boxApex(i,j) i-th box apex j-th coordinate x,y,z
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2)! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
LET NNx = 32 ! x-max number of sdState(,NNx,NNy,NNz)
LET NNy = 32 ! y-max number of sdState(,NNx,NNy,NNz)
LET NNz = 32 ! z-max number of sdState(,NNx,NNy,NNz)
LET dx = 0.5 ! (au) x division
LET dy = 0.5 ! (au) y division
LET dz = 0.5 ! (au) y division
LET iterCount = 0 ! sd iteration count
!
! ---------- set initial condition
!
EXTERNAL SUB setInitialCondition(stateMax,kx0,ky0) !public
DECLARE EXTERNAL SUB setInitialState,setPotential,setBox
RANDOMIZE
CALL setInitialState(stateMax)
CALL setPotential(8,8,8)
CALL setBox
! set window
LET xMargin = 60
LET yMargin = 120
SET WINDOW -xMargin,500-xMargin,-yMargin,500-yMargin
END SUB
!
EXTERNAL SUB setInitialState(stateMax)
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = RND-0.5
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
!
EXTERNAL SUB setPotential(x0,y0,z0)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET x = i*dx
LET y = j*dy
LET z = k*dz
LET r = SQR((x-x0)*(x-x0)+(y-y0)*(y-y0)+(z-z0)*(z-z0))
IF r<0.25 THEN LET r = 0.25
LET vv(i,j,k) = -1/r
NEXT k
NEXT j
NEXT i
END SUB
EXTERNAL SUB setPotential2(x0,y0,z0)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET x = i*dx
LET y = j*dy
LET z = k*dz
LET vv(i,j,k) = 2.0*((x-x0)*(x-x0)+(y-y0)*(y-y0)+(z-z0)*(z-z0))
NEXT k
NEXT j
NEXT i
END SUB
EXTERNAL SUB setBox
IF boxApex(7,2)<>1 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
MAT READ boxApex !(0 TO 7,0 TO 2)
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
!
! ---------- steepest descent iteration
!
EXTERNAL SUB SDiteration(stateMax, iterMax, dump) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, dump)
NEXT ist
CALL GramSchmidt(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
!
EXTERNAL FUNCTION steepestDescent(ist,dump) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
&-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
LET wrk(i,j,k) = kesdState+(vv(i,j,k)-ei)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - dump*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = sdState(ist,i,j,k)-dump*wrk(i,j,k)
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
!
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
&-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
LET s = s + sdState(ist,i,j,k)*(kesdState+vv(i,j,k)*sdState(ist,i,j,k))
LET sn = sn+sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
!
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(istate,i,j,k) = sdState(istate,i,j,k) - s*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
!
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET s = s + sdState(ist,i,j,k)*sdState(jst,i,j,k)
NEXT k
NEXT j
NEXT i
LET innerProduct = s*dx*dy*dz
END FUNCTION
!
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET s = s + sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
LET a = SQR(1/(s*dx*dy*dz))
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = a*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
END SUB
!
! ---------- utility
!
EXTERNAL FUNCTION iterationCount
LET iterationCount = iterCount
END FUNCTION
!
EXTERNAL FUNCTION stateEnergy(ist)
LET stateEnergy = sdEnergy(ist)
END FUNCTION
!
! ---------- 3D graphics
!
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0+xShift, y1+cy0+yShift; !z=z1+cz0
END SUB
EXTERNAL SUB drawDisk3D(x,y,z,r,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
DRAW disk WITH SCALE(r)*SHIFT(x1+cx0+xShift,y1+cy0+yShift)
END SUB
EXTERNAL SUB plotText3DAt(x,y,z,xShift,yShift,A$)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT TEXT,AT x1+cx0+xShift,y1+cy0+yShift:A$
END SUB
EXTERNAL FUNCTION getRotateZ(x,y,z,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET getRotateZ = z1+cz0
END FUNCTION
!
! ---------- drawState
!
EXTERNAL SUB drawState(ist,xRotateAngle,yRotateAngle,drawMode)
!DECLARE EXTERNAL SUB setRotateXYParameters,drawDensity3D,drawStateGrid,drawStateGridx6
SET DRAW MODE HIDDEN
CLEAR
LET sc = 6
IF drawMode=0 THEN
CALL drawDensity3D(ist,sc, xRotateAngle,yRotateAngle)
ELSEIF drawMode=1 THEN
CALL setRotateXYParameters(-PI/3,-PI/6,(NNx/2)*sc,(NNy/2)*sc,(NNy/2)*sc)
CALL drawStateGrid(ist,320/NNx,1.0,0,50) !(ist,sc,zMag,xShift,yShift)
ELSEIF drawMode=2 THEN
CALL setRotateXYParameters(-PI/3,-PI/6,(NNx/2)*sc,(NNy/2)*sc,(NNz/2)*sc)
CALL drawStateGridx6
ELSE
!
END IF
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,-50 ,USING "iterarion count =##### ":iterCount
PLOT TEXT, AT 0,-65 ,USING "E0 =###.######### E3 =###.#########(au)":sdEnergy(0),sdEnergy(3)
PLOT TEXT, AT 0,-80 ,USING "E1 =###.######### E4 =###.#########(au)":sdEnergy(1),sdEnergy(4)
PLOT TEXT, AT 0,-95 ,USING "E2 =###.######### E5 =###.#########(au)":sdEnergy(2),sdEnergy(5)
PLOT TEXT, AT 0,-110 :"steepest descent method 2D"
SET DRAW MODE EXPLICIT
END SUB
!
EXTERNAL SUB drawDensity3D(ist,sc,xRotateAngle,yRotateAngle) !----- drawMode=0
DECLARE EXTERNAL SUB setRotateXYParameters, drawDisk3D, plotEdge3D
DECLARE EXTERNAL FUNCTION getRotateZ,getZminApex
CALL setRotateXYParameters(xRotateAngle,yRotateAngle,NNx*sc/2,NNy*sc/2,NNx*sc/2)
LET xOffset = 80
LET yOffset = 50
SET LINE COLOR 1
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET psi = sdState(ist,i,j,k)
LET psi2 = psi*psi
IF psi2>0.001 THEN
IF psi>0 THEN SET AREA COLOR 4 ELSE SET AREA COLOR 2
CALL drawDisk3D(i*sc,j*sc,k*sc,ABS(psi)*10,xOffset,yOffset)
END IF
NEXT k
NEXT j
NEXT i
CALL plotEdge3D(0,sc,xOffset,yOffset,1) !x-axis:black !(iEdge,xShift,yShift,lineColorIndex)
CALL plotEdge3D(1,sc,xOffset,yOffset,2) !y-axis:blue
CALL plotEdge3D(2,sc,xOffset,yOffset,3) !z-axis:green
FOR iEdge=3 TO 11
CALL plotEdge3D(iEdge,sc,xOffset,yOffset,8) !other edge:grey
NEXT iEdge
CALL plotText3DAt(0,0,NNz*sc,xOffset,yOffset,"Z"&STR$(getRotateZ(0,0,NNz*sc,xOffset,yOffset)))
CALL plotText3DAt(0,0,0,xOffset,yOffset,"Z"&STR$(getRotateZ(0,0,0,xOffset,yOffset)))
LET apx = getZminApex(sc,xOffset,yOffset)
CALL drawDisk3D(boxApex(apx,0)*NNx*sc,boxApex(apx,1)*NNy*sc,boxApex(apx,2)*NNz*sc,10,xOffset,yOffset)
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 0,-20:"|"&STR$(ist)&">"
PLOT TEXT, AT 0,-35 ,USING "Ax =###.#(deg) Ay =###.#(deg)":MOD(xRotateAngle*180/PI,360),MOD(yRotateAngle*180/PI,360)
END SUB
!
EXTERNAL SUB plotEdge3D(iEdge,sc,xShift,yShift,lineColorIndex)
DECLARE EXTERNAL SUB plotLines3D
SET LINE COLOR lineColorIndex
FOR j=0 TO 1
LET apex = boxEdge(iEdge,j)
LET x = boxApex(apex,0)*NNx*sc
LET y = boxApex(apex,1)*NNy*sc
LET z = boxApex(apex,2)*NNz*sc
CALL plotLines3D(x,y,z,xShift,yShift)
NEXT j
PLOT LINES
END SUB
EXTERNAL FUNCTION getZminApex(sc,xShift,yShift)
DECLARE EXTERNAL FUNCTION getRotateZ !(x,y,z,xShift,yShift)
LET zmin = 1E99
FOR iApex = 0 TO 7
LET x = boxApex(iApex,0)*NNx*sc
LET y = boxApex(iApex,1)*NNy*sc
LET z = boxApex(iApex,2)*NNz*sc
LET rotz = getRotateZ(x,y,z,xShift,yShift)
PRINT USING "### rotZ=####.## x=###.## y=###.## z=###.##":iApex,rotz,x,y,z
IF rotz<zmin THEN
LET zmin = rotz
LET zminApex = iApex
END IF
NEXT iApex
LET getZminApex = zminApex
END FUNCTION
!
EXTERNAL SUB drawStateGrid(ist,sc,zMag,xShift,yShift) !--- drawMode=1
DECLARE EXTERNAL SUB drawGridXY
CALL drawGridXY(ist,sc,zMag,xShift,yShift)
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 0,-20:"|"&STR$(ist)&">"
END SUB
!
EXTERNAL SUB drawStateGridx6
DECLARE EXTERNAL SUB drawGridXY
CALL drawGridXY(0,4,0.5,-30,40) !(ist,sc,zMag,xShift,yShift) !--- drawMode=2
CALL drawGridXY(1,4,0.5,120,40)
CALL drawGridXY(2,4,0.5,270,40)
CALL drawGridXY(3,4,0.5,-30,190)
CALL drawGridXY(4,4,0.5,120,190)
CALL drawGridXY(5,4,0.5,270,190)
SET TEXT HEIGHT 10
PLOT TEXT, AT -30,-12:"|0>"
PLOT TEXT, AT 120,-12:"|1>"
PLOT TEXT, AT 270,-12:"|2>"
PLOT TEXT, AT -30,138:"|3>"
PLOT TEXT, AT 120,138:"|4>"
PLOT TEXT, AT 270,138:"|5>"
END SUB
!
EXTERNAL SUB drawGridXY(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j,NNz/2)),xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j,NNz/2)),xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
!
END MODULE
とりあえず手元にあった
OS 10.5.8
2Ghz Core 2 duo
1GB 667Mhz DDR2
のMAC BOOKだと
Iteration Count=2000
まで実行して普通に終了しました。
ただし、使用した十進BASICのバージョンは6.6.0です。
（計算に関係する部分は0.6.6.0から変わっていません）
> 下記のプログラムの実行中に内部エラーが発生しました。
> EXTERNAL FUNCTION getZminApex(sc,xShift,yShift)
> のデバグのためprintで変数の変化を見ながら実行中にエラーが発生しました。
> 立方体が１回転する前に発生しました。
> 実行環境は 十進BASIC 0.6.6.0 / macOS 10.7.5 / 2.7Ghz Intel Core i7
> メモリ 4GB 1333Mhz DDR3 です。
> ご検討ください。
>
> !
> ! ========= steepest descent method 3D ==========
> !
> ! eigenFunctionSD2D.bas
> ! Mitsuru Ikeuchi (C) Copyleft
> !
> ! ver 0.0.0 2017.01.31 created
> !
> OPTION ARITHMETIC NATIVE
> DECLARE EXTERNAL SUB sd3d.setInitialCondition,sd3d.SDiteration,sd3d.drawState
> DECLARE EXTERNAL FUNCTION sd3d.iterationCount,sd3d.stateEnergy,INKEY$
> LET Ax = -PI/24
> LET Ay = -PI/12
> LET drawMode = 0
> !setInitialCondition(stateMax,kx0,ky0)
> CALL setInitialCondition(10,2.0,2.0)
> !
> LET ist = 0
> FOR it=1 TO 1000
> LET Ay=Ay +PI/180
> LET dump = 0.05
> CALL SDiteration(6, 2, dump) !(stateMax, iterMax, dump)
> CALL drawState(ist,Ax,Ay,drawMode) !(state,xRotateAngle,yRotateAngle,drawMode)
> LET S$=INKEY$
> IF S$="0" THEN LET ist = MOD(ist+1,6)
> IF S$="1" THEN LET drawMode = MOD(drawMode+1,3)
> IF S$="." THEN EXIT FOR
> NEXT it
> !
> END
>
>
> EXTERNAL FUNCTION INKEY$
> OPTION ARITHMETIC NATIVE
> SET ECHO "OFF"
> LET S$=""
> CHARACTER INPUT NOWAIT: S$
> LET INKEY$=S$
> END FUNCTION
> !
> ! ---------- steepest descent method 3D ----------
> !
> ! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
> ! eigen energy Ei, eigen function set { |i> }
> !
> ! procedure : successive approximation
> ! (i) trial function set { |0>,|1>,..,|i>,.. }
> ! (2) energy of |i> : ei = <i|H|i>/<i|i>
> ! (3) steepest gradient direction (H-ei)|i>
> ! (4) next generation : |i(next)> = |i> - dumpingFactor*(H-ei)|i>
> ! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
> ! (6) goto (2)
> !
> MODULE sd3d
> MODULE OPTION ARITHMETIC NATIVE
> OPTION BASE 0
> PUBLIC SUB setInitialCondition, SDiteration, drawState
> PUBLIC FUNCTION iterationCount, stateEnergy
> SHARE NUMERIC NNx, NNy, NNz, dx, dy, dz, iterCount
> SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
> SHARE NUMERIC sdEnergy(10) ! electron state energy
> SHARE NUMERIC sdState(10,65,65,65) ! electron states 0...20 0:ground state
> SHARE NUMERIC wrk(65,65,65) ! state work space in steepestDescent
> SHARE NUMERIC vv(65,65,65) ! external potential
> SHARE NUMERIC boxApex(0 TO 7,0 TO 2) ! boxApex(i,j) i-th box apex j-th coordinate x,y,z
> SHARE NUMERIC boxEdge(0 TO 11,0 TO 2)! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
> LET NNx = 32 ! x-max number of sdState(,NNx,NNy,NNz)
> LET NNy = 32 ! y-max number of sdState(,NNx,NNy,NNz)
> LET NNz = 32 ! z-max number of sdState(,NNx,NNy,NNz)
> LET dx = 0.5 ! (au) x division
> LET dy = 0.5 ! (au) y division
> LET dz = 0.5 ! (au) y division
> LET iterCount = 0 ! sd iteration count
> !
> ! ---------- set initial condition
> !
> EXTERNAL SUB setInitialCondition(stateMax,kx0,ky0) !public
> DECLARE EXTERNAL SUB setInitialState,setPotential,setBox
> RANDOMIZE
> CALL setInitialState(stateMax)
> CALL setPotential(8,8,8)
> CALL setBox
> ! set window
> LET xMargin = 60
> LET yMargin = 120
> SET WINDOW -xMargin,500-xMargin,-yMargin,500-yMargin
> END SUB
> !
> EXTERNAL SUB setInitialState(stateMax)
> RANDOMIZE
> FOR ist=0 TO stateMax-1
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET sdState(ist,i,j,k) = RND-0.5
> NEXT k
> NEXT j
> NEXT i
> CALL normalizeState(ist)
> NEXT ist
> END SUB
> !
> EXTERNAL SUB setPotential(x0,y0,z0)
> FOR i=0 TO NNx-1
> FOR j=0 TO NNy-1
> FOR k=0 TO NNz-1
> LET x = i*dx
> LET y = j*dy
> LET z = k*dz
> LET r = SQR((x-x0)*(x-x0)+(y-y0)*(y-y0)+(z-z0)*(z-z0))
> IF r<0.25 THEN LET r = 0.25
> LET vv(i,j,k) = -1/r
> NEXT k
> NEXT j
> NEXT i
> END SUB
>
> EXTERNAL SUB setPotential2(x0,y0,z0)
> FOR i=0 TO NNx-1
> FOR j=0 TO NNy-1
> FOR k=0 TO NNz-1
> LET x = i*dx
> LET y = j*dy
> LET z = k*dz
> LET vv(i,j,k) = 2.0*((x-x0)*(x-x0)+(y-y0)*(y-y0)+(z-z0)*(z-z0))
> NEXT k
> NEXT j
> NEXT i
> END SUB
>
> EXTERNAL SUB setBox
> IF boxApex(7,2)<>1 THEN
> DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
> MAT READ boxApex !(0 TO 7,0 TO 2)
> DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
> MAT READ boxEdge !(0 TO 11,0 TO 2)
> END IF
> END SUB
> !
> ! ---------- steepest descent iteration
> !
> EXTERNAL SUB SDiteration(stateMax, iterMax, dump) !public
> DECLARE EXTERNAL FUNCTION steepestDescent
> DECLARE EXTERNAL SUB GramSchmidt
> FOR i=0 TO iterMax-1
> FOR ist=0 TO stateMax-1
> LET sdEnergy(ist) = steepestDescent(ist, dump)
> NEXT ist
> CALL GramSchmidt(stateMax)
> LET iterCount = iterCount + 1
> NEXT i
> END SUB
> !
> EXTERNAL FUNCTION steepestDescent(ist,dump) !--- steepest descent method
> DECLARE EXTERNAL FUNCTION energyOfState
> DECLARE EXTERNAL SUB normalizeState
> LET h2 = 2*dx*dx
> LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
> FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
> &-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
> LET wrk(i,j,k) = kesdState+(vv(i,j,k)-ei)*sdState(ist,i,j,k)
> NEXT k
> NEXT j
> NEXT i
> FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - dump*|wrk> ( norm(|ist(next)>) <>1 )
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET sdState(ist,i,j,k) = sdState(ist,i,j,k)-dump*wrk(i,j,k)
> NEXT k
> NEXT j
> NEXT i
> CALL normalizeState(ist)
> LET steepestDescent = ei
> END FUNCTION
> !
> EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
> LET h2 = 2*dx*dx
> LET s = 0
> LET sn=0
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
> &-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
> LET s = s + sdState(ist,i,j,k)*(kesdState+vv(i,j,k)*sdState(ist,i,j,k))
> LET sn = sn+sdState(ist,i,j,k)*sdState(ist,i,j,k)
> NEXT k
> NEXT j
> next i
> LET energyOfState = s/sn
> END FUNCTION
> !
> EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
> DECLARE EXTERNAL FUNCTION innerProduct
> DECLARE EXTERNAL SUB normalizeState
> CALL normalizeState(0)
> FOR istate=1 TO stateMax-1
> FOR ist=0 TO istate-1
> LET s = innerProduct(ist,istate)
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET sdState(istate,i,j,k) = sdState(istate,i,j,k) - s*sdState(ist,i,j,k)
> NEXT k
> NEXT j
> NEXT i
> NEXT ist
> CALL normalizeState(istate)
> NEXT iState
> END SUB
> !
> EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
> LET s = 0
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET s = s + sdState(ist,i,j,k)*sdState(jst,i,j,k)
> NEXT k
> NEXT j
> NEXT i
> LET innerProduct = s*dx*dy*dz
> END FUNCTION
> !
> EXTERNAL SUB normalizeState(ist)
> LET s = 0
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET s = s + sdState(ist,i,j,k)*sdState(ist,i,j,k)
> NEXT k
> NEXT j
> NEXT i
> LET a = SQR(1/(s*dx*dy*dz))
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET sdState(ist,i,j,k) = a*sdState(ist,i,j,k)
> NEXT k
> NEXT j
> NEXT i
> END SUB
> !
> ! ---------- utility
> !
> EXTERNAL FUNCTION iterationCount
> LET iterationCount = iterCount
> END FUNCTION
> !
> EXTERNAL FUNCTION stateEnergy(ist)
> LET stateEnergy = sdEnergy(ist)
> END FUNCTION
> !
> ! ---------- 3D graphics
> !
> EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
> LET cosAx = COS(angleX)
> LET sinAx = SIN(angleX)
> LET cosAy = COS(angleY)
> LET sinAy = SIN(angleY)
> LET cx0 = xCenter
> LET cy0 = yCenter
> LET cz0 = zCenter
> END SUB
>
> EXTERNAL SUB plotLines3D(x,y,z,xShift,yShift)
> LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
> LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> PLOT LINES: x1+cx0+xShift, y1+cy0+yShift; !z=z1+cz0
> END SUB
>
> EXTERNAL SUB drawDisk3D(x,y,z,r,xShift,yShift)
> LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
> LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> DRAW disk WITH SCALE(r)*SHIFT(x1+cx0+xShift,y1+cy0+yShift)
> END SUB
>
> EXTERNAL SUB plotText3DAt(x,y,z,xShift,yShift,A$)
> LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
> LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> PLOT TEXT,AT x1+cx0+xShift,y1+cy0+yShift:A$
> END SUB
>
> EXTERNAL FUNCTION getRotateZ(x,y,z,xShift,yShift)
> LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
> LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
> LET getRotateZ = z1+cz0
> END FUNCTION
> !
> ! ---------- drawState
> !
> EXTERNAL SUB drawState(ist,xRotateAngle,yRotateAngle,drawMode)
> !DECLARE EXTERNAL SUB setRotateXYParameters,drawDensity3D,drawStateGrid,drawStateGridx6
> SET DRAW MODE HIDDEN
> CLEAR
> LET sc = 6
> IF drawMode=0 THEN
> CALL drawDensity3D(ist,sc, xRotateAngle,yRotateAngle)
> ELSEIF drawMode=1 THEN
> CALL setRotateXYParameters(-PI/3,-PI/6,(NNx/2)*sc,(NNy/2)*sc,(NNy/2)*sc)
> CALL drawStateGrid(ist,320/NNx,1.0,0,50) !(ist,sc,zMag,xShift,yShift)
> ELSEIF drawMode=2 THEN
> CALL setRotateXYParameters(-PI/3,-PI/6,(NNx/2)*sc,(NNy/2)*sc,(NNz/2)*sc)
> CALL drawStateGridx6
> ELSE
> !
> END IF
> !--- caption
> SET TEXT HEIGHT 10
> SET TEXT COLOR 1 ! black
> PLOT TEXT, AT 0,-50 ,USING "iterarion count =##### ":iterCount
> PLOT TEXT, AT 0,-65 ,USING "E0 =###.######### E3 =###.#########(au)":sdEnergy(0),sdEnergy(3)
> PLOT TEXT, AT 0,-80 ,USING "E1 =###.######### E4 =###.#########(au)":sdEnergy(1),sdEnergy(4)
> PLOT TEXT, AT 0,-95 ,USING "E2 =###.######### E5 =###.#########(au)":sdEnergy(2),sdEnergy(5)
> PLOT TEXT, AT 0,-110 :"steepest descent method 2D"
> SET DRAW MODE EXPLICIT
> END SUB
> !
> EXTERNAL SUB drawDensity3D(ist,sc,xRotateAngle,yRotateAngle) !----- drawMode=0
> DECLARE EXTERNAL SUB setRotateXYParameters, drawDisk3D, plotEdge3D
> DECLARE EXTERNAL FUNCTION getRotateZ,getZminApex
> CALL setRotateXYParameters(xRotateAngle,yRotateAngle,NNx*sc/2,NNy*sc/2,NNx*sc/2)
> LET xOffset = 80
> LET yOffset = 50
> SET LINE COLOR 1
> FOR i=1 TO NNx-2
> FOR j=1 TO NNy-2
> FOR k=1 TO NNz-2
> LET psi = sdState(ist,i,j,k)
> LET psi2 = psi*psi
> IF psi2>0.001 THEN
> IF psi>0 THEN SET AREA COLOR 4 ELSE SET AREA COLOR 2
> CALL drawDisk3D(i*sc,j*sc,k*sc,ABS(psi)*10,xOffset,yOffset)
> END IF
> NEXT k
> NEXT j
> NEXT i
> CALL plotEdge3D(0,sc,xOffset,yOffset,1) !x-axis:black !(iEdge,xShift,yShift,lineColorIndex)
> CALL plotEdge3D(1,sc,xOffset,yOffset,2) !y-axis:blue
> CALL plotEdge3D(2,sc,xOffset,yOffset,3) !z-axis:green
> FOR iEdge=3 TO 11
> CALL plotEdge3D(iEdge,sc,xOffset,yOffset,8) !other edge:grey
> NEXT iEdge
> CALL plotText3DAt(0,0,NNz*sc,xOffset,yOffset,"Z"&STR$(getRotateZ(0,0,NNz*sc,xOffset,yOffset)))
> CALL plotText3DAt(0,0,0,xOffset,yOffset,"Z"&STR$(getRotateZ(0,0,0,xOffset,yOffset)))
> LET apx = getZminApex(sc,xOffset,yOffset)
> CALL drawDisk3D(boxApex(apx,0)*NNx*sc,boxApex(apx,1)*NNy*sc,boxApex(apx,2)*NNz*sc,10,xOffset,yOffset)
> SET TEXT COLOR 1
> SET TEXT HEIGHT 10
> PLOT TEXT, AT 0,-20:"|"&STR$(ist)&">"
> PLOT TEXT, AT 0,-35 ,USING "Ax =###.#(deg) Ay =###.#(deg)":MOD(xRotateAngle*180/PI,360),MOD(yRotateAngle*180/PI,360)
> END SUB
> !
> EXTERNAL SUB plotEdge3D(iEdge,sc,xShift,yShift,lineColorIndex)
> DECLARE EXTERNAL SUB plotLines3D
> SET LINE COLOR lineColorIndex
> FOR j=0 TO 1
> LET apex = boxEdge(iEdge,j)
> LET x = boxApex(apex,0)*NNx*sc
> LET y = boxApex(apex,1)*NNy*sc
> LET z = boxApex(apex,2)*NNz*sc
> CALL plotLines3D(x,y,z,xShift,yShift)
> NEXT j
> PLOT LINES
> END SUB
>
> EXTERNAL FUNCTION getZminApex(sc,xShift,yShift)
> DECLARE EXTERNAL FUNCTION getRotateZ !(x,y,z,xShift,yShift)
> LET zmin = 1E99
> FOR iApex = 0 TO 7
> LET x = boxApex(iApex,0)*NNx*sc
> LET y = boxApex(iApex,1)*NNy*sc
> LET z = boxApex(iApex,2)*NNz*sc
> LET rotz = getRotateZ(x,y,z,xShift,yShift)
> PRINT USING "### rotZ=####.## x=###.## y=###.## z=###.##":iApex,rotz,x,y,z
> IF rotz<zmin THEN
> LET zmin = rotz
> LET zminApex = iApex
> END IF
> NEXT iApex
> LET getZminApex = zminApex
> END FUNCTION
> !
> EXTERNAL SUB drawStateGrid(ist,sc,zMag,xShift,yShift) !--- drawMode=1
> DECLARE EXTERNAL SUB drawGridXY
> CALL drawGridXY(ist,sc,zMag,xShift,yShift)
> SET TEXT COLOR 1
> SET TEXT HEIGHT 10
> PLOT TEXT, AT 0,-20:"|"&STR$(ist)&">"
> END SUB
> !
> EXTERNAL SUB drawStateGridx6
> DECLARE EXTERNAL SUB drawGridXY
> CALL drawGridXY(0,4,0.5,-30,40) !(ist,sc,zMag,xShift,yShift) !--- drawMode=2
> CALL drawGridXY(1,4,0.5,120,40)
> CALL drawGridXY(2,4,0.5,270,40)
> CALL drawGridXY(3,4,0.5,-30,190)
> CALL drawGridXY(4,4,0.5,120,190)
> CALL drawGridXY(5,4,0.5,270,190)
> SET TEXT HEIGHT 10
> PLOT TEXT, AT -30,-12:"|0>"
> PLOT TEXT, AT 120,-12:"|1>"
> PLOT TEXT, AT 270,-12:"|2>"
> PLOT TEXT, AT -30,138:"|3>"
> PLOT TEXT, AT 120,138:"|4>"
> PLOT TEXT, AT 270,138:"|5>"
> END SUB
> !
> EXTERNAL SUB drawGridXY(ist,sc,zMag,xShift,yShift)
> DECLARE EXTERNAL SUB plotLines3D
> FOR j=0 TO NNy-1 STEP 1
> FOR i=0 TO NNx-1
> LET psi = sdState(ist,i,j,NNz/2)*200
> IF psi>1 THEN
> SET LINE COLOR 4 ! red
> ELSEIF psi<-1 THEN
> SET LINE COLOR 2 ! blue
> ELSE
> SET LINE COLOR 3 ! potential:green
> END IF
> CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j,NNz/2)),xShift,yShift) !(x,y,z)
> NEXT i
> PLOT LINES
> NEXT j
> FOR i=0 TO NNx-1 STEP 1
> FOR j=0 TO NNy-1
> LET psi = sdState(ist,i,j,NNz/2)*200
> IF psi>1 THEN
> SET LINE COLOR 4 ! red
> ELSEIF psi<-1 THEN
> SET LINE COLOR 2 ! blue
> ELSE
> SET LINE COLOR 3 ! potential:green
> END IF
> CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j,NNz/2)),xShift,yShift) !(x,y,z)
> NEXT j
> PLOT LINES
> NEXT i
> END SUB
> !
> END MODULE
>
i7@4.5GHzの場合サンダラムの篩の約4倍速い。
-------------------------------------------------
DECLARE EXTERNAL FUNCTION cprime
DECLARE EXTERNAL SUB sqprime
OPTION ARITHMETIC NATIVE !2進モード
LET t0=TIME
LET k6=1E8
CALL sqprime(k6)
LET SA=2 !MIN 2 (1億to)
LET SB=1000 !MAX 10200 (1兆200億)
LET ki=SB
DIM Ba(ki)
OPEN #1:NAME "prime_n.txt",ACCESS INPUT
FOR i=1 TO ki
INPUT #1: BA(i)
NEXT i
CLOSE #1
DIM Bb(ki)
OPEN #2:NAME "prime_pi.txt",ACCESS INPUT
FOR i=1 TO ki
INPUT #2: BB(i)
NEXT i
CLOSE #2
LET k6=SA*1E8-1E8
FOR n=SA TO SB
LET k=Ba(n) !SQR(1E8)
LET k2=Bb(n) !π(x)
LET k6=k6+1E8
LET C=cprime(k,k2,k6)
LET c1=c1+c
PRINT n;":";c1;":";c
NEXT n
LET TM=TIME-t0
PRINT USING"######." & REPEAT$("#",2):TM;
PRINT "秒"
END
EXTERNAL FUNCTION cprime (k,k2,k6)
OPTION ARITHMETIC NATIVE
!エラトステネスの篩
DIM P(k)
DIM A(k2) !素数
SUB prime(k)
MAT P=ZER
MAT A=ZER
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
END IF
NEXT I
END SUB
CALL prime(k)
LET k4=k6-1E8
LET B6=IP(k6/30)+1
LET U=IP(k6/6)+1 !k5=u
LET W=IP(k4/6)-1 !k3=w
LET M7=W-2
DIM x(W-M7 TO U-M7)
DIM y(W-M7 TO U-M7)
MAT x = ZER !(6*n-1)
MAT y = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=A(n)
LET G1=IP(W/P6)-2
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r6=(P6+1)/6
CALL nap(P6,G1,r6)
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
CALL nap(P6,G1,r6*(-1))
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r6=(P6+1)/6
CALL napi(P6,G1,r6*(-1))
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
CALL napi(P6,G1,r6)
END IF
NEXT n
SUB nap(z,t1,r6) !(6*n-1)
FOR i=t1 TO B6
IF z*i+r6<W THEN GOTO 50
IF z*i+r6>U THEN EXIT SUB
LET x(z*i+r6-M7)=1
50 NEXT i
END SUB
SUB napi(z,t1,r6) !(6*n+1)
FOR i=t1 TO B6
IF z*i+r6<W THEN GOTO 60
IF z*i+r6>U THEN EXIT SUB
LET y(z*i+r6-M7)=1
60 NEXT i
END SUB
LET Cc=0
FOR n=W-M7 TO U-M7
LET ST=n+M7
IF x(n)=1 THEN GOTO 100
IF 6*ST-1>k4 AND 6*ST-1<k6 THEN
LET cc=cc+1
IF 1=cc THEN PRINT 6*ST-1;" :";cc;" 6*n-1"
END IF
100 IF y(n)=1 THEN GOTO 200
IF 6*ST+1>k4 AND 6*ST+1<k6 THEN
LET cc=cc+1
IF 1=cc THEN PRINT 6*ST+1;" :";cc;" 6*n+1"
END IF
200 NEXT n
LET cprime=cc
END FUNCTION
EXTERNAL SUB sqprime(x)
OPTION ARITHMETIC NATIVE
!エラトステネスの篩
LET k=1009997
DIM P(k)
DIM A(79251) !素数
MAT P=ZER
MAT A=ZER
LET H1=1
LET A(H1)=2
LET H1=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET A(H1)=I
LET H1=H1+1
END IF
NEXT I
OPEN #1:NAME "prime_n.txt",RECTYPE INTERNAL
ERASE #1
OPEN #2:NAME "prime_pi.txt",RECTYPE INTERNAL
ERASE #2
LET x1=SQR(x)
FOR i=1229 TO 79251
LET v=A(i)
IF x1=<v THEN
LET c=c+1
LET x=x+1E8
LET x1=SQR(x)
WRITE #1:v
WRITE #2:i
!PRINT c;":";v;":";i
END IF
NEXT i
CLOSE #1
CLOSE #2
END SUB
-------------------------------------
いつも分かりにくい。プログラム解説
基本的に1億間の素数をカウントします。
LET SA=2 !MIN 2 (1億to) 最小値
LET SB=1000 !MAX 10200 (1兆200億) 最大値
-------------------------------
LET k6=1E8
CALL sqprime(k6)まだ、未完成です。SQR(x)よりも余分に出ます。
試験環境：
本プログラムは十進BASIC 6.6.0/macOS 10.7.5と 十進BASIC Ver 7.7.8/windows 10でテストしました。
!
! ========= Quantum Electron Dynamics 2D ==========
!
! 005wavePacketQED2D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.02.19 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB qed2d.setInitialCondition, qed2d.evolveWave, qed2d.drawWave
CALL setInitialCondition
FOR it=1 TO 1000
CALL evolveWave(0) !0:no loss, 1: loss energy (steepest-descent)
CALL drawWave(2) !0:psi^2, 1:cloud, 2:grid3D, 3:prob current, 5:phase
NEXT it
END
! ---------- QED2D module (QED: Quantum Electron Dynamics) ----------
!
! - time dependent Schrodinger equation: i(d/dt)psi(r,t) = H psi(r,t)
! - time evolution
! psi(r,t+dt) = exp(-i dt H) psi(r,t), (H:Hamiltonian of the system)
! H = -delta/2 + V(r), delta = d^2/dx^2 + d^2/dy^2 + d^2/dz^2
! psi(r,t+dt) = exp(-i dt H) psi(r,t) nearly=
! {exp(-i(dt/2)V} {exp(i dt(delta/2)} {exp(-i(dt/2)V} psi(r,t)
! - algorism: {exp(i dt(delta/2)}
! QED: Watanabe's algorism (semi-implicit method)
! Naoki Watanabe, Masaru Tsukada; arXiv:physics/0011068v1
! (Published from Physical Review E. 62, 2914, (2000).)
!
! Cayley's form : exp(i dt delta/2) nearly= (1 + i dt delta/4)/(1 - i dt delta/4)
! psi(r,t+dt) = exp(i dt delta/2) psi(r,dt)
! (1 - i dt delta/4) psi(r,t+dt) = (1 + i dt delta/4) psi(r,t)
!
! difference form psi(r,t) --> psi(j,n)
! psi(j,n+1) - i (dt/dx^2)/4 {psi(j-1,n+1))-2psi(j,n+1)+psi(j+1,n+1)}
! = psi(j,n) + i (dt/dx^2)/4 {psi(j-1,n))-2psi(j,n)+psi(j+1,n)}
! x i(4dx^2/dt) by each term
! psi(j-1,n+1) + A Psi(j,n+1) + psi(j+1,n+1) = -psi(j-1,n) + B Psi(j,n) -psi(j+1,n)
! where A=(i4dx^2/dt)-2, B=(i4dx^2/dt)+2
! bnj = -psi(j-1,n) + B Psi(j,n) -psi(j+1,n) is calculated using known psi(j,n)
! psi(j-1,n+1) + A Psi(j,n+1) + psi(j+1,n+1) = bnj
!
! solve tri-diagonal equation A X = B
! | a1 1 0 0 | | x1 | | b1 |
! | 1 a2 1 0 | | x2 | = | b2 |
! | 0 1 a3 1 | | x3 | | b3 |
! | 0 0 1 a4 | | x4 | | b4 |
!
! u(1) = 1.0/a(1) ! u() : work vector
! x(1) = b(1)*u(1)
!
! FOR i=2 TO N-2 ! forward elimination
! u(i) = 1/(a(i)-u(i-1))
! x(i) = (b(i)-x(i-1))*u(i)
! NEXT i
!
! FOR i=N-3 TO 1 STEP -1 ! backward substitution
! x(i) -= x(i+1)*u(i)
! NEXT i
!
MODULE qed2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, evolveWave, drawWave
PUBLIC FUNCTION systemTime, norm
SHARE NUMERIC sysTime, NNx, NNy, dx, dy, dt, auLength, auTime, auEnergy
SHARE NUMERIC cosAx, sinAx, cosAy, sinAy, cx0, cy0, cz0 !--- 3D graphics
SHARE NUMERIC psi(320,320,0 TO 1) ! wave function (,,0):real part (,,1):imaginary part
SHARE NUMERIC vv(320,320) ! external potential
SHARE NUMERIC wrk(320,320,0 TO 1) ! work space in lossEnergy
SHARE NUMERIC bRe(400),bIm(400) ! b vector in kxStep,kyStep
SHARE NUMERIC uRe(400),uIm(400) ! u vector in kxStep,kyStep
SHARE NUMERIC psicol(160,160) ! MAT PLOT CELL matrix for psi(x,y)
SHARE NUMERIC vcol(160,160) ! MAT PLOT CELL matrix for potential V(x,y)
SHARE NUMERIC srnd(1000) ! 1000 RND orderd series 0 to 1,use drawCloud
LET sysTime = 0.0 ! (au) au : atomic unit (hbar=1, me=1, e=1)
LET NNx = 160 ! max number of psi(x,,)
LET NNy = 160 ! max number of psi(,y,)
LET dx = 0.5 ! (au) x division
LET dy = 0.5 ! (au) y division
LET dt = 1.0*dx*dx ! (au) time division dt/(dx*dx)>3 ~ unstable?
LET auLength = 5.29177e-11 ! (m) 1(au) = auLength (m)
LET auTime = 2.41888e-17 ! (s) 1(au) = auTime (s)
LET auEnergy = 4.38975e-18 ! (J) 1(au) = auEnergy (J) (= 27.2114 eV)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition !public
DECLARE EXTERNAL SUB setGaussianWave,setHarmonicPotential,initDraw
RANDOMIZE
LET sysTime = 0.0
CALL setGaussianWave(NNx*dx/2,NNy*dy/4,3,1,0) !(xPos,yPos,waveWidth,kx,ky)
CALL setHarmonicPotential(2.0) ! v(x)=k*(x-x0)^2
CALL initDraw !set color pallet and vcol(,)
! set window
LET xMargin = 60
LET yMargin = 120
SET WINDOW -xMargin,500-xMargin,-yMargin,500-yMargin
END SUB
EXTERNAL SUB setGaussianWave(xPos,yPos,waveWidth,kx,ky)
DECLARE EXTERNAL SUB normalize
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET x = i*dx
LET y = j*dy
LET phAb = EXP(-((x-xPos)*(x-xPos)+(y-yPos)*(y-yPos))/(4*waveWidth*waveWidth) )
LET phPh = kx*x+ky*y
LET psi(i,j,0) = phAb*COS(phPh)
LET psi(i,j,1) = phAb*SIN(phPh)
NEXT j
NEXT i
FOR i=1 TO NNx-1
LET psi(i,0,0) = 0
LET psi(i,0,1) = 0
LET psi(i,NNy-1,0) = 0
LET psi(i,NNy-1,1) = 0
NEXT i
FOR j=0 TO NNy-1
LET psi(0,j,0) = 0
LET psi(0,j,1) = 0
LET psi(NNx-1,j,0) = 0
LET psi(NNx-1,j,1) = 0
NEXT j
CALL normalize
END SUB
EXTERNAL SUB setHarmonicPotential(k0) !--- V(r)= k0*r^2
LET aa = k0/(NNx*dx*NNx*dx/4)
LET x0 = NNx*dx/2.0
LET y0 = NNy*dy/2.0
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET x = i*dx
LET y = j*dy
LET vv(i,j) = aa*((x-x0)*(x-x0)+(y-y0)*(y-y0))
NEXT j
NEXT i
END SUB
EXTERNAL SUB initDraw !--- set set color pallet and MAT PLOT matrix vcol(,)
FOR i = 0 TO 100 !--- set color pallet
SET COLOR MIX(40+i) 0.01*i,0.01*i,0 ! yellow for <psi|psi>
SET COLOR MIX(150+i) 0,0.01*i,0 ! green for V(x)
NEXT i
FOR i=0 TO NNx-1 !--- set vcol(,)
FOR j=0 TO NNy-1
LET col = 0.25*vv(i,j)
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET vcol(i,j) = 150+INT(col*100)
NEXT j
NEXT i
END SUB
! ---------- evolve Wave
EXTERNAL SUB evolveWave(lossSW) !public
DECLARE EXTERNAL SUB phaseStep,kxStep,kyStep,lossEnergy
CALL phaseStep
CALL kxStep
CALL kyStep
CALL phaseStep
LET sysTime = sysTime + dt
IF (lossSW=1) THEN CALL lossEnergy(0.01)
END SUB
EXTERNAL SUB phaseStep !--- {exp(-i(dt/2)V} : evolve 0.5dt
FOR i=1 TO NNx-2
FOR j=1 TO NNx-2
LET th = 0.5*dt*vv(i,j)
LET cs = COS(th)
LET sn = SIN(th)
LET phr = psi(i,j,0)
LET phi = psi(i,j,1)
LET psi(i,j,0) = cs*phr+sn*phi
LET psi(i,j,1) = -sn*phr+cs*phi
NEXT j
NEXT i
END SUB
EXTERNAL SUB kxStep !--- {exp(i dt(delta/2)} semi-implicit method : evolve dt
LET a = 4.0*dy*dy/dt
LET aaAb = 4.0+a*a
FOR j=1 TO NNy-2
FOR i=1 TO NNx-2
LET bRe(i) = 2*psi(i,j,0)-a*psi(i,j,1) - psi(i+1,j,0) - psi(i-1,j,0)
LET bIm(i) = 2*psi(i,j,1)+a*psi(i,j,0) - psi(i+1,j,1) - psi(i-1,j,1)
NEXT i
LET uRe(1) = -2/aaAb
LET uIm(1) = -a/aaAb
LET psi(1,j,0) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET psi(1,j,1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR i=2 TO NNx-2 !--- forward elimination
LET auAb = (-2-uRe(i-1))*(-2-uRe(i-1))+(a-uIm(i-1))*(a-uIm(i-1))
LET uRe(i) = (-2-uRe(i-1))/auAb
LET uIm(i) = -(a-uIm(i-1))/auAb
LET psi(i,j,0) = (bRe(i)-psi(i-1,j,0))*uRe(i) - (bIm(i)-psi(i-1,j,1))*uIm(i)
LET psi(i,j,1) = (bRe(i)-psi(i-1,j,0))*uIm(i) + (bIm(i)-psi(i-1,j,1))*uRe(i)
NEXT i
FOR i=NNx-3 TO 1 STEP -1 !--- backward substitution
LET psi(i,j,0) = psi(i,j,0) - (psi(i+1,j,0)*uRe(i) - psi(i+1,j,1)*uIm(i))
LET psi(i,j,1) = psi(i,j,1) - (psi(i+1,j,0)*uIm(i) + psi(i+1,j,1)*uRe(i))
NEXT i
NEXT j
END SUB
EXTERNAL SUB kyStep !--- {exp(i dt(delta/2)} semi-implicit method : evolve dt
LET a = 4*dy*dy/dt
LET aaAb = 4+a*a
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET bRe(j) = 2*psi(i,j,0)-a*psi(i,j,1) - psi(i,j+1,0) - psi(i,j-1,0)
LET bIm(j) = 2*psi(i,j,1)+a*psi(i,j,0) - psi(i,j+1,1) - psi(i,j-1,1)
NEXT j
LET uRe(1) = -2/aaAb
LET uIm(1) = -a/aaAb
LET psi(i,1,0) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET psi(i,1,1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR j=2 TO NNy-2 !--- forward elimination
LET auAb = (-2-uRe(j-1))*(-2-uRe(j-1))+(a-uIm(j-1))*(a-uIm(j-1))
LET uRe(j) = (-2-uRe(j-1))/auAb
LET uIm(j) = -(a-uIm(j-1))/auAb
LET psi(i,j,0) = (bRe(j)-psi(i,j-1,0))*uRe(j) - (bIm(j)-psi(i,j-1,1))*uIm(j)
LET psi(i,j,1) = (bRe(j)-psi(i,j-1,0))*uIm(j) + (bIm(j)-psi(i,j-1,1))*uRe(j)
NEXT j
FOR j=NNy-3 TO 1 STEP -1 !--- backward substitution
LET psi(i,j,0) = psi(i,j,0) - (psi(i,j+1,0)*uRe(j) - psi(i,j+1,1)*uIm(j))
LET psi(i,j,1) = psi(i,j,1) - (psi(i,j+1,0)*uIm(j) + psi(i,j+1,1)*uRe(j))
NEXT j
NEXT i
END SUB
EXTERNAL SUB lossEnergy(dumpingFactor) ! steepest-descent
DECLARE EXTERNAL SUB normalize
LET h2 = 2.0*dx*dx
LET ee = kineticEnergy + potentialEnergy
FOR i=1 TO NNx-2
FOR j=1 TO NNx-2
LET wrk(i,j,0) = -(psi(i+1,j,0)+psi(i-1,j,0)+psi(i,j+1,0)+psi(i,j-1,0)-4*psi(i,j,0))/h2+(vv(i,j)-ee)*psi(i,j,0)
LET wrk(i,j,1) = -(psi(i+1,j,1)+psi(i-1,j,1)+psi(i,j+1,1)+psi(i,j-1,1)-4*psi(i,j,1))/h2+(vv(i,j)-ee)*psi(i,j,1)
NEXT j
NEXT i
FOR i=1 TO NNx-2
FOR j=1 TO NNx-2
LET psi(i,j,0) = psi(i,j,0) - dumpingFactor*wrk(i,j,0)
LET psi(i,j,1) = psi(i,j,1) - dumpingFactor*wrk(i,j,1)
NEXT j
NEXT i
CALL normalize
END SUB
! ---------- utility
EXTERNAL FUNCTION systemTime !public
LET systemTime = sysTime
END FUNCTION
EXTERNAL FUNCTION norm !public <psi|psi>
LET p = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET p = p + (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))
NEXT j
NEXT i
LET norm = p*dx*dy
END FUNCTION
EXTERNAL SUB normalize
DECLARE EXTERNAL FUNCTION norm
LET a = 1/SQR(norm)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET psi(i,j,0) = psi(i,j,0)*a
LET psi(i,j,1) = psi(i,j,1)*a
NEXT j
NEXT i
END SUB
EXTERNAL FUNCTION potentialEnergy !--- <psi| V(x) |psi>
LET p = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET p = p + (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*vv(i,j)
NEXT j
NEXT i
LET potentialEnergy = p*dx*dy
END FUNCTION
EXTERNAL FUNCTION kineticEnergy !--- <psi| -0.5(d^2/dx^2+d^2/dy^2) |psi>
LET h2 = dx*dx
LET p = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET d2phRe = (psi(i+1,j,0)+psi(i-1,j,0)+psi(i,j+1,0)+psi(i,j-1,0)-4.0*psi(i,j,0))/h2
LET d2phIm = (psi(i+1,j,1)+psi(i-1,j,1)+psi(i,j+1,1)+psi(i,j-1,1)-4.0*psi(i,j,1))/h2
LET p = p + (psi(i,j,0)*d2phRe+psi(i,j,1)*d2phIm)
NEXT j
NEXT i
LET kineticEnergy = -0.5*p*dx*dy
END FUNCTION
EXTERNAL FUNCTION xProbabilityCurrentDensity(i,j) !--- Re(<psi| -i(d/dx) |psi>)
LET pRe = (psi(i+1,j,1)-psi(i-1,j,1))/(2*dx)
LET pIm = (-psi(i+1,j,0)+psi(i-1,j,0))/(2*dx)
LET xProbabilityCurrentDensity = psi(i,j,0)*pRe + psi(i,j,1)*pIm
END FUNCTION
EXTERNAL FUNCTION yProbabilityCurrentDensity(i,j) !--- Re(<psi| -i(d/dy) |psi>)
LET pRe = (psi(i,j+1,1)-psi(i,j-1,1))/(2*dy)
LET pIm = (-psi(i,j+1,0)+psi(i,j-1,0))/(2*dy)
LET yProbabilityCurrentDensity = psi(i,j,0)*pRe + psi(i,j,1)*pIm
END FUNCTION
! ---------- 3D graphics
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z) !shift*xRotateAx*yRotateAy*(shift^-1)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0, y1+cy0; !z=z1+cz0
END SUB
! ---------- draw wave
EXTERNAL SUB drawWave(drawMode)
DECLARE EXTERNAL FUNCTION kineticEnergy,potentialEnergy
DECLARE EXTERNAL SUB drawPsi2,drawCloud,draw3DPsi2,drawProbabilityCurrent,drawPsiPhase
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 THEN CALL drawPsi2
IF drawMode=1 THEN CALL drawCloud
IF drawMode=2 THEN CALL draw3DPsi2(-PI/4,-PI/12) !(xRotateAngle,yRotateAngle)
IF drawMode=3 THEN CALL drawProbabilityCurrent
IF drawMode=4 THEN CALL drawPsiPhase
!--- caption
LET ke = kineticEnergy
LET pe = potentialEnergy
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,-20 ,USING "time =#####.## (au) =####.#### (femto s)":sysTime,sysTime*auTime*1e15
PLOT TEXT, AT 0,-35 ,USING "norm of wave function =#.###############":norm
PLOT TEXT, AT 0,-50 ,USING "kinetic energy =#.###### (au) =##.### (eV)":ke,ke*27.2114
PLOT TEXT, AT 0,-65 ,USING "potential energy =#.###### (au) =##.### (eV)":pe,pe*27.2114
PLOT TEXT, AT 0,-80 ,USING "total energy =#.###### (au) =##.### (eV)":ke+pe,(ke+pe)*27.2114
PLOT TEXT, AT 0,-95 ,USING "Box =###.# x ###.# (au)":NNx*dx,NNx*dx
PLOT TEXT, AT 0,-110 :"wave packet - quantum electron dynamics 2D"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB drawPsi2 !drawMode=0
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET col = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*100
IF col>0.2 THEN
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 40+INT(col*100)
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN 0,0; 320,320 :psicol
END SUB
EXTERNAL SUB drawCloud !drawMode=1
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
LET srnd(0) = RND
FOR i = 1 TO 1000
LET srnd(i) = srnd(i-1) + RND
NEXT i
FOR i = 0 TO 1000
LET srnd(i) = srnd(i)/srnd(1000)
NEXT i
LET m = 0
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET cij = 0
LET s = s + (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*dx*dy
DO WHILE (s>srnd(m) AND m<1000)
LET m = m + 1
LET cij = cij + 1
LOOP
IF cij>0 THEN LET psicol(i,j) = 6 ! yellow
IF cij>3 THEN LET psicol(i,j) = 4 ! red
NEXT j
NEXT i
MAT PLOT CELLS,IN 0,0; 320,320 :psicol
END SUB
EXTERNAL SUB draw3DPsi2(xRotateAngle,yRotateAngle) !drawMode=2
DECLARE EXTERNAL SUB setRotateXYParameters,plotLines3D
LET sc = 320/NNx
LET zMag = 20
CALL setRotateXYParameters(xRotateAngle,yRotateAngle,NNx/2,NNy/2,0)
FOR j=0 TO NNy-1 STEP 2
FOR i=0 TO NNx-1
LET psi2 = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*300
IF psi2>0.2 THEN
SET LINE COLOR 13 !psi^2:dark yellow
ELSEIF vv(i,j)>2 THEN
SET LINE COLOR 10 !potential:dark green
ELSE
SET LINE COLOR 3 !potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi2 + vv(i,j))) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 2
FOR j=0 TO NNy-1
LET psi2 = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*300
IF psi2>0.2 THEN
SET LINE COLOR 13 !psi^2:dark yellow
ELSEIF vv(i,j)>2 THEN
SET LINE COLOR 10 !potential:dark green
ELSE
SET LINE COLOR 3 !potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi2 + vv(i,j))) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
EXTERNAL SUB drawProbabilityCurrent !drawMode=3
DECLARE EXTERNAL FUNCTION xProbabilityCurrentDensity,yProbabilityCurrentDensity
DECLARE EXTERNAL SUB drawPsi2
LET sc = 320/NNx
LET mag = 20000
CALL drawPsi2
SET LINE COLOR 4 !red
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET psi2 = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*100
IF psi2>0.4 AND MOD(i,4)=0 AND MOD(j ,4)=0 THEN
LET xp = xProbabilityCurrentDensity(i,j)*dt*mag
LET yp = yProbabilityCurrentDensity(i,j)*dt*mag
PLOT LINES: i*sc, j*sc; i*sc+xp,j*sc+yp
END IF
NEXT j
NEXT i
PLOT LINES
END SUB
EXTERNAL SUB drawPsiPhase !drawMode=4
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET col = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*100
IF col>0.2 AND col>RND+0.2 THEN
IF abs(psi(i,j,0))>abs(psi(i,j,1)) THEN
IF psi(i,j,0)>=0 THEN LET psicol(i,j) = 6 ELSE LET psicol(i,j) = 5
ELSE
IF psi(i,j,1)>=0 THEN LET psicol(i,j) = 13 ELSE LET psicol(i,j) = 8
END IF
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN 0,0; 320,320 :psicol
END SUB
END MODULE
-------------------------------------------------
!6n±1篩 prime number Counting !Ver.2.13
!素数計数関数（英: Prime-counting function）π(x)
DECLARE EXTERNAL FUNCTION cprime
DECLARE EXTERNAL SUB sqprime
OPTION ARITHMETIC NATIVE
!PRINT DATE$;"/"; TIME$
LET t0=TIME
LET k=31622809
LET k2=1951961
!エラトステネスの篩
LET Fu=5639
DIM P(Fu)
DIM A(740) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
DIM GT(k2)
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO 740
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET GT(1)=2
LET GT(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n+1
END IF
NEXT n
LET SA=2 !11092 ,634831,190331, 70141,26451,754901,250000, 9999990,4000001,MIN 2 (1億to)
LET SB=100 !11093 ,634840,190340, 70150,26461,754910,250010,10000000,4100000,MAX 1E15-1
CALL sqprime(SA,SB,k2,GT)
DIM Ba(SA TO SB)
DIM Bb(SA TO SB)
OPEN #1:NAME "prime_n1.txt",ACCESS INPUT
OPEN #2:NAME "prime_pi1.txt",ACCESS INPUT
FOR i=SA TO SB
INPUT #1: BA(i)
INPUT #2: BB(i)
NEXT i
CLOSE #1
CLOSE #2
! !SA=数値入力+1
!LET c1=12273824155491 !400兆
!LET c1=12270876688507 !3999009億
!LET c1=11678533758926 !380兆
!LET c1=3204941750802 !1E14 (100兆)1000001億
!LET c1=2894232250783 !9E13 (90兆) 900001億
!LET c1=2441437469602 !754900 : 2441437469602
!LET c1=1638923764567 !5E13 (50兆) 500001億
!LET c1=2064698005481 !634830 : 2064698005481
!LET c1=838534798134 !249999 : 838534798134
!LET c1=644296877669 !190330 : 644296877669
!LET c1=346065536839 !1E13 (10兆) 100001億
!LET c1=245751018905 !70140 : 245751018905
!LET c1=95957135910 !26450 : 95957135910
!LET c1=41548852740 !11091 : 41548852740
!LET c1=37607912018 !1E12 (1兆) 10001億
!LET c1=4118054813 !1E11 (1000億) 1001億
!LET c1=455052511 !1E10 (100億) 101億
!LET c1=450708777 !9.9E9 (99億) 100億
!LET c1=50847534 !1E9 (10億) 11億
LET c1=5761455 !1E8 (1億) 2億
!https://www.wikiwand.com/ja/素数計数関数
PRINT SA-1;":";c1;":";c
LET k6=SA*1E8-1E8
FOR n=SA TO SB
!LET t1=TIME
LET k=Ba(n) !SQR(1E8)
LET k2=Bb(n) !π(x)
LET k6=k6+1E8
LET C=cprime(k,k2,k6,GT)
LET c1=c1+c
PRINT n;":";c1;":";c
!LET TM=TIME-t1
!PRINT USING"######." & REPEAT$("#",2):TM;
!PRINT "秒"
NEXT n
LET TM=TIME-t0
PRINT USING"######." & REPEAT$("#",2):TM;
PRINT "秒"
!PRINT DATE$;"/"; TIME$
END
EXTERNAL FUNCTION cprime (k,k2,k6,GT())
OPTION ARITHMETIC NATIVE
LET k4=k6-1E8
LET B6=IP(k6/30)+1
LET U=IP(k6/6)+1
LET W=IP(k4/6)-1
LET M7=W-2
DIM x(W-M7 TO U-M7)
DIM y(W-M7 TO U-M7)
MAT x = ZER !(6*n-1)
MAT y = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=GT(n)
LET G1=IP(W/P6)!-2
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 140
IF P6*i+r6>U THEN EXIT FOR
LET x(P6*i+r6-M7)=1
140 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 150
IF P6*i-r6>U THEN EXIT FOR
LET x(P6*i-r6-M7)=1
150 NEXT i
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 160
IF P6*i-r6>U THEN EXIT FOR
LET y(P6*i-r6-M7)=1
160 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 170
IF P6*i+r6>U THEN EXIT FOR
LET y(P6*i+r6-M7)=1
170 NEXT i
END IF
NEXT n
LET Cc=0
FOR n=W-M7 TO U-M7
LET ST=n+M7
IF x(n)=1 THEN GOTO 180
IF 6*ST-1>k4 AND 6*ST-1<k6 THEN
LET cc=cc+1
! IF 1=cc THEN PRINT 6*ST-1;" :";cc;" 6*n-1"
! IF 3102679=cc OR 3099882=cc THEN PRINT 6*ST-1;" :";cc;" 6*n-1"
END IF
180 IF y(n)=1 THEN GOTO 200
IF 6*ST+1>k4 AND 6*ST+1<k6 THEN
LET cc=cc+1
! IF 1=cc THEN PRINT 6*ST+1;" :";cc;" 6*n+1"
! IF 3102679=cc OR 3099882=cc THEN PRINT 6*ST+1;" :";cc;" 6*n+1"
END IF
200 NEXT n
LET cprime=cc
END FUNCTION
EXTERNAL SUB sqprime(SA,SB,k2,GT())
OPTION ARITHMETIC NATIVE
OPEN #1:NAME "prime_n1.txt",RECTYPE INTERNAL
ERASE #1
OPEN #2:NAME "prime_pi1.txt",RECTYPE INTERNAL
ERASE #2
LET x=1E8
FOR i=1 TO k2-1
LET v=GT(i)^2
LET vi=GT(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=1E8 THEN
LET vt=IP(vv/1E8)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+1E8
IF C>=SA AND SB>=C THEN
WRITE #1:GT(i)
WRITE #2:i
END IF
NEXT ns
END SUB
CLOSE #1
CLOSE #2
END SUB
-------------------------------------------------
変数
LET SA=2 !MIN 2 (1億to) 最小値 2から1億も分岐を付ければ計算可能です。6n±1なので5からです。
LET SB=20000!MAX 1E15-1 15桁まで
LET c1=5761455 !1E8 (1億)
----------------------------------------
450.21s BASIC 6.6.0 / MAC OS 10.7.5 / mac mini Intel Core-i7 (2.7GHz) 4GB
332.56s BASIC 7.7.8 / windows 10 64bit / FMV-A561D CPU intel core-i5 2400M (2.5GHz) 4GB
123.53s BASIC Acc 0.9.8.1 / windows 10 64bit / FMV-A561D CPU intel core-i5 2400M (2.5GHz) 4GB
BASIC Accで2～3倍加速されるようです。これで動いて見えます。
----------------
!
! ========= Quantum Electron Dynamics 2D ==========
!
! 005wavePacketQED2D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.02.19 created
! ver 0.0.2 2017.02.20 bug fixed (BASIC Acc 0.9.8.1 compiling error fixed)
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB qed2d.setInitialCondition, qed2d.evolveWave, qed2d.drawWave
LET t0 = TIME
CALL setInitialCondition
FOR it=1 TO 1000
CALL evolveWave(0) !0:no loss, 1: loss energy (steepest-descent)
CALL drawWave(2) !0:psi^2, 1:cloud, 2:grid3D, 3:prob current, 5:phase
NEXT it
!PRINT TIME - t0
END
! ---------- QED2D module (QED: Quantum Electron Dynamics) ----------
!
! - time dependent Schrodinger equation: i(d/dt)psi(r,t) = H psi(r,t)
! - time evolution
! psi(r,t+dt) = exp(-i dt H) psi(r,t), (H:Hamiltonian of the system)
! H = -delta/2 + V(r), delta = d^2/dx^2 + d^2/dy^2 + d^2/dz^2
! psi(r,t+dt) = exp(-i dt H) psi(r,t) nearly=
! {exp(-i(dt/2)V} {exp(i dt(delta/2)} {exp(-i(dt/2)V} psi(r,t)
! - algorism: {exp(i dt(delta/2)}
! QED: Watanabe's algorism (semi-implicit method)
! Naoki Watanabe, Masaru Tsukada; arXiv:physics/0011068v1
! (Published from Physical Review E. 62, 2914, (2000).)
!
! Cayley's form : exp(i dt delta/2) nearly= (1 + i dt delta/4)/(1 - i dt delta/4)
! psi(r,t+dt) = exp(i dt delta/2) psi(r,dt)
! (1 - i dt delta/4) psi(r,t+dt) = (1 + i dt delta/4) psi(r,t)
!
! difference form psi(r,t) --> psi(j,n)
! psi(j,n+1) - i (dt/dx^2)/4 {psi(j-1,n+1))-2psi(j,n+1)+psi(j+1,n+1)}
! = psi(j,n) + i (dt/dx^2)/4 {psi(j-1,n))-2psi(j,n)+psi(j+1,n)}
! x i(4dx^2/dt) by each term
! psi(j-1,n+1) + A Psi(j,n+1) + psi(j+1,n+1) = -psi(j-1,n) + B Psi(j,n) -psi(j+1,n)
! where A=(i4dx^2/dt)-2, B=(i4dx^2/dt)+2
! bnj = -psi(j-1,n) + B Psi(j,n) -psi(j+1,n) is calculated using known psi(j,n)
! psi(j-1,n+1) + A Psi(j,n+1) + psi(j+1,n+1) = bnj
!
! solve tri-diagonal equation A X = B
! | a1 1 0 0 | | x1 | | b1 |
! | 1 a2 1 0 | | x2 | = | b2 |
! | 0 1 a3 1 | | x3 | | b3 |
! | 0 0 1 a4 | | x4 | | b4 |
!
! u(1) = 1.0/a(1) ! u() : work vector
! x(1) = b(1)*u(1)
!
! FOR i=2 TO N-2 ! forward elimination
! u(i) = 1/(a(i)-u(i-1))
! x(i) = (b(i)-x(i-1))*u(i)
! NEXT i
!
! FOR i=N-3 TO 1 STEP -1 ! backward substitution
! x(i) -= x(i+1)*u(i)
! NEXT i
!
MODULE qed2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, evolveWave, drawWave
PUBLIC FUNCTION systemTime, norm
SHARE NUMERIC sysTime, NNx, NNy, dx, dy, dt, auLength, auTime, auEnergy
SHARE NUMERIC cosAx, sinAx, cosAy, sinAy, cx0, cy0, cz0 !--- 3D graphics
SHARE NUMERIC psi(320,320,0 TO 1) ! wave function (,,0):real part (,,1):imaginary part
SHARE NUMERIC vv(320,320) ! external potential
SHARE NUMERIC wrk(320,320,0 TO 1) ! work space in lossEnergy
SHARE NUMERIC bRe(400),bIm(400) ! b vector in kxStep,kyStep
SHARE NUMERIC uRe(400),uIm(400) ! u vector in kxStep,kyStep
SHARE NUMERIC psicol(160,160) ! MAT PLOT CELL matrix for psi(x,y)
SHARE NUMERIC vcol(160,160) ! MAT PLOT CELL matrix for potential V(x,y)
SHARE NUMERIC srnd(1000) ! 1000 RND orderd series 0 to 1,use drawCloud
LET sysTime = 0.0 ! (au) au : atomic unit (hbar=1, me=1, e=1)
LET NNx = 160 ! max number of psi(x,,)
LET NNy = 160 ! max number of psi(,y,)
LET dx = 0.5 ! (au) x division
LET dy = 0.5 ! (au) y division
LET dt = 1.0*dx*dx ! (au) time division dt/(dx*dx)>3 ~ unstable?
LET auLength = 5.29177e-11 ! (m) 1(au) = auLength (m)
LET auTime = 2.41888e-17 ! (s) 1(au) = auTime (s)
LET auEnergy = 4.38975e-18 ! (J) 1(au) = auEnergy (J) (= 27.2114 eV)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition !public
DECLARE EXTERNAL SUB setGaussianWave,setHarmonicPotential,initDraw
RANDOMIZE
LET sysTime = 0.0
CALL setGaussianWave(NNx*dx/2,NNy*dy/4,3,1,0) !(xPos,yPos,waveWidth,kx,ky)
CALL setHarmonicPotential(2.0) ! v(x)=k*(x-x0)^2
CALL initDraw !set color pallet and vcol(,)
! set window
LET xMargin = 60
LET yMargin = 120
SET WINDOW -xMargin,500-xMargin,-yMargin,500-yMargin
END SUB
EXTERNAL SUB setGaussianWave(xPos,yPos,waveWidth,kx,ky)
DECLARE EXTERNAL SUB normalize
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET x = i*dx
LET y = j*dy
LET phAb = EXP(-((x-xPos)*(x-xPos)+(y-yPos)*(y-yPos))/(4*waveWidth*waveWidth) )
LET phPh = kx*x+ky*y
LET psi(i,j,0) = phAb*COS(phPh)
LET psi(i,j,1) = phAb*SIN(phPh)
NEXT j
NEXT i
FOR i=1 TO NNx-1
LET psi(i,0,0) = 0
LET psi(i,0,1) = 0
LET psi(i,NNy-1,0) = 0
LET psi(i,NNy-1,1) = 0
NEXT i
FOR j=0 TO NNy-1
LET psi(0,j,0) = 0
LET psi(0,j,1) = 0
LET psi(NNx-1,j,0) = 0
LET psi(NNx-1,j,1) = 0
NEXT j
CALL normalize
END SUB
EXTERNAL SUB setHarmonicPotential(k0) !--- V(r)= k0*r^2
LET aa = k0/(NNx*dx*NNx*dx/4)
LET x0 = NNx*dx/2.0
LET y0 = NNy*dy/2.0
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET x = i*dx
LET y = j*dy
LET vv(i,j) = aa*((x-x0)*(x-x0)+(y-y0)*(y-y0))
NEXT j
NEXT i
END SUB
EXTERNAL SUB initDraw !--- set set color pallet and MAT PLOT matrix vcol(,)
FOR i = 0 TO 100 !--- set color pallet
SET COLOR MIX(40+i) 0.01*i,0.01*i,0 ! yellow for <psi|psi>
SET COLOR MIX(150+i) 0,0.01*i,0 ! green for V(x)
NEXT i
FOR i=0 TO NNx-1 !--- set vcol(,)
FOR j=0 TO NNy-1
LET col = 0.25*vv(i,j)
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET vcol(i,j) = 150+INT(col*100)
NEXT j
NEXT i
END SUB
! ---------- evolve Wave
EXTERNAL SUB evolveWave(lossSW) !public
DECLARE EXTERNAL SUB phaseStep,kxStep,kyStep,lossEnergy
CALL phaseStep
CALL kxStep
CALL kyStep
CALL phaseStep
LET sysTime = sysTime + dt
IF (lossSW=1) THEN CALL lossEnergy(0.01)
END SUB
EXTERNAL SUB phaseStep !--- {exp(-i(dt/2)V} : evolve 0.5dt
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET th = 0.5*dt*vv(i,j)
LET cs = COS(th)
LET sn = SIN(th)
LET phr = psi(i,j,0)
LET phi = psi(i,j,1)
LET psi(i,j,0) = cs*phr+sn*phi
LET psi(i,j,1) = -sn*phr+cs*phi
NEXT j
NEXT i
END SUB
EXTERNAL SUB kxStep !--- {exp(i dt(delta/2)} semi-implicit method : evolve dt
LET a = 4.0*dx*dx/dt
LET aaAb = 4.0+a*a
FOR j=1 TO NNy-2
FOR i=1 TO NNx-2
LET bRe(i) = 2*psi(i,j,0)-a*psi(i,j,1) - psi(i+1,j,0) - psi(i-1,j,0)
LET bIm(i) = 2*psi(i,j,1)+a*psi(i,j,0) - psi(i+1,j,1) - psi(i-1,j,1)
NEXT i
LET uRe(1) = -2/aaAb
LET uIm(1) = -a/aaAb
LET psi(1,j,0) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET psi(1,j,1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR i=2 TO NNx-2 !--- forward elimination
LET auAb = (-2-uRe(i-1))*(-2-uRe(i-1))+(a-uIm(i-1))*(a-uIm(i-1))
LET uRe(i) = (-2-uRe(i-1))/auAb
LET uIm(i) = -(a-uIm(i-1))/auAb
LET psi(i,j,0) = (bRe(i)-psi(i-1,j,0))*uRe(i) - (bIm(i)-psi(i-1,j,1))*uIm(i)
LET psi(i,j,1) = (bRe(i)-psi(i-1,j,0))*uIm(i) + (bIm(i)-psi(i-1,j,1))*uRe(i)
NEXT i
FOR i=NNx-3 TO 1 STEP -1 !--- backward substitution
LET psi(i,j,0) = psi(i,j,0) - (psi(i+1,j,0)*uRe(i) - psi(i+1,j,1)*uIm(i))
LET psi(i,j,1) = psi(i,j,1) - (psi(i+1,j,0)*uIm(i) + psi(i+1,j,1)*uRe(i))
NEXT i
NEXT j
END SUB
EXTERNAL SUB kyStep !--- {exp(i dt(delta/2)} semi-implicit method : evolve dt
LET a = 4*dy*dy/dt
LET aaAb = 4+a*a
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET bRe(j) = 2*psi(i,j,0)-a*psi(i,j,1) - psi(i,j+1,0) - psi(i,j-1,0)
LET bIm(j) = 2*psi(i,j,1)+a*psi(i,j,0) - psi(i,j+1,1) - psi(i,j-1,1)
NEXT j
LET uRe(1) = -2/aaAb
LET uIm(1) = -a/aaAb
LET psi(i,1,0) = bRe(1)*uRe(1) - bIm(1)*uIm(1)
LET psi(i,1,1) = bIm(1)*uRe(1) + bRe(1)*uIm(1)
FOR j=2 TO NNy-2 !--- forward elimination
LET auAb = (-2-uRe(j-1))*(-2-uRe(j-1))+(a-uIm(j-1))*(a-uIm(j-1))
LET uRe(j) = (-2-uRe(j-1))/auAb
LET uIm(j) = -(a-uIm(j-1))/auAb
LET psi(i,j,0) = (bRe(j)-psi(i,j-1,0))*uRe(j) - (bIm(j)-psi(i,j-1,1))*uIm(j)
LET psi(i,j,1) = (bRe(j)-psi(i,j-1,0))*uIm(j) + (bIm(j)-psi(i,j-1,1))*uRe(j)
NEXT j
FOR j=NNy-3 TO 1 STEP -1 !--- backward substitution
LET psi(i,j,0) = psi(i,j,0) - (psi(i,j+1,0)*uRe(j) - psi(i,j+1,1)*uIm(j))
LET psi(i,j,1) = psi(i,j,1) - (psi(i,j+1,0)*uIm(j) + psi(i,j+1,1)*uRe(j))
NEXT j
NEXT i
END SUB
EXTERNAL SUB lossEnergy(dumpingFactor) ! steepest-descent
DECLARE EXTERNAL FUNCTION kineticEnergy,potentialEnergy
DECLARE EXTERNAL SUB normalize
LET h2 = 2.0*dx*dx
LET ee = kineticEnergy + potentialEnergy
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET wrk(i,j,0) = -(psi(i+1,j,0)+psi(i-1,j,0)+psi(i,j+1,0)+psi(i,j-1,0)-4*psi(i,j,0))/h2+(vv(i,j)-ee)*psi(i,j,0)
LET wrk(i,j,1) = -(psi(i+1,j,1)+psi(i-1,j,1)+psi(i,j+1,1)+psi(i,j-1,1)-4*psi(i,j,1))/h2+(vv(i,j)-ee)*psi(i,j,1)
NEXT j
NEXT i
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET psi(i,j,0) = psi(i,j,0) - dumpingFactor*wrk(i,j,0)
LET psi(i,j,1) = psi(i,j,1) - dumpingFactor*wrk(i,j,1)
NEXT j
NEXT i
CALL normalize
END SUB
! ---------- utility
EXTERNAL FUNCTION systemTime !public
LET systemTime = sysTime
END FUNCTION
EXTERNAL FUNCTION norm !public <psi|psi>
LET p = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET p = p + (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))
NEXT j
NEXT i
LET norm = p*dx*dy
END FUNCTION
EXTERNAL SUB normalize
DECLARE EXTERNAL FUNCTION norm
LET a = 1/SQR(norm)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET psi(i,j,0) = psi(i,j,0)*a
LET psi(i,j,1) = psi(i,j,1)*a
NEXT j
NEXT i
END SUB
EXTERNAL FUNCTION potentialEnergy !--- <psi| V(x) |psi>
LET p = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET p = p + (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*vv(i,j)
NEXT j
NEXT i
LET potentialEnergy = p*dx*dy
END FUNCTION
EXTERNAL FUNCTION kineticEnergy !--- <psi| -0.5(d^2/dx^2+d^2/dy^2) |psi>
LET h2 = dx*dx
LET p = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET d2phRe = (psi(i+1,j,0)+psi(i-1,j,0)+psi(i,j+1,0)+psi(i,j-1,0)-4.0*psi(i,j,0))/h2
LET d2phIm = (psi(i+1,j,1)+psi(i-1,j,1)+psi(i,j+1,1)+psi(i,j-1,1)-4.0*psi(i,j,1))/h2
LET p = p + (psi(i,j,0)*d2phRe+psi(i,j,1)*d2phIm)
NEXT j
NEXT i
LET kineticEnergy = -0.5*p*dx*dy
END FUNCTION
EXTERNAL FUNCTION xProbabilityCurrentDensity(i,j) !--- Re(<psi| -i(d/dx) |psi>)
LET pRe = (psi(i+1,j,1)-psi(i-1,j,1))/(2*dx)
LET pIm = (-psi(i+1,j,0)+psi(i-1,j,0))/(2*dx)
LET xProbabilityCurrentDensity = psi(i,j,0)*pRe + psi(i,j,1)*pIm
END FUNCTION
EXTERNAL FUNCTION yProbabilityCurrentDensity(i,j) !--- Re(<psi| -i(d/dy) |psi>)
LET pRe = (psi(i,j+1,1)-psi(i,j-1,1))/(2*dy)
LET pIm = (-psi(i,j+1,0)+psi(i,j-1,0))/(2*dy)
LET yProbabilityCurrentDensity = psi(i,j,0)*pRe + psi(i,j,1)*pIm
END FUNCTION
! ---------- 3D graphics
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z) !shift*xRotateAx*yRotateAy*(shift^-1)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0, y1+cy0; !z=z1+cz0
END SUB
! ---------- draw wave
EXTERNAL SUB drawWave(drawMode)
DECLARE EXTERNAL FUNCTION kineticEnergy,potentialEnergy
DECLARE EXTERNAL SUB drawPsi2,drawCloud,draw3DPsi2,drawProbabilityCurrent,drawPsiPhase
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 THEN CALL drawPsi2
IF drawMode=1 THEN CALL drawCloud
IF drawMode=2 THEN CALL draw3DPsi2(-PI/4,-PI/12) !(xRotateAngle,yRotateAngle)
IF drawMode=3 THEN CALL drawProbabilityCurrent
IF drawMode=4 THEN CALL drawPsiPhase
!--- caption
LET ke = kineticEnergy
LET pe = potentialEnergy
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 0,-20 ,USING "time =#####.## (au) =####.#### (femto s)":sysTime,sysTime*auTime*1e15
PLOT TEXT, AT 0,-35 ,USING "norm of wave function =#.###############":norm
PLOT TEXT, AT 0,-50 ,USING "kinetic energy =#.###### (au) =##.### (eV)":ke,ke*27.2114
PLOT TEXT, AT 0,-65 ,USING "potential energy =#.###### (au) =##.### (eV)":pe,pe*27.2114
PLOT TEXT, AT 0,-80 ,USING "total energy =#.###### (au) =##.### (eV)":ke+pe,(ke+pe)*27.2114
PLOT TEXT, AT 0,-95 ,USING "Box =###.# x ###.# (au)":NNx*dx,NNx*dx
PLOT TEXT, AT 0,-110 :"wave packet - quantum electron dynamics 2D"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB drawPsi2 !drawMode=0
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET col = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*100
IF col>0.2 THEN
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 40+INT(col*100)
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN 0,0; 320,320 :psicol
END SUB
EXTERNAL SUB drawCloud !drawMode=1
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
LET srnd(0) = RND
FOR i = 1 TO 1000
LET srnd(i) = srnd(i-1) + RND
NEXT i
FOR i = 0 TO 1000
LET srnd(i) = srnd(i)/srnd(1000)
NEXT i
LET m = 0
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET cij = 0
LET s = s + (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*dx*dy
DO WHILE (s>srnd(m) AND m<1000)
LET m = m + 1
LET cij = cij + 1
LOOP
IF cij>0 THEN LET psicol(i,j) = 6 ! yellow
IF cij>3 THEN LET psicol(i,j) = 4 ! red
NEXT j
NEXT i
MAT PLOT CELLS,IN 0,0; 320,320 :psicol
END SUB
EXTERNAL SUB draw3DPsi2(xRotateAngle,yRotateAngle) !drawMode=2
DECLARE EXTERNAL SUB setRotateXYParameters,plotLines3D
LET sc = 320/NNx
LET zMag = 20
CALL setRotateXYParameters(xRotateAngle,yRotateAngle,NNx/2,NNy/2,0)
FOR j=0 TO NNy-1 STEP 2
FOR i=0 TO NNx-1
LET psi2 = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*300
IF psi2>0.2 THEN
SET LINE COLOR 13 !psi^2:dark yellow
ELSEIF vv(i,j)>2 THEN
SET LINE COLOR 10 !potential:dark green
ELSE
SET LINE COLOR 3 !potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi2 + vv(i,j))) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 2
FOR j=0 TO NNy-1
LET psi2 = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*300
IF psi2>0.2 THEN
SET LINE COLOR 13 !psi^2:dark yellow
ELSEIF vv(i,j)>2 THEN
SET LINE COLOR 10 !potential:dark green
ELSE
SET LINE COLOR 3 !potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi2 + vv(i,j))) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
EXTERNAL SUB drawProbabilityCurrent !drawMode=3
DECLARE EXTERNAL FUNCTION xProbabilityCurrentDensity,yProbabilityCurrentDensity
DECLARE EXTERNAL SUB drawPsi2
LET sc = 320/NNx
LET mag = 20000
CALL drawPsi2
SET LINE COLOR 4 !red
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET psi2 = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*100
IF psi2>0.4 AND MOD(i,4)=0 AND MOD(j ,4)=0 THEN
LET xp = xProbabilityCurrentDensity(i,j)*dt*mag
LET yp = yProbabilityCurrentDensity(i,j)*dt*mag
PLOT LINES: i*sc, j*sc; i*sc+xp,j*sc+yp
END IF
NEXT j
NEXT i
PLOT LINES
END SUB
EXTERNAL SUB drawPsiPhase !drawMode=4
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET col = (psi(i,j,0)*psi(i,j,0)+psi(i,j,1)*psi(i,j,1))*100
IF col>0.2 AND col>RND+0.2 THEN
IF abs(psi(i,j,0))>abs(psi(i,j,1)) THEN
IF psi(i,j,0)>=0 THEN LET psicol(i,j) = 6 ELSE LET psicol(i,j) = 5
ELSE
IF psi(i,j,1)>=0 THEN LET psicol(i,j) = 13 ELSE LET psicol(i,j) = 8
END IF
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN 0,0; 320,320 :psicol
END SUB
END MODULE
DO
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode,menu)
LET S$=INKEY$
IF S$="." THEN
EXIT DO
ELSEIF S$="0" THEN
!LOCATE VALUE (1),RANGE 10 TO 300 , AT 150 : temp
LOCATE VALUE (1),RANGE 0 TO 300 : temp
IF temp>1 THEN
LET tempMode = 1
LET contTemp = temp
ELSE
LET tempMode = 0
END IF
ELSEIF S$="1" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$="9" THEN
LOCATE CHOICE (menu$) :nmenu
IF nmenu=1 THEN !--- Ar N=36 box=6x6nm
CALL setInitialCondition(2,36,6,6,contTemp)
ELSEIF nmenu=2 THEN !--- Ar N=100 box=8x8nm
CALL setInitialCondition(2,100,8,8,contTemp)
ELSEIF nmenu=3 THEN !--- Ar N=300 box=12x12nm
CALL setInitialCondition(2,300,12,12,contTemp)
ELSEIF nmenu=4 THEN !--- Kr N=100 box=8x8nm
CALL setInitialCondition(3,100,8,8,contTemp)
ELSEIF nmenu=5 THEN !--- Xe N=100 box=8x8nm
CALL setInitialCondition(4,100,8,8,contTemp)
ELSEIF nmenu=6 THEN !--- Hg N=100 box=8x8nm
CALL setInitialCondition(5,100,8,8,contTemp)
ELSEIF nmenu=7 THEN !--- Ar N=500 box=15x15nm
CALL setInitialCondition(2,500,15,15,contTemp)
ELSEIF nmenu=8 THEN !contine
!
END IF
END IF
LOOP
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- Lennard-Jones md2d module ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
! = 24*epsilon*r6*(2*r6-1)/r, r6 = (sigma/r)^6
MODULE md2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molecKind,nMolecule,xMaximum,yMaximum,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC sysTime, dt, nMolec, xMax, yMax, sigma, mass, epsilon, rCutoff, hh
SHARE NUMERIC xx(500),yy(500) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC reg(500,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 12,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE NUMERIC forceTable(0 TO 1200) ! force table
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 36 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET mass = 39.95*1.661e-27 ! mass of Ar (kg)
LET sigma = 3.418e-10 ! Lennard-Jones potential sigma for Ar (m)
LET epsilon = 1.711e-21 ! Lennard-Jones potential epsilon FOR Ar (J)
LET rCutoff = 1e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(molecKind,nMolecule,xMaximum,yMaximum,contTemp)
DECLARE EXTERNAL SUB setMoreculesData,setForceTable,setMorecules
RANDOMIZE
! set particles
CALL setMoreculesData
LET sysTime = 0.0
LET nMolec = nMolecule
LET xMax = xMaximum*1e-9
LET yMax = yMaximum*1e-9
LET mass = molecData(molecKind,0)
LET epsilon = molecData(molecKind,1)
LET sigma = molecData(molecKind,2)
LET rCutoff = MIN(1e-9, 3*sigma)
CALL setForceTable
CALL setMorecules(nMolecule,contTemp)
! set window
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setMoreculesData
! 0:mass(in AU) 1:eps(in kB) 2:sigma(m) 3:dt(s)
DATA 4.003 , 10.2 , 2.576e-10 , 5.0e-15 ! 0 He
DATA 20.183 , 36.2 , 2.976e-10 , 10.0e-15 ! 1 Ne
DATA 39.948 , 124.0 , 3.418e-10 , 20.0e-15 ! 2 Ar
DATA 83.50 , 190.0 , 3.610e-10 , 20.0e-15 ! 3 Kr
DATA 131.30 , 229.0 , 4.055e-10 , 20.0e-15 ! 4 Xe
DATA 200.59 , 851.0 , 2.898e-10 , 20.0e-15 ! 5 Hg
DATA 2.016 , 33.3 , 2.968e-10 , 5.0e-15 ! 6 H2
DATA 28.013 , 91.5 , 3.681e-10 , 10.0e-15 ! 7 N2
DATA 31.999 , 113.0 , 3.433e-10 , 10.0e-15 ! 8 O2
DATA 18.015 , 809.1 , 2.641e-10 , 10.0e-15 ! 9 H2O
DATA 16.043 , 137.0 , 3.822e-10 , 10.0e-15 ! 10 CH4
DATA 44.010 , 190.0 , 3.996e-10 , 20.0e-15 ! 11 CO2
DATA 28.011 , 110.0 , 3.590e-10 , 10.0e-15 ! 12 CO
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 12
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.38e-23 !eps(kB) --> (J)
NEXT i
END IF
END SUB
EXTERNAL SUB setMorecules(nMolecule,contTemp)
DECLARE EXTERNAL SUB ajustVelocity
FOR j=1 TO nMolecule
LET loopCount = 0
DO
LET xx(j) = (xMax-2*sigma)*RND + sigma
LET yy(j) = (yMax-2*sigma)*RND + sigma
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2 < 2*sigma^2 THEN EXIT FOR
NEXT i
LET loopCount = loopCount + 1
IF loopCount>1000 THEN EXIT DO
LOOP UNTIL i>=j
IF loopCount>1000 THEN
LET nMolec = j - 1
EXIT FOR
END IF
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
CALL ajustVelocity(contTemp)
END SUB
! ---------- set force table
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ir=10 TO 1200
LET r = ir*hh
LET r6 = (sigma/r)^6
LET forceTable(ir) = cutoff(r,rCutoff)*(24*epsilon*r6*(2*r6-1)/r)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ir) = forceTable(10)
NEXT ir
END SUB
EXTERNAL FUNCTION cutoff(r,rCutoff)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
EXTERNAL FUNCTION force(r) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ir) + a*forceTable(ir+1))/hh
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB registerNearMolec,moveParticlesDT,ajustVelocity
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*sigma
LET rCut2 = rCutoff^2 ! force cutoff radius^2
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET r2ij = xij*xij+yij*yij
IF (r2ij<rCut2) THEN
LET rij = SQR(r2ij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)-boundaryForce(xMax+s-xx(i))
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)-boundaryForce(yMax+s-yy(i))
NEXT i
END SUB
!EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
! LET ri = sigma/r
! LET r6 = ri^6
! LET force = (24.0*epsilon*r6*(2.0*r6-1.0)/r)
!END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET adsorp = 0.5*1.67e-21 ! epsilon(Ar)=1.67e-21
LET ri = sigma/r
LET r6 = ri^6
LET boundaryForce = (24.0*adsorp*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
!EXTERNAL FUNCTION systemTime
! LET systemTime = sysTime
!END FUNCTION
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode,menu)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL PICTURE realSpace,velocitySpace
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:disk 1:circle+V+F
DRAW realSpace(drawMode)
ELSEIF drawMode=2 THEN
DRAW velocitySpace
END IF
!--- control key guide
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 10,480 :"'.':exit '0':Temp control (Temp<1 adiabatic mode)"
PLOT TEXT, AT 10,460 :"'1':changeGraph '9':select theme "
PLOT TEXT, AT 10,445 :"------------------------------------------------------"
!--- draw caption
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING "N =#### max number of near molec =###":nMolec,maxNearMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional molecular dynamics"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL PICTURE realSpace(drawMode)
LET boxSize = 300
LET deltat = 2e-14 !(s)
LET sc = boxSize/xMax
LET xp = 100
LET yp = 100
LET vScate = 100*deltat !velocity line length = v*100*deltat
LET fScale = 1000*deltat*deltat/mass
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; xp+boxSize,yp; xp+boxSize,yp+boxSize; xp,yp+boxSize; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,yp+boxSize+2 ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
IF drawMode=1 THEN !--- draw circle, velocity and force
SET LINE COLOR 2 ! blue : molecule
DRAW circle WITH SCALE(sigma/2.0*sc)*SHIFT(xp+xx(i)*sc,yp+yy(i)*sc)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp+xx(i)*sc,yp+yy(i)*sc;
PLOT LINES: xp+(xx(i)+vx(i)*vScate)*sc,yp+(yy(i)+vy(i)*vScate)*sc
SET LINE COLOR 1 ! black : force
PLOT LINES: xp+xx(i)*sc,yp+yy(i)*sc;
PLOT LINES: xp+(xx(i)+ffx(i)*fScale)*sc,yp+(yy(i)+ffy(i)*fScale)*sc
ELSE !--- draw disk
SET AREA COLOR 2 ! blue : molecule
DRAW disk WITH SCALE(sigma/2*sc)*SHIFT(xp+xx(i)*sc,yp+yy(i)*sc)
END IF
NEXT i
IF drawMode=1 THEN
LET xp = 100+boxSize*0.6
LET yp = 100+boxSize+25
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp,yp;xp+23,yp
SET TEXT COLOR 4 ! red
PLOT TEXT, AT xp+30,yp-4: "velosity"
SET LINE COLOR 1 ! black : force
PLOT LINES: xp,yp-15;xp+23,yp-15
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp+30,yp-19: "force"
END IF
END PICTURE
EXTERNAL PICTURE velocitySpace
LET boxSize = 300
LET xp = 100+boxSize/2
LET yp = 100+boxSize/2
SET LINE COLOR 1 !black : axis
PLOT LINES: 100,yp; 100+boxSize,yp !vx-axis
PLOT LINES: xp,100; xp,100+boxSize !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 100+boxSize,yp: "vx"
PLOT TEXT, AT 100+boxSize,yp-12: "1000m/s"
PLOT TEXT, AT xp-12,100+boxSize: "vy 1000m/s"
PLOT TEXT, AT xp-8,yp-10: "0"
PLOT TEXT, AT 100,100+boxSize+8: "velocity space (vx,vy)"
LET sc = boxSize/2000
FOR i=1 TO nMolec
SET LINE COLOR 2 ! blue
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*sc+xp,vy(i)*sc+yp)
NEXT i
END PICTURE
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
DIM M(4,4),POINT(4),ROTXY(4,4),ROTXZ(4,4),ROTYU(4,4),ROTYZ(4,4),ROTXU(4,4),ROTZU(4,4)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
LOCATE VALUE NOWAIT(1),RANGE -180 TO 180,AT 0:XY
LOCATE VALUE NOWAIT(2),RANGE -180 TO 180,AT 0:XZ
LOCATE VALUE NOWAIT(3),RANGE -180 TO 180,AT 0:YU
LOCATE VALUE NOWAIT(4),RANGE -180 TO 180,AT 0:YZ
LOCATE VALUE NOWAIT(5),RANGE -180 TO 180,AT 0:XU
DO
LOCATE VALUE NOWAIT(1):XY
LOCATE VALUE NOWAIT(2):XZ
LOCATE VALUE NOWAIT(3):YU
LOCATE VALUE NOWAIT(4):YZ
LOCATE VALUE NOWAIT(5):XU
MAT ROTXY=IDN !'XY平面上の回転(ZU平面を軸とする回転)
LET ROTXY(1,1)=COS(XY)
LET ROTXY(1,2)=SIN(XY)
LET ROTXY(2,1)=-SIN(XY)
LET ROTXY(2,2)=COS(XY)
MAT ROTXZ=IDN !'XZ平面上の回転(YU平面を軸とする回転)
LET ROTXZ(1,1)=COS(XZ)
LET ROTXZ(1,3)=-SIN(XZ)
LET ROTXZ(3,1)=SIN(XZ)
LET ROTXZ(3,3)=COS(XZ)
MAT ROTYU=IDN !'YU平面上の回転(XZ平面を軸とする回転)
LET ROTYU(2,2)=COS(YU)
LET ROTYU(2,4)=-SIN(YU)
LET ROTYU(4,2)=SIN(YU)
LET ROTYU(4,4)=COS(YU)
MAT ROTYZ=IDN !'YZ平面上の回転(XU平面を軸とする回転)
LET ROTYZ(2,2)=COS(YZ)
LET ROTYZ(2,3)=SIN(YZ)
LET ROTYZ(3,2)=-SIN(YZ)
LET ROTYZ(3,3)=COS(YZ)
MAT ROTXU=IDN !'XU平面上の回転(YZ平面を軸とする回転)
LET ROTXU(1,1)=COS(XU)
LET ROTXU(1,4)=SIN(XU)
LET ROTXU(4,1)=-SIN(XU)
LET ROTXU(4,4)=COS(XU)
MAT ROTZU=IDN !'ZU平面上の回転(XY平面を軸とする回転)
LET ROTZU(3,3)=COS(ZU)
LET ROTZU(3,4)=-SIN(ZU)
LET ROTZU(4,3)=SIN(ZU)
LET ROTZU(4,4)=COS(ZU)
MAT M=ROTXY*ROTXZ*ROTYU*ROTYZ*ROTXU*ROTZU
SET DRAW MODE HIDDEN
CLEAR
CALL CUBE(0,0,0,0,L)
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
LET FL=1
END IF
SET DRAW MODE EXPLICIT
LOOP
SUB PLOT(X,Y,Z,U)
LET POINT(1)=X
LET POINT(2)=Y
LET POINT(3)=Z
LET POINT(4)=U
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1),POINT(2);
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,U1,X2,Y2,Z2,U2)
PLOT LINES
CALL PLOT(X1,Y1,Z1,U1)
CALL PLOT(X2,Y2,Z2,U2)
PLOT LINES
END SUB
SUB CUBE(X,Y,Z,U,L)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y+L/2,Z-L/2,U)
CALL PLOT(X+L/2,Y+L/2,Z-L/2,U)
SET LINE COLOR 4
CALL PLOT(X+L/2,Y+L/2,Z+L/2,U)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y+L/2,Z+L/2,U)
SET LINE COLOR 4
CALL PLOT(X-L/2,Y+L/2,Z-L/2,U)
PLOT LINES
CALL PLOT(X-L/2,Y-L/2,Z-L/2,U)
SET LINE COLOR 2
CALL PLOT(X+L/2,Y-L/2,Z-L/2,U)
SET LINE COLOR 4
CALL PLOT(X+L/2,Y-L/2,Z+L/2,U)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y-L/2,Z+L/2,U)
SET LINE COLOR 4
CALL PLOT(X-L/2,Y-L/2,Z-L/2,U)
PLOT LINES
SET LINE COLOR 3
CALL PLOTLINE(X-L/2,Y+L/2,Z-L/2,U,X-L/2,Y-L/2,Z-L/2,U)
CALL PLOTLINE(X+L/2,Y+L/2,Z-L/2,U,X+L/2,Y-L/2,Z-L/2,U)
CALL PLOTLINE(X+L/2,Y+L/2,Z+L/2,U,X+L/2,Y-L/2,Z+L/2,U)
CALL PLOTLINE(X-L/2,Y+L/2,Z+L/2,U,X-L/2,Y-L/2,Z+L/2,U)
END SUB
END
EXTERNAL SUB DISPLAY(P$(,),A$())
FOR I=1 TO 3
PRINT A$(I);"'=";
FOR J=1 TO 2
PRINT A$(J);"*";P$(I,J);"+";
NEXT J
PRINT A$(3);"*";P$(I,3)
NEXT I
PRINT
END SUB
EXTERNAL SUB MATRIX(D$(,),A$(,),B$(,),C$(,))
FOR I=1 TO 3
FOR J=1 TO 3
FOR K=1 TO 3
FOR L=1 TO 3
IF A$(I,K)<>"0" AND B$(K,L)<>"0" AND C$(L,J)<>"0" THEN
LET S$=S$ &"+"& A$(I,K) &"*" &B$(K,L) & "*" & C$(L,J)
END IF
NEXT L
NEXT K
IF LEFT$(S$,1)="+" THEN LET S$=RIGHT$(S$,LEN(S$)-1)
LET L=POS(S$,"1*")
IF L>0 THEN LET S$(L:L+1)=""
LET L=POS(S$,"*1")
IF L>0 THEN LET S$(L:L+1)=""
LET D$(I,J)="["&S$&"]"
LET S$=""
NEXT J
NEXT I
END SUB
LET NN=5
LET MM=3
DIM A$(MM,NN,NN),X$(NN,NN)
LET S$="abcdefghijklmnopqrstuvwxyz"
FOR M=1 TO MM
FOR I=1 TO NN
FOR J=1 TO NN
LET A$(M,I,J)=S$(M:M)&STR$(I)&STR$(J)
NEXT J
NEXT I
NEXT M
FOR I=2 TO NN
FOR P=2 TO MM
CALL MATRIX(P+1,I,A$,X$)
FOR J=1 TO I
FOR M=1 TO P
PRINT "(";
FOR K=1 TO I-1
PRINT A$(M,J,K);" ";
NEXT K
PRINT A$(M,J,I);")";
NEXT M
PRINT
NEXT J
PRINT "="
CALL DISPLAY(I,X$)
NEXT P
NEXT I
END
EXTERNAL SUB MATRIX(M,N,A$(,,),X$(,))
DIM A(0 TO M)
MAT A=CON
DO
LET K=M
LET SS$=SS$&"+"&A$(1,A(1),A(3))
FOR J=2 TO M-2
LET SS$=SS$&"*"&A$(J,A(J+1),A(J+2))
NEXT J
LET SS$=SS$&"*"&A$(M-1,A(M),A(2))
LET FL=0
FOR J=3 TO M
IF A(J)<>N THEN LET FL=1
NEXT J
IF FL=0 THEN
LET SS$(1:1)=""
LET X$(A(1),A(2))=SS$
LET SS$=""
END IF
DO WHILE A(K)=N
LET A(K)=1
LET K=K-1
LOOP
LET A(K)=A(K)+1
LOOP UNTIL K=0
END SUB
EXTERNAL SUB DISPLAY(N,P$(,))
FOR I=1 TO N
PRINT "(";
FOR J=1 TO N-1
PRINT P$(I,J);" ";
NEXT J
PRINT P$(I,N);")"
NEXT I
PRINT
END SUB
LET MM=3
DIM N(0 TO MM+1)
FOR I=1 TO MM+1
READ N(I) !'N(1)行N(2)列 , N(2)行N(3)列 , N(3)行N(4)列 , N(4)行N(5)列...
NEXT I
DATA 2,3,4,5,6,7
DIM A$(MM,MAX1(N),MAX2(N)),X$(N(1),N(MM+1))
LET S$="abcdefghijklmnopqrstuvwxyz"
FOR M=1 TO MM
FOR I=1 TO N(M)
FOR J=1 TO N(M+1)
LET A$(M,I,J)=S$(M:M)&STR$(I)&STR$(J)
NEXT J
NEXT I
NEXT M
CALL MATRIX(MM+1,N,A$,X$)
FOR J=1 TO MAX1(N)
FOR M=1 TO MM
IF J<=N(M) THEN
PRINT "(";
FOR K=1 TO N(M+1)-1
PRINT A$(M,J,K);" ";
NEXT K
PRINT A$(M,J,N(M+1));")";
ELSE
FOR K=1 TO N(M+1)
PRINT " ";
NEXT K
PRINT " ";
END IF
NEXT M
PRINT
NEXT J
PRINT "="
CALL DISPLAY(N(1),N(MM+1),X$)
END
EXTERNAL SUB MATRIX(M,N(),A$(,,),X$(,))
DIM A(0 TO M),L(0 TO M)
MAT A=CON
LET L(1)=1
LET L(2)=M
FOR I=3 TO M
LET L(I)=I-1
NEXT I
DO
LET K=M
LET SS$=SS$&"+"&A$(1,A(1),A(3))
FOR J=2 TO M-2
LET SS$=SS$&"*"&A$(J,A(J+1),A(J+2))
NEXT J
LET SS$=SS$&"*"&A$(M-1,A(M),A(2))
LET FL=0
FOR J=3 TO M
IF A(J)<>N(L(J)) THEN LET FL=1
NEXT J
IF FL=0 THEN
LET SS$(1:1)=""
LET X$(A(1),A(2))=SS$
LET SS$=""
END IF
DO WHILE A(K)=N(L(K))
LET A(K)=1
LET K=K-1
LOOP
LET A(K)=A(K)+1
LOOP UNTIL K=0
END SUB
EXTERNAL SUB DISPLAY(N1,N2,P$(,))
FOR I=1 TO N1
PRINT "(";
FOR J=1 TO N2-1
PRINT P$(I,J);" ";
NEXT J
PRINT P$(I,N2);")"
NEXT I
PRINT
END SUB
EXTERNAL FUNCTION MAX1(N())
FOR I=1 TO UBOUND(N)-1
LET X=MAX(X,N(I))
NEXT I
LET MAX1=X
END FUNCTION
EXTERNAL FUNCTION MAX2(N())
FOR I=2 TO UBOUND(N)
LET X=MAX(X,N(I))
NEXT I
LET MAX2=X
END FUNCTION
!30n+k篩 50億までの素数を数える。π(5E9)234954223個
OPTION ARITHMETIC NATIVE
LET t0=TIME
LET kb=5E9
LET k6=70709 !60億,77447 10億,31607 1億,9973
LET k2=7004 !60億,7608 10億,3401 1億,1229
!エラトステネスの篩
LET Fu=k6
DIM P(Fu)
DIM A(k2) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
DIM B(8)
DATA 1,7,11,13,17,19,23,29
MAT READ B
LET Q=30
LET U=IP(kb/Q)+1
LET kd=IP(kb/207)
DIM D(U)
LET cj=10
FOR r=1 TO 8
LET rr=B(r)
MAT D = ZER
FOR t=4 TO k2
LET x=A(t)
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 80
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 80
END IF
FOR i=0 TO x
IF MOD(Q*i-rr,x)=0 THEN
LET y=-i
GOTO 80
EXIT FOR
END IF
NEXT i
80 FOR f=1 TO kd
IF x*f+y>U THEN EXIT FOR
LET D(x*f+y)=1
NEXT f
NEXT t
FOR n=1 TO U
IF D(n)=0 THEN
IF n*Q+rr>kb THEN EXIT FOR
LET cj=cj+1
END IF
NEXT n
NEXT r
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
----------------------------------
課題
不完全なループ
FOR i=0 TO x
IF MOD(Q*i-rr,x)=0 THEN
LET y=-i
GOTO 80
EXIT FOR
END IF
NEXT i
試験環境：
本プログラムは十進BASIC 6.6.0 / macOS 10.7.5, 十進BASIC Ver 7.7.8 / windows 10,
BASIC Acc 0.9.8.1 / windows 10でテストしました。
計算時間の比較： BASIC778 BASICAcc BASIC660
Ar 100個 Box 5x5x5nm 111.64s 33.05s 149.98s
Ar 300個 Box 6x6x6nm 895.07s 211.82s 850.09s
Ar 500個 Box 8x8x8nm 2428.13s 545.67s 2240.29s
BASIC778: BASIC 7.7.8 / windows 10 64bit / FMV-A561D CPU intel core-i5 2400M (2.5GHz) 4GB
BASICAcc: BASIC Acc 0.9.8.1 / windows 10 64bit / FMV-A561D CPU intel core-i5 2400M (2.5GHz) 4GB
BASIC660: BASIC 6.6.0 / MAC OS 10.7.5 / mac mini Intel Core-i7 (2.7GHz) 4GB
高速化の手法を用いていないため、分子数が増えると急激に計算時間がかかるようになります。
---------------------
!
! ========= molecular dynamics 3D ==========
!
! 006ArGasMD3D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.02.26 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB md3d.setInitialCondition, md3d.moveParticles, md3d.drawParticles
LET Ax = PI/12 ! rotate angle around x-axis
LET Ay = -PI/6 ! rotate angle around y-axis
LET dAy = 0.5*(PI/180) ! Ay <- Ay+dAy, Ay:rotate angle around y-axis
!setInitialCondition(nMolecule,xMaximum,yMaximum,zMaximum,contTemp)
CALL setInitialCondition(100,5,5,5,200)
!CALL setInitialCondition(300,6,6,6,200)
!CALL setInitialCondition(500,8,8,8,200)
LET t0 = TIME
FOR it=1 TO 1000
LET Ay = Ay+dAy
FOR i=1 TO 10
CALL moveParticles
NEXT i
CALL drawParticles(Ax,Ay)
NEXT it
!PRINT TIME - t0
END
! ---------- Lennard-Jones md3d module ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
! = 24*epsilon*r6*(2*r6-1)/r, r6 = (sigma/r)^6
!
MODULE md3d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition,moveParticles,drawParticles
SHARE NUMERIC sysTime, dt, nMolec, xMax, yMax, zMax, mass, sigma, epsilon
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy, cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC xx(500),yy(500),zz(500) ! (xx(i),yy(i),zz(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500),vz(500) ! (vx(i),vy(i),vz(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500),ffz(500) ! (ffx(i),ffy(i),ffz(i)): total force of i-th particle
SHARE NUMERIC ppx(500),ppy(500),ppz(500) ! (ppx(i),ppy(i),ppz(i)): rotated particle position
SHARE NUMERIC srtzix(500) ! sort ppz(i) : sort z --> ppz(srtzix(i))
!SHARE NUMERIC molecData(0 TO 12,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE NUMERIC xApex(0 TO 7),yApex(0 TO 7),zApex(0 TO 7) ! boxApex x- y- z-coordinate
SHARE NUMERIC pxApex(0 TO 7),pyApex(0 TO 7),pzApex(0 TO 7) ! rotated boxApex x- y- z-coordinate
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2) ! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
LET sysTime = 0.0 ! system time (s)
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 5.0E-9 ! x-Box size (m)
LET yMax = 5.0E-9 ! y-Box size (m)
LET zMax = 5.0e-9 ! z-Box size (m)
LET mass = 39.948*1.661e-27 ! mass of Ar (kg)
LET sigma = 3.418e-10 ! Lennard-Jones potential sigma for Ar (m)
LET epsilon =1.711e-21 ! Lennard-Jones potential epsilon FOR Ar (J)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(nMolecule,xMaximum,yMaximum,zMaximum,contTemp)
DECLARE EXTERNAL SUB setMorecules,setBox
RANDOMIZE
LET sysTime = 0.0
LET nMolec = nMolecule
LET xMax = xMaximum*1e-9
LET yMax = yMaximum*1e-9
LET zMax = zMaximum*1e-9
CALL setMorecules(nMolecule,contTemp)
CALL setBox
!set color mix
FOR i = 0 TO 100 !--- set color pallet
SET COLOR MIX(150+i) 0,0.01*i,0 !the darker green, the deeper z-position
NEXT i
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMorecules(nMolecule,contTemp)
DECLARE EXTERNAL SUB ajustVelocity
FOR j=1 TO nMolecule
LET loopCount = 0
DO
LET xx(j) = (xMax-2*sigma)*RND + sigma
LET yy(j) = (yMax-2*sigma)*RND + sigma
LET zz(j) = (zMax-2*sigma)*RND + sigma
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2+(zz(i)-zz(j))^2 < 2*sigma^2 THEN EXIT FOR
NEXT i
LET loopCount = loopCount + 1
IF loopCount>1000 THEN EXIT DO
LOOP UNTIL i>=j
IF loopCount>1000 THEN
LET nMolec = j - 1
EXIT FOR
END IF
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vz(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET ffz(i) = 0.0
NEXT i
CALL ajustVelocity(contTemp)
END SUB
EXTERNAL SUB setBox
IF boxEdge(11,1)<>7 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
FOR i=0 TO 7
READ x,y,z
LET xApex(i) = x*xMax
LET yApex(i) = y*yMax
LET zApex(i) = z*zMax
NEXT i
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
! ---------- move particles
EXTERNAL SUB moveParticles ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET vz(i) = vz(i)+a*ffz(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
LET zz(i) = zz(i)+vz(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET vz(i) = vz(i)+a*ffz(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*sigma
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET ffz(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR j=i+1 TO nMolec
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET zij = zz(i)-zz(j)
LET rij = SQR(xij*xij+yij*yij+zij*zij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET fzij = f*zij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffz(i) = ffz(i)+fzij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
LET ffz(j) = ffz(j)-fzij
NEXT j
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)-boundaryForce(xMax+s-xx(i))
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)-boundaryForce(yMax+s-yy(i))
LET ffz(i) = ffz(i)+boundaryForce(zz(i)+s)-boundaryForce(zMax+s-zz(i))
NEXT i
END SUB
EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
LET ri = sigma/r
LET r6 = ri^6
LET force = (24.0*epsilon*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET ri = sigma/r
LET r6 = ri^6
LET boundaryForce = (24.0*(0.5*epsilon)*r6*(2.0*r6-1.0)/r)
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2+vz(i)^2)
NEXT i
LET systemTemprature = 2*ek/(3*nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
LET vz(i) = r*vz(i)
NEXT i
END SUB
! ---------- 3D graphics aid
EXTERNAL SUB setRotateXY(angleX,angleY)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = 0.5*xMax
LET cy0 = 0.5*yMax
LET cz0 = 0.5*zMax
END SUB
EXTERNAL SUB rotateXY !particles and box apex
FOR i=1 TO nMolec
LET ppx(i) = cosAy*(xx(i)-cx0)+sinAy*(sinAx*(yy(i)-cy0)+cosAx*(zz(i)-cz0)) + cx0
LET ppy(i) = cosAx*(yy(i)-cy0)-sinAx*(zz(i)-cz0) + cy0
LET ppz(i) =-sinAy*(xx(i)-cx0)+cosAy*(sinAx*(yy(i)-cy0)+cosAx*(zz(i)-cz0)) + cz0
NEXT i
FOR i=0 TO 7
LET pxApex(i) = cosAy*(xApex(i)-cx0)+sinAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cx0
LET pyApex(i) = cosAx*(yApex(i)-cy0)-sinAx*(zApex(i)-cz0) + cy0
LET pzApex(i) =-sinAy*(xApex(i)-cx0)+cosAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cz0
NEXT i
END SUB
EXTERNAL SUB markFarEdge
! seek far apex --> iMin
LET zMin = pzApex(0)
LET iMin = 0
FOR i=1 TO 7
IF zMin>pzApex(i) THEN
LET zMin = pzApex(i)
LET iMin = i
END IF
NEXT i
!mark far edge
FOR iEdge = 0 TO 11
LET boxEdge(iEdge,2) = 0
IF (boxEdge(iEdge,0)=iMin OR boxEdge(iEdge,1)=iMin) THEN LET boxEdge(iEdge,2) = 1
NEXT iEdge
END SUB
EXTERNAL SUB sortz
DECLARE EXTERNAL SUB qSort
FOR i=1 TO nMolec
LET srtzix(i) = i
NEXT i
CALL qSort(ppz,srtzix,1,nMolec)
END SUB
EXTERNAL SUB qSort(m(),a(),le,ri) !modified decimal BASIC library
IF ri>le THEN
LET i=le-1
LET j=ri
LET pv=m(a(ri))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(ri)
LET a(ri)=t
CALL qSort(m,a,le,i-1)
CALL qSort(m,a,i+1,ri)
END IF
END SUB
EXTERNAL SUB plotNearEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=0 THEN !far edge mark = 0
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotFarEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=1 THEN !far edge mark = 1
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotEdge(iEdge,mag,xp,yp,lineColor)
SET LINE COLOR lineColor
FOR i=0 TO 1
LET iApex = boxEdge(iEdge,i)
PLOT LINES: pxApex(iApex)*mag+xp, pyApex(iApex)*mag+yp;
NEXT i
PLOT LINES
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(Ax,Ay) !Ax:rotate angle around s-axis, Ay:rotate angle around y-axis
DECLARE EXTERNAL FUNCTION systemTemprature
DECLARE EXTERNAL SUB setRotateXY,rotateXY,sortz,markFarEdge,plotFarEdge,plotNearEdge
LET sc = 200/xMax ! 200=boxsize in graphic window
LET xp = 150
LET yp = 120
CALL setRotateXY(Ax,Ay)
CALL rotateXY !xx(i),yy(i),zz(i) rotate--> ppx(i),ppy(i),ppz(i)
CALL sortz !sort ppz(i) : ppz(srtzix(1))<ppz(srtzix(2))<...<ppz(srtzix(nMolec))
CALL markFarEdge ! boxEdge(iEdge,2)=1:far side edge or 0:near side edge
SET DRAW MODE HIDDEN
CLEAR
CALL plotFarEdge(sc,xp,yp,8) !8:gray
FOR i=1 TO nMolec
LET j = srtzix(i)
SET AREA COLOR 150+int((ppz(j)/zMax+1)*40) ! the darker green, the deeper z-position
DRAW disk WITH SCALE(0.5*sigma*sc)*SHIFT(ppx(j)*sc+xp,ppy(j)*sc+yp)
NEXT i
CALL plotNearEdge(sc,xp,yp,1) !1:black
!draw caption
SET TEXT HEIGHT 8
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,40 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50,25 ,USING "box size =##.# x ##.# x ##.# (nm) N=###":xMax*1e9,yMax*1e9,zMax*1e9,nMolec
PLOT TEXT, AT 50,10 :"Ar in the box (3D molecular dynamics)"
PLOT TEXT, AT 50,380 ,USING "Ax =####.#(deg) Ay =####.#(deg)":MOD(Ax*180/PI,360),MOD(Ay*180/PI,360)
SET DRAW MODE EXPLICIT
END SUB
試験環境：
本プログラムは十進BASIC 6.6.0 / macOS 10.7.5, 十進BASIC Ver 7.7.8 / windows 10,
BASIC Acc 0.9.8.1 / windows 10でテストしました。
計算時間の比較： BASIC778 BASICAcc BASIC660
Ar 100個 Box 5x5x5nm 24.77s 15.31s 83.49s
Ar 300個 Box 6x6x6nm 102.83s 50.44s 149.98s
Ar 500個 Box 8x8x8nm 186.37s 89.14s 232.08s
BASIC778: BASIC 7.7.8 / windows 10 64bit / FMV-A561D CPU intel core-i5 2400M (2.5GHz) 4GB
BASICAcc: BASIC Acc 0.9.8.1 / windows 10 64bit / FMV-A561D CPU intel core-i5 2400M (2.5GHz) 4GB
BASIC660: BASIC 6.6.0 / MAC OS 10.7.5 / mac mini Intel Core-i7 (2.7GHz) 4GB
高速化の手法により、分子数が増えても、ほぼ粒子数に比例した計算時間になります。
---------------------
!
! ========= molecular dynamics 3D ==========
!
! 007fastLJMD3D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.03.02 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB md3d.setInitialCondition, md3d.moveParticles, md3d.drawParticles
LET Ax = PI/12 ! rotate angle around x-axis
LET Ay = -PI/6 ! rotate angle around y-axis
LET dAy = 0.5*(PI/180) ! Ay <- Ay+dAy, Ay:rotate angle around y-axis
LET t0 = TIME
FOR it=1 TO 1000
LET Ay = Ay+dAy
CALL moveParticles(0,200) !(tempMode,contTemp) : tempMode 0:adiabatic 1:constant-temp
CALL drawParticles(Ax,Ay)
NEXT it
!PRINT time-t0
END
! ---------- Lennard-Jones md3d module ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
! = 24*epsilon*r6*(2*r6-1)/r, r6 = (sigma/r)^6
!
MODULE md3d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition,moveParticles,drawParticles
SHARE NUMERIC sysTime, dt, nMolec, xMax, yMax, zMax, molecKind, mass, sigma, epsilon, rCutoff, hh
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy, cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC xx(500),yy(500),zz(500) ! (xx(i),yy(i),zz(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500),vz(500) ! (vx(i),vy(i),vz(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500),ffz(500) ! (ffx(i),ffy(i),ffz(i)): total force of i-th particle
SHARE NUMERIC ppx(500),ppy(500),ppz(500) ! (ppx(i),ppy(i),ppz(i)): rotated particle position
SHARE NUMERIC srtzix(500) ! sort ppz(i) : sort z --> ppz(srtzix(i))
SHARE NUMERIC reg(500,0 TO 300) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 12,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE NUMERIC xApex(0 TO 7),yApex(0 TO 7),zApex(0 TO 7) ! boxApex x- y- z-coordinate
SHARE NUMERIC pxApex(0 TO 7),pyApex(0 TO 7),pzApex(0 TO 7) ! rotated boxApex x- y- z-coordinate
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2) ! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
SHARE NUMERIC forceTable(0 TO 1200) ! force table
SHARE STRING molecStr$(0 TO 12)
LET sysTime = 0.0 ! system time (s)
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 5.0E-9 ! x-Box size (m)
LET yMax = 5.0E-9 ! y-Box size (m)
LET zMax = 5.0e-9 ! z-Box size (m)
LET molecKind = 2 ! molecule kind ( 2:Ar )
LET mass = 39.948*1.661e-27! mass of Ar (kg)
LET sigma = 3.418e-10 ! Lennard-Jones potential sigma for Ar (m)
LET epsilon =1.711e-21 ! Lennard-Jones potential epsilon FOR Ar (J)
LET rCutoff = 1e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0) = 0 ! if molecData(0,0)=0 then mat read molecData
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(moleculeKind,nMolecule,xMaximum,yMaximum,zMaximum,contTemp)
DECLARE EXTERNAL SUB setMoreculesData,setForceTable,setMorecules,setBox
RANDOMIZE
CALL setMoreculesData
LET sysTime = 0.0
LET molecKind = moleculeKind
LET nMolec = nMolecule
LET xMax = xMaximum*1e-9
LET yMax = yMaximum*1e-9
LET zMax = zMaximum*1e-9
LET mass = molecData(molecKind,0)
LET sigma = molecData(molecKind,2)
LET epsilon = molecData(molecKind,1)
LET rCutoff = MIN(1e-9, 3*sigma)
CALL setForceTable
CALL setMorecules(nMolecule,contTemp)
CALL setBox
!set color mix
FOR i = 0 TO 100 !--- set color pallet
SET COLOR MIX(150+i) 0,0.01*i,0 !the darker green, the deeper z-position
NEXT i
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMoreculesData
! 0:mass(in AU) 1:eps(in kB) 2:sigma(m) 3:dt(s)
DATA 4.003 , 10.2 , 2.576e-10 , 5.0e-15 ! 0 He
DATA 20.183 , 36.2 , 2.976e-10 , 10.0e-15 ! 1 Ne
DATA 39.948 , 124.0 , 3.418e-10 , 20.0e-15 ! 2 Ar
DATA 83.50 , 190.0 , 3.610e-10 , 20.0e-15 ! 3 Kr
DATA 131.30 , 229.0 , 4.055e-10 , 20.0e-15 ! 4 Xe
DATA 200.59 , 851.0 , 2.898e-10 , 20.0e-15 ! 5 Hg
DATA 2.016 , 33.3 , 2.968e-10 , 5.0e-15 ! 6 H2
DATA 28.013 , 91.5 , 3.681e-10 , 10.0e-15 ! 7 N2
DATA 31.999 , 113.0 , 3.433e-10 , 10.0e-15 ! 8 O2
DATA 18.015 , 809.1 , 2.641e-10 , 10.0e-15 ! 9 H2O
DATA 16.043 , 137.0 , 3.822e-10 , 10.0e-15 ! 10 CH4
DATA 44.010 , 190.0 , 3.996e-10 , 20.0e-15 ! 11 CO2
DATA 28.011 , 110.0 , 3.590e-10 , 10.0e-15 ! 12 CO
!
! 0 1 2 3 4 5 6 7 8 9 10 11 12
DATA "He", "Ne", "Ar", "Kr", "Xe", "Hg", "H2", "N2", "O2", "H2O", "CH4", "CO2", "CO"
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 12
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.38e-23 !eps(kB) --> (J)
NEXT i
MAT READ molecStr$
END IF
END SUB
EXTERNAL SUB setMorecules(nMolecule,contTemp)
DECLARE EXTERNAL SUB ajustVelocity
FOR j=1 TO nMolecule
LET loopCount = 0
DO
LET xx(j) = (xMax-2*sigma)*RND + sigma
LET yy(j) = (yMax-2*sigma)*RND + sigma
LET zz(j) = (zMax-2*sigma)*RND + sigma
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2+(zz(i)-zz(j))^2 < 2*sigma^2 THEN EXIT FOR
NEXT i
LET loopCount = loopCount + 1
IF loopCount>1000 THEN EXIT DO
LOOP UNTIL i>=j
IF loopCount>1000 THEN
LET nMolec = j - 1
EXIT FOR
END IF
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vz(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET ffz(i) = 0.0
NEXT i
CALL ajustVelocity(contTemp)
END SUB
EXTERNAL SUB setBox
IF boxEdge(11,1)<>7 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
FOR i=0 TO 7
READ x,y,z
LET xApex(i) = x*xMax
LET yApex(i) = y*yMax
LET zApex(i) = z*zMax
NEXT i
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
! ---------- set force table
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ir=10 TO 1200
LET r = ir*hh
LET ri = sigma/r
LET r6 = ri^6
LET forceTable(ir) = cutoff(r,rCutoff)*(24*epsilon*r6*(2*r6-1)/r)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ir) = forceTable(10)
NEXT ir
END SUB
EXTERNAL FUNCTION cutoff(r,rCutoff)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
EXTERNAL FUNCTION force(r) !force(r) <-- forceTable
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ir) + a*forceTable(ir+1))/hh
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB registerNearMolec,moveParticlesDT,ajustVelocity
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 10
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET vz(i) = vz(i)+a*ffz(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
LET zz(i) = zz(i)+vz(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET vz(i) = vz(i)+a*ffz(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*sigma
LET rCut2 = rCutoff^2 !(3*sigma)^2 ! force cutoff rij>3*sigma
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET ffz(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET zij = zz(i)-zz(j)
LET r2ij = xij*xij+yij*yij+zij*zij
IF (r2ij<rCut2) THEN
LET rij = SQR(r2ij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET fzij = f*zij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffz(i) = ffz(i)+fzij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
LET ffz(j) = ffz(j)-fzij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)-boundaryForce(xMax+s-xx(i))
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)-boundaryForce(yMax+s-yy(i))
LET ffz(i) = ffz(i)+boundaryForce(zz(i)+s)-boundaryForce(zMax+s-zz(i))
NEXT i
END SUB
!EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
! LET ri = sigma/r
! LET r6 = ri^6
! LET force = (24.0*epsilon*r6*(2.0*r6-1.0)/r)
!END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET ri = sigma/r
LET r6 = ri^6
LET boundaryForce = (24.0*(0.5*epsilon)*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+10*2000*dt !3*sigma+10*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))+(zz(i)-zz(j))*(zz(i)-zz(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2+vz(i)^2)
NEXT i
LET systemTemprature = 2*ek/(3*nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
LET vz(i) = r*vz(i)
NEXT i
END SUB
! ---------- 3D graphics aid
EXTERNAL SUB setRotateXY(angleX,angleY)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = 0.5*xMax
LET cy0 = 0.5*yMax
LET cz0 = 0.5*zMax
END SUB
EXTERNAL SUB rotateXY !particles and box apex
FOR i=1 TO nMolec
LET ppx(i) = cosAy*(xx(i)-cx0)+sinAy*(sinAx*(yy(i)-cy0)+cosAx*(zz(i)-cz0)) + cx0
LET ppy(i) = cosAx*(yy(i)-cy0)-sinAx*(zz(i)-cz0) + cy0
LET ppz(i) =-sinAy*(xx(i)-cx0)+cosAy*(sinAx*(yy(i)-cy0)+cosAx*(zz(i)-cz0)) + cz0
NEXT i
FOR i=0 TO 7
LET pxApex(i) = cosAy*(xApex(i)-cx0)+sinAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cx0
LET pyApex(i) = cosAx*(yApex(i)-cy0)-sinAx*(zApex(i)-cz0) + cy0
LET pzApex(i) =-sinAy*(xApex(i)-cx0)+cosAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cz0
NEXT i
END SUB
EXTERNAL SUB markFarEdge
! seek far apex --> iMin
LET zMin = pzApex(0)
LET iMin = 0
FOR i=1 TO 7
IF zMin>pzApex(i) THEN
LET zMin = pzApex(i)
LET iMin = i
END IF
NEXT i
!mark far edge
FOR iEdge = 0 TO 11
LET boxEdge(iEdge,2) = 0
IF (boxEdge(iEdge,0)=iMin OR boxEdge(iEdge,1)=iMin) THEN LET boxEdge(iEdge,2) = 1
NEXT iEdge
END SUB
EXTERNAL SUB sortz
DECLARE EXTERNAL SUB qSort
FOR i=1 TO nMolec
LET srtzix(i) = i
NEXT i
CALL qSort(ppz,srtzix,1,nMolec)
END SUB
EXTERNAL SUB qSort(m(),a(),le,ri) !modified decimal BASIC library
IF ri>le THEN
LET i=le-1
LET j=ri
LET pv=m(a(ri))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(ri)
LET a(ri)=t
CALL qSort(m,a,le,i-1)
CALL qSort(m,a,i+1,ri)
END IF
END SUB
EXTERNAL SUB plotNearEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=0 THEN !far edge mark = 0
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotFarEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=1 THEN !far edge mark = 1
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotEdge(iEdge,mag,xp,yp,lineColor)
SET LINE COLOR lineColor
FOR i=0 TO 1
LET iApex = boxEdge(iEdge,i)
PLOT LINES: pxApex(iApex)*mag+xp, pyApex(iApex)*mag+yp;
NEXT i
PLOT LINES
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(Ax,Ay) !Ax:rotate angle around s-axis, Ay:rotate angle around y-axis
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL SUB setRotateXY,rotateXY,sortz,markFarEdge,plotFarEdge,plotNearEdge
LET sc = 200/xMax ! 200=boxsize in graphic window
LET xp = 150
LET yp = 120
LET Ay=Ay+dAy
CALL setRotateXY(Ax,Ay)
CALL rotateXY !xx(i),yy(i),zz(i) rotate--> ppx(i),ppy(i),ppz(i)
CALL sortz !sort ppz(i) : ppz(srtzix(1))<ppz(srtzix(2))<...<ppz(srtzix(nMolec))
CALL markFarEdge ! boxEdge(iEdge,2)=1:far side edge or 0:near side edge
SET DRAW MODE HIDDEN
CLEAR
CALL plotFarEdge(sc,xp,yp,8) !8:gray
FOR i=1 TO nMolec
LET j = srtzix(i)
SET AREA COLOR 150+int((ppz(j)/zMax+1)*40) ! the darker green, the deeper z-position
DRAW disk WITH SCALE(0.5*sigma*sc)*SHIFT(ppx(j)*sc+xp,ppy(j)*sc+yp)
NEXT i
CALL plotNearEdge(sc,xp,yp,1) !1:black
!draw caption
SET TEXT HEIGHT 8
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,55 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50,40 ,USING "box size =##.# x ##.# x ##.# (nm)":xMax*1e9,yMax*1e9,zMax*1e9
PLOT TEXT, AT 50,25 ,USING "N=### max number of registerd near molec=###":nMolec,maxNearMolec
PLOT TEXT, AT 50,10 :molecStr$(molecKind)&" in the box (3D molecular dynamics)"
PLOT TEXT, AT 50,380 ,USING "Ax =####.#(deg) Ay =####.#(deg)":MOD(Ax*180/PI,360),MOD(Ay*180/PI,360)
SET DRAW MODE EXPLICIT
END SUB
試験環境：
本プログラムは十進BASIC 6.6.0 / macOS 10.7.5, 十進BASIC Ver 7.7.8 / windows 10 でテストしました。
----------------
!
! ========= steepest descent method 1D ==========
!
! 008harmonicsSD1D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.03.06 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB sd1d.setInitialCondition,sd1d.SDiteration,sd1d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET stateMax = 10 !state 0,1,...,stateMax-1
LET vIndex = 0 !0:harmonic potential, 1:quantum well
LET iterMax = 10 ! 10 = iteration in SDiteration()
CALL setInitialCondition(stateMax,vIndex)
DO
CALL SDiteration(stateMax,iterMax)
CALL drawState
LET S$=INKEY$
IF S$="0" THEN
LET vIndex = 0
CALL setInitialCondition(stateMax,vIndex)
ELSEIF S$="1" THEN
LET vIndex = 1
CALL setInitialCondition(stateMax,vIndex)
ELSEIF S$="." THEN
EXIT DO
END IF
LOOP
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- steepest descent method 1D ----------
!
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy set { Ei }, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
!
MODULE sd1d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, dx, iterCount
SHARE NUMERIC sdEnergy(20) ! electron state energy
SHARE NUMERIC sdState(20,400) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(400) ! state work space in steepestDescent
SHARE NUMERIC vv(400) ! external potential
LET NNx = 256 ! max number of sdState(,NNx,NNy)
LET dx = 1/16 ! (au) x-division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential
LET iterCount = 0
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
! set window
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
LET sdState(ist,i) = RND-0.5
NEXT i
LET sdState(ist,0) = 0
LET sdState(ist,NNx-1) = 0
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
LET x0 = 0.5*NNx*dx
IF vIndex=0 THEN !--- hermonic
FOR i=0 TO NNx-1
LET x = i*dx
LET vv(i) = MIN(0.5*(x-x0)^2,24.5)
NEXT i
ELSEIF vIndex=1 THEN !--- well
FOR i=0 TO NNx-1
LET x = i*dx
IF ABS(x-x0)<4 THEN LET vv(i) = 0 ELSE LET vv(i) = 18
NEXT i
END IF
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt
LET damp = 0.003 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist,damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
LET wrk(i) = (2*sdState(ist,i)-sdState(ist,i+1)-sdState(ist,i-1))/h2+(vv(i)-ei)*sdState(ist,i)
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
LET sdState(ist,i) = sdState(ist,i)-damp*wrk(i)
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
LET s = s+sdState(ist,i)*((2*sdState(ist,i)-sdState(ist,i+1)-sdState(ist,i-1))/h2+vv(i)*sdState(ist,i))
LET sn = sn + sdState(ist,i)*sdState(ist,i)
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
LET sdState(istate,i) = sdState(istate,i) - s*sdState(ist,i)
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
LET s = s + sdState(ist,i)*sdState(jst,i)
NEXT i
LET innerProduct = s*dx
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
LET s = s + sdState(ist,i)*sdState(ist,i)*dx
NEXT i
LET a = SQR(1/s)
FOR i=1 TO NNx-2
LET sdState(ist,i) = a*sdState(ist,i)
NEXT i
END SUB
! ---------- drawState
EXTERNAL SUB drawState !public
DECLARE EXTERNAL SUB dispInnerProduct
LET sc = 20
LET xp = 50
LET yp = 180
LET vMag = 10
LET stMag = 100
SET DRAW MODE HIDDEN
CLEAR
SET LINE COLOR 1 ! black : PLOT x-axis
PLOT LINES: xp,yp;dx*NNx*sc+xp,yp
!---plot V(x)
SET LINE COLOR 10 ! dark green : PLOT potential V(x);
FOR i=0 TO NNx-1
PLOT LINES: dx*i*sc+xp,vv(i)*vMag+yp;
NEXT i
PLOT LINES
SET TEXT HEIGHT 5
FOR ist=0 TO 9
IF sdEnergy(ist)<12 THEN
SET LINE COLOR 1+ist
SET TEXT COLOR 1+ist
FOR i=0 TO NNx-1 !plot wave function |psi(x,t)>
PLOT LINES: i*dx*sc+xp, sdState(ist,i)*stMag+sdEnergy(ist)*20+yp;
NEXT i
PLOT LINES
PLOT TEXT, AT xp-20,sdEnergy(ist)*20+yp :"|"&STR$(ist)&">"
END IF
NEXT ist
CALL dispInnerProduct(0,dx*NNx*sc+xp+20,yp)
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,100 ,USING "count =###### ":iterCount
PLOT TEXT, AT 50, 85 ,USING "E0 =###.########## E5 =###.##########(au)":sdEnergy(0),sdEnergy(5)
PLOT TEXT, AT 50, 70 ,USING "E1 =###.########## E6 =###.##########(au)":sdEnergy(1),sdEnergy(6)
PLOT TEXT, AT 50, 55 ,USING "E2 =###.########## E7 =###.##########(au)":sdEnergy(2),sdEnergy(7)
PLOT TEXT, AT 50, 40 ,USING "E3 =###.########## E8 =###.##########(au)":sdEnergy(3),sdEnergy(8)
PLOT TEXT, AT 50, 25 ,USING "E4 =###.########## E9 =###.##########(au)":sdEnergy(4),sdEnergy(9)
PLOT TEXT, AT 50, 10 :"steepest descent method 1D"
PLOT TEXT, AT 50,470 :"'.' exit "
PLOT TEXT, AT 50,455 :"'0' hermonics k*x^2 '1' quantum well"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB dispInnerProduct(ist,xp,yp)
DECLARE EXTERNAL FUNCTION innerProduct
SET TEXT HEIGHT 5
SET TEXT COLOR 1 ! black
FOR jst=0 TO 9
PLOT TEXT, AT xp,yp+15*jst ,USING "("&STR$(ist)&"|"&STR$(jst)&") = -%.###^^^^":innerProduct(ist,jst)
NEXT jst
PLOT TEXT, AT xp,yp+15*10 :"(i|j) inner product"
END SUB
試験環境：
本プログラムは十進BASIC 6.6.1 / macOS 10.7.5, 十進BASIC Ver 7.7.8 / windows 10 でテストしました。
------------------
!
! ========= real-coded lattice gas model 2D ==========
!
! 009expansionRLG2D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.03.12 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB rlg2d.setInitialCondition, rlg2d.moveParticles, rlg2d.drawParticles
DECLARE EXTERNAL FUNCTION INKEY$
LET dispMode = 3 !3:mean flow+dens+temperature
CALL setInitialCondition
DO
CALL moveParticles
CALL drawParticles(dispMode)
LET S$=INKEY$
IF S$="." THEN EXIT DO
IF S$="0" THEN LET dispMode = 0 !0:500 sample particles
IF s$="1" THEN LET dispMode = 1 !1:mean flow
IF s$="2" THEN LET dispMode = 2 !2:mean flow+dens
IF s$="3" THEN LET dispMode = 3 !3:mean flow+dens+temperature
IF s$="4" THEN LET dispMode = 4 !4:mean flow+dens+pressure
LOOP
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- rlg2d module (real-coded lattice gas model 2D) ----------
!
! (1) move particles
! r = r + v*dt
! (2) collision - all particles collide each other in the same cell
! vm = mean v in the cell
! vi = vm + rotate(theta)(vi0-vm), (theta = PI/2 or -PI/2 : minmum viscosity)
!
MODULE rlg2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, moveParticles, drawParticles
PUBLIC FUNCTION systemTime,systemTemp,totalKineticEnergy
SHARE NUMERIC Nsx,Nsy,NNs,NinCell,NNp,sysTime,t,dt,dx,dy,xMax,yMax,gravity
SHARE NUMERIC xx(400000),yy(400000) ! position of particle
SHARE NUMERIC vx(400000),vy(400000) ! velocity of particle
SHARE NUMERIC section(300,300,30) ! section(Nsx,Nsy,NNs)
SHARE NUMERIC cellAttribute(300,300)! cellAttribute(Nsx,Nsy)
SHARE NUMERIC refTemp(4)
LET Nsx = 200 ! x-max number of section(x,y,n)
LET Nsy = 200 ! y-max number of section(x,y,n)
LET NNs = 30 ! n-max number of section(x,y,n)
LET NinCell = 4 !
LET NNp = Nsx*Nsy*NinCell
LET sysTime = 0.0
LET t = 0.0
LET dt = 1.0
LET dx = 1.0
LET dy = 1.0
LET xMax = Nsx*dx
LET yMax = Nsy*dy
LET gravity = 0.0 !e.g. -0.001 (gravitational force direction is -y direction)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition
DECLARE EXTERNAL FUNCTION cellAttributeAt
DECLARE EXTERNAL SUB setColorMix
LET t = 0.0
FOR ic=0 TO Nsx-1
FOR jc=0 TO Nsy-1
LET cellAttribute(ic,jc) = 0
IF (ic>=Nsx-Nsx/5 AND ic<=Nsx-Nsx/5+3 AND jc<Nsy/2) THEN
LET cellAttribute(ic,jc) = 1
END IF
NEXT jc
NEXT ic
LET i=0
DO WHILE (i<NNp)
LET x = xMax*RND*0.799
LET y = yMax*RND
IF (cellAttributeAt(x,y)=0) THEN
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 2.0*(RND-0.5)
LET vy(i) = 2.0*(RND-0.5)
LET i = i+1
END IF
LOOP
CALL setColorMix
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setColorMix !modified decimal BASIC library
! color pallet 100-180 blue(100) - green(140) - red(180)
FOR i=0 TO 80
LET x = 8 - 0.1*i
SELECT CASE x
CASE 0 TO 2
LET red=1
LET green=x/2
LET blue=0
CASE 2 TO 4
LET red=2-x/2
LET green=1
LET blue=0
CASE 4 TO 6
LET red=0
LET green=1
LET blue=x/2-2
CASE 6 TO 8
LET red=0
LET green=4-x/2
LET blue=1
END SELECT
SET COLOR MIX(100+i) red,green,blue
NEXT i
END SUB
! ---------- move particles
EXTERNAL SUB moveParticles
DECLARE EXTERNAL SUB movement,collision
CALL movement
CALL collision
LET t = t + dt
END SUB
EXTERNAL SUB movement
DECLARE EXTERNAL FUNCTION cellAttributeAt
FOR i=0 TO NNp-1
LET vy(i) = vy(i)+gravity*dt
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
LET ca = cellAttributeAt(xx(i),yy(i))
IF (ca>0) THEN
LET xx(i) = xx(i)-vx(i)*dt
LET yy(i) = yy(i)-vy(i)*dt
LET r = 1
IF (refTemp(ca)>0.0) THEN
LET temp = 0.5*(vx(i)*vx(i)+vy(i)*vy(i))
LET r = SQR(refTemp(ca)/temp)*(1.0-(RND-0.5))
ELSE
LET r = 1
END IF
LET vx(i) = -r*vx(i)
LET vy(i) = -r*vy(i)
END IF
NEXT i
!--- wall reflection
LET rr = 1
FOR i=0 TO NNp-1
IF (xx(i)<0.0) THEN
LET xx(i) = 0.0
LET vx(i) = -rr*vx(i)
LET vy(i) = rr*vy(i)
END IF
IF (xx(i) > xMax) THEN
LET xx(i) = xMax
LET vx(i) = -rr*vx(i)
LET vy(i) = rr*vy(i)
END IF
IF (yy(i) < 0.0) THEN
LET yy(i) = 0.0
LET vx(i) = rr*vx(i)
LET vy(i) = -rr*vy(i)
END IF
IF (yy(i) > yMax) THEN
LET yy(i) = yMax
LET vx(i) = rr*vx(i)
LET vy(i) = -rr*vy(i)
END IF
NEXT i
END SUB
EXTERNAL FUNCTION cellAttributeAt(x,y)
LET ix = INT(x/dx)
IF ix>=Nsx THEN LET ix = Nsx-1
IF ix<0 THEN LET ix = 0
LET iy = INT(y/dy)
IF iy>=Nsy THEN LET iy = Nsy-1
IF iy<0 THEN LET iy = 0
LET cellAttributeAt = cellAttribute(ix,iy)
END FUNCTION
EXTERNAL SUB collision
DECLARE EXTERNAL SUB dividingSection,collisionInTheCell
CALL dividingSection
FOR ic=0 TO Nsx-1
FOR jc=0 TO Nsy-1
LET nn = section(ic,jc,0)
IF nn>1 THEN
IF cellAttribute(ic,jc)=0 THEN
CALL collisionInTheCell(ic,jc)
END IF
END IF
NEXT jc
NEXT ic
END SUB
EXTERNAL SUB collisionInTheCell(ic,jc)
LET cTh = 0
IF RND<0.5 THEN LET sTh = -1 ELSE LET sTh = 1
LET n = section(ic,jc,0)
LET vxm = 0.0
LET vym = 0.0
FOR i=1 TO n
LET k = section(ic,jc,i)
LET vxm = vxm+vx(k)
LET vym = vym+vy(k)
NEXT i
LET vxm = vxm/n
LET vym = vym/n
FOR i=1 TO n
LET k = section(ic,jc,i)
LET vxs = vx(k)-vxm
LET vys = vy(k)-vym
LET vx(k) = vxm +cTh*vxs +sTh*vys
LET vy(k) = vym -sTh*vxs +cTh*vys
NEXT i
END SUB
EXTERNAL SUB dividingSection
FOR ic=0 TO Nsx-1
FOR jc=0 TO Nsy-1
LET section(ic,jc,0) = 0
NEXT jc
NEXT ic
FOR ipp=0 TO NNp-1
LET ic = INT(Nsx*xx(ipp)/xMax)
IF ic>=Nsx THEN LET ic = Nsx-1
LET jc = INT(Nsy*yy(ipp)/yMax)
IF jc>=Nsy THEN LET jc = Nsy-1
LET iq = section(ic,jc,0) + 1
IF iq<NNs THEN
LET section(ic,jc,0) = iq
LET section(ic,jc,iq) = ipp
END IF
NEXT ipp
END SUB
EXTERNAL FUNCTION maxSection
LET m = 0
FOR ic=0 TO Nsx-1
FOR jc=0 TO Nsy-1
IF section(ic,jc,0)>m THEN LET m = section(ic,jc,0)
NEXT jc
NEXT ic
LET maxSection = m
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTime
LET systemTime = t
END FUNCTION
EXTERNAL FUNCTION totalKineticEnergy
LET en = 0
FOR i=0 TO NNp-1
LET en = en + 0.5*(vx(i)*vx(i)+vy(i)*vy(i))
NEXT i
LET totalKineticEnergy = en
END FUNCTION
EXTERNAL FUNCTION systemTemp
DECLARE EXTERNAL FUNCTION totalKineticEnergy
LET systemTemp = totalKineticEnergy/NNp
END FUNCTION
! ---------- draw particles
EXTERNAL SUB drawParticles(drawMode)
DECLARE EXTERNAL FUNCTION maxSection
DECLARE EXTERNAL PICTURE boxWall,sampleParticles,meanFlow
SET DRAW MODE HIDDEN
CLEAR
LET sc = 300/Nsx !300 = boxsize in graphic window
LET xp = 100
LET yp = 100
IF drawMode=0 THEN
CALL boxWall(xp,yp,sc)
CALL sampleParticles(500,xp,yp,sc)
ELSEIF drawMode>=1 AND drawMode<=4 THEN
CALL boxWall(xp,yp,sc)
CALL meanFlow(drawMode-1,xp,yp,sc)
END IF
!draw caption
SET TEXT HEIGHT 8
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50, 70 ,USING "time =####.#, N =########":t,NNp
PLOT TEXT, AT 50, 55 ,USING "box size =####.# x ####.# ":xMax,yMax
PLOT TEXT, AT 50, 40 ,USING "max section =####": maxSection
PLOT TEXT, AT 50, 25 ,USING "total energy(=kinetic energy) =######.###########": totalKineticEnergy
PLOT TEXT, AT 50, 10 :"real-coded lattice gas model 2D"
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,480 :"'.':exit '0':500-sample particles "
PLOT TEXT, AT 30,460 :"'1':mean v '2':mean v + dens"
PLOT TEXT, AT 30,440 :"'3':mean v + Temp '4':mean v + Pres"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB boxWall(x0,y0,mag)
DECLARE EXTERNAL FUNCTION cellAttributeAt
SET LINE COLOR 1 ! black : wall
PLOT LINES: x0,y0; x0+Nsx*mag,y0; x0+Nsx*mag,y0+Nsy*mag; x0,y0+Nsy*mag; x0,y0
SET LINE COLOR 8 ! gray : wall
FOR ic=1 TO Nsx
FOR jc=1 TO Nsy
IF cellAttributeAt(ic,jc)=1 THEN
DRAW circle WITH SCALE(0.5)*SHIFT(x0+ic*mag,y0+jc*mag)
END IF
NEXT jc
NEXT ic
END SUB
EXTERNAL SUB sampleParticles(nSample,x0,y0,mag)
FOR i=1 TO nSample
SET LINE COLOR 2 ! blue : particle
DRAW circle WITH SCALE(2)*SHIFT(x0+xx(i)*mag,y0+yy(i)*mag)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: x0+xx(i)*mag,y0+yy(i)*mag;
PLOT LINES: x0+xx(i)*mag+vx(i)*mag*10,y0+yy(i)*mag+vy(i)*mag*10
NEXT i
END SUB
EXTERNAL SUB meanFlow(mode,x0,y0,mag) !mode=0: mvx,mvy 1:0+dens 2:1+temp 3:1+pres
DECLARE EXTERNAL FUNCTION cellAttributeAt
LET nStep = 5
SET LINE COLOR 2 ! blue : velocity
FOR ic=1 TO Nsx STEP nStep
FOR jc=1 TO Nsy STEP nStep
LET n = 0
LET mvx = 0
LET mvy = 0
FOR i=ic TO ic+nStep-1
FOR j=jc TO jc+nStep-1
LET nn = section(i,j,0)
LET n = n + nn
FOR ipp=1 TO nn-1
LET k = section(i,j,ipp)
LET mvx = mvx+vx(k)
LET mvy = mvy+vy(k)
NEXT ipp
NEXT j
next i
IF n>0 AND cellAttribute(ic+INT(nStep/2),jc+INT(nStep/2))=0 THEN
LET mvx = mvx/n
LET mvy = mvy/n
LET dens = (n/(1.0*nStep*nStep))/NinCell
!--- temp,pres
IF mode>=2 THEN
LET ke = 0
FOR i=ic TO ic+nStep-1
FOR j=jc TO jc+nStep-1
LET nn = section(i,j,0)
FOR ipp=1 TO nn-1
LET k = section(i,j,ipp)
LET ke = ke + 0.5*((vx(k)-mvx)*(vx(k)-mvx)+(vy(k)-mvy)*(vy(k)-mvy))
NEXT ipp
NEXT j
NEXT i
LET temp = ke/n
LET pres = dens*temp !here, no use
IF mode=2 THEN
LET tempCol = INT(MIN(temp*160,80))
SET AREA COLOR 100+tempCol
ELSEIF mode=3 THEN
LET presCol = INT(MIN(pres*160,80))
SET AREA COLOR 100+presCol
END IF
END IF
!--- dens+temp plot
IF mode>=1 THEN
IF mode=1 THEN SET AREA COLOR 5 ! cyan
DRAW disk WITH SCALE(dens*1.2*mag)*SHIFT(x0+(ic+0.5)*mag,y0+(jc+0.5)*mag)
END IF
!--- mvx,mvy plot
IF ABS(mvx)>ABS(mvy) THEN
IF mvx>=0 THEN SET LINE COLOR 2 ELSE SET LINE COLOR 4
ELSE
IF mvy>=0 THEN SET LINE COLOR 7 ELSE SET LINE COLOR 10
END IF
PLOT LINES: x0+(ic+0.5)*mag,y0+(jc+0.5)*mag;
PLOT LINES: x0+(ic+0.5)*mag+mvx*mag*50,y0+(jc+0.5)*mag+mvy*mag*50
END IF
NEXT jc
NEXT ic
END SUB
DO
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode,menu)
LET S$=INKEY$
IF S$="." THEN
EXIT DO
ELSEIF S$="0" THEN
LOCATE VALUE (1),RANGE 0 TO 400 : temp
IF temp>1 THEN
LET tempMode = 1
LET contTemp = temp
ELSE
LET tempMode = 0
END IF
ELSEIF S$="1" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$="9" THEN
LOCATE CHOICE (menu$) :nmenu
IF nmenu=1 THEN
CALL setInitialCondition(2,50,4,50,8,8,contTemp)
ELSEIF nmenu=2 THEN
CALL setInitialCondition(2,200,4,100,12,12,contTemp)
ELSEIF nmenu=3 THEN
LET tempMode = 1
LET contTemp = 300
CALL setInitialCondition(2,50,5,50,8,8,contTemp)
ELSEIF nmenu=4 THEN
CALL setInitialCondition(2,50,3,50,8,8,contTemp)
ELSEIF nmenu=5 THEN
CALL setInitialCondition(3,50,4,50,8,8,contTemp)
ELSEIF nmenu=6 THEN
CALL setInitialCondition(3,50,5,50,8,8,contTemp)
ELSEIF nmenu=7 THEN
CALL setInitialCondition(4,50,5,50,8,8,contTemp)
ELSEIF nmenu=8 THEN !contine
!
END IF
END IF
LOOP
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- Lennard-Jones md2d module ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
! = 24*epsilon*r6*(2*r6-1)/r, r6 = (sigma/r)^6
MODULE md2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(moleculeKind,nMolecule,xMaximum,yMaximum,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(tempMode,contTemp,drawMode,menu)
SHARE NUMERIC sysTime,dt,nMolec,xMax,yMax, molecKind1,molecKind2, rCutoff,hh
SHARE NUMERIC xx(500),yy(500) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC kind(500),mas(500)! kind(i),mas(i) : molec kind, mass of i-th particle
SHARE NUMERIC reg(500,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 5,0 TO 4) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt 4:color
SHARE NUMERIC forceTable(0 TO 5, 0 TO 5,0 TO 1001) ! force table
SHARE STRING molecStr$(0 TO 5)
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 36 ! total number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET molecKind1 = 2 ! molecule kind1 ( 2:Ar )
LET molecKind2 = 4 ! molecule kind2 ( 4:Xe )
LET rCutoff = 1e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(kind1,nMol1,kind2,nMol2,xMaximum,yMaximum,contTemp)
DECLARE EXTERNAL SUB setMoleculesData,setForceTable,setMolecules
RANDOMIZE
! set particles
CALL setMoleculesData
LET sysTime = 0.0
LET nMolec = nMol1+nMol2
LET molecKind1 = kind1
LET molecKind2 = kind2
LET xMax = xMaximum*1e-9
LET yMax = yMaximum*1e-9
LET rCutoff = 1e-9
CALL setForceTable
CALL setMolecules(kind1,nMol1,kind2,nMol2,contTemp)
! set window
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setMoleculesData
! 0:mass(in AU) 1:eps(in kB) 2:sigma(m) 3:dt(s) 4:color
DATA 4.003 , 10.2 , 2.576e-10 , 5.0e-15, 1 ! 0 He black
DATA 20.183 , 36.2 , 2.976e-10 , 10.0e-15, 13 ! 1 Ne olieve
DATA 39.948 , 124.0 , 3.418e-10 , 20.0e-15, 2 ! 2 Ar blue
DATA 83.50 , 190.0 , 3.610e-10 , 20.0e-15, 3 ! 3 Kr green
DATA 131.30 , 229.0 , 4.055e-10 , 20.0e-15, 10 ! 4 Xe dark green
DATA 200.59 , 851.0 , 2.898e-10 , 20.0e-15, 12 ! 5 Hg brown
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 5
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.38e-23 !eps(kB) --> (J)
NEXT i
MAT READ molecStr$
END IF
END SUB
EXTERNAL SUB setMolecules(kind1,nMol1,kind2,nMol2,contTemp)
DECLARE EXTERNAL SUB ajustVelocity
LET sigmax = MAX(molecData(kind1,2),molecData(kind2,2))
FOR j=1 TO nMol1+nMol2
LET loopCount = 0
DO
LET xx(j) = (xMax-2*sigmax)*RND + sigmax
LET yy(j) = (yMax-2*sigmax)*RND + sigmax
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2 < 2*sigmax^2 THEN EXIT FOR
NEXT i
LET loopCount = loopCount + 1
IF loopCount>1000 THEN EXIT DO
LOOP UNTIL i>=j
IF loopCount>1000 THEN
LET nMolec = j - 1
EXIT FOR
END IF
IF j<=nMol1 THEN LET kind(j) = kind1 ELSE LET kind(j) = kind2
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET mas(i) = molecData(kind(i),0)
NEXT i
CALL ajustVelocity(contTemp)
END SUB
! ---------- set force table
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ki=0 TO 5
FOR kj=0 TO 5
LET epsi = SQR(molecData(ki,1)*molecData(kj,1))
LET sigm = 0.5*(molecData(ki,2)+molecData(kj,2))
FOR ir=10 TO 1001
LET r = ir*hh
LET r6 = (sigm/r)^6
LET forceTable(ki,kj,ir) = cutoff(r,rCutoff)*(24*epsi*r6*(2*r6-1)/r)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ki,kj,ir) = forceTable(ki,kj,10)
NEXT ir
NEXT kj
NEXT ki
END SUB
EXTERNAL FUNCTION cutoff(r,rCutoff)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
EXTERNAL FUNCTION force(r,ki,kj) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ki,kj,ir) + a*forceTable(ki,kj,ir+1))/hh
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB registerNearMolec,moveParticlesDT,ajustVelocity
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*molecData(2,2) !molecData(2,2)=sigma for Ar
LET rCut2 = rCutoff^2 ! force cutoff radius^2
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET r2ij = xij*xij+yij*yij
IF (r2ij<rCut2) THEN
LET rij = SQR(r2ij)
LET f = force(rij,kind(i),kind(j))
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
!EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
! LET ri = sigma/r
! LET r6 = ri^6
! LET force = (24*epsilon*r6*(2*r6-1)/r)
!END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET adsorp = 0.5*molecData(2,1) !molecData(2,1)=epsilon for Ar
LET ri = molecData(2,2)/r !molecData(2,2)=sigma for Ar
LET r6 = ri^6
LET boundaryForce = (24.0*adsorp*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mas(i)*(vx(i)*vx(i)+vy(i)*vy(i))
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode,menu)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL PICTURE realSpace,velocitySpace
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:disk 1:circle+V+F
DRAW realSpace(drawMode)
ELSEIF drawMode=2 THEN
DRAW velocitySpace
END IF
!--- control key guide
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 10,480 :"'.':exit '0':Temp control (Temp<1 adiabatic mode)"
PLOT TEXT, AT 10,460 :"'1':changeGraph '9':select theme "
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING "N =#### max number of near molec =###":nMolec,maxNearMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 90, 10 :" in the box(2D molecular dynamics)"
SET TEXT COLOR molecData(molecKind1,4) ! color of molec kind1
PLOT TEXT, AT 50, 10 :molecStr$(molecKind1)
SET TEXT COLOR molecData(molecKind2,4) ! color of molec kind2
PLOT TEXT, AT 70, 10 :molecStr$(molecKind2)
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL PICTURE realSpace(drawMode)
LET boxSize = 300
LET deltat = 2e-14 !(s)
LET sc = boxSize/xMax
LET xp = 100
LET yp = 100
LET vScate = 100*deltat !velocity line length = v*100*deltat
LET fScale = 1000*deltat*deltat/molecData(2,0) !mass of Ar
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; xp+boxSize,yp; xp+boxSize,yp+boxSize; xp,yp+boxSize; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,yp+boxSize+2 ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
IF drawMode=1 THEN !--- draw circle, velocity and force
SET LINE COLOR molecData(kind(i),4) ! molec color
DRAW circle WITH SCALE(molecData(kind(i),2)/2*sc)*SHIFT(xp+xx(i)*sc,yp+yy(i)*sc)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp+xx(i)*sc,yp+yy(i)*sc;
PLOT LINES: xp+(xx(i)+vx(i)*vScate)*sc,yp+(yy(i)+vy(i)*vScate)*sc
SET LINE COLOR 1 ! black : force
PLOT LINES: xp+xx(i)*sc,yp+yy(i)*sc;
PLOT LINES: xp+(xx(i)+ffx(i)*fScale)*sc,yp+(yy(i)+ffy(i)*fScale)*sc
ELSE !--- draw disk
SET AREA COLOR molecData(kind(i),4) ! molec color
DRAW disk WITH SCALE(molecData(kind(i),2)/2*sc)*SHIFT(xp+xx(i)*sc,yp+yy(i)*sc)
END IF
NEXT i
IF drawMode=1 THEN
LET xp = 100+boxSize*0.6
LET yp = 100+boxSize+25
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp,yp;xp+23,yp
SET TEXT COLOR 4 ! red
PLOT TEXT, AT xp+30,yp-4: "velosity"
SET LINE COLOR 1 ! black : force
PLOT LINES: xp,yp-15;xp+23,yp-15
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp+30,yp-19: "force"
END IF
END PICTURE
EXTERNAL PICTURE velocitySpace
LET boxSize = 300
LET xp = 100+boxSize/2
LET yp = 100+boxSize/2
SET LINE COLOR 1 !black : axis
PLOT LINES: 100,yp; 100+boxSize,yp !vx-axis
PLOT LINES: xp,100; xp,100+boxSize !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 100+boxSize,yp: "vx"
PLOT TEXT, AT 100+boxSize,yp-12: "1000m/s"
PLOT TEXT, AT xp-12,100+boxSize: "vy 1000m/s"
PLOT TEXT, AT xp-8,yp-10: "0"
PLOT TEXT, AT 100,100+boxSize+8: "velocity space (vx,vy)"
LET sc = boxSize/2000
FOR i=1 TO nMolec
SET LINE COLOR molecData(kind(i),4) ! molec color
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*sc+xp,vy(i)*sc+yp)
NEXT i
END PICTURE
試験環境：
本プログラムは十進BASIC 6.6.2 / macOS 10.7.5, 十進BASIC Ver 7.8.0 / windows 10 でテストしました。
----------------
!
! ========= steepest descent method 2D ==========
!
! 011harmonicsSD2D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.03.24 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB sd2d.setInitialCondition,sd2d.SDiteration,sd2d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET stateMax = 10 !state 0,1,...,stateMax-1
LET vIndex = 0 !0:harmonic, 1:well
LET iterMax = 5 !5 -iteration in SDiteration()
LET drawMode = 1 !0:draw3DPsi, 1:drawPsi
CALL setInitialCondition(stateMax,vIndex)
DO
CALL SDiteration(stateMax, iterMax)
CALL drawState(drawMode)
LET S$=INKEY$
IF S$="6" THEN CALL setInitialCondition(stateMax,0) !Hermonics
IF S$="7" THEN CALL setInitialCondition(stateMax,1) !Well
IF S$="8" THEN LET drawMode = 0 !0:draw3DPsi
IF S$="9" THEN LET drawMode = 1 !1:drawPsi
IF S$="." THEN EXIT DO
LOOP
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- steepest descent method 2D ----------
!
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy Ei, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
!
MODULE sd2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, NNy, dx, dy, iterCount
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(20) ! electron state energy
SHARE NUMERIC sdState(20,200,200) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(200,200) ! state work space in steepestDescent
SHARE NUMERIC vv(200,200) ! external potential
SHARE NUMERIC psicol(64,64) ! MAT PLOT CELL matrix for psi(x,y)
SHARE NUMERIC vcol(64,64) ! MAT PLOT CELL matrix for potential V(x,y)
LET NNx = 64 ! max number of sdState(,NNx,NNy)
LET NNy = 64 ! max number of sdState(,NNx,NNy)
LET dx = 0.25 ! (au) x division
LET dy = 0.25 ! (au) y division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential,initDraw
LET iterCount = 0
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
CALL initDraw
! set window
LET xMargin = 60
LET yMargin = 120
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
FOR j=1 TO NNx-2
LET sdState(ist,i,j) = RND-0.5
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
LET x0 = 0.5*NNx*dx
LET y0 = 0.5*NNy*dy
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET x = i*dx
LET y = j*dy
IF vIndex=0 THEN
LET vv(i,j) = 0.5*((x-x0)*(x-x0)+(y-y0)*(y-y0))
ELSEIF vIndex=1 THEN
LET r = SQR((x-x0)*(x-x0)+(y-y0)*(y-y0))
IF r>5 THEN LET vv(i,j)=20 ELSE LET vv(i,j)=0
ELSE
LET vv(i,j)=0
END IF
NEXT j
NEXT i
END SUB
EXTERNAL SUB initDraw !--- set set color pallet and MAT PLOT matrix vcol(,)
FOR i = 0 TO 50 !--- set color pallet
SET COLOR MIX( 40+i) 0.02*i,0.02*i,0 ! red for |psi> +
SET COLOR MIX(100+i) 0,0.02*i,0.02*i ! blue for |psi> -
SET COLOR MIX(160+i) 0,0.02*i,0 ! green for V(x)
NEXT i
FOR i=0 TO NNx-1 !--- set vcol(,)
FOR j=0 TO NNy-1
LET col = 0.02*vv(i,j)
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET vcol(i,j) = 160+INT(col*50)
NEXT j
NEXT i
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
LET damp = 0.01 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
CALL sortState(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist,damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
FOR j=1 TO NNy-2
LET pij = sdState(ist,i,j)
LET wrk(i,j) = (4*pij-sdState(ist,i+1,j)-sdState(ist,i-1,j)-sdState(ist,i,j-1)-sdState(ist,i,j+1))/h2+(vv(i,j)-ei)*pij
NEXT j
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=1 TO NNy-2
LET sdState(ist,i,j) = sdState(ist,i,j)-damp*wrk(i,j)
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET pij = sdState(ist,i,j)
LET s = s+pij*((4*pij-sdState(ist,i+1,j)-sdState(ist,i-1,j)-sdState(ist,i,j-1)-sdState(ist,i,j+1))/h2+vv(i,j)*pij)
LET sn = sn+pij*pij
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET sdState(istate,i,j) = sdState(istate,i,j) - s*sdState(ist,i,j)
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET w = sdState(ist,i,j)
LET sdState(ist,i,j) = sdState(ist+1,i,j)
LET sdState(ist+1,i,j) = w
NEXT j
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET s = s + sdState(ist,i,j)*sdState(jst,i,j)
NEXT j
NEXT i
LET innerProduct = s*dx*dy
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET s = s + sdState(ist,i,j)*sdState(ist,i,j)*dx*dy
NEXT j
NEXT i
LET a = SQR(1/s)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET sdState(ist,i,j) = a*sdState(ist,i,j)
NEXT j
NEXT i
END SUB
! ---------- utility
!EXTERNAL FUNCTION iterationCount
! LET iterationCount = iterCount
!END FUNCTION
EXTERNAL FUNCTION stateEnergy(ist)
LET stateEnergy = sdEnergy(ist)
END FUNCTION
! ---------- 3D graphics
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z,xShift,yShift) !shift*xRotateAx*yRotateAy*(shift^-1)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0+xShift, y1+cy0+yShift; !z=z1+cz0
END SUB
! ---------- drawState
EXTERNAL SUB drawState(drawMode)
DECLARE EXTERNAL SUB setRotateXYParameters,drawState3D,draw3DPsix6,drawPsix6
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 THEN
CALL setRotateXYParameters(-PI/6,-PI/12,NNx/2,NNy/2,0)
CALL draw3DPsix6
ELSEIF drawMode=1 THEN
CALL drawPsix6
END IF
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,100 ,USING "iteration count =##### ":iterCount
PLOT TEXT, AT 50, 85 ,USING "E0 =###.########### E5 =###.###########(au)":sdEnergy(0),sdEnergy(5)
PLOT TEXT, AT 50, 70 ,USING "E1 =###.########### E6 =###.###########(au)":sdEnergy(1),sdEnergy(6)
PLOT TEXT, AT 50, 55 ,USING "E2 =###.########### E7 =###.###########(au)":sdEnergy(2),sdEnergy(7)
PLOT TEXT, AT 50, 40 ,USING "E3 =###.########### E8 =###.###########(au)":sdEnergy(3),sdEnergy(8)
PLOT TEXT, AT 50, 25 ,USING "E4 =###.########### E9 =###.###########(au)":sdEnergy(4),sdEnergy(9)
PLOT TEXT, AT 50, 10 :"steepest descent method 2D"
PLOT TEXT, AT 50,480 :"potential -> [6] Hermonics [7] well "
PLOT TEXT, AT 50,465 :"display -> [8] psi3D [9] psi "
PLOT TEXT, AT 50,450 :"[.] exit "
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB draw3DPsix6
DECLARE EXTERNAL SUB drawState3D
CALL drawState3D(0,2,0.5, 30,120) !(ist,sc,zMag,xShift,yShift)
CALL drawState3D(1,2,0.5,180,120)
CALL drawState3D(2,2,0.5,330,120)
CALL drawState3D(3,2,0.5, 30,270)
CALL drawState3D(4,2,0.5,180,270)
CALL drawState3D(5,2,0.5,330,270)
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,130:"|0>"
PLOT TEXT, AT 180,130:"|1>"
PLOT TEXT, AT 330,130:"|2>"
PLOT TEXT, AT 30,280:"|3>"
PLOT TEXT, AT 180,280:"|4>"
PLOT TEXT, AT 330,280:"|5>"
END SUB
EXTERNAL SUB drawState3D(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j)),xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j)),xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
EXTERNAL SUB drawPsix6
DECLARE EXTERNAL SUB drawPsi
CALL drawPsi(0, 30,135) !(ist,xPos,yPos)
CALL drawPsi(1,180,135)
CALL drawPsi(2,330,135)
CALL drawPsi(3, 30,285)
CALL drawPsi(4,180,285)
CALL drawPsi(5,330,285)
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,120:"|0>"
PLOT TEXT, AT 180,120:"|1>"
PLOT TEXT, AT 330,120:"|2>"
PLOT TEXT, AT 30,270:"|3>"
PLOT TEXT, AT 180,270:"|4>"
PLOT TEXT, AT 330,270:"|5>"
END SUB
EXTERNAL SUB drawPsi(ist,xPos,yPos) !drawMode=0
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j)
IF abs(psi)>0.002 THEN
IF psi>=0 THEN
LET col = psi*10
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 40+INT(col*50)
ELSE
LET col = -psi*10
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 100+INT(col*50)
END IF
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN xPos,yPos; xPos+128,yPos+128 :psicol
END SUB
┌ F(q(t)) ⊿t ┐
q(t+⊿t)＝q(t)＋│v(t)＋──── ──│⊿t
└ m 2 ┘
┌ F(q(t)) ⊿t ┐ F(q(t+⊿t)) ⊿t
v(t+⊿t)＝│v(t)＋──── ──│＋────── ──
└ m 2 ┘ m 2
--------------------------------------------------------
上の式を、十進BASICプログラム風に直すと・・
DO
LET v＝(v＋ F/m *⊿t/2)
LET q＝q＋v *⊿t
LET F= force(q) ! 更新された q の、F
LET v＝v＋ F/m *⊿t/2
LOOP
ループなので、４行目の計算は、Ｆの更新なしに、１行目へ連続しており、
以下の様にしても、最初の１回だけの違い。( 初期値 F=0 なら、影響なし）
DO
LET v＝v＋F/m *⊿t/2＋F/m *⊿t/2
LET q＝q＋v *⊿t
LET F= force(q)
LOOP
式としては、以下と同一。但し、BASIC 側の計算の誤差が異なる分、累積で違っていく。
DO
LET v＝v＋F/m *⊿t
LET q＝q＋v *⊿t
LET F= force(q)
LOOP
FUNCTION sysTemp
LET v2 = 0
FOR i=1 TO Nmt
LET v2 = v2 + ABS(vxy(i))^2-vz(i)^2 ! vx^2 + vy^2 + vz^2
!LET v2 = v2 + ABS(ABS(vxy(i))+vz(i))^2 ! vx^2 + vy^2 + vz^2
NEXT i
LET sysTemp = mass*v2/Nmt/3/k_ ! {∑(.5*m*v^2) /N} *2/3 /k
END FUNCTION
SUB moveParticles
FOR i=1 TO Nmt
LET vxy(i) = vxy(i)+a_*fxy(i) !a_ = 0.5*dt/mass
LET vz(i) = vz(i)+ a_*fz(i)
LET pxy(i) = pxy(i)+vxy(i)*dt
LET pz(i) = pz(i)+vz(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO Nmt
LET vxy(i) = vxy(i)+a_*fxy(i) !a_ = 0.5*dt/mass
LET vz(i) = vz(i)+ a_*fz(i)
NEXT i
LET sysTime=sysTime+dt
LET Az=Az+dt*1e11
END SUB
現状の、上式での実行結果
time = .00 (ps) temp = 150.00 (K)
time = 2.00 (ps) temp = 155.62 (K)
time = 4.00 (ps) temp = 194.59 (K)
time = 6.00 (ps) temp = 180.24 (K)
time = 8.00 (ps) temp = 181.89 (K)
time = 10.00 (ps) temp = 188.48 (K)
time = 12.00 (ps) temp = 192.71 (K)
time = 14.00 (ps) temp = 196.33 (K)
time = 16.00 (ps) temp = 193.79 (K)
time = 18.00 (ps) temp = 187.88 (K)
time = 20.00 (ps) temp = 171.75 (K)
(
)
time = 992.00 (ps) temp = 180.61 (K)
time = 994.00 (ps) temp = 194.11 (K)
time = 996.00 (ps) temp = 188.18 (K)
time = 998.00 (ps) temp = 196.90 (K)
time =1000.00 (ps) temp = 205.22 (K)
FUNCTION sysTemp
LET v2 = 0 !v2：速度 絶対値の２乗
FOR i=1 TO Nmt
!---------------- 温度表示を、同位置にする為、vxy,vz の１段先を、観測。
LET w1=vxy(i)+a_*fxy(i) !a_ = 0.5*dt/mass
LET w2=vz(i) +a_*fz(i)
LET v2 = v2 + ABS( w1)^2 -( w2)^2 !re(vx+⊿)^2 +im(vy+⊿)^2 +im(vz+⊿)^2
!---------------- 元の、温度表示。(停止)
! LET v2 = v2 + ABS(vxy(i))^2 -vz(i)^2 !re(vxy)^2 +im(vxy)^2 +im(vz)^2
NEXT i
LET sysTemp = mass*v2/Nmt/3/k_ ! {∑(.5*mass*v^2) /Nmt} *2/3 /k
END FUNCTION
SUB moveParticles
FOR i=1 TO Nmt
LET vxy(i) = vxy(i)+a_*fxy(i) +a_*fxy(i) !a_ = 0.5*dt/mass
LET vz(i) = vz(i)+ a_*fz(i) + a_*fz(i)
LET pxy(i) = pxy(i)+vxy(i)*dt
LET pz(i) = pz(i)+vz(i)*dt
NEXT i
CALL calcForce
LET sysTime=sysTime+dt
LET Az=Az+dt*1e11
END SUB
! LET vxy(i) = vxy(i)+fxy(i)/mass*dt !左記は、式として、上の２行と同一ですが、
! LET vz(i) = vz(i)+ fz(i)/mass*dt ! 計算誤差の違いで、time=34.00(ps) 以降ズレる
上式での実行結果
time = .00 (ps) temp = 150.00 (K)
time = 2.00 (ps) temp = 155.62 (K)
time = 4.00 (ps) temp = 194.59 (K)
time = 6.00 (ps) temp = 180.24 (K)
time = 8.00 (ps) temp = 181.89 (K)
time = 10.00 (ps) temp = 188.48 (K)
time = 12.00 (ps) temp = 192.71 (K)
time = 14.00 (ps) temp = 196.33 (K)
time = 16.00 (ps) temp = 193.79 (K)
time = 18.00 (ps) temp = 187.88 (K)
time = 20.00 (ps) temp = 171.75 (K)
(
)
time = 992.00 (ps) temp = 180.61 (K)
time = 994.00 (ps) temp = 194.11 (K)
time = 996.00 (ps) temp = 188.18 (K)
time = 998.00 (ps) temp = 196.90 (K)
time =1000.00 (ps) temp = 205.22 (K)
EXTERNAL SUB setInitialCondition
DECLARE EXTERNAL SUB ajustVelocity
! set particles
RANDOMIZE 5 ←再現させるため引数を、追加する。
(
)
EXTERNAL SUB moveParticles ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
LET vx(i) = vx(i)+a*ffx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
LET sysTime=sysTime+dt
END SUB
(
)
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
!---------------- 温度表示を、同位置にする為、vx,vy の１段先を、観測。
LET a = 0.5*dt/mass
LET w1=vx(i) +a*ffx(i)
LET w2=vy(i) +a*ffy(i)
LET ek = ek + 0.5*mass*( w1^2 + w2^2)
!---------------- 元の、温度表示。
! LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB)
END FUNCTION
試験環境：
本プログラムは十進BASIC 6.6.2 / macOS 10.7.5, 十進BASIC Ver 7.8.0 / windows 10でテストしました。
-------------------
!
! ========= molecular dynamics 3D ==========
!
! 0XXmixLJMD3D.bas
! Mitsuru Ikeuchi (C) Copyleft
!
! ver 0.0.1 2017.03.31 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB md3d.setInitialCondition, md3d.moveParticles, md3d.drawParticles
LET Ax = PI/12 ! rotate angle around x-axis
LET Ay = -PI/6 ! rotate angle around y-axis
LET ddAy = 0.5*(PI/180) ! Ay <- Ay+ddAy, Ay:rotate angle around y-axis
LET contTemp = 200 ! controled temperature at initial and tempMode=1
LET tempMode = 0 ! tempMode 0:adiabatic 1:constant-temp
LET t0 = TIME
FOR it=1 TO 1000
LET Ay = Ay+ddAy
IF Ay>PI THEN LET Ay = Ay - 2*PI
IF Ay<-PI THEN LET Ay = Ay + 2*PI
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(Ax,Ay)
NEXT it
!PRINT time-t0
END
! ---------- Lennard-Jones md3d module ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Lennard-Jones V(r) = 4*epsilon*((sigma/r)^12-(sigma/r)^6)
! force F(r) = -dV(r)/dr
! = 24*epsilon*r6*(2*r6-1)/r, r6 = (sigma/r)^6
!
MODULE md3d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition,moveParticles,drawParticles
SHARE NUMERIC sysTime, dt, nMolec, xMax, yMax, zMax, molecKind1,molecKind2, rCutoff, hh
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy, cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC xx(500),yy(500),zz(500) ! (xx(i),yy(i),zz(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500),vz(500) ! (vx(i),vy(i),vz(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500),ffz(500) ! (ffx(i),ffy(i),ffz(i)): total force of i-th particle
SHARE NUMERIC kind(500),mas(500) ! kind(i),mas(i) : molec kind, mass of i-th particle
SHARE NUMERIC ppx(500),ppy(500),ppz(500) ! (ppx(i),ppy(i),ppz(i)): rotated particle position
SHARE NUMERIC srtzix(500) ! sort ppz(i) : sort z --> ppz(srtzix(i))
SHARE NUMERIC reg(500,0 TO 300) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 5,0 TO 4) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt 4:color
SHARE NUMERIC xApex(0 TO 7),yApex(0 TO 7),zApex(0 TO 7) ! boxApex x- y- z-coordinate
SHARE NUMERIC pxApex(0 TO 7),pyApex(0 TO 7),pzApex(0 TO 7) ! rotated boxApex x- y- z-coordinate
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2) ! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
SHARE NUMERIC forceTable(0 TO 5, 0 TO 5,0 TO 1001) ! force table
SHARE STRING molecStr$(0 TO 5) !molecStr$(2) = "Ar"
LET sysTime = 0.0 ! system time (s)
LET dt = 20.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET zMax = 6.0e-9 ! z-Box size (m)
LET molecKind1 = 2 ! molecule kind1 ( 2:Ar )
LET molecKind2 = 4 ! molecule kind2 ( 4:Xe )
LET rCutoff = 1e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0) = 0 ! if molecData(0,0)=0 then mat read molecData
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(kind1,nMol1,kind2,nMol2,xMaximum,yMaximum,zMaximum,contTemp)
DECLARE EXTERNAL SUB setMoleculesData,setForceTable,setMolecules,setBox
RANDOMIZE
CALL setMoleculesData
LET sysTime = 0.0
LET nMolec = nMol1+nMol2
LET molecKind1 = kind1
LET molecKind2 = kind2
LET xMax = xMaximum*1e-9
LET yMax = yMaximum*1e-9
LET zMax = zMaximum*1e-9
CALL setForceTable
CALL setMolecules(kind1,nMol1,kind2,nMol2,contTemp)
CALL setBox
!set color mix
FOR i = 0 TO 49 !--- set color pallet
SET COLOR MIX(50+i) 0,0.02*i,0 !green, the darker green, the deeper z-position
SET COLOR MIX(100+i) 0.02*i,0.02*i,0 !yellow the darker yellow, the deeper z-position
NEXT i
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMoleculesData
! 0:mass(in AU) 1:eps(in kB) 2:sigma(m) 3:dt(s) 4:color
DATA 4.003 , 10.2 , 2.576e-10 , 5.0e-15, 1 ! 0 He black
DATA 20.183 , 36.2 , 2.976e-10 , 10.0e-15, 13 ! 1 Ne olieve
DATA 39.948 , 124.0 , 3.418e-10 , 20.0e-15, 2 ! 2 Ar blue
DATA 83.50 , 190.0 , 3.610e-10 , 20.0e-15, 3 ! 3 Kr green
DATA 131.30 , 229.0 , 4.055e-10 , 20.0e-15, 10 ! 4 Xe dark green
DATA 200.59 , 851.0 , 2.898e-10 , 20.0e-15, 12 ! 5 Hg brown
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 5
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.38e-23 !eps(kB) --> (J)
NEXT i
MAT READ molecStr$
END IF
END SUB
EXTERNAL SUB setMolecules(kind1,nMol1,kind2,nMol2,contTemp)
DECLARE EXTERNAL SUB ajustVelocity
LET sigmax = MAX(molecData(kind1,2),molecData(kind2,2))
FOR j=1 TO nMol1+nMol2
LET loopCount = 0
DO
LET xx(j) = (xMax-2*sigmax)*RND + sigmax
LET yy(j) = (yMax-2*sigmax)*RND + sigmax
LET zz(j) = (zMax-2*sigmax)*RND + sigmax
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2+(zz(i)-zz(j))^2 < 2*sigmax^2 THEN EXIT FOR
NEXT i
LET loopCount = loopCount + 1
IF loopCount>1000 THEN EXIT DO
LOOP UNTIL i>=j
IF loopCount>1000 THEN
LET nMolec = j - 1
EXIT FOR
END IF
IF j<=nMol1 THEN LET kind(j) = kind1 ELSE LET kind(j) = kind2
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vz(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET ffz(i) = 0.0
LET mas(i) = molecData(kind(i),0)
NEXT i
CALL ajustVelocity(contTemp)
END SUB
EXTERNAL SUB setBox
IF boxEdge(11,1)<>7 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
FOR i=0 TO 7
READ x,y,z
LET xApex(i) = x*xMax
LET yApex(i) = y*yMax
LET zApex(i) = z*zMax
NEXT i
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ki=0 TO 5
FOR kj=0 TO 5
LET epsi = SQR(molecData(ki,1)*molecData(kj,1))
LET sigm = 0.5*(molecData(ki,2)+molecData(kj,2))
FOR ir=10 TO 1001
LET r = ir*hh
LET r6 = (sigm/r)^6
LET forceTable(ki,kj,ir) = cutoff(r)*(24*epsi*r6*(2*r6-1)/r)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ki,kj,ir) = forceTable(ki,kj,10)
NEXT ir
NEXT kj
NEXT ki
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB registerNearMolec,moveParticlesDT,ajustVelocity
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 10
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET vz(i) = vz(i)+a*ffz(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
LET zz(i) = zz(i)+vz(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET vz(i) = vz(i)+a*ffz(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*molecData(2,2)
LET rCut2 = rCutoff^2
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET ffz(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET zij = zz(i)-zz(j)
LET r2ij = xij*xij+yij*yij+zij*zij
IF (r2ij<rCut2) THEN
LET rij = SQR(r2ij)
LET f = force(rij,kind(i),kind(j))
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET fzij = f*zij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffz(i) = ffz(i)+fzij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
LET ffz(j) = ffz(j)-fzij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
LET ffz(i) = ffz(i)+boundaryForce(zz(i)+s)+boundaryForce(zz(i)-zMax-s)
NEXT i
END SUB
!EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
! LET ri = sigma/r
! LET r6 = ri^6
! LET force = (24.0*epsilon*r6*(2.0*r6-1.0)/r)
!END FUNCTION
EXTERNAL FUNCTION force(r,ki,kj) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ki,kj,ir) + a*forceTable(ki,kj,ir+1))/hh
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (molecData(2,2)/r)^6
LET boundaryForce = (24.0*(0.5*molecData(2,1))*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+10*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))+(zz(i)-zz(j))*(zz(i)-zz(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mas(i)*(vx(i)^2+vy(i)^2+vz(i)^2)
NEXT i
LET systemTemprature = 2*ek/(3*nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
LET vz(i) = r*vz(i)
NEXT i
END SUB
! ---------- 3D graphics aid
EXTERNAL SUB setRotateXY(angleX,angleY)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = 0.5*xMax
LET cy0 = 0.5*yMax
LET cz0 = 0.5*zMax
END SUB
EXTERNAL SUB rotateXY !particles and box apex
FOR i=1 TO nMolec
LET ppx(i) = cosAy*(xx(i)-cx0)+sinAy*(sinAx*(yy(i)-cy0)+cosAx*(zz(i)-cz0)) + cx0
LET ppy(i) = cosAx*(yy(i)-cy0)-sinAx*(zz(i)-cz0) + cy0
LET ppz(i) =-sinAy*(xx(i)-cx0)+cosAy*(sinAx*(yy(i)-cy0)+cosAx*(zz(i)-cz0)) + cz0
NEXT i
FOR i=0 TO 7
LET pxApex(i) = cosAy*(xApex(i)-cx0)+sinAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cx0
LET pyApex(i) = cosAx*(yApex(i)-cy0)-sinAx*(zApex(i)-cz0) + cy0
LET pzApex(i) =-sinAy*(xApex(i)-cx0)+cosAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cz0
NEXT i
END SUB
EXTERNAL SUB markFarEdge
! seek far apex --> iMin
LET zMin = pzApex(0)
LET iMin = 0
FOR i=1 TO 7
IF zMin>pzApex(i) THEN
LET zMin = pzApex(i)
LET iMin = i
END IF
NEXT i
!mark far edge
FOR iEdge = 0 TO 11
LET boxEdge(iEdge,2) = 0
IF (boxEdge(iEdge,0)=iMin OR boxEdge(iEdge,1)=iMin) THEN LET boxEdge(iEdge,2) = 1
NEXT iEdge
END SUB
EXTERNAL SUB sortz
DECLARE EXTERNAL SUB qSort
FOR i=1 TO nMolec
LET srtzix(i) = i
NEXT i
CALL qSort(ppz,srtzix,1,nMolec)
END SUB
EXTERNAL SUB qSort(m(),a(),le,ri) !modified decimal BASIC library
IF ri>le THEN
LET i=le-1
LET j=ri
LET pv=m(a(ri))
DO
DO
LET i=i+1
LOOP UNTIL pv<=m(a(i))
DO
LET j=j-1
LOOP UNTIL j<=i OR m(a(j))<=pv
IF j<=i THEN EXIT DO
LET t=a(i)
LET a(i)=a(j)
LET a(j)=t
LOOP
LET t=a(i)
LET a(i)=a(ri)
LET a(ri)=t
CALL qSort(m,a,le,i-1)
CALL qSort(m,a,i+1,ri)
END IF
END SUB
EXTERNAL SUB plotNearEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=0 THEN !far edge mark = 0
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotFarEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=1 THEN !far edge mark = 1
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotEdge(iEdge,mag,xp,yp,lineColor)
SET LINE COLOR lineColor
FOR i=0 TO 1
LET iApex = boxEdge(iEdge,i)
PLOT LINES: pxApex(iApex)*mag+xp, pyApex(iApex)*mag+yp;
NEXT i
PLOT LINES
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(Ax,Ay) !Ax:rotate angle around s-axis, Ay:rotate angle around y-axis
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL SUB setRotateXY,rotateXY,sortz,markFarEdge,plotFarEdge,plotNearEdge
LET sc = 200/xMax ! 200=boxsize in graphic window
LET xp = 150
LET yp = 120
CALL setRotateXY(Ax,Ay)
CALL rotateXY !xx(i),yy(i),zz(i) rotate--> ppx(i),ppy(i),ppz(i)
CALL sortz !sort ppz(i) : ppz(srtzix(1))<ppz(srtzix(2))<...<ppz(srtzix(nMolec))
CALL markFarEdge ! boxEdge(iEdge,2)=1:far side edge or 0:near side edge
SET DRAW MODE HIDDEN
CLEAR
CALL plotFarEdge(sc,xp,yp,8) !8:gray
FOR i=1 TO nMolec
LET j = srtzix(i)
IF kind(j)=molecKind1 THEN
SET AREA COLOR 50+INT((ppz(j)/zMax+1)*20) ! the darker green, the deeper z-position
ELSEIF kind(j)=molecKind2 THEN
SET AREA COLOR 100+INT((ppz(j)/zMax+1)*20) ! the darker yellow, the deeper z-position
END IF
DRAW disk WITH SCALE(0.5*molecData(kind(j),2)*sc)*SHIFT(ppx(j)*sc+xp,ppy(j)*sc+yp)
NEXT i
CALL plotNearEdge(sc,xp,yp,1) !1:black
!draw caption
SET TEXT HEIGHT 8
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,55 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50,40 ,USING "box size =##.# x ##.# x ##.# (nm)":xMax*1e9,yMax*1e9,zMax*1e9
PLOT TEXT, AT 50,25 ,USING "N=### max number of registerd near molec=###":nMolec,maxNearMolec
PLOT TEXT, AT 50,10 :molecStr$(molecKind1)&molecStr$(molecKind2)&" in the box (3D molecular dynamics)"
PLOT TEXT, AT 50,380 ,USING "Ax =####.#(deg) Ay =####.#(deg)":Ax*180/PI,Ay*180/PI
SET DRAW MODE EXPLICIT
END SUB
!ミラーラビン法 http://6317.teacup.com/basic/bbs/4085
OPTION ARITHMETIC RATIONAL
LET k9=1000
DIM B(k9)
OPEN #2:NAME "E:\カーマイケル.TXT",ACCESS INPUT
FOR i=1 TO k9
INPUT #2: B(i)
NEXT i
CLOSE #2
FOR I=1 TO k9
LET A$=STR$(B(I))
IF ISPRIME2(A$,100)=1 THEN
PRINT A$
END IF
NEXT I
END
EXTERNAL FUNCTION ISPRIME(N$,NUM)
OPTION ARITHMETIC RATIONAL
ASSIGN "miller.dll","isprime"
END FUNCTION
EXTERNAL FUNCTION ISPRIME2(N$,NUM)
OPTION ARITHMETIC RATIONAL
ASSIGN "isprime.dll","isprime"
END FUNCTION
プログラムをご覧のように、ISPRIME2はboostライブラリー内のルーチンを
そのまま使用しているだけです。最新版 Version 1.63.0を使用し、VC++2017で
コンパイルし直して試してみましたが、残念ながら結果は同じでした。
Version 1.64.0 beta 2も1.63.0と内容同じでした。boostライブラリー内のことなので
どうしようもありません。使用に不安があるなら問題ナシのISPRIMEを使用してください。
試験環境：
本プログラムは十進BASIC 6.6.2 / macOS 10.7.5, 十進BASIC Ver 7.8.0 / windows 10 でテストしました。
----------------
!
! ========= Harmonics - steepest descent method 3D ==========
!
! 013harmonicsSD3D.bas
! Mitsuru Ikeuchi (C) copyleft
!
! ver 0.0.1 2017.04.06 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB sd3d.setInitialCondition,sd3d.SDiteration,sd3d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET Ax = PI/12 !rotate angle around x-axis
LET Ay = -PI/6 !rotate angle around y-axis
LET ddAy = PI/180 !Ay=Ay+ddAy
LET vIndex = 1 !vIndex=0: V=1/r, 1: V=(1/2)r^2, 2:V=0(r<=4) or V=16(r>4)
LET stateMax = 6 !state 0,1,...,stateMax-1
LET drawMode = 0 !drawMode=0:density3D, 1:grid |i> in (x,y,0)
LET dispState = 0 !display state |i>
CALL setInitialCondition(stateMax,vIndex)
DO
LET Ay = Ay + ddAy
IF Ay>PI THEN LET Ay = Ay - 2*PI
IF Ay<-PI THEN LET Ay = Ay + 2*PI
CALL SDiteration(stateMax, 2) !2 - iteration in SDiteration()
CALL drawState(dispState,Ax,Ay,drawMode,vIndex)
LET S$=INKEY$
IF S$="0" OR S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" THEN LET dispState = VAL(S$)
IF S$="W" OR S$="w" THEN LET ddAy = -PI/180
IF S$="E" OR S$="e" THEN LET ddAy = PI/180
IF S$="S" OR S$="s" THEN LET ddAy = 0
IF s$="/" THEN LET drawMode = MOD(drawMode+1,2)
IF S$="7" OR S$="8" OR S$="9" THEN
LET vIndex = VAL(S$)-7
CALL setInitialCondition(stateMax,vIndex)
END IF
IF S$="." THEN EXIT DO
LOOP
END
EXTERNAL FUNCTION INKEY$ !--- from decimal BASIC library inkey$.bas
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ========== SD3D(steepest descent method 3D) module ==========
!
! steepest descent method
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy set { Ei }, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
MODULE sd3d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, NNy, NNz, dx, dy, dz, iterCount
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(10) ! electron state energy
SHARE NUMERIC sdState(10,65,65,65) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(65,65,65) ! state work space in steepestDescent
SHARE NUMERIC vv(65,65,65) ! external potential
SHARE NUMERIC xApex(0 TO 7),yApex(0 TO 7),zApex(0 TO 7) ! boxApex x- y- z-coordinate
SHARE NUMERIC pxApex(0 TO 7),pyApex(0 TO 7),pzApex(0 TO 7) ! rotated boxApex x- y- z-coordinate
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2)! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
LET NNx = 32 ! x-max number of sdState(,NNx,NNy,NNz)
LET NNy = 32 ! y-max number of sdState(,NNx,NNy,NNz)
LET NNz = 32 ! z-max number of sdState(,NNx,NNy,NNz)
LET dx = 0.5 ! (au) x division
LET dy = 0.5 ! (au) y division
LET dz = 0.5 ! (au) y division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential,setBox
RANDOMIZE
LET iterCount = 0
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
CALL setBox
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = RND-0.5
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET x = i*dx
LET y = j*dy
LET z = k*dz
LET r = SQR((x-8)*(x-8)+(y-8)*(y-8)+(z-8)*(z-8))
IF vIndex=0 THEN
IF r<0.25 THEN LET r = 0.25
LET vv(i,j,k) = -1/r
ELSEIF vIndex=1 THEN
LET vv(i,j,k) = MIN(0.5*r*r,18)
ELSEIF vIndex=2 THEN
IF r<=4 THEN LET vv(i,j,k) = 0 ELSE LET vv(i,j,k) = 16
ELSE
LET vv(i,j,k) = 0
END IF
NEXT k
NEXT j
NEXT i
END SUB
EXTERNAL SUB setBox
IF boxEdge(11,1)<>7 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
FOR i=0 TO 7
READ x,y,z
LET xApex(i) = x*NNx*dx
LET yApex(i) = y*NNy*dy
LET zApex(i) = z*NNz*dz
NEXT i
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
LET damp = 0.05 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
CALL sortState(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist, damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
&-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
LET wrk(i,j,k) = kesdState+(vv(i,j,k)-ei)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = sdState(ist,i,j,k)-damp*wrk(i,j,k)
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
&-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
LET s = s + sdState(ist,i,j,k)*(kesdState+vv(i,j,k)*sdState(ist,i,j,k))
LET sn = sn+sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(istate,i,j,k) = sdState(istate,i,j,k) - s*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET w = sdState(ist,i,j,k)
LET sdState(ist,i,j,k) = sdState(ist+1,i,j,k)
LET sdState(ist+1,i,j,k) = w
NEXT k
NEXT j
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET s = s + sdState(ist,i,j,k)*sdState(jst,i,j,k)
NEXT k
NEXT j
NEXT i
LET innerProduct = s*dx*dy*dz
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET s = s + sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
LET a = SQR(1/(s*dx*dy*dz))
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = a*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
END SUB
! ---------- 3D graphics aid
EXTERNAL SUB setRotateXY(angleX,angleY)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = 0.5*NNx*dx
LET cy0 = 0.5*NNy*dy
LET cz0 = 0.5*NNz*dz
END SUB
EXTERNAL SUB rotateXY !particles and box apex
FOR i=0 TO 7
LET pxApex(i) = cosAy*(xApex(i)-cx0)+sinAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cx0
LET pyApex(i) = cosAx*(yApex(i)-cy0)-sinAx*(zApex(i)-cz0) + cy0
LET pzApex(i) =-sinAy*(xApex(i)-cx0)+cosAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cz0
NEXT i
END SUB
EXTERNAL SUB drawDisk3D(x,y,z,r,mag,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cx0
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0) + cy0
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cz0
DRAW disk WITH SCALE(r)*SHIFT(x1*mag+xShift,y1*mag+yShift)
END SUB
EXTERNAL SUB plotLines3D(x,y,z,mag,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cx0
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0) + cy0
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cz0
PLOT LINES: x1*mag+xShift, y1*mag+yShift;
END SUB
EXTERNAL SUB markFarEdge
! seek far apex --> iMin
LET zMin = pzApex(0)
LET iMin = 0
FOR i=1 TO 7
IF zMin>pzApex(i) THEN
LET zMin = pzApex(i)
LET iMin = i
END IF
NEXT i
!mark far edge
FOR iEdge = 0 TO 11
LET boxEdge(iEdge,2) = 0
IF (boxEdge(iEdge,0)=iMin OR boxEdge(iEdge,1)=iMin) THEN LET boxEdge(iEdge,2) = 1
NEXT iEdge
END SUB
EXTERNAL SUB plotNearEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=0 THEN !far edge mark = 0
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotFarEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=1 THEN !far edge mark = 1
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotEdge(iEdge,mag,xp,yp,lineColor)
SET LINE COLOR lineColor
FOR i=0 TO 1
LET iApex = boxEdge(iEdge,i)
PLOT LINES: pxApex(iApex)*mag+xp, pyApex(iApex)*mag+yp;
NEXT i
PLOT LINES
END SUB
! ---------- draw state
EXTERNAL SUB drawState(ist,xRotateAngle,yRotateAngle,drawMode,vIndex)
DECLARE EXTERNAL SUB drawDensity3D,setRotateXY,drawDensity3D,drawStateGrid
SET DRAW MODE HIDDEN
LET a$="H like harmonic quantumWell "
CLEAR
IF drawMode=0 THEN
CALL drawDensity3D(ist,xRotateAngle,yRotateAngle,200/(NNx*dx),140,150) !!(ist,Ax,Ay,sc,xp,yp)
ELSEIF drawMode=1 THEN
CALL drawStateGrid(ist,200/(NNx*dx),0.1,140,200) !(ist,sc,zMag,xp,yp)
END IF
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50, 70 ,USING "iterarion count =##### ":iterCount
PLOT TEXT, AT 50, 55 ,USING "E0 =###.######### E3 =###.#########(au)":sdEnergy(0),sdEnergy(3)
PLOT TEXT, AT 50, 40 ,USING "E1 =###.######### E4 =###.#########(au)":sdEnergy(1),sdEnergy(4)
PLOT TEXT, AT 50, 25 ,USING "E2 =###.######### E5 =###.#########(au)":sdEnergy(2),sdEnergy(5)
PLOT TEXT, AT 50, 10 :"steepest descent method 3D"
PLOT TEXT, AT 50,470 :"[.] exit [/] change drawMode "
PLOT TEXT, AT 50,455 :"[7] V=-1/r, [8] V=0.5r^2, [9] V=0(r<=4) =16(r>4)"
PLOT TEXT, AT 50,440 :"[0],[1],...,[5] view state "
PLOT TEXT, AT 50,425 :"[W] <<- rotate [S]top rotate ->> [E] "
PLOT TEXT, AT 50,410 :"potential = "&a$(vIndex*12+1:vIndex*12+11)
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB drawDensity3D(ist,xRotateAngle,yRotateAngle,sc,xp,yp) !----- drawMode=0
DECLARE EXTERNAL SUB setRotateXY,rotateXY,markFarEdge,plotFarEdge,drawDisk3D,plotNearEdge
CALL setRotateXY(xRotateAngle,yRotateAngle)
CALL rotateXY !rotateXY BOX
CALL markFarEdge ! boxEdge(iEdge,2)=1:far side edge or 0:near side edge
CALL plotFarEdge(sc,xp,yp,8) !8:gray
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET psi = sdState(ist,i,j,k)
LET psi2 = psi*psi
IF psi2>0.001 THEN
IF psi>0 THEN SET AREA COLOR 4 ELSE SET AREA COLOR 2
CALL drawDisk3D(i*dx,j*dy,k*dz,ABS(psi)*10,sc,xp,yp)
END IF
NEXT k
NEXT j
NEXT i
!SET AREA COLOR 1
!CALL drawDisk3D(0,0,0,5,sc,xp,yp)
CALL plotNearEdge(sc,xp,yp,1) !1:black
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,100:"|"&STR$(ist)&">"
PLOT TEXT, AT 50, 85 ,USING "Ax =####.#(deg) Ay =####.#(deg)":xRotateAngle*180/PI,yRotateAngle*180/PI
END SUB
EXTERNAL SUB drawStateGrid(ist,sc,zMag,xp,yp) !--- drawMode=1
DECLARE EXTERNAL SUB setRotateXY,drawGridXY
CALL setRotateXY(-PI/3,-PI/6)
CALL drawGridXY(ist,sc,zMag,xp,yp)
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,100:"|"&STR$(ist)&"> in (x,y,0)"
END SUB
EXTERNAL SUB drawGridXY(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*dx,j*dx,zMag*(psi + 2*vv(i,j,NNz/2)),sc,xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*dx,j*dx,zMag*(psi + 2*vv(i,j,NNz/2)),sc,xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
!
! ========= Harmonics - steepest descent method 3D ==========
!
! 013harmonicsSD3Dv002.bas
! Mitsuru Ikeuchi (C) copyleft
!
! ver 0.0.1 2017.04.06 created
! ver 0.0.2 2017.04.10 bug in sub drawDensity3D fixed
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB sd3d.setInitialCondition,sd3d.SDiteration,sd3d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET Ax = PI/12 !rotate angle around x-axis
LET Ay = -PI/6 !rotate angle around y-axis
LET ddAy = PI/180 !Ay=Ay+ddAy
LET vIndex = 1 !vIndex=0: V=1/r, 1: V=(1/2)r^2, 2:V=0(r<=4) or V=16(r>4)
LET stateMax = 6 !state 0,1,...,stateMax-1
LET drawMode = 0 !drawMode=0:density3D, 1:grid |i> in (x,y,0)
LET dispState = 0 !display state |i>
CALL setInitialCondition(stateMax,vIndex)
DO
LET Ay = Ay + ddAy
IF Ay>PI THEN LET Ay = Ay - 2*PI
IF Ay<-PI THEN LET Ay = Ay + 2*PI
CALL SDiteration(stateMax, 2) !2 - iteration in SDiteration()
CALL drawState(dispState,Ax,Ay,drawMode,vIndex)
LET S$=INKEY$
IF S$="0" OR S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" THEN LET dispState = VAL(S$)
IF S$="W" OR S$="w" THEN LET ddAy = -PI/180
IF S$="E" OR S$="e" THEN LET ddAy = PI/180
IF S$="S" OR S$="s" THEN LET ddAy = 0
IF s$="/" THEN LET drawMode = MOD(drawMode+1,2)
IF S$="7" OR S$="8" OR S$="9" THEN
LET vIndex = VAL(S$)-7
CALL setInitialCondition(stateMax,vIndex)
END IF
IF S$="." THEN EXIT DO
LOOP
END
EXTERNAL FUNCTION INKEY$ !--- from decimal BASIC library inkey$.bas
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ========== SD3D(steepest descent method 3D) module ==========
!
! steepest descent method
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy set { Ei }, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
MODULE sd3d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, NNy, NNz, dx, dy, dz, iterCount
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(10) ! electron state energy
SHARE NUMERIC sdState(10,65,65,65) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(65,65,65) ! state work space in steepestDescent
SHARE NUMERIC vv(65,65,65) ! external potential
SHARE NUMERIC xApex(0 TO 7),yApex(0 TO 7),zApex(0 TO 7) ! boxApex x- y- z-coordinate
SHARE NUMERIC pxApex(0 TO 7),pyApex(0 TO 7),pzApex(0 TO 7) ! rotated boxApex x- y- z-coordinate
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2)! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
LET NNx = 32 ! x-max number of sdState(,NNx,NNy,NNz)
LET NNy = 32 ! y-max number of sdState(,NNx,NNy,NNz)
LET NNz = 32 ! z-max number of sdState(,NNx,NNy,NNz)
LET dx = 0.5 ! (au) x division
LET dy = 0.5 ! (au) y division
LET dz = 0.5 ! (au) y division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential,setBox
RANDOMIZE
LET iterCount = 0
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
CALL setBox
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = RND-0.5
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET x = i*dx
LET y = j*dy
LET z = k*dz
LET r = SQR((x-8)*(x-8)+(y-8)*(y-8)+(z-8)*(z-8))
IF vIndex=0 THEN
IF r<0.25 THEN LET r = 0.25
LET vv(i,j,k) = -1/r
ELSEIF vIndex=1 THEN
LET vv(i,j,k) = MIN(0.5*r*r,18)
ELSEIF vIndex=2 THEN
IF r<=4 THEN LET vv(i,j,k) = 0 ELSE LET vv(i,j,k) = 16
ELSE
LET vv(i,j,k) = 0
END IF
NEXT k
NEXT j
NEXT i
END SUB
EXTERNAL SUB setBox
IF boxEdge(11,1)<>7 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
FOR i=0 TO 7
READ x,y,z
LET xApex(i) = x*NNx*dx
LET yApex(i) = y*NNy*dy
LET zApex(i) = z*NNz*dz
NEXT i
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
LET damp = 0.05 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
CALL sortState(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist, damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
&-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
LET wrk(i,j,k) = kesdState+(vv(i,j,k)-ei)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = sdState(ist,i,j,k)-damp*wrk(i,j,k)
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,i+1,j,k)-sdState(ist,i-1,j,k)&
&-sdState(ist,i,j+1,k)-sdState(ist,i,j-1,k)-sdState(ist,i,j,k+1)-sdState(ist,i,j,k-1))/h2
LET s = s + sdState(ist,i,j,k)*(kesdState+vv(i,j,k)*sdState(ist,i,j,k))
LET sn = sn+sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(istate,i,j,k) = sdState(istate,i,j,k) - s*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET w = sdState(ist,i,j,k)
LET sdState(ist,i,j,k) = sdState(ist+1,i,j,k)
LET sdState(ist+1,i,j,k) = w
NEXT k
NEXT j
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET s = s + sdState(ist,i,j,k)*sdState(jst,i,j,k)
NEXT k
NEXT j
NEXT i
LET innerProduct = s*dx*dy*dz
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET s = s + sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
LET a = SQR(1/(s*dx*dy*dz))
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
FOR k=1 TO NNz-2
LET sdState(ist,i,j,k) = a*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
END SUB
! ---------- 3D graphics aid
EXTERNAL SUB setRotateXY(angleX,angleY)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = 0.5*NNx*dx
LET cy0 = 0.5*NNy*dy
LET cz0 = 0.5*NNz*dz
END SUB
EXTERNAL SUB rotateXY !particles and box apex
FOR i=0 TO 7
LET pxApex(i) = cosAy*(xApex(i)-cx0)+sinAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cx0
LET pyApex(i) = cosAx*(yApex(i)-cy0)-sinAx*(zApex(i)-cz0) + cy0
LET pzApex(i) =-sinAy*(xApex(i)-cx0)+cosAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cz0
NEXT i
END SUB
EXTERNAL SUB drawDisk3D(x,y,z,r,mag,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cx0
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0) + cy0
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cz0
DRAW disk WITH SCALE(r)*SHIFT(x1*mag+xShift,y1*mag+yShift)
END SUB
EXTERNAL SUB plotLines3D(x,y,z,mag,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cx0
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0) + cy0
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cz0
PLOT LINES: x1*mag+xShift, y1*mag+yShift;
END SUB
EXTERNAL SUB markFarEdge
! seek far apex --> iMin
LET zMin = pzApex(0)
LET iMin = 0
FOR i=1 TO 7
IF zMin>pzApex(i) THEN
LET zMin = pzApex(i)
LET iMin = i
END IF
NEXT i
!mark far edge
FOR iEdge = 0 TO 11
LET boxEdge(iEdge,2) = 0
IF (boxEdge(iEdge,0)=iMin OR boxEdge(iEdge,1)=iMin) THEN LET boxEdge(iEdge,2) = 1
NEXT iEdge
END SUB
EXTERNAL SUB plotNearEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=0 THEN !far edge mark = 0
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotFarEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=1 THEN !far edge mark = 1
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotEdge(iEdge,mag,xp,yp,lineColor)
SET LINE COLOR lineColor
FOR i=0 TO 1
LET iApex = boxEdge(iEdge,i)
PLOT LINES: pxApex(iApex)*mag+xp, pyApex(iApex)*mag+yp;
NEXT i
PLOT LINES
END SUB
! ---------- draw state
EXTERNAL SUB drawState(ist,xRotateAngle,yRotateAngle,drawMode,vIndex)
DECLARE EXTERNAL SUB drawDensity3D,setRotateXY,drawDensity3D,drawStateGrid
SET DRAW MODE HIDDEN
LET a$="H like harmonic quantumWell "
CLEAR
IF drawMode=0 THEN
CALL drawDensity3D(ist,xRotateAngle,yRotateAngle,200/(NNx*dx),140,150) !!(ist,Ax,Ay,sc,xp,yp)
ELSEIF drawMode=1 THEN
CALL drawStateGrid(ist,200/(NNx*dx),0.1,140,200) !(ist,sc,zMag,xp,yp)
END IF
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50, 70 ,USING "iterarion count =##### ":iterCount
PLOT TEXT, AT 50, 55 ,USING "E0 =###.######### E3 =###.#########(au)":sdEnergy(0),sdEnergy(3)
PLOT TEXT, AT 50, 40 ,USING "E1 =###.######### E4 =###.#########(au)":sdEnergy(1),sdEnergy(4)
PLOT TEXT, AT 50, 25 ,USING "E2 =###.######### E5 =###.#########(au)":sdEnergy(2),sdEnergy(5)
PLOT TEXT, AT 50, 10 :"steepest descent method 3D"
PLOT TEXT, AT 50,470 :"[.] exit [/] change drawMode "
PLOT TEXT, AT 50,455 :"[7] V=-1/r, [8] V=0.5r^2, [9] V=0(r<=4) =16(r>4)"
PLOT TEXT, AT 50,440 :"[0],[1],...,[5] view state "
PLOT TEXT, AT 50,425 :"[W] <<- rotate [S]top rotate ->> [E] "
PLOT TEXT, AT 50,410 :"potential = "&a$(vIndex*12+1:vIndex*12+11)
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB drawDensity3D(ist,xRotateAngle,yRotateAngle,sc,xp,yp) !----- drawMode=0
DECLARE EXTERNAL SUB setRotateXY,rotateXY,markFarEdge,plotFarEdge,drawDisk3D,plotNearEdge
CALL setRotateXY(xRotateAngle,yRotateAngle)
CALL rotateXY !rotateXY BOX
CALL markFarEdge ! boxEdge(iEdge,2)=1:far side edge or 0:near side edge
CALL plotFarEdge(sc,xp,yp,8) !8:gray
LET ibeg = 1
LET iend = NNx-2
LET istep = 1
IF pzApex(1)-pzApex(0)<0 THEN
LET ibeg = NNx-2
LET iend = 1
LET istep = -1
END IF
LET jbeg = 1
LET jend = NNy-2
LET jstep = 1
IF pzApex(2)-pzApex(0)<0 THEN
LET jbeg = NNy-2
LET jend = 1
LET jstep = -1
END IF
LET kbeg = 1
LET kend = NNz-2
LET kstep = 1
IF pzApex(4)-pzApex(0)<0 THEN
LET kbeg = NNz-2
LET kend = 1
LET kstep = -1
END IF
FOR i=ibeg TO iend STEP istep
FOR j=jbeg TO jend STEP jstep
FOR k=kbeg TO kend STEP kstep
LET psi = sdState(ist,i,j,k)
LET psi2 = psi*psi
IF psi2>0.001 THEN
IF psi>0 THEN SET AREA COLOR 4 ELSE SET AREA COLOR 2
CALL drawDisk3D(i*dx,j*dy,k*dz,ABS(psi)*10,sc,xp,yp)
END IF
NEXT k
NEXT j
NEXT i
!SET AREA COLOR 1
!CALL drawDisk3D(0,0,0,5,sc,xp,yp)
CALL plotNearEdge(sc,xp,yp,1) !1:black
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,100:"|"&STR$(ist)&">"
PLOT TEXT, AT 50, 85 ,USING "Ax =####.#(deg) Ay =####.#(deg)":xRotateAngle*180/PI,yRotateAngle*180/PI
END SUB
EXTERNAL SUB drawStateGrid(ist,sc,zMag,xp,yp) !--- drawMode=1
DECLARE EXTERNAL SUB setRotateXY,drawGridXY
CALL setRotateXY(-PI/3,-PI/6)
CALL drawGridXY(ist,sc,zMag,xp,yp)
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,100:"|"&STR$(ist)&"> in (x,y,0)"
END SUB
EXTERNAL SUB drawGridXY(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*dx,j*dx,zMag*(psi + 2*vv(i,j,NNz/2)),sc,xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*dx,j*dx,zMag*(psi + 2*vv(i,j,NNz/2)),sc,xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
!30n± k篩 prime quadruplet
OPTION ARITHMETIC NATIVE
LET t0=TIME
LET k6=31627
LET k2=3402
!エラトステネスの篩
LET Fu=k6
DIM P(Fu)
DIM A(k2) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
DIM B(4)
DATA 11,13,17,19
MAT READ B
LET Q=30
LET ka=IP(1E9/Q)+1
LET kb=1E9
LET kc=k2
LET kd=IP(kb/207)
FOR r=1 TO 4
LET rr=B(r)
MAT D = ZER
FOR t=4 TO kc
LET x=A(t)
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 80
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 80
END IF
FOR i=2 TO x !*.86
IF MOD(Q*i-rr,x)=0 THEN
LET y=-i
EXIT FOR
END IF
NEXT i
80 FOR f=1 TO kd
IF x*f+y>ka THEN EXIT FOR
LET D(x*f+y)=1
NEXT f
NEXT t
MAT E=D+E
NEXT r
OPEN #1:NAME "E:\prime_10_PQF.txt",RECTYPE INTERNAL
ERASE #1
WRITE #1: 5
WRITE #1: 11
FOR n=1 TO ka
IF n*Q+rr>kb THEN EXIT FOR
IF E(n)=0 THEN
LET cj=cj+1
WRITE #1: 30*n+11
END IF
NEXT n
CLOSE #1
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
プログラム
-----------------------------------------
LET t0=TIME
LET k=100000007
LET k2=5761456
DIM GT(k2)
CALL prime(k,k2,GT)
FOR i=1 TO k2-1
LET M=GT(i)
LET M1=GT(i+1)
IF M1-M=2 THEN
LET M2=MOD(M+1,6)
LET C=C+1
PRINT C;M;M2
END IF
NEXT i
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
EXTERNAL SUB prime(k,k2,GT())
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
DIM A(Fm) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET GT(1)=2
LET GT(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n+1
END IF
NEXT n
END SUB
OPTION ARITHMETIC RATIONAL
LET S=1000000000000001 !'開始値(奇数)
LET E=S+100000000 !'終了値
LET P=GetArray((E-S)/2)
IF P<>0 THEN
LET T=TIME
OPEN #1:NAME "prime_list.txt"
LET K=INTSQR(E)+1
DO
INPUT #1,IF MISSING THEN EXIT DO:A
IF A>2 THEN
IF A>K THEN EXIT DO
IF MOD(S,A)>0 THEN LET S1=INT(S/A+1)*A ELSE LET S1=S
IF S<=A THEN
IF Test(p,(S1-S)/2)=0 THEN LET S1=S1+A
END IF
FOR I=S1 TO E STEP A
IF MOD(I,2)=1 THEN CALL SetBit(P,(I-S)/2) !'奇数のみセット
NEXT I
END IF
LOOP
CLOSE #1
PRINT USING "####.##秒":MOD(TIME-T+86400,86400)
LET T=TIME
OPEN #1:NAME "out.txt"
ERASE #1
LET S1=INT((S-11)/30+1)*30+11
FOR I=S1 TO E-8 STEP 30
IF Test(p,(I-S)/2)=0 AND Test(p,(I-S+2)/2)=0 AND Test(p,(I-S+6)/2)=0 AND Test(p,(I-S+8)/2)=0 THEN
LET COUNT=COUNT+1
PRINT #1:I;I+2;I+6;I+8
END IF
NEXT I
PRINT #1:"COUNT=";COUNT
CLOSE #1
CALL FreeArray(p)
PRINT USING "####.##秒":TIME-T
END IF
END
EXTERNAL FUNCTION GetArray(s)
OPTION ARITHMETIC RATIONAL
! (s+1)ビットのメモリを確保し，ゼロで埋める。
! 結果は，メモリのアドレス。0のときは失敗。
FUNCTION GetArray_sub(s)
ASSIGN "BitArray.DLL","GetArray"
END FUNCTION
IF 0<=s AND s<2^32 THEN
LET GetArray=getArray_sub(s)
ELSE
LET GetArray=0
END IF
END FUNCTION
EXTERNAL SUB FreeArray(p)
OPTION ARITHMETIC RATIONAL
! メモリを返却する。pはGetArrayで得た値
ASSIGN "BitArray.DLL","FreeArray"
END SUB
EXTERNAL FUNCTION Test(p,i)
OPTION ARITHMETIC RATIONAL
! i番目のビットを取得する。pはGetArrayで得た値
ASSIGN "BitArray.DLL", "Test"
END FUNCTION
EXTERNAL SUB SetBit(p,i)
OPTION ARITHMETIC RATIONAL
! i番目のビットを1にする。pはGetArrayで得た値
ASSIGN "BitArray.DLL", "SetBit"
END SUB
EXTERNAL SUB ResetBit(p,i)
OPTION ARITHMETIC RATIONAL
! i番目のビットを0にする。pはGetArrayで得た値
ASSIGN "BitArray.DLL", "ResetBit"
END SUB
LET t0=TIME
LET k=100000007
LET k2=5761456
DIM GT(k2)
CALL prime(k,k2,GT)
FOR i=1 TO k2-1
LET M=GT(i)
PRINT M
NEXT i
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
EXTERNAL SUB prime(k,k2,GT())
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
DIM A(Fm) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET GT(1)=2
LET GT(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n+1
END IF
NEXT n
END SUB
--------------------------------
出力テキストファイル確認用 プログラム
--------------------------------
OPTION ARITHMETIC NATIVE
LET t0=TIME
LET k6=1000000
DIM A(k6),B(k6),C(k6)
OPEN #1:NAME "prime1E_84.TXT",ACCESS INPUT
OPEN #2:NAME "prime_1E8xv.TXT",ACCESS INPUT
FOR i=1 TO k6
INPUT #1: A(i)
INPUT #2: B(i)
NEXT i
CLOSE #1
CLOSE #2
PRINT A(10000);B(10000)
PRINT A(k6);B(k6)
MAT C=B-A
FOR n=1 TO k6
IF C(n)<>0 THEN PRINT n;A(n);B(n)
NEXT n
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
var working:boolean=false; //追加
procedure TextoutExec;
begin
if working then exit; //追加
working:=true; //追加
if Cachelen>0 then
begin
TextForm.AppendString(CacheString);
CharPoint:=PChar(CacheString);
Cachelen:=0;
end;
working:=false; //追加
end;
A014561 Numbers n giving rise to prime quadruples (30n+11, 30n+13, 30n+17, 30n+19). http://oeis.org/A014561
上記の数列を生成するプログラム
prime quadruples BASIC Acc program
-------------------------------
!30n± k篩
OPTION ARITHMETIC NATIVE
LET t0=TIME
LET k6=31627
LET k2=3402
!エラトステネスの篩 !http://6317.teacup.com/basic/bbs/4264
LET Fu=k6
DIM P(Fu)
DIM A(k2) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
DIM B(4)
DATA 11,13,17,19
MAT READ B
LET Q=30
LET ka=INT(1E9/Q)+1
LET kb=1E9
LET kc=k2
LET kd=INT(kb/207)
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 80
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 80
END IF
FOR i=2 TO x !*.86
IF MOD(Q*i-rr,x)=0 THEN
LET y=-i
EXIT FOR
END IF
NEXT i
80 FOR f=1 TO kd
IF x*f+y>ka THEN EXIT FOR
LET D(x*f+y)=1
NEXT f
NEXT t
NEXT r
OPEN #1:NAME "E:\pi4_1E_9.txt",RECTYPE INTERNAL
ERASE #1
WRITE #1:0
FOR n=1 TO ka
!IF n*Q+rr>kb THEN EXIT FOR
IF D(n)=0 THEN
LET cj=cj+1
WRITE #1:n
END IF
NEXT n
CLOSE #1
PRINT cj
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END
-----------------------
計算結果
28388 37.07秒
30n+k 篩 の探究の結果 このアルゴリズムにたどり着きました。
精度確認中です。
FOR i=2 TO x !*.86
IF MOD(Q*i-rr,x)=0 THEN
LET y=-i
EXIT FOR
END IF
NEXT i
素数の係数を求めるループがネックで1000億位が限度です。
それで
6n±1 篩
十進BASIC 1000桁モードで 16桁も行ってみた。
!6n±1篩 Ver.1
!四つ子素数計数関数（π4(x) Prime Quadruplet-counting function）
DECLARE EXTERNAL FUNCTION cprime
DECLARE EXTERNAL SUB sqprime
OPTION ARITHMETIC DECIMAL_HIGH
PRINT DATE$;"/"; TIME$
LET t0=TIME
LET k=31716427
LET k2=1957369
DIM GT(k2)
OPEN #3:NAME "E:\prime_1E8xv.txt",ACCESS INPUT
FOR i=1 TO k2
INPUT #3: GT(i)
NEXT i
CLOSE #3
! MAX 1005931741646329=31716427^2
LET SA=100000001 !MIN 2 (1E+7 to)
LET SB=100001000 !MAX 1E15-1
CALL sqprime(SA,SB,k2,GT)
DIM Bb(SA TO SB)
OPEN #2:NAME "prime_pi1.txt",ACCESS INPUT
FOR i=SA TO SB
INPUT #2: BB(i)
NEXT i
CLOSE #2
LET c2=3314576487 !http://oeis.org/A050258/b050258.txt
! !SA=数値入力+1 (1E7)
LET c1=0 !1E7 (1E7) to 2E7
PRINT SA-1;":";c2;":";c1;":";c
LET k6=SA*1E7-1E7
FOR n=SA TO SB
LET t1=TIME
LET k2=Bb(n) !π(x)
LET k6=k6+1E7
LET C=cprime(k2,k6,GT)
LET c1=c1+c
PRINT n*1E7;":";c2+c1;":";c1;":";c;
LET TM=TIME-t1
PRINT USING"######." & REPEAT$("#",2):TM;
PRINT "秒"
NEXT n
LET TM=TIME-t0
PRINT USING"######." & REPEAT$("#",2):TM;
PRINT "秒"
PRINT DATE$;"/"; TIME$
END
EXTERNAL FUNCTION cprime (k2,k6,GT())
OPTION ARITHMETIC DECIMAL_HIGH
LET k4=k6-1E7
LET B6=INT(k6/30)
LET U=INT(k6/6)
LET W=INT(k4/6)
LET M7=W
DIM x(W-M7 TO U-M7)
MAT x = ZER !(6*n-1)
FOR n=3 TO k2
LET P6=GT(n)
LET G1=INT(W/P6)!-2
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 140
IF P6*i+r6>U THEN EXIT FOR
LET x(P6*i+r6-M7)=1
140 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 150
IF P6*i-r6>U THEN EXIT FOR
LET x(P6*i-r6-M7)=1
150 NEXT i
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 160
IF P6*i-r6>U THEN EXIT FOR
LET x(P6*i-r6-M7)=1
160 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 170
IF P6*i+r6>U THEN EXIT FOR
LET x(P6*i+r6-M7)=1
170 NEXT i
END IF
NEXT n
LET Cc=0
FOR n=W-M7 TO U-M7-1
LET ST=n+M7
IF x(n)=0 AND x(n+1)=0 AND 6*ST-1>k4 AND 6*ST-1<k6 THEN
LET cc=cc+1
END IF
NEXT n
LET cprime=cc
END FUNCTION
EXTERNAL SUB sqprime(SA,SB,k2,GT())
OPTION ARITHMETIC DECIMAL_HIGH
OPEN #2:NAME "prime_pi1.txt",RECTYPE INTERNAL
ERASE #2
LET x=1E7
FOR i=1 TO k2-1
LET v=GT(i)^2
LET vi=GT(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=1E7 THEN
LET vt=INT(vv/1E7)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+1E7
IF C>=SA AND SB>=C THEN
WRITE #2:i
END IF
NEXT ns
END SUB
CLOSE #2
END SUB
> 原因は特定できた（修正したら問題なし）ので，
> 近いうちに修正版を出します。
>
> お急ぎでしたら，
> OUTPUT フォルダを一旦，空にして，
> sourceフォルダのtextfile.pasの544行～552行にある
> procedure TextoutExec
> を以下のように書き換えてください。
>
> var working:boolean=false; //追加
> procedure TextoutExec;
> begin
> if working then exit; //追加
> working:=true; //追加
> if Cachelen>0 then
> begin
> TextForm.AppendString(CacheString);
> CharPoint:=PChar(CacheString);
> Cachelen:=0;
> end;
> working:=false; //追加
> end;
試ました。
Free Pascal Compiler version 3.0.2 [2017/02/27] for i386
Copyright (c) 1993-2017 by Florian Klaempfl and others
textfile.pas(548,18) Fatal: illegal character "'?'" ($E3)
Fatal: Compilation aborted
LET t0 = TIME
FOR it = 1 TO 1000
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode)
NEXT it
!PRINT TIME - t0
END
! ---------- molecular dynamics 2D - Morse potential ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Morse V(r) = D*((1-EXP(-A*(r-r0)))^2-1)
! = D*(EXP(-2*A*(r-r0))-2*EXP(-A*(r-r0)))
! (D:dissociation energy, r0:bond length, A:width parameter { A=SQR(k/(2*D)) }
! force F(r) = -dV(r)/dr
! = 2*D*A*y*(y-1), y=EXP(-A*(r-r0))
MODULE mmd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC molecKind, sysTime, dt, nMolec, xMax, yMax, mass, Dmrs, Amrs, r0mrs
SHARE NUMERIC xx(500),yy(500) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC molecData(0 TO 18,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE STRING molecSTR$(0 TO 18) ! molec string
LET molecKind = 3 ! 3:Fe
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 5.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET mass = 55.847*1.661e-27! mass of Fe (kg)
LET Dmrs = 0.4174*1.602e-19! D of Morse potential (J) : energy of dissociation
LET Amrs = 1.3885e10 ! A of Morse potential (1/m) : width parameter
LET r0mrs = 2.845e-10 ! r0 of Morse potential (m) : bond length
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
DECLARE EXTERNAL SUB setMolecData,setMolecules,ajustVelocity
DECLARE EXTERNAL FUNCTION setCrystalBlock
RANDOMIZE
CALL setMolecData
LET molecKind = molKind
LET mass = molecData(molecKind,0)
LET Dmrs = molecData(molecKind,1)
LET Amrs = molecData(molecKind,2)
LET r0mrs = molecData(molecKind,3)
LET sysTime = 0.0
! set particles
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
LET s = 0.5*(boxSizeInNM-xtalSizeInNM)*1.0e-9
LET nMolec = setCrystalBlock(1, s, s, xtalSizeInNM*1.0e-9, xtalSizeInNM*1.0e-9, PI/4)
CALL ajustVelocity(contTemp)
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMolecData
! Morse potential data
! 0:mass(AU) 1:D(eV) 2:A(m^-1) 3:r0(m)
DATA 183.85 , 0.9906, 1.4116e10, 3.032e-10 ! 0 W
DATA 95.94 , 0.8032, 1.5079e10, 2.976e-10 ! 1 Mo
DATA 51.996, 0.4414, 1.5721e10, 2.754e-10 ! 2 Cr
DATA 55.847, 0.4174, 1.3885e10, 2.845e-10 ! 3 Fe
DATA 58.71 , 0.4205, 1.4199e10, 2.780e-10 ! 4 Ni
DATA 26.98 , 0.2703, 1.1646e10, 3.253e-10 ! 5 Al
DATA 207.19 , 0.2348, 1.1836e10, 3.733e-10 ! 6 Pb
DATA 63.54 , 0.3429, 1.3588e10, 2.866e-10 ! 7 Cu
DATA 107.87 , 0.3323, 1.3690e10, 3.115e-10 ! 8 Ag
DATA 39.948, 0.0104, 1.3400e10, 3.816e-10 ! 9 Ar
DATA 200.59 , 0.0734, 1.4900e10, 3.255e-10 ! 10 Hg
DATA 40.08 , 0.1623, 0.8054e10, 4.569e-10 ! 11 Ca
DATA 87.62 , 0.1513, 0.7878e10, 4.988e-10 ! 12 Sr
DATA 137.34 , 0.1416, 0.6570e10, 5.373e-10 ! 13 Ba
DATA 22.99 , 0.0633, 0.5900e10, 5.336e-10 ! 14 Na
DATA 39.102, 0.0542, 0.4977e10, 6.369e-10 ! 15 K
DATA 20.183, 0.0031, 1.6500e10, 3.076e-10 ! 16 Ne
DATA 83.80 , 0.0141, 1.2500e10, 4.097e-10 ! 17 Kr
DATA 131.30 , 0.0200, 1.2400e10, 4.467e-10 ! 18 Xe
DATA "W" ,"Mo","Cr","Fe","Ni","Al","Pb","Cu","Ag","Ar","Hg"
DATA "Ca","Sr","Ba","Na","K" ,"Ne","Kr","Xe"
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 18
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.602e-19 !eps(eV) --> (J)
NEXT i
MAT READ molecSTR$
END IF
END SUB
EXTERNAL function setCrystalBlock(ii, x0, y0, xLen, yLen, theta)
DECLARE EXTERNAL SUB setParticle
LET iip = ii
LET a = 0.98*r0mrs
LET b = 0.866025*a
LET leng = xLen
IF (leng<yLen) THEN LET leng = yLen
LET leng = 1.5*leng
LET nx = INT(leng/b) + 1
LET ny = INT(leng/a) + 1
LET sth = SIN(theta)
LET cth = COS(theta)
FOR i=0 TO nx-1
LET x = b*i - leng/2.0
FOR j=0 TO ny-1
LET y = a*j - leng/2.0
IF MOD(i,2)=1 THEN LET y = y + 0.5*a
LET xp = x0 + xLen/2.0 + cth*x - sth*y
LET yp = y0 + yLen/2.0 + sth*x + cth*y
IF (xp>=x0 AND xp<=x0+xLen AND yp>=y0 AND yp<=y0+yLen) THEN
CALL setParticle(iip, xp, yp)
LET iip = iip + 1
END IF
NEXT j
NEXT i
LET setCrystalBlock = iip - 1
end function
EXTERNAL SUB setParticle(i, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
END SUB
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR j=i+1 TO nMolec
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
NEXT j
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
LET y = EXP(-Amrs*(r-r0mrs))
LET force = 2*Dmrs*Amrs*y*(y-1)
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (3.418e-10/r)^6
LET boundaryForce = (24.0*(0.5*1.711e-21)*r6*(2.0*r6-1.0)/r)
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond
SET DRAW MODE HIDDEN
CLEAR
call plotBond(drawMode)
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING "N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional molecular dynamics"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
SET LINE COLOR 8 ! gray
DRAW circle WITH SCALE(r0mrs/2.0*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR j=i TO nMolec
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
IF r<1.2*r0mrs THEN
IF r<0.93*r0mrs THEN
SET LINE COLOR 4 !red 13 !'oleave
ELSEIF r<1.03*r0mrs THEN
SET LINE COLOR 3 !green
ELSEIF r<1.08*r0mrs THEN
SET LINE COLOR 2 !blue
ELSE
SET LINE COLOR 8 !gray
END IF
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT j
NEXT i
END IF
END sub
pi(x) : n=9.99E+10 TO 1E+11
1000 : 4118054813 : 3949221
107.13秒( 1分47.13秒 )
PC-AMD Athlon(tm) 64 Processor 3800+
周波数 : 2.40 GHz
メモリー : 3.00 GB
Microsoft Windows 8.1(32 ビット)
BASIC Acc
-----------------------------------------------------------------------
!6n±1篩 prime number pi(x) Ver.2.3
DECLARE EXTERNAL FUNCTION cprime
DECLARE EXTERNAL SUB sqprime
DECLARE EXTERNAL SUB TIMES
OPTION ARITHMETIC NATIVE
!PRINT DATE$;"/"; TIME$
LET t0=TIME
LET k=31622803
LET k2=1951960
!エラトステネスの篩
LET Fu=5633
DIM P(Fu)
DIM A(739) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
DIM GT(k2)
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO 739
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET GT(1)=2
LET GT(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n+1
END IF
NEXT n
LET SA=2 !1000 !,MIN 2 (1億to)
LET SB=2 !1000 !,MAX 1E15-1
CALL sqprime(SA,SB,k2,GT)
DIM Bb(SA TO SB)
OPEN #2:NAME "prime_pi1.txt",ACCESS INPUT
FOR i=SA TO SB
INPUT #2: BB(i)
NEXT i
CLOSE #2
!
DIM Pn(1000)
MAT READ Pn
DATA 5761455,11078937,16252325,21336326,26355867,31324703,36252931,41146179,46009215,50847534
DATA 55662470,60454705,65228333,69985473,74726528,79451833,84163019,88862422,93547928,98222287
DATA 102886526,107540122,112184940,116818447,121443371,126062167,130670192,135270258,139864011,144449537
DATA 149028641,153600805,158165829,162725196,167279333,171827136,176369517,180906194,185436625,189961812
DATA 194481069,198996103,203507248,208013454,212514323,217011319,221504167,225991743,230475545,234954223
DATA 239429993,243902342,248370960,252834065,257294520,261751864,266206294,270655552,275101551,279545368
DATA 283984956,288422869,292856421,297285198,301711468,306137611,310558733,314977166,319391721,323804352
DATA 328215206,332620900,337024801,341426904,345826612,350221825,354615116,359006517,363395981,367783654
DATA 372168766,376549859,380930729,385307831,389682427,394055910,398425675,402793457,407159590,411523195
DATA 415885628,420243162,424603409,428958595,433311792,437663672,442014876,446362736,450708777,455052511
DATA 459394441,463733626,468072089,472408200,476741968,481074475,485405902,489736021,494062787,498388617
DATA 502712575,507036251,511354887,515673696,519991125,524309392,528624525,532936342,537247292,541555851
DATA 545864306,550170437,554476170,558778993,563082532,567382703,571680924,575978253,580275482,584570200
DATA 588863345,593155089,597445378,601735269,606022680,610308664,614594106,618878615,623159296,627440336
DATA 631717982,635997249,640275231,644550922,648825715,653099304,657371139,661643304,665911851,670180516
DATA 674447835,678714823,682979568,687242934,691504332,695766925,700028114,704286233,708543557,712799821
DATA 717055212,721310048,725563140,729813991,734065508,738315156,742564929,746813071,751060249,755305935
DATA 759550004,763794029,768035554,772276773,776516528,780756650,784994469,789230673,793467703,797703398
DATA 801937611,806169530,810401956,814633249,818864199,823092766,827320850,831548431,835773764,840000027
DATA 844224822,848450250,852673966,856895823,861116918,865335133,869555570,873772692,877989808,882206716
DATA 886422213,890636921,894850907,899064419,903275849,907487780,911698381,915907322,920117006,924324489
DATA 928532509,932738007,936943763,941147666,945351970,949555347,953758330,957958052,962158684,966358351
DATA 970556800,974755898,978951680,983147464,987343369,991538483,995733104,999926054,1004118104,1008309544
DATA 1012500258,1016690917,1020879037,1025067175,1029256469,1033444454,1037631294,1041815774,1046001482,1050186367
DATA 1054370637,1058552429,1062734476,1066916147,1071094927,1075274949,1079454128,1083631538,1087809564,1091987405
DATA 1096163370,1100339660,1104513787,1108687177,1112860305,1117034447,1121205592,1125376629,1129547281,1133717820
DATA 1137887191,1142056097,1146225390,1150393648,1154560299,1158727002,1162892823,1167057747,1171221046,1175385155
DATA 1179549444,1183711384,1187874380,1192034212,1196195238,1200356153,1204515304,1208673910,1212829795,1216987937
DATA 1221145073,1225300872,1229455037,1233609164,1237764170,1241917157,1246070670,1250224878,1254376178,1258528162
DATA 1262678524,1266827683,1270976954,1275125632,1279274172,1283421484,1287567873,1291715676,1295861693,1300005926
DATA 1304150462,1308296664,1312440578,1316583470,1320724811,1324868019,1329010956,1333151863,1337291809,1341430624
DATA 1345570079,1349708221,1353846756,1357984935,1362122305,1366257814,1370393786,1374528892,1378664634,1382799415
DATA 1386933522,1391065576,1395199789,1399331489,1403463860,1407594647,1411724086,1415855689,1419985631,1424115489
DATA 1428244053,1432371870,1436498522,1440625629,1444751745,1448877006,1453002152,1457125036,1461250000,1465374659
DATA 1469497594,1473620220,1477744125,1481866173,1485988244,1490109683,1494229934,1498349689,1502469332,1506589876
DATA 1510706235,1514824921,1518942965,1523061505,1527178351,1531294454,1535409890,1539526326,1543640517,1547756812
DATA 1551870851,1555985016,1560097442,1564208549,1568320054,1572432177,1576544661,1580654270,1584764017,1588873108
DATA 1592982840,1597091049,1601199712,1605308326,1609414491,1613521803,1617628777,1621733835,1625839726,1629945987
DATA 1634052052,1638156927,1642258972,1646361787,1650465128,1654567808,1658669200,1662770302,1666869794,1670972264
DATA 1675072419,1679170566,1683270249,1687369711,1691467151,1695565190,1699662748,1703761548,1707858902,1711955433
DATA 1716050469,1720144848,1724241897,1728336282,1732430410,1736526180,1740619156,1744713632,1748805530,1752898084
DATA 1756987393,1761078122,1765169921,1769260641,1773351175,1777442877,1781530474,1785621307,1789709560,1793798703
DATA 1797887260,1801975182,1806062390,1810149996,1814236123,1818322676,1822407623,1826489988,1830575906,1834658067
DATA 1838742792,1842825653,1846909270,1850992005,1855074218,1859156347,1863238351,1867320859,1871402335,1875482847
DATA 1879562930,1883642470,1887722398,1891800587,1895879932,1899958276,1904036638,1908114573,1912191800,1916268743
DATA 1920347116,1924422570,1928498011,1932573349,1936646486,1940721696,1944797174,1948871367,1952945594,1957018338
DATA 1961089383,1965161808,1969233350,1973304195,1977376665,1981447779,1985519033,1989588548,1993659289,1997729452
DATA 2001796366,2005864843,2009933793,2014002593,2018069377,2022137196,2026204289,2030270517,2034337796,2038404475
DATA 2042469434,2046534053,2050598713,2054662457,2058727455,2062791593,2066855115,2070918071,2074981871,2079045540
DATA 2083107257,2087170358,2091232421,2095293756,2099353852,2103414866,2107473358,2111533438,2115593696,2119654578
DATA 2123711202,2127769041,2131828079,2135887473,2139945263,2144002868,2148061201,2152118222,2156173876,2160230408
DATA 2164287399,2168343450,2172397905,2176451935,2180506650,2184561319,2188616526,2192670595,2196723874,2200777436
DATA 2204828910,2208879508,2212930015,2216982800,2221034120,2225087204,2229138005,2233188780,2237237738,2241286680
DATA 2245337711,2249386635,2253437044,2257486659,2261534669,2265582088,2269630722,2273677293,2277723942,2281770277
DATA 2285816118,2289861391,2293908247,2297955870,2301999709,2306044120,2310088597,2314134053,2318177990,2322223112
DATA 2326266900,2330308778,2334351201,2338393413,2342436031,2346478314,2350519355,2354560561,2358602447,2362642765
DATA 2366683716,2370724495,2374763504,2378804084,2382843532,2386880413,2390919906,2394959109,2398996112,2403034927
DATA 2407071577,2411110078,2415147307,2419181034,2423219093,2427255367,2431292536,2435327045,2439361501,2443396396
DATA 2447431831,2451466331,2455500451,2459534282,2463565779,2467597919,2471632122,2475665529,2479696435,2483729191
DATA 2487761399,2491793997,2495825196,2499856755,2503887935,2507918465,2511947717,2515978063,2520007177,2524038155
DATA 2528067401,2532097043,2536126664,2540155255,2544183491,2548211228,2552238285,2556266399,2560294002,2564319542
DATA 2568345835,2572372442,2576397670,2580421933,2584447929,2588472785,2592497820,2596522622,2600546330,2604571471
DATA 2608595062,2612618628,2616643294,2620665663,2624687920,2628709369,2632732626,2636754699,2640776029,2644799757
DATA 2648820585,2652840994,2656861044,2660881979,2664902170,2668922912,2672943760,2676963401,2680982125,2685000601
DATA 2689021011,2693039441,2697057353,2701075683,2705092716,2709109210,2713125397,2717143223,2721159932,2725176643
DATA 2729193507,2733210696,2737225536,2741242121,2745257057,2749272015,2753286718,2757299847,2761314795,2765327756
DATA 2769341791,2773356225,2777369850,2781383306,2785394924,2789408169,2793419860,2797431717,2801443922,2805454432
DATA 2809465484,2813477356,2817487436,2821497837,2825509231,2829520068,2833530738,2837539518,2841549369,2845558213
DATA 2849566042,2853574755,2857584531,2861594266,2865601989,2869610768,2873619181,2877625961,2881633373,2885641353
DATA 2889648502,2893654733,2897660376,2901667770,2905672946,2909678043,2913685600,2917689568,2921695146,2925699539
DATA 2929702761,2933706263,2937709465,2941713524,2945717900,2949719949,2953724092,2957726064,2961727364,2965730599
DATA 2969734593,2973737899,2977740005,2981742619,2985744869,2989743222,2993744024,2997743403,3001742385,3005740846
DATA 3009740083,3013740632,3017740443,3021739912,3025737894,3029738266,3033736354,3037734260,3041732620,3045730736
DATA 3049728863,3053726975,3057724728,3061722012,3065718156,3069714416,3073709903,3077706121,3081700773,3085694966
DATA 3089690887,3093686041,3097682212,3101677762,3105672385,3109665704,3113660777,3117654258,3121648738,3125641477
DATA 3129636165,3133628489,3137621629,3141615091,3145607391,3149600532,3153593186,3157583551,3161575400,3165568071
DATA 3169558897,3173549966,3177541505,3181531857,3185524100,3189515502,3193505484,3197494480,3201485771,3205474366
DATA 3209464223,3213453462,3217442657,3221430632,3225418712,3229406344,3233394790,3237380550,3241367601,3245353518
DATA 3249340672,3253327262,3257314501,3261302137,3265288786,3269274318,3273261676,3277246756,3281232235,3285218896
DATA 3289205184,3293189136,3297172860,3301158042,3305141278,3309125457,3313108871,3317092589,3321076365,3325059246
DATA 3329042269,3333024320,3337007745,3340990584,3344973656,3348954479,3352936965,3356918381,3360899212,3364880246
DATA 3368861514,3372843128,3376824341,3380804536,3384785252,3388764045,3392744352,3396724969,3400703302,3404683449
DATA 3408661629,3412641191,3416621174,3420600239,3424577712,3428556536,3432533925,3436512942,3440489299,3444467709
DATA 3448443650,3452420745,3456398055,3460376073,3464354329,3468330724,3472306712,3476280273,3480257644,3484232867
DATA 3488208449,3492182057,3496156616,3500132047,3504107018,3508083271,3512056531,3516031243,3520004496,3523979003
DATA 3527952545,3531925382,3535899657,3539873170,3543843428,3547815425,3551789160,3555761507,3559733867,3563706203
DATA 3567677571,3571648151,3575618333,3579587822,3583559953,3587530335,3591499540,3595471441,3599441281,3603412533
DATA 3607382383,3611353499,3615323157,3619293204,3623260438,3627230054,3631199924,3635167788,3639133977,3643101671
DATA 3647069932,3651037811,3655006291,3658974043,3662941495,3666909363,3670877228,3674842642,3678809724,3682776125
DATA 3686743894,3690708635,3694674136,3698640744,3702607660,3706572805,3710536268,3714502398,3718465031,3722428991
DATA 3726394088,3730358421,3734323031,3738287024,3742250941,3746214561,3750179004,3754141753,3758105608,3762067054
DATA 3766030492,3769992222,3773955567,3777917868,3781881979,3785842285,3789803781,3793766088,3797726848,3801688660
DATA 3805649459,3809611918,3813571463,3817534298,3821493048,3825453351,3829412874,3833371480,3837330842,3841291749
DATA 3845250279,3849209920,3853169493,3857129155,3861088365,3865047067,3869005617,3872964725,3876923182,3880881273
DATA 3884839528,3888796569,3892753631,3896710330,3900667023,3904623253,3908580398,3912536328,3916492455,3920449831
DATA 3924406577,3928362015,3932316075,3936271016,3940227600,3944182809,3948137829,3952093061,3956048108,3960003559
DATA 3963957671,3967911833,3971865657,3975818018,3979772869,3983725586,3987677658,3991630533,3995584016,3999537962
DATA 4003491500,4007444082,4011396563,4015348558,4019300356,4023253116,4027204376,4031157206,4035109071,4039061553
DATA 4043014010,4046965198,4050915644,4054865513,4058816261,4062767391,4066716906,4070666662,4074616057,4078566781
DATA 4082514143,4086464266,4090414411,4094363532,4098312828,4102261058,4106208569,4110157418,4114105592,4118054813
!
!https://www.wikiwand.com/ja/素数計数関数
!https://blogs.yahoo.co.jp/donald_stinger/15012382.html
LET k6=SA*1E8-1E8
FOR n=SA TO SB
LET c1=Pn(n-1)
LET k2=Bb(n) !pi(x)
LET k6=k6+1E8
LET C=cprime(c1,k2,k6,GT)
LET c1=c1+c
PRINT n;":";c1;":";c
NEXT n
!
LET TM=TIME-t0
PRINT USING"######.##":TM;
PRINT "秒"
!PRINT DATE$;"/"; TIME$
!CALL TIMES(ROUND(TM,2))
END
!
EXTERNAL FUNCTION cprime (c2,k2,k6,GT())
OPTION ARITHMETIC NATIVE
LET k4=k6-1E8
LET B6=IP(k6/30)
LET U=IP(k6/6)
LET W=IP(k4/6)
LET M7=W
!
DIM x(W-M7 TO U-M7)
DIM y(W-M7 TO U-M7)
MAT x = ZER !(6*n-1)
MAT y = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=GT(n)
LET G1=IP(W/P6)
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 140
IF P6*i+r6>U THEN EXIT FOR
LET x(P6*i+r6-M7)=1
140 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 150
IF P6*i-r6>U THEN EXIT FOR
LET x(P6*i-r6-M7)=1
150 NEXT i
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 160
IF P6*i-r6>U THEN EXIT FOR
LET y(P6*i-r6-M7)=1
160 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 170
IF P6*i+r6>U THEN EXIT FOR
LET y(P6*i+r6-M7)=1
170 NEXT i
END IF
NEXT n
LET Cc=0
FOR n=W-M7 TO U-M7
LET ST=n+M7
IF x(n)=0 THEN
IF 6*ST-1>k4 AND 6*ST-1<k6 THEN
LET cc=cc+1
LET c2=c2+1
PRINT 6*ST-1;":";c2
END IF
END IF
IF y(n)=0 THEN
IF 6*ST+1>k4 AND 6*ST+1<k6 THEN
LET cc=cc+1
LET c2=c2+1
PRINT 6*ST+1;":";c2
END IF
END IF
NEXT n
LET cprime=cc
PRINT
END FUNCTION
EXTERNAL SUB sqprime(SA,SB,k2,GT())
OPTION ARITHMETIC NATIVE
OPEN #2:NAME "prime_pi1.txt",RECTYPE INTERNAL
ERASE #2
LET x=1E8
FOR i=1 TO k2-1
LET v=GT(i)^2
LET vi=GT(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=1E8 THEN
LET vt=IP(vv/1E8)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+1E8
IF C>=SA AND SB>=C THEN
WRITE #2:i
END IF
NEXT ns
END SUB
CLOSE #2
END SUB
EXTERNAL SUB TIMES(N) !時間変換(秒)to(時:分)
LET M=IP(N/60)
LET I=MOD(N,60)
LET N=M
LET M=IP(N/60)
LET S=MOD(N,60)
PRINT STR$(M)&"時間";STR$(S)&"分";
PRINT USING"##.##":I;
PRINT "秒"
END SUB
JIS Full BASIC 実時間機能単位で定義された並行活動(Parallel Activity)の実装です。
平たく言えば，マルチスレッドプログラミングが可能なBASICです。
並行活動を持たないプログラムも実行可能です。
文字出力のみのプログラムはそのままでもBASICAccで実行するより少し速くなります。
グラフィックスは，そのままだとBASICAccより少し遅くなります。並行活動に処理を分割しないと速くなりません。
Lazarus＋FPCでコンパイルすればMAC，Linuxでも動作しますが，不完全です。
!6n±1篩 prime number Ver.2.3
DECLARE EXTERNAL FUNCTION cprime
DECLARE EXTERNAL SUB sqprime
DECLARE EXTERNAL SUB TIMES
OPTION ARITHMETIC NATIVE
!PRINT DATE$;"/"; TIME$
LET t0=TIME
LET k=31622803
LET k2=1951960
!エラトステネスの篩
LET Fu=5633
DIM P(Fu)
DIM A(739) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
DIM GT(k2)
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO 739
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET GT(1)=2
LET GT(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET GT(cz)=6*n+1
END IF
NEXT n
!1E+15-1E+10 TO 1E+15
! 9999901 TO 10000000 (1億単位)
LET SA=10000000 !MIN 2 (1億to)
LET SB=10000000 !MAX 1E15-1
CALL sqprime(SA,SB,k2,GT)
DIM Bb(SA TO SB)
OPEN #2:NAME "prime_pi1.txt",ACCESS INPUT
FOR i=SA TO SB
INPUT #2: BB(i)
NEXT i
CLOSE #2
DIM Pn(101) !1億単位
MAT READ Pn
DATA 29844280881108,29844283778350,29844286673183,29844289567927,29844292461897,29844295359129,29844298254684,29844301151063,29844304047136,29844306941518
DATA 29844309839746,29844312733943,29844315627199,29844318521334,29844321418009,29844324314523,29844327210344,29844330105150,29844332999978,29844335895709
DATA 29844338789244,29844341684694,29844344580567,29844347478427,29844350373782,29844353269227,29844356162629,29844359058710,29844361952280,29844364848357
DATA 29844367743371,29844370638200,29844373534893,29844376430806,29844379325503,29844382222516,29844385117770,29844388013180,29844390908262,29844393802839
DATA 29844396697666,29844399592539,29844402489028,29844405385715,29844408281893,29844411175272,29844414071355,29844416966188,29844419861029,29844422754610
DATA 29844425650435,29844428546187,29844431441463,29844434337930,29844437232986,29844440128474,29844443023109,29844445918084,29844448814585,29844451709782
DATA 29844454605616,29844457501216,29844460396817,29844463292125,29844466187497,29844469083188,29844471978285,29844474874218,29844477769269,29844480665850
DATA 29844483562161,29844486457507,29844489352992,29844492248320,29844495141763,29844498038403,29844500932757,29844503827750,29844506722855,29844509616736
DATA 29844512511515,29844515407744,29844518304021,29844521200361,29844524094726,29844526989128,29844529883655,29844532780287,29844535677285,29844538574330
DATA 29844541468540,29844544364058,29844547260257,29844550153650,29844553050083,29844555944162,29844558841306,29844561736036,29844564632690,29844567526938
DATA 29844570422669
!http://oeis.org/A038820/b038820.txt
! 9999901: 1:29844280881108
! 9999902: 2:29844283778350
!
!10000000:100:29844567526938
LET k6=SA*1E8-1E8
FOR n=SA TO SB
LET c1=Pn(n-9999900)
LET k2=Bb(n) !π(x)
LET k6=k6+1E8
LET C=cprime(c1,k2,k6,GT)
LET c1=c1+c
PRINT n;":";c1;":";c
NEXT n
LET TM=TIME-t0
PRINT USING"######.##":TM;
PRINT "秒"
!PRINT DATE$;"/"; TIME$
CALL TIMES(ROUND(TM,2))
END
EXTERNAL FUNCTION cprime (c2,k2,k6,GT())
OPTION ARITHMETIC NATIVE
LET k4=k6-1E8
LET B6=IP(k6/30)
LET U=IP(k6/6)
LET W=IP(k4/6)
LET M7=W
DIM x(W-M7 TO U-M7)
DIM y(W-M7 TO U-M7)
MAT x = ZER !(6*n-1)
MAT y = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=GT(n)
LET G1=IP(W/P6)
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 140
IF P6*i+r6>U THEN EXIT FOR
LET x(P6*i+r6-M7)=1
140 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 150
IF P6*i-r6>U THEN EXIT FOR
LET x(P6*i-r6-M7)=1
150 NEXT i
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 160
IF P6*i-r6>U THEN EXIT FOR
LET y(P6*i-r6-M7)=1
160 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 170
IF P6*i+r6>U THEN EXIT FOR
LET y(P6*i+r6-M7)=1
170 NEXT i
END IF
NEXT n
LET Cc=0
FOR n=W-M7 TO U-M7
LET ST=n+M7
IF x(n)=0 THEN
IF 6*ST-1>k4 AND 6*ST-1<k6 THEN
LET cc=cc+1
LET c2=c2+1
PRINT 6*ST-1;":";c2
END IF
END IF
IF y(n)=0 THEN
IF 6*ST+1>k4 AND 6*ST+1<k6 THEN
LET cc=cc+1
LET c2=c2+1
PRINT 6*ST+1;":";c2
END IF
END IF
NEXT n
LET cprime=cc
PRINT
END FUNCTION
EXTERNAL SUB sqprime(SA,SB,k2,GT())
OPTION ARITHMETIC NATIVE
OPEN #2:NAME "prime_pi1.txt",RECTYPE INTERNAL
ERASE #2
LET x=1E8
FOR i=1 TO k2-1
LET v=GT(i)^2
LET vi=GT(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=1E8 THEN
LET vt=IP(vv/1E8)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+1E8
IF C>=SA AND SB>=C THEN
WRITE #2:i
END IF
NEXT ns
END SUB
CLOSE #2
END SUB
EXTERNAL SUB TIMES(N) !時間変換(秒)to(時:分)
LET M=IP(N/60)
LET I=MOD(N,60)
LET N=M
LET M=IP(N/60)
LET S=MOD(N,60)
PRINT STR$(M)&"時間";STR$(S)&"分";
PRINT USING"##.##":I;
PRINT "秒"
END SUB
非マルチスレッド／マルチスレッド化との対比率は209.3秒/64.3秒≒3.25倍
となりましたので、マルチスレッド化プログラムの効果は十分大きいと思います。
なお、VC++2017 + OPEN MPによるマルチスレッドdllによる実行(※8スレッド)では29秒でした。
DECLARE STRUCTURE STRUCT1: 2 OF NUMERIC
DECLARE STRUCTURE STRUCT2: 2 OF NUMERIC
DECLARE STRUCTURE STRUCT3: 2 OF NUMERIC
DECLARE STRUCTURE STRUCT4: 1 OF NUMERIC
DECLARE STRUCTURE STRUCT5: 1 OF NUMERIC
DECLARE STRUCTURE STRUCT6: 1 OF NUMERIC
DECLARE SHARED buff1 OF STRUCT1
DECLARE SHARED buff2 OF STRUCT2
DECLARE SHARED buff3 OF STRUCT3
DECLARE SHARED buff4 OF STRUCT4
DECLARE SHARED buff5 OF STRUCT5
DECLARE SHARED buff6 OF STRUCT6
PARACT PART1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC S,E,ST,I,TOTAL,L1,L2,L3,L4
LET S=1000000001
LET E=2000000000
LET ST=10000000
LET TOTAL=0
DECLARE EXTERNAL FUNCTION ERATOS
FOR I=S TO E STEP ST
PUT TO BUFF1 FROM I,ST
START PART2
PUT TO BUFF2 FROM I,ST
START PART3
PUT TO BUFF3 FROM I,ST
START PART4
LET L1=ERATOS(I,I+ST/4-1)
WAIT EVENT ok2
GET FROM BUFF4 TO L2
WAIT EVENT ok3
GET FROM BUFF5 TO L3
WAIT EVENT ok4
GET FROM BUFF6 TO L4
LET TOTAL=TOTAL+L1+L2+L3+L4
PRINT I;"～";I+ST-1;":";L1+L2+L3+L4;TOTAL
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L2
DECLARE EXTERNAL FUNCTION ERATOS
GET FROM BUFF1 TO I,ST
LET L2=ERATOS(I+ST/4,I+ST/2-1)
SIGNAL ok2
PUT TO BUFF4 FROM L2
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L3
DECLARE EXTERNAL FUNCTION ERATOS
GET FROM BUFF2 TO I,ST
LET L3=ERATOS(I+ST/2,I+3*ST/4-1)
SIGNAL ok3
PUT TO BUFF5 FROM L3
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L4
DECLARE EXTERNAL FUNCTION ERATOS
GET FROM BUFF3 TO I,ST
LET L4=ERATOS(I+3*ST/4,I+ST-1)
SIGNAL ok4
PUT TO BUFF6 FROM L4
END PARACT
EXTERNAL FUNCTION ERATOS(N,M)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,NN,J,COUNT
DIM X(0 TO M-N+1)
LET COUNT=0
FOR I=3 TO SQR(M) STEP 2
IF MOD(N,I)=0 THEN
LET NN=N
ELSE
LET NN=INT(N/I+1)*I
END IF
IF N<=I THEN
IF X(NN-N)=0 THEN LET NN=NN+I
END IF
FOR J=NN TO M STEP I
LET X(J-N)=1
NEXT J
NEXT I
FOR J=N TO M
IF MOD(J,2)=1 THEN
IF X(J-N)=0 THEN
LET COUNT=COUNT+1
END IF
END IF
NEXT J
LET ERATOS=COUNT
END FUNCTION
!6n-1 6n+1 Parallel activity Ver.1
DECLARE STRUCTURE abc1: 1 OF NUMERIC
DECLARE MESSAGE AMACHANN OF abc1
Paract Par1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC xv
START Par2
LET t0=TIME
LET k=100000000
LET k2=5761455
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
DIM A(Fm) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=INT(k7/Q)
DIM Au(k5)
MAT Au = ZER !(6*n-1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
NEXT n
FOR n=1 TO k5
IF 6*n-1>k7 THEN EXIT FOR
IF Au(n)=0 THEN
LET cz=cz+1
END IF
NEXT n
receive from AMACHANN TO xv
PRINT "6n-1 ";cz
PRINT "pi(x)";cz+xv+2
LET TM=TIME-t0
PRINT USING"####.##":TM;
PRINT "秒"
END PARACT
PARACT Par2
OPTION ARITHMETIC NATIVE !2進モード
DECLARE NUMERIC zv
!6n+1 素数
LET k=100000007
LET k2=5761456
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
DIM A(Fm) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=INT(k7/Q)
DIM Av(k5)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
FOR n=1 TO k5
IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET zv=zv+1
END IF
NEXT n
PRINT "6n+1 ";zv
send TO AMACHANN from zv
END PARACT
---------------------------------------
!6n-1 6n+1 Parallel activity Ver.2
DECLARE STRUCTURE abc1: 1 OF NUMERIC
DECLARE STRUCTURE abc2: NUMERIC(1230)
DECLARE SHARED sh OF abc2
DECLARE MESSAGE AMACHANN OF abc1
Paract Par1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC cz
DECLARE NUMERIC zv
DECLARE NUMERIC A(1230) !素数
LET t0=TIME
LET k=100000000
LET k2=5761455
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
MAT P=ZER
LET I=2
LET H=1
LET A(H)=I
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H=H+1
LET A(H)=I
END IF
NEXT I
PUT TO sh FROM A
start par2
START par3
RECEIVE FROM AMACHANN TO cz
RECEIVE FROM AMACHANN TO zv
PRINT "6n-1 ";cz
PRINT "6n+1 ";zv
PRINT "pi(x)";cz+zv+2
LET TM=TIME-t0
PRINT USING"###.###":TM;
PRINT "秒"
END PARACT
paract par2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(1230) !素数
DECLARE NUMERIC cz
GET from sh TO A
LET Q=6
LET k7=100000000 !篩の計算範囲
LET k5=INT(k7/Q)
DIM Au(k5)
MAT Au = ZER !(6*n-1)
FOR n=3 TO 1229
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
NEXT n
FOR n=1 TO k5
IF 6*n-1>k7 THEN EXIT FOR
IF Au(n)=0 THEN
LET cz=cz+1
END IF
NEXT n
send TO AMACHANN from cz
END PARACT
Paract Par3
DECLARE NUMERIC A(1230) !素数
DECLARE NUMERIC zv
GET FROM sh TO A
LET Q=6
LET k7=100000000 !篩の計算範囲
LET k5=INT(k7/Q)
DIM Av(k5)
MAT Av = ZER !(6*n+1)
FOR n=3 TO 1229
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
FOR n=1 TO k5
IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET zv=zv+1
END IF
NEXT n
send TO AMACHANN from zv
END PARACT
!双子素数6n-1 6n+1 Parallel activity Ver.2
DECLARE STRUCTURE abc1: 1 OF NUMERIC
DECLARE STRUCTURE abc2: NUMERIC(1230)
DECLARE STRUCTURE abc3: NUMERIC(16666666)
DECLARE SHARED sha OF abc2
DECLARE SHARED shb OF abc3
DECLARE MESSAGE AMACHANN OF abc1
Paract Par1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC zv
DECLARE NUMERIC A(1230) !素数
LET t0=TIME
LET k=100000000
LET k2=5761455
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
MAT P=ZER
LET I=2
LET H=1
LET A(H)=I
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H=H+1
LET A(H)=I
END IF
NEXT I
PUT TO sha FROM A
START par2
START par3
RECEIVE FROM AMACHANN TO zv
PRINT "pi2(x)";zv+1
LET TM=TIME-t0
PRINT USING"###.###":TM;
PRINT "秒"
END PARACT
paract par2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(1230) !素数
DECLARE NUMERIC AA(16666666)
GET from sha TO A
LET Q=6
LET k7=100000000 !篩の計算範囲
LET k5=INT(k7/Q)
FOR n=3 TO 1229
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET AA(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET AA(Pu*i-ru)=1
NEXT i
END IF
NEXT n
put TO shb from AA
END PARACT
Paract Par3
DECLARE NUMERIC zv
DECLARE NUMERIC A(1230) !素数
DECLARE NUMERIC AA(16666666)
GET FROM sha TO A
LET Q=6
LET k7=100000000 !篩の計算範囲
LET k5=INT(k7/Q)
DIM Av(k5)
MAT Av = ZER !(6*n+1)
FOR n=3 TO 1229
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
GET from shb TO AA
MAT Av=AA+Av
FOR n=1 TO k5
IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET zv=zv+1
END IF
NEXT n
send TO AMACHANN from zv
END PARACT
---------------------------------------
当初の狙いは、sample program を手本に
!SHAREDポート経由のデータ転送
DECLARE STRUCTURE struct2: NUMERIC(10)
DECLARE shared sha OF struct2
DECLARE SHARED shb OF struct2
paract p1
DECLARE NUMERIC m(10)
start p2
FOR i=1 TO 9 STEP 2
LET m(i)=i^2
NEXT i
put TO sha from m
start p3
END PARACT
PARACT p2
DECLARE NUMERIC W(10)
FOR i=2 TO 10 STEP 2
LET W(i)=i^2
NEXT i
put TO shb from W
END PARACT
paract p3
DECLARE NUMERIC m(10)
DECLARE NUMERIC W(10)
GET from sha TO m
GET from shb TO W
MAT m=m+w
FOR i=1 TO 10
PRINT m(i)
NEXT i
END paract
!Sieve of Sundaram Prime number Counting !Ver.2.1
!素数計数関数（英: Prime-counting function）π(x)
!Paract BASICによるマルチスレッド化プログラム
DECLARE STRUCTURE STRUCT1: 2 OF NUMERIC
DECLARE STRUCTURE STRUCT4: 1 OF NUMERIC
DECLARE SHARED buff1 OF STRUCT1
DECLARE SHARED buff2 OF STRUCT1
DECLARE SHARED buff3 OF STRUCT1
DECLARE SHARED buff4 OF STRUCT4
DECLARE SHARED buff5 OF STRUCT4
DECLARE SHARED buff6 OF STRUCT4
PARACT PART1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC ST,I
LET t0=TIME
LET S=1000000000
LET E=2000000000
LET ST=10000000
LET TOTAL=50847534
DECLARE EXTERNAL FUNCTION ERATOS
FOR I=S TO E-ST STEP ST
PUT TO BUFF1 FROM I,ST
SIGNAL Ready1
DO
WHEN EXCEPTION IN
START PART2
LET success=1
USE
LET success=0
WAIT DELAY 0.01
END WHEN
LOOP UNTIL success=1
PUT TO BUFF2 FROM I,ST
SIGNAL Ready3
START PART3
PUT TO BUFF3 FROM I,ST
SIGNAL Ready5
START PART4
LET L1=ERATOS(I,I+ST/4)
WAIT EVENT Ready2
GET FROM BUFF4 TO L2
WAIT EVENT Ready4
GET FROM BUFF5 TO L3
WAIT EVENT Ready6
GET FROM BUFF6 TO L4
LET TOTAL=TOTAL+L1+L2+L3+L4
PRINT I;"～";I+ST;":";L1+L2+L3+L4;TOTAL
NEXT I
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L2
DECLARE EXTERNAL FUNCTION ERATOS
WAIT EVENT Ready1
GET FROM BUFF1 TO I,ST
LET L2=ERATOS(I+ST/4,I+ST/2)
PUT TO BUFF4 FROM L2
SIGNAL Ready2
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L3
DECLARE EXTERNAL FUNCTION ERATOS
WAIT EVENT Ready3
GET FROM BUFF2 TO I,ST
LET L3=ERATOS(I+ST/2,I+3*ST/4)
PUT TO BUFF5 FROM L3
SIGNAL Ready4
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L4
DECLARE EXTERNAL FUNCTION ERATOS
WAIT EVENT Ready5
GET FROM BUFF3 TO I,ST
LET L4=ERATOS(I+3*ST/4,I+ST)
PUT TO BUFF6 FROM L4
SIGNAL Ready6
END PARACT
EXTERNAL FUNCTION ERATOS(N,M)
OPTION ARITHMETIC NATIVE
LET COUNT=0
LET k8=INT(N/2)
LET M7=k8-1
LET k9=INT(M/2)+1
DIM A(k9-M7)
MAT A=ZER
LET S=3
LET D=4
LET k=INT(SQR(k9))*3
DO
LET B=D+S*INT((k8-D)/S)
DO UNTIL B>=k8
LET B=B+S
LOOP
FOR I=B TO k9 STEP S
LET A(I-M7)=1
NEXT I
LET S=S+2
LET D=D+3
LOOP UNTIL D>k
FOR n=1 TO k9-M7
IF (n+M7)*2+1>M THEN EXIT FOR
IF A(n)=0 THEN LET COUNT=COUNT+1
!LET Sun=(n+M7)*2+1
!PRINT Sun
NEXT n
LET ERATOS=COUNT
END FUNCTION
------------------------------
精度確認は
1e9 50847534
2e9 98222287
以外は未確認です。
家のPC では、sample program 「 No_SEIZE 」を一度実行後 ほぼ確実に成功します。
私のところでもExtype12001が出ます。
signal文で終了のシグナルを発行したのを確認しても，その時点ではまだその並行活動は終了していないかも知れません。
Full BASICには他の並行活動の状態を調べる手段が用意されていないので，終了したかどうかはSTART文を実行してみるまでわかりません。
EXTYPE12001の例外状態になるときは終了を待てばよいので，各start文を次のように変えれば動くと思います。
例 START PART2のとき
DO
WHEN EXCEPTION IN
START PART2
LET success=1
USE
IF EXTYPE=12001 THEN
LET success=0
WAIT DELAY 0.01
ELSE
exit handler
END IF
END WHEN
LOOP UNTIL success=1
簡略化して
DO
WHEN EXCEPTION IN
START PART3
LET success=1
USE
LET success=0
WAIT DELAY 0.01
END WHEN
LOOP UNTIL success=1
でも大丈夫です（多分）。
> 私のところでもExtype12001が出ます。
> signal文で終了のシグナルを発行したのを確認しても，その時点ではまだその並行活動は終了していないかも知れません。
> Full BASICには他の並行活動の状態を調べる手段が用意されていないので，終了したかどうかはSTART文を実行してみるまでわかりません。
> EXTYPE12001の例外状態になるときは終了を待てばよいので，各start文を次のように変えれば動くと思います。
>
> 例 START PART2のとき
> DO
> WHEN EXCEPTION IN
> START PART2
> LET success=1
> USE
> IF EXTYPE=12001 THEN
> LET success=0
> WAIT DELAY 0.01
> ELSE
> exit handler
> END IF
> END WHEN
> LOOP UNTIL success=1
>
> 簡略化して
> DO
> WHEN EXCEPTION IN
> START PART3
> LET success=1
> USE
> LET success=0
> WAIT DELAY 0.01
> END WHEN
> LOOP UNTIL success=1
> でも大丈夫です（多分）。
>
> USE行の下に
> PRINT EXTYPE
> を追加して実行してみると，ときたま
> 12001
> を表示するのが観察できます。
>
!Sieve of Sundaram Prime number Counting !Ver.2.1
!素数計数関数（英: Prime-counting function）π(x)
!Paract BASICによるマルチスレッド化プログラム
DECLARE STRUCTURE STRUCT1: 2 OF NUMERIC
DECLARE STRUCTURE STRUCT4: 1 OF NUMERIC
DECLARE SHARED buff1 OF STRUCT1
DECLARE SHARED buff2 OF STRUCT1
DECLARE SHARED buff3 OF STRUCT1
DECLARE SHARED buff4 OF STRUCT4
DECLARE SHARED buff5 OF STRUCT4
DECLARE SHARED buff6 OF STRUCT4
PARACT PART1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC ST,I
LET t0=TIME
LET S=90000000001
LET E=100000000000 !pi(x)4118054813
LET ST=10000000
LET TOTAL=3722428991!9e10,3325059246,8e10,2925699539,7e10,2524038155,6e10,2119654578,5e10,1711955433,4e10,1711955433,3e10,1300005926,2e10,882206716,1e10,455052511,1e9,50847534
DECLARE EXTERNAL FUNCTION ERATOS
FOR I=S TO E STEP ST
PUT TO BUFF1 FROM I,ST
SIGNAL Ready1
DO
WHEN EXCEPTION IN
START PART2
LET success=1
USE
LET success=0
WAIT DELAY 0.01
END WHEN
LOOP UNTIL success=1
PUT TO BUFF2 FROM I,ST
SIGNAL Ready3
START PART3
PUT TO BUFF3 FROM I,ST
SIGNAL Ready5
START PART4
LET L1=ERATOS(I,I+ST/4-1)
WAIT EVENT Ready2
GET FROM BUFF4 TO L2
WAIT EVENT Ready4
GET FROM BUFF5 TO L3
WAIT EVENT Ready6
GET FROM BUFF6 TO L4
LET TOTAL=TOTAL+L1+L2+L3+L4
PRINT I;"～";I+ST-1;":";L1+L2+L3+L4;TOTAL
NEXT I
LET TM=TIME-t0
PRINT USING"####." & REPEAT$("#",2):TM;
PRINT "秒"
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L2
DECLARE EXTERNAL FUNCTION ERATOS
WAIT EVENT Ready1
GET FROM BUFF1 TO I,ST
LET L2=ERATOS(I+ST/4,I+ST/2-1)
PUT TO BUFF4 FROM L2
SIGNAL Ready2
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L3
DECLARE EXTERNAL FUNCTION ERATOS
WAIT EVENT Ready3
GET FROM BUFF2 TO I,ST
LET L3=ERATOS(I+ST/2,I+3*ST/4-1)
PUT TO BUFF5 FROM L3
SIGNAL Ready4
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC I,ST
DECLARE NUMERIC L4
DECLARE EXTERNAL FUNCTION ERATOS
WAIT EVENT Ready5
GET FROM BUFF3 TO I,ST
LET L4=ERATOS(I+3*ST/4,I+ST-1)
PUT TO BUFF6 FROM L4
SIGNAL Ready6
END PARACT
EXTERNAL FUNCTION ERATOS(N,M)
OPTION ARITHMETIC NATIVE
LET N=N-1
LET COUNT=0
LET k8=INT(N/2)
LET M7=k8-1
LET k9=INT(M/2)
DIM A(k9-M7)
MAT A=ZER
LET S=3
LET D=4
LET k=INT(SQR(k9))*3
DO
LET B=D+S*INT((k8-D)/S)
DO UNTIL B>=k8
LET B=B+S
LOOP
FOR I=B TO k9 STEP S
LET A(I-M7)=1
NEXT I
LET S=S+2
LET D=D+3
LOOP UNTIL D>k
FOR n=1 TO k9-M7
IF (n+M7)*2+1>M THEN EXIT FOR
IF A(n)=0 THEN LET COUNT=COUNT+1
!LET Sun=(n+M7)*2+1
!PRINT Sun
NEXT n
LET ERATOS=COUNT
END FUNCTION
--------------------------------------------
> 白石和夫さんへのお返事です。
>
> > なお，start文の実行には時間がかかるので，停止―開始 の繰り返しでなく，
> > signal文とwait event文による同期か，send文とrecieve文による同期を用いるほうが速くなると思います。
>
> startの実行を１回かぎりにとどめ，
>
> PARACT PART1
> START Part2
> START PART3
> FOR I=S TO E STEP ST
>
> WAIT EVENT Ready2
> WAIT EVENT Ready3
> SIGNAL Ok2
> SIGNAL Ok3
> NEXT I
> END PARACT
>
> PARACT PART2
> FOR I=S TO E STEP ST
>
> SIGNAL Ready2
> WAIT EVENT Ok2
> NEXT I
> END PARACT
>
> PARACT PART3
> FOR I=S TO E STEP ST
>
> SIGNAL ready3
> WAIT EVENT Ok3
> NEXT I
> END PARACT
> みたいな感じで，各並行単位が同期をとりながら同じ繰り返し文を実行していく形です。
>
試しました。
---------------------------------------
! Sieve of Sundaram
PARACT PART1
OPTION ARITHMETIC NATIVE
START Part2
START PART3
START PART4
LET S=1E8+1
LET E=2E8
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
FOR I=S TO E STEP ST
LET L1=Sund(I,I+ST/4-1)
WAIT EVENT Ready2
WAIT EVENT Ready3
WAIT EVENT Ready4
SIGNAL Ok2
SIGNAL Ok3
SIGNAL Ok4
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
LET S=1E8+1
LET E=2E8
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
FOR I=S TO E STEP ST
LET L2=Sund(I+ST/4,I+ST/2-1)
SIGNAL Ready2
WAIT EVENT Ok2
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
LET S=1E8+1
LET E=2E8
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
FOR I=S TO E STEP ST
LET L3=Sund(I+ST/2,I+3*ST/4-1)
SIGNAL ready3
WAIT EVENT Ok3
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
LET S=1E8+1
LET E=2E8
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
FOR I=S TO E STEP ST
LET L4=Sund(I+3*ST/4,I+ST-1)
SIGNAL ready4
WAIT EVENT Ok4
NEXT I
END PARACT
EXTERNAL FUNCTION Sund(N,M)
OPTION ARITHMETIC NATIVE
LET COUNT=0
LET N=N-1
LET N1=N
LET M1=M
LET k8=INT(N/2)
LET M7=k8-1
LET k9=INT(M/2)+1
DIM A(k9-M7)
MAT A=ZER
LET S=3
LET D=4
LET k=INT(SQR(k9))*3
DO
LET B=D+S*INT((k8-D)/S)
DO UNTIL B>=k8
LET B=B+S
LOOP
FOR I=B TO k9 STEP S
LET A(I-M7)=1
NEXT I
LET S=S+2
LET D=D+3
LOOP UNTIL D>k
FOR n=1 TO k9-M7
IF (n+M7)*2+1>M THEN EXIT FOR
IF A(n)=0 THEN LET COUNT=COUNT+1
!LET Sun=(n+M7)*2+1
!PRINT Sun
NEXT n
!LET ERATOS=COUNT
PRINT n1;m1;COUNT
END FUNCTION
----------------------------------------
> 白石 和夫さんへのお返事です。
>
> > 白石和夫さんへのお返事です。
> >
> > > なお，start文の実行には時間がかかるので，停止―開始 の繰り返しでなく，
> > > signal文とwait event文による同期か，send文とrecieve文による同期を用いるほうが速くなると思います。
> >
> > startの実行を１回かぎりにとどめ，
> >
> > PARACT PART1
> > START Part2
> > START PART3
> > FOR I=S TO E STEP ST
> >
> > WAIT EVENT Ready2
> > WAIT EVENT Ready3
> > SIGNAL Ok2
> > SIGNAL Ok3
> > NEXT I
> > END PARACT
> >
> > PARACT PART2
> > FOR I=S TO E STEP ST
> >
> > SIGNAL Ready2
> > WAIT EVENT Ok2
> > NEXT I
> > END PARACT
> >
> > PARACT PART3
> > FOR I=S TO E STEP ST
> >
> > SIGNAL ready3
> > WAIT EVENT Ok3
> > NEXT I
> > END PARACT
> > みたいな感じで，各並行単位が同期をとりながら同じ繰り返し文を実行していく形です。
> >
>
> 試しました。
>
> ---------------------------------------
わたしの間違いに気付きました。
! Sieve of Sundaram
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE MESSAGE mes2 OF struct1
DECLARE MESSAGE mes3 OF struct1
DECLARE MESSAGE mes4 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
START Part2
START PART3
START PART4
LET S=1E9+1
LET E=2E9
LET ST=1E7
LET TOTAL=50847534
DECLARE EXTERNAL FUNCTION Sund
DECLARE NUMERIC X,Y,Z
FOR I=S TO E STEP ST
LET L=Sund(I,I+ST/4-1)
RECEIVE FROM mes2 TO X
WAIT EVENT Ready2
RECEIVE FROM mes3 TO Y
WAIT EVENT Ready3
RECEIVE FROM mes4 TO Z
WAIT EVENT Ready4
SIGNAL Ok2
SIGNAL Ok3
SIGNAL Ok4
LET L=L+X+Y+Z
LET TOTAL=TOTAL+L
PRINT I-1;I+ST-1;TOTAL;L
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
DECLARE NUMERIC L
FOR I=S TO E STEP ST
LET L=Sund(I+ST/4,I+ST/2-1)
SEND TO mes2 FROM L
SIGNAL Ready2
WAIT EVENT Ok2
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
DECLARE NUMERIC L
FOR I=S TO E STEP ST
LET L=Sund(I+ST/2,I+3*ST/4-1)
SEND TO mes3 FROM L
SIGNAL ready3
WAIT EVENT Ok3
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION Sund
DECLARE NUMERIC L
FOR I=S TO E STEP ST
LET L=Sund(I+3*ST/4,I+ST-1)
SEND TO mes4 FROM L
SIGNAL ready4
WAIT EVENT Ok4
NEXT I
END PARACT
EXTERNAL FUNCTION Sund(N,M)
OPTION ARITHMETIC NATIVE
LET COUNT=0
LET N=N-1
LET N1=N
LET M1=M
LET k8=INT(N/2)
LET M7=k8-1
LET k9=INT(M/2)+1
DIM A(k9-M7)
MAT A=ZER
LET S=3
LET D=4
LET k=INT(SQR(k9))*3
DO
LET B=D+S*INT((k8-D)/S)
DO UNTIL B>=k8
LET B=B+S
LOOP
FOR I=B TO k9 STEP S
LET A(I-M7)=1
NEXT I
LET S=S+2
LET D=D+3
LOOP UNTIL D>k
FOR n=1 TO k9-M7
IF (n+M7)*2+1>M THEN EXIT FOR
IF A(n)=0 THEN LET COUNT=COUNT+1
!LET Sun=(n+M7)*2+1
!PRINT Sun
NEXT n
LET Sund=COUNT
!PRINT COUNT !n1;m1;COUNT
END FUNCTION
------------------------------------------
シングルコアでも動作してます。私の問題は解決しました。
計算範囲の4分割には問題が残っています。
LET S=1E9+1
LET E=2E9
LET ST=1E7
この範囲は確認しました。
計算時間は、結局 繰り返し START と同じになりました。
白石 和夫 様
有難うございました。
追記
------------------------------
!計算範囲を4分割する計算例 Ver.1
!Sieve of Sundaram サンダラムの篩(ふるい)用
LET S=1E9+1
LET E=2E9
LET ST=1E7
FOR I=S TO E STEP ST
PRINT "L1";I;INT(I/2);"TO";I+ST/4-1;INT((I+ST/4-1)/2)
PRINT "L2";I+ST/4;INT((I+ST/4)/2);"TO";I+ST/2-1;INT((I+ST/2-1)/2)
PRINT "L3";I+ST/2;INT((I+ST/2)/2);"TO";I+3*ST/4-1;INT((I+3*ST/4-1)/2)
PRINT "L4";I+3*ST/4;INT((I+3*ST/4)/2);"TO";I+ST-1;INT((I+ST-1)/2)
PRINT
NEXT I
END
--------------------------------------------
! Sieve of Eratosthenes
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(9593)
DECLARE STRUCTURE struct3: 1 OF NUMERIC(101 TO 200)
DECLARE SHARED sha OF struct2
DECLARE SHARED shb OF struct3
DECLARE MESSAGE mes2 OF struct1
DECLARE MESSAGE mes3 OF struct1
DECLARE MESSAGE mes4 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
START Part2
START PART3
START PART4
LET k=100003
LET k3=9593
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL SUB sqprime
CALL sqprime(101,200,k3)
DECLARE NUMERIC B(101 TO 200)
WAIT EVENT Ok6
GET FROM shb TO B
LET TOTAL=50847534
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC X,Y,Z
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I,I+ST/4-1,k2)
RECEIVE FROM mes2 TO X
WAIT EVENT Ready2
RECEIVE FROM mes3 TO Y
WAIT EVENT Ready3
RECEIVE FROM mes4 TO Z
WAIT EVENT Ready4
SIGNAL Ok2
SIGNAL Ok3
SIGNAL Ok4
LET L=L+X+Y+Z
LET TOTAL=TOTAL+L
PRINT I-1;I+ST-1;TOTAL;L
!PRINT TOTAL
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(101 TO 200)
GET FROM shb TO B
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+ST/4,I+ST/2-1,k2)
SEND TO mes2 FROM L
SIGNAL Ready2
WAIT EVENT Ok2
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(101 TO 200)
GET FROM shb TO B
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+ST/2,I+3*ST/4-1,k2)
SEND TO mes3 FROM L
SIGNAL ready3
WAIT EVENT Ok3
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(101 TO 200)
GET FROM shb TO B
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+3*ST/4,I+ST-1,k2)
SEND TO mes4 FROM L
SIGNAL ready4
WAIT EVENT Ok4
NEXT I
END PARACT
EXTERNAL FUNCTION ERATOS(N,M,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(9593) !素数
GET FROM sha TO G
DIM X(0 TO M-N+1)
LET COUNT=0
FOR I=2 TO k2 STEP 1
LET P=G(I)
IF MOD(N,P)=0 THEN
LET NN=N
ELSE
LET NN=INT(N/P+1)*P
END IF
IF N<=I THEN LET NN=NN+P
FOR J=NN TO M STEP P
LET X(J-N)=1
!PRINT i;p;j;n;j-n
NEXT J
NEXT I
FOR J=N TO M STEP 2
IF X(J-N)=0 THEN
LET COUNT=COUNT+1
END IF
NEXT J
LET ERATOS=COUNT
SIGNAL Ok7
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(9593) !素数
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
DIM A(Fm) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
EXTERNAL SUB sqprime(SA,SB,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(9593) !素数
GET FROM sha TO G
DECLARE NUMERIC B(101 TO 200)
LET x=1E7
LET x1=x
FOR i=1 TO k2-1
LET v=G(i)^2
LET vi=G(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=x1 THEN
LET vt=INT(vv/x1)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+x1
IF C>=SA AND SB>=C THEN
LET B(c)=i
END IF
NEXT ns
END SUB
PUT TO shb FROM B
SIGNAL Ok6
END SUB
! Sieve of Eratosthenes
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(9593)
DECLARE STRUCTURE struct3: 1 OF NUMERIC(101 TO 200)
DECLARE SHARED sha OF struct2
DECLARE SHARED shb OF struct3
DECLARE MESSAGE mes2 OF struct1
DECLARE MESSAGE mes3 OF struct1
DECLARE MESSAGE mes4 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
START Part2
START PART3
START PART4
LET k=100003
LET k3=9593
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL SUB sqprime
CALL sqprime(101,200,k3)
DECLARE NUMERIC B(101 TO 200)
WAIT EVENT Ok6
GET FROM shb TO B
LET TOTAL=50847534
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC X,Y,Z
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I,I+ST/4-1,k2)
RECEIVE FROM mes2 TO X
WAIT EVENT Ready2
RECEIVE FROM mes3 TO Y
WAIT EVENT Ready3
RECEIVE FROM mes4 TO Z
WAIT EVENT Ready4
SIGNAL Ok2
SIGNAL Ok3
SIGNAL Ok4
LET L=L+X+Y+Z
LET TOTAL=TOTAL+L
PRINT I-1;I+ST-1;TOTAL;L
!PRINT TOTAL
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(101 TO 200)
WAIT EVENT Ok7
GET FROM shb TO B
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+ST/4,I+ST/2-1,k2)
SEND TO mes2 FROM L
SIGNAL Ready2
WAIT EVENT Ok2
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(101 TO 200)
WAIT EVENT Ok8
GET FROM shb TO B
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+ST/2,I+3*ST/4-1,k2)
SEND TO mes3 FROM L
SIGNAL ready3
WAIT EVENT Ok3
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(101 TO 200)
WAIT EVENT Ok9
GET FROM shb TO B
LET S=1E9+1
LET E=2E9
LET ST=1E7
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=101
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+3*ST/4,I+ST-1,k2)
SEND TO mes4 FROM L
SIGNAL ready4
WAIT EVENT Ok4
NEXT I
END PARACT
EXTERNAL FUNCTION ERATOS(N,M,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(9593) !素数
GET FROM sha TO G
DIM X(0 TO M-N+1)
LET COUNT=0
FOR I=2 TO k2 STEP 1
LET P=G(I)
IF MOD(N,P)=0 THEN
LET NN=N
ELSE
LET NN=INT(N/P+1)*P
END IF
IF N<=I THEN LET NN=NN+P
FOR J=NN TO M STEP P
LET X(J-N)=1
!PRINT i;p;j;n;j-n
NEXT J
NEXT I
FOR J=N TO M STEP 2
IF X(J-N)=0 THEN
LET COUNT=COUNT+1
END IF
NEXT J
LET ERATOS=COUNT
SIGNAL Ok7
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(9593) !素数
!エラトステネスの篩
LET Fu=10007
LET Fm=1230
DIM P(Fu)
DIM A(Fm) !素数
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
EXTERNAL SUB sqprime(SA,SB,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(9593) !素数
GET FROM sha TO G
DECLARE NUMERIC B(101 TO 200)
LET x=1E7
LET x1=x
FOR i=1 TO k2-1
LET v=G(i)^2
LET vi=G(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=x1 THEN
LET vt=INT(vv/x1)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+x1
IF C>=SA AND SB>=C THEN
LET B(c)=i
END IF
NEXT ns
END SUB
PUT TO shb FROM B
SIGNAL Ok6
SIGNAL Ok7
SIGNAL Ok8
SIGNAL Ok9
END SUB
WAIT EVENTとSIGNAL文を外すと何故か動きました。
私もエラトステネスの篩を素数リストで篩ってみました。
VC++2017 + OPEN MPより速くなってしまいました。驚きです。
DECLARE STRUCTURE STRUCT1: 1 OF NUMERIC
DECLARE STRUCTURE STRUCT2: NUMERIC(10000)
DECLARE SHARED SHA OF STRUCT2
DECLARE MESSAGE MES2 OF STRUCT1
DECLARE MESSAGE MES3 OF STRUCT1
DECLARE MESSAGE MES4 OF STRUCT1
DECLARE MESSAGE MES5 OF STRUCT1
DECLARE MESSAGE MES6 OF STRUCT1
DECLARE MESSAGE MES7 OF STRUCT1
DECLARE MESSAGE MES8 OF STRUCT1
PARACT PART1
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB PRIME
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L,X1,X2,X3,X4,X5,X6,X7
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
LET TOTAL=0
LET T=TIME
CALL PRIME(INT(SQR(E)),A)
PUT TO SHA FROM A
START PART2
PUT TO SHA FROM A
START PART3
PUT TO SHA FROM A
START PART4
PUT TO SHA FROM A
START PART5
PUT TO SHA FROM A
START PART6
PUT TO SHA FROM A
START PART7
PUT TO SHA FROM A
START PART8
FOR I=S TO E STEP ST
LET L=ERATOS(I,I+ST/8-1,A)
! WAIT EVENT READY2
RECEIVE FROM MES2 TO X1
! WAIT EVENT READY3
RECEIVE FROM MES3 TO X2
! WAIT EVENT READY4
RECEIVE FROM MES4 TO X3
! WAIT EVENT READY5
RECEIVE FROM MES5 TO X4
! WAIT EVENT READY6
RECEIVE FROM MES6 TO X5
! WAIT EVENT READY7
RECEIVE FROM MES7 TO X6
! WAIT EVENT READY8
RECEIVE FROM MES8 TO X7
! SIGNAL Ok2
! SIGNAL Ok3
! SIGNAL Ok4
! SIGNAL Ok5
! SIGNAL Ok6
! SIGNAL Ok7
! SIGNAL Ok8
LET L=L+X1+X2+X3+X4+X5+X6+X7
LET TOTAL=TOTAL+L
PRINT I;"～";I+ST-1;L;TOTAL
NEXT I
PRINT TIME-T
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+ST/8,I+ST/4-1,A)
SEND TO MES2 FROM L
! WAIT EVENT Ok2
! SIGNAL READY2
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+ST/4,I+3*ST/8-1,A)
SEND TO MES3 FROM L
! WAIT EVENT Ok3
! SIGNAL ready3
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+3*ST/8,I+ST/2-1,A)
SEND TO MES4 FROM L
! WAIT EVENT Ok4
! SIGNAL ready4
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+ST/2,I+5*ST/8-1,A)
SEND TO MES5 FROM L
! WAIT EVENT Ok5
! SIGNAL READY5
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+5*ST/8,I+3*ST/4-1,A)
SEND TO MES6 FROM L
! WAIT EVENT Ok6
! SIGNAL ready6
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+3*ST/4,I+7*ST/8-1,A)
SEND TO MES7 FROM L
! WAIT EVENT Ok7
! SIGNAL ready7
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
DECLARE NUMERIC A(10000)
LET S=1E9+1
LET E=2E9
LET ST=1E7
GET FROM SHA TO A
FOR I=S TO E STEP ST
LET L=ERATOS(I+7*ST/8,I+ST-1,A)
SEND TO MES8 FROM L
! WAIT EVENT Ok8
! SIGNAL ready8
NEXT I
END PARACT
EXTERNAL FUNCTION ERATOS(N,M,A())
OPTION ARITHMETIC NATIVE
DIM X(0 TO M-N+1)
LET COUNT=0
LET I=1
DO
LET I=I+1
LET P=A(I)
IF P*P>=M OR P=-1 THEN EXIT DO
IF MOD(N,P)=0 THEN
LET NN=N
ELSE
LET NN=INT(N/P+1)*P
END IF
FOR J=NN TO M STEP P
LET X(J-N)=1
NEXT J
LOOP
IF MOD(N,2)=0 THEN LET N=N+1
LET MODE=0
SELECT CASE MODE
CASE 0
FOR J=N TO M STEP 2
IF X(J-N)=0 THEN
LET COUNT=COUNT+1
END IF
NEXT J
CASE 1
FOR J=N TO M-2 STEP 2
IF X(J-N)=0 AND X(J-N+2)=0 THEN !'双子素数
LET COUNT=COUNT+1
END IF
NEXT J
CASE 2
FOR J=N TO M-4 STEP 2
IF X(J-N)=0 AND X(J-N+4)=0 THEN !'いとこ素数
LET COUNT=COUNT+1
END IF
NEXT J
CASE 3
FOR J=N TO M-6 STEP 2
IF X(J-N)=0 AND X(J-N+6)=0 THEN !'セクシー素数
LET COUNT=COUNT+1
END IF
NEXT J
CASE 4
FOR J=N TO M-6 STEP 2
IF X(J-N)=0 AND X(J-N+2)=0 AND X(J-N+6)=0 OR X(J-N)=0 AND X(J-N+4)=0 AND X(J-N+6)=0 THEN !'三つ子素数
LET COUNT=COUNT+1
END IF
NEXT J
CASE 5
LET N1=INT((N-11)/30+1)*30+11
FOR J=N1 TO M-8 STEP 30
IF X(J-N)=0 AND X(J-N+2)=0 AND X(J-N+6)=0 AND X(J-N+8)=0 THEN !'四つ子素数
LET COUNT=COUNT+1
END IF
NEXT J
END SELECT
LET ERATOS=COUNT
END FUNCTION
EXTERNAL SUB PRIME(K,A())
OPTION ARITHMETIC NATIVE
DIM P(K)
LET H1=1
LET A(H1)=2
FOR I=3 TO SQR(K) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO K STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO K STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET H1=H1+1
LET A(H1)=-1
END SUB
! Sieve of Eratosthenes 1兆 4/28
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(78505)
DECLARE STRUCTURE struct3: 1 OF NUMERIC(1 TO 100001)
DECLARE STRUCTURE struct4: 4 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE SHARED shb OF struct3
DECLARE MESSAGE mes2 OF struct1
DECLARE MESSAGE mes3 OF struct1
DECLARE MESSAGE mes4 OF struct1
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
PARACT PART1
OPTION ARITHMETIC NATIVE
LET k=1000117
LET k3=78505
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=99E10+1 !pi(1E12),37607912018
LET E=1E12 !pi(1E11),4118054813
LET ST=1E7
LET cc=(S-1)/ST+1
DECLARE EXTERNAL SUB sqprime
CALL sqprime(1,100001,k3)
DECLARE NUMERIC B(1 TO 100001)
WAIT EVENT Ok6
GET FROM shb TO B
START Part2
START PART3
START PART4
SEND TO mes5 FROM S,E,ST,CC
SEND TO mes6 FROM S,E,ST,CC
SEND TO mes7 FROM S,E,ST,CC
LET TOTAL=37245934597!1e7=664579,1e9=50847534
DECLARE EXTERNAL FUNCTION ERATOS
!DECLARE NUMERIC X,Y,Z
FOR I=S TO E STEP ST
LET k2=B(cc)
LET L=ERATOS(I,I+ST/4-1,k2)
RECEIVE FROM mes2 TO X
RECEIVE FROM mes3 TO Y
RECEIVE FROM mes4 TO Z
LET L=L+X+Y+Z
LET TOTAL=TOTAL+L
PRINT I-1;I+ST-1;TOTAL;L
!PRINT TOTAL
LET cc=cc+1
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes5 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+ST/4,I+ST/2-1,k2)
SEND TO mes2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes6 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+ST/2,I+3*ST/4-1,k2)
SEND TO mes3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes7 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION ERATOS
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=ERATOS(I+3*ST/4,I+ST-1,k2)
SEND TO mes4 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION ERATOS(N,M,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DIM X(0 TO M-N+1)
LET COUNT=0
FOR I=2 TO k2 STEP 1
LET P=G(I)
IF MOD(N,P)=0 THEN
LET NN=N
ELSE
LET NN=INT(N/P+1)*P
END IF
IF N<=I THEN LET NN=NN+P
FOR J=NN TO M STEP P
LET X(J-N)=1
!PRINT i;p;j;n;j-n
NEXT J
NEXT I
FOR J=N TO M STEP 2
IF X(J-N)=0 THEN
LET COUNT=COUNT+1
END IF
NEXT J
LET ERATOS=COUNT
SIGNAL Ok7
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
!エラトステネスの篩
LET Fu=1013 !5633
LET Fm=170 !739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
EXTERNAL SUB sqprime(SA,SB,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DECLARE NUMERIC B(1 TO 100001)
LET x=1E7
LET x1=x
FOR i=1 TO k2-1
LET v=G(i)^2
LET vi=G(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=x1 THEN
LET vt=INT(vv/x1)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+x1
IF C>=SA AND SB>=C THEN
LET B(c)=i+1
END IF
NEXT ns
END SUB
PUT TO shb FROM B
SIGNAL Ok6
END SUB
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: NUMERIC(3401)
DECLARE SHARED shar OF struct2
DECLARE MESSAGE mess1 OF struct1
DECLARE MESSAGE mess2 OF struct1
DECLARE MESSAGE mess3 OF struct1
paract par1
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(3401)
LET k6=31607
LET k2=3401
DECLARE EXTERNAL SUB prime
CALL prime(k6)
WAIT EVENT ok1
GET from shar TO A
START par2
START par3
START par4
PRINT A(1);"par1"
!DECLARE NUMERIC x,y,z
RECEIVE FROM mess1 TO x
PRINT x;"par2 mess1"
RECEIVE FROM mess2 TO y
PRINT y;"par3 mess2"
RECEIVE FROM mess3 TO z
PRINT z;"par4 mess3"
PRINT A(8);"par1"
END PARACT
paract par2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(3401)
!DECLARE NUMERIC B
GET FROM shar TO A
PRINT A(2);"par2"
LET B=A(5)
SEND TO mess1 FROM B
END paract
paract par3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(3401)
!DECLARE NUMERIC B
GET from shar TO A
PRINT A(3);"par3"
LET B=A(6)
SEND TO mess2 FROM B
END paract
paract par4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(3401)
!DECLARE NUMERIC B
GET from shar TO A
PRINT A(4);"par4"
LET B=A(7)
SEND TO mess3 FROM B
END paract
EXTERNAL SUB prime(k6)!エラトステネスの篩
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC A(3401)!素数
LET Fu=k6
DIM P(Fu)
MAT P=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
PUT TO shar FROM A
signal ok1
END SUB
------------------------------
paract par1
DECLARE EXTERNAL SUB prime
素数を共有配列に登録して
!Paract BASIC 6n±1篩 1兆 4/29
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(78505)
DECLARE STRUCTURE struct3: 1 OF NUMERIC(1 TO 100001)
DECLARE STRUCTURE struct4: 4 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE SHARED shb OF struct3
DECLARE MESSAGE mes2 OF struct1
DECLARE MESSAGE mes3 OF struct1
DECLARE MESSAGE mes4 OF struct1
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
PARACT PART1
OPTION ARITHMETIC NATIVE
LET k=1000117
LET k3=78505
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=1E9 !pi(1E12),37607912018
LET E=2E9 !pi(1E11),4118054813
LET ST=1E7
LET cc=S/ST+1
DECLARE EXTERNAL SUB sqprime
CALL sqprime(1,100001,k3)
DECLARE NUMERIC B(1 TO 100001)
WAIT EVENT Ok6
GET FROM shb TO B
START Part2
START PART3
START PART4
SEND TO mes5 FROM S,E,ST,CC
SEND TO mes6 FROM S,E,ST,CC
SEND TO mes7 FROM S,E,ST,CC
LET TOTAL=50847534!37245934597!1e7=664579
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET L=cprime(I,I+ST/4,k2)
RECEIVE FROM mes2 TO X
RECEIVE FROM mes3 TO Y
RECEIVE FROM mes4 TO Z
LET L=L+X+Y+Z
LET TOTAL=TOTAL+L
PRINT I;I+ST;TOTAL;L
!PRINT TOTAL
LET cc=cc+1
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes5 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/4,I+ST/2,k2)
SEND TO mes2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes6 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/2,I+3*ST/4,k2)
SEND TO mes3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes7 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+3*ST/4,I+ST,k2)
SEND TO mes4 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
LET B6=INT(k6/30)
LET U=INT(k6/6)
LET W=INT(k4/6)
DIM x(0 TO U-W)
DIM y(0 TO U-W)
MAT x = ZER !(6*n-1)
MAT y = ZER !(6*n+1)
FOR n=3 TO k2
LET P6=G(n)
LET G1=INT(W/P6)
IF MOD(P6+1,6)=0 THEN !(6*n-1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 140
IF P6*i+r6>U THEN EXIT FOR
LET x(P6*i+r6-W)=1
140 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 150
IF P6*i-r6>U THEN EXIT FOR
LET x(P6*i-r6-W)=1
150 NEXT i
END IF
IF MOD(P6+1,6)=0 THEN !(6*n+1)
LET r6=(P6+1)/6
FOR i=G1 TO B6
IF P6*i-r6<W THEN GOTO 160
IF P6*i-r6>U THEN EXIT FOR
LET y(P6*i-r6-W)=1
160 NEXT i
END IF
IF MOD(P6-1,6)=0 THEN
LET r6=(P6-1)/6
FOR i=G1 TO B6
IF P6*i+r6<W THEN GOTO 170
IF P6*i+r6>U THEN EXIT FOR
LET y(P6*i+r6-W)=1
170 NEXT i
END IF
NEXT n
LET COUNT=0
FOR n=0 TO U-W
LET ST=n+W
IF x(n)=0 THEN
IF 6*ST-1>k4 AND 6*ST-1<k6 THEN LET COUNT=COUNT+1
END IF
IF y(n)=0 THEN
IF 6*ST+1>k4 AND 6*ST+1<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
!エラトステネスの篩
LET Fu=1013 !5633
LET Fm=170 !739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
EXTERNAL SUB sqprime(SA,SB,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DECLARE NUMERIC B(1 TO 100001)
LET x=1E7
LET x1=x
FOR i=1 TO k2-1
LET v=G(i)^2
LET vi=G(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=x1 THEN
LET vt=INT(vv/x1)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+x1
IF C>=SA AND SB>=C THEN
LET B(c)=i+1
END IF
NEXT ns
END SUB
PUT TO shb FROM B
SIGNAL Ok6
END SUB
------------------------------------------------
> 追記
>
> 1E7 TO 1E12 1時間48分54.09秒
>
>
> PRINT TOTAL 精度確認中
>
8分割にしました。EXTERNAL FUNCTION cprime も6n+k に 入れ替えて
1E7 TO 1E12 1時間5分2.7秒 精度確認済
0 TO 1E7 は誤差を確認しています。
!Paract BASIC 6n+k篩 1兆 4/30 1E7 step
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(78505)
DECLARE STRUCTURE struct3: 1 OF NUMERIC(1 TO 100001)
DECLARE STRUCTURE struct4: 4 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE SHARED shb OF struct3
DECLARE MESSAGE mes2 OF struct4
DECLARE MESSAGE mes3 OF struct4
DECLARE MESSAGE mes4 OF struct4
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
DECLARE MESSAGE mes8 OF struct4
DECLARE MESSAGE met2 OF struct1
DECLARE MESSAGE met3 OF struct1
DECLARE MESSAGE met4 OF struct1
DECLARE MESSAGE met5 OF struct1
DECLARE MESSAGE met6 OF struct1
DECLARE MESSAGE met7 OF struct1
DECLARE MESSAGE met8 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
LET k=1000117
LET k3=78505
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=1E9 !pi(1E12),37607912018
LET E=2E9 !pi(1E11),4118054813
LET ST=1E7
LET cc=S/ST+1
DECLARE EXTERNAL SUB sqprime
CALL sqprime(1,100001,k3)
DECLARE NUMERIC B(1 TO 100001)
WAIT EVENT Ok6
GET FROM shb TO B
START Part2
START PART3
START PART4
START PART5
START PART6
START PART7
START PART8
SEND TO mes2 FROM S,E,ST,CC
SEND TO mes3 FROM S,E,ST,CC
SEND TO mes4 FROM S,E,ST,CC
SEND TO mes5 FROM S,E,ST,CC
SEND TO mes6 FROM S,E,ST,CC
SEND TO mes7 FROM S,E,ST,CC
SEND TO mes8 FROM S,E,ST,CC
LET TOTAL=50847534!1e7=664579
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
!LET FW=S+1E8-2E7
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET L=cprime(I,I+ST/8,k2)
RECEIVE FROM met2 TO X
RECEIVE FROM met3 TO Y
RECEIVE FROM met4 TO Z
RECEIVE FROM met5 TO X1
RECEIVE FROM met6 TO Y1
RECEIVE FROM met7 TO Z1
RECEIVE FROM met8 TO X2
LET L=L+X+Y+Z+X1+Y1+Z1+X2
LET TOTAL=TOTAL+L
PRINT I;I+ST;TOTAL;L!;cc
!PRINT TOTAL
!IF I=FW THEN
! PRINT TOTAL
! LET FW=FW+1E8
!END IF
LET cc=cc+1
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes2 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/8,I+ST/4,k2)
SEND TO met2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes3 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/4,I+3*ST/8,k2)
SEND TO met3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes4 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+3*ST/8,I+ST/2,k2)
SEND TO met4 FROM L
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes5 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/2,I+5*ST/8,k2)
SEND TO met5 FROM L
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes6 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+5*ST/8,I+3*ST/4,k2)
SEND TO met6 FROM L
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes7 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+3*ST/4,I+7*ST/8,k2)
SEND TO met7 FROM L
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes8 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+7*ST/8,I+ST,k2)
SEND TO met8 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DIM B(2) !素数の最小値7から
DATA 1,5
MAT READ B
LET Q=6
LET U=INT(k6/Q)
LET W=INT(k4/Q)
LET kD=INT(k6/30)
LET M7=W
DIM D(0 TO U-M7)
LET COUNT=0
FOR r=1 TO 2
LET rr=B(r)
MAT D = ZER
FOR t=3 TO k2
LET x=G(t)
LET G1=INT(W/x)
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 70
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 70
END IF
70 FOR f=G1 TO kD
IF x*f+y<W THEN GOTO 80
IF x*f+y>U THEN GOTO 90
LET D(x*f+y-M7)=1
80 NEXT f
90 NEXT t
FOR n=0 TO U-M7
LET ST=n+M7
IF D(n)=0 THEN
IF Q*ST+rr>k4 AND Q*ST+rr<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
NEXT r
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
!エラトステネスの篩
LET Fu=1013 !5633
LET Fm=170 !739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
EXTERNAL SUB sqprime(SA,SB,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DECLARE NUMERIC B(1 TO 100001)
LET x=1E7
LET x1=x
FOR i=1 TO k2-1
LET v=G(i)^2
LET vi=G(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=x1 THEN
LET vt=INT(vv/x1)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+x1
IF C>=SA AND SB>=C THEN
LET B(c)=i+1
END IF
NEXT ns
END SUB
PUT TO shb FROM B
SIGNAL Ok6
END SUB
!Paract BASIC 6n+k篩 1兆 4/30 1E7 step
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(78505)
DECLARE STRUCTURE struct3: 1 OF NUMERIC(1 TO 100001)
DECLARE STRUCTURE struct4: 4 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE SHARED shb OF struct3
DECLARE MESSAGE mes2 OF struct4
DECLARE MESSAGE mes3 OF struct4
DECLARE MESSAGE mes4 OF struct4
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
DECLARE MESSAGE mes8 OF struct4
DECLARE MESSAGE met2 OF struct1
DECLARE MESSAGE met3 OF struct1
DECLARE MESSAGE met4 OF struct1
DECLARE MESSAGE met5 OF struct1
DECLARE MESSAGE met6 OF struct1
DECLARE MESSAGE met7 OF struct1
DECLARE MESSAGE met8 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
LET k=1000117
LET k3=78505
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=1E7 !pi(1E12),37607912018
LET E=1E9 !pi(1E11),4118054813
LET ST=1E7
LET cc=S/ST+1
DECLARE EXTERNAL SUB sqprime
CALL sqprime(1,100001,k3)
DECLARE NUMERIC B(1 TO 100001)
WAIT EVENT Ok6
GET FROM shb TO B
START Part2
START PART3
START PART4
START PART5
START PART6
START PART7
START PART8
SEND TO mes2 FROM S,E,ST,CC
SEND TO mes3 FROM S,E,ST,CC
SEND TO mes4 FROM S,E,ST,CC
SEND TO mes5 FROM S,E,ST,CC
SEND TO mes6 FROM S,E,ST,CC
SEND TO mes7 FROM S,E,ST,CC
SEND TO mes8 FROM S,E,ST,CC
LET TOTAL=664579
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
LET FW=S+1E8-2E7
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET L=cprime(I,I+ST/8,k2)
RECEIVE FROM met2 TO X
RECEIVE FROM met3 TO Y
RECEIVE FROM met4 TO Z
RECEIVE FROM met5 TO X1
RECEIVE FROM met6 TO Y1
RECEIVE FROM met7 TO Z1
RECEIVE FROM met8 TO X2
LET L=L+X+Y+Z+X1+Y1+Z1+X2
LET TOTAL=TOTAL+L
!PRINT I;I+ST;TOTAL;L!;cc
!PRINT TOTAL
IF I=FW THEN
PRINT TOTAL
LET FW=FW+1E8
END IF
LET cc=cc+1
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes2 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/8,I+ST/4,k2)
SEND TO met2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes3 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/4,I+3*ST/8,k2)
SEND TO met3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes4 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+3*ST/8,I+ST/2,k2)
SEND TO met4 FROM L
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes5 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+ST/2,I+5*ST/8,k2)
SEND TO met5 FROM L
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes6 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+5*ST/8,I+3*ST/4,k2)
SEND TO met6 FROM L
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes7 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+3*ST/4,I+7*ST/8,k2)
SEND TO met7 FROM L
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC B(1 TO 100001)
GET FROM shb TO B
RECEIVE FROM mes8 TO X,Y,Z,G
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
LET cc=G
FOR I=S TO E-ST STEP ST
LET k2=B(cc)
LET cc=cc+1
LET L=cprime(I+7*ST/8,I+ST,k2)
SEND TO met8 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DIM B(2) !素数の最小値7から
DATA 1,5
MAT READ B
LET Q=6
LET U=INT(k6/Q)
LET W=INT(k4/Q)
LET kD=INT(k6/30)
LET M7=W
DIM D(0 TO U-M7)
LET COUNT=0
FOR r=1 TO 2
LET rr=B(r)
MAT D = ZER
FOR t=3 TO k2
LET x=G(t)
LET G1=INT(W/x)
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 70
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 70
END IF
70 FOR f=G1 TO kD
IF x*f+y<W THEN GOTO 80
IF x*f+y>U THEN GOTO 90
LET D(x*f+y-M7)=1
80 NEXT f
90 NEXT t
FOR n=0 TO U-M7
LET ST=n+M7
IF D(n)=0 THEN
IF Q*ST+rr>k4 AND Q*ST+rr<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
NEXT r
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
!エラトステネスの篩
LET Fu=1013 !5633
LET Fm=170 !739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
EXTERNAL SUB sqprime(SA,SB,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(78505) !素数
GET FROM sha TO G
DECLARE NUMERIC B(1 TO 100001)
LET x=1E7
LET x1=x
FOR i=1 TO k2-1
LET v=G(i)^2
LET vi=G(i+1)^2
LET vv=vi-v
IF x =< v THEN
CALL sqrp(1)
IF vv>=x1 THEN
LET vt=INT(vv/x1)
CALL sqrp(vt)
END IF
END IF
NEXT i
SUB sqrp(vo)
FOR ns=1 TO vo
LET C=C+1
LET X=X+x1
IF C>=SA AND SB>=C THEN
LET B(c)=i+1
END IF
NEXT ns
END SUB
PUT TO shb FROM B
SIGNAL Ok6
END SUB
十進モードは四捨五入による丸めなので，単純に和を求めるような計算だと誤差の累積がプラスの側に偏る傾向が出ると思います。
2進モードで
LET x=0
FOR I=1 TO 100000000
LET X=X+I
IF x>1e15 THEN LET x=INT((x+5)/10)*10
NEXT I
PRINT x
END
を実行すると
5000000077639320
になるので，計算は合っていると思います。
> mikeさんへのお返事です。
>
> 10進モードで実行すると
>
> FOR I=1 TO 100000000
> LET X=X+I
> LET Y=I*(I+1)/2
> IF X<>Y THEN
> PRINT I
> PRINT X;Y
> STOP
> END IF
> NEXT I
> END
>
> 実行結果
> 44721363
> 1.00000017664956E15 1.00000017664957E15
>
> となりました
>
> 1000桁モードで
>
> PRINT 44721363*(44721363+1)/2
> END
>
> 実行結果
> 1000000176649566
>
> これを見ると精度不足による誤差の累積が原因ではないでしょうか?
>
>
DO
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode)
LET S$=INKEY$
IF S$="." THEN
EXIT DO
ELSEIF S$="0" THEN
LOCATE VALUE (1),RANGE 0 TO 4000 : temp
IF temp>1 THEN
LET tempMode = 1
LET contTemp = temp
ELSE
LET tempMode = 0
END IF
ELSEIF S$="1" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$="9" THEN
LOCATE CHOICE (menu$) :nmenu
IF nmenu=1 THEN !--- Fe 2.8 box=6x6nm
CALL setInitialCondition(3,6.0,2.8,contTemp)
ELSEIF nmenu=2 THEN !--- Fe 4.0
CALL setInitialCondition(3,6.0,4.0,contTemp)
ELSEIF nmenu=3 THEN !--- Cu 4.0
CALL setInitialCondition(7,6.0,4.0,contTemp)
ELSEIF nmenu=4 THEN !--- Al 4.0
CALL setInitialCondition(5,6.0,4.0,contTemp)
ELSEIF nmenu=5 THEN !--- Ca 4.0
CALL setInitialCondition(9,6.0,4.0,contTemp)
ELSEIF nmenu=6 THEN !--- Ba 4.0
CALL setInitialCondition(11,6.0,4.0,contTemp)
ELSEIF nmenu=7 THEN !--- W 4.0
CALL setInitialCondition(0,6.0,4.0,contTemp)
ELSEIF nmenu=8 THEN !contine
!
END IF
END IF
LOOP
END
EXTERNAL FUNCTION INKEY$ !from decimal BASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- molecular dynamics 2D - Morse potential ----------
!
! method: velocity Verlet algorithm
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Morse V(r) = D*((1-EXP(-A*(r-r0)))^2-1)
! = D*(EXP(-2*A*(r-r0))-2*EXP(-A*(r-r0)))
! (D:dissociation energy, r0:bond length, A:width parameter { A=SQR(k/(2*D)) }
! force F(r) = -dV(r)/dr
! = 2*D*A*y*(y-1), y=EXP(-A*(r-r0))
MODULE mmd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC molecKind, sysTime, dt, nMolec, xMax, yMax, mass, Dmrs, Amrs, r0mrs, rCutoff, hh
SHARE NUMERIC xx(500),yy(500) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC reg(500,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 20,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE STRING molecSTR$(0 TO 20) ! molec string
SHARE NUMERIC forceTable(0 TO 1200) ! force table
LET molecKind = 3 ! 3:Fe
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 5.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET mass = 55.847*1.661e-27! mass of Fe (kg)
LET Dmrs = 0.4174*1.602e-19! D of Morse potential (J) : energy of dissociation
LET Amrs = 1.3885e10 ! A of Morse potential (1/m) : width parameter
LET r0mrs = 2.845e-10 ! r0 of Morse potential (m) : bond length
LET rCutoff = 1.0e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
DECLARE EXTERNAL SUB setMolecData,setMolecules,ajustVelocity,setForceTable
DECLARE EXTERNAL FUNCTION setCrystalBlock
RANDOMIZE
CALL setMolecData
LET molecKind = molKind
LET mass = molecData(molecKind,0)
LET Dmrs = molecData(molecKind,1)
LET Amrs = molecData(molecKind,2)
LET r0mrs = molecData(molecKind,3)
LET sysTime = 0.0
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
! set particles
LET s = 0.5*(boxSizeInNM-xtalSizeInNM)*1.0e-9
LET a = xtalSizeInNM*1.0e-9
LET d = 0.5*r0mrs
LET ii= setCrystalBlock(1, s, s, 0.5*a-0.5*d, a, PI/2)
LET nMolec = setCrystalBlock(ii+1, s+0.5*a+0.5*d, s, 0.5*a-0.5*d, a, 0)
CALL ajustVelocity(contTemp)
LET rCutoff = MIN(1.0e-9, 3.0*r0mrs)
CALL setForceTable
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMolecData
! Morse potential data
! 0:mass(AU) 1:D(eV) 2:A(m^-1) 3:r0(m)
DATA 183.85 , 0.9906, 1.4116e10, 3.032e-10 ! 0 W
DATA 95.94 , 0.8032, 1.5079e10, 2.976e-10 ! 1 Mo
DATA 51.996, 0.4414, 1.5721e10, 2.754e-10 ! 2 Cr
DATA 55.847, 0.4174, 1.3885e10, 2.845e-10 ! 3 Fe
DATA 58.71 , 0.4205, 1.4199e10, 2.780e-10 ! 4 Ni
DATA 26.98 , 0.2703, 1.1646e10, 3.253e-10 ! 5 Al
DATA 207.19 , 0.2348, 1.1836e10, 3.733e-10 ! 6 Pb
DATA 63.54 , 0.3429, 1.3588e10, 2.866e-10 ! 7 Cu
DATA 107.87 , 0.3323, 1.3690e10, 3.115e-10 ! 8 Ag
DATA 40.08 , 0.1623, 0.8054e10, 4.569e-10 ! 9 Ca
DATA 87.62 , 0.1513, 0.7878e10, 4.988e-10 ! 10 Sr
DATA 137.34 , 0.1416, 0.6570e10, 5.373e-10 ! 11 Ba
DATA 22.99 , 0.0633, 0.5900e10, 5.336e-10 ! 12 Na
DATA 39.102, 0.0542, 0.4977e10, 6.369e-10 ! 13 K
DATA 85.47 , 0.0464, 0.4298e10, 7.207e-10 ! 14 Rb
DATA 132.905, 0.0449, 0.4157e10, 7.557e-10 ! 15 Cs
DATA 20.183, 0.0031, 1.6500e10, 3.076e-10 ! 16 Ne
DATA 39.948, 0.0104, 1.3400e10, 3.816e-10 ! 17 Ar
DATA 83.80 , 0.0141, 1.2500e10, 4.097e-10 ! 18 Kr
DATA 131.30 , 0.0200, 1.2400e10, 4.467e-10 ! 19 Xe
DATA 200.59 , 0.0734, 1.4900e10, 3.255e-10 ! 20 Hg
DATA "W" ,"Mo","Cr","Fe","Ni","Al","Pb","Cu","Ag","Ca","Sr"
DATA "Ba","Na","K" ,"Rb","Cs","Ne","Ar","Kr","Xe","Hg"
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 20
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.602e-19 !eps(eV) --> (J)
NEXT i
MAT READ molecSTR$
END IF
END SUB
EXTERNAL function setCrystalBlock(ii, x0, y0, xLen, yLen, theta)
DECLARE EXTERNAL SUB setParticle
LET iip = ii
LET a = 0.98*r0mrs
LET b = 0.866025*a
LET leng = xLen
IF (leng<yLen) THEN LET leng = yLen
LET leng = 1.5*leng
LET nx = INT(leng/b) + 1
LET ny = INT(leng/a) + 1
LET sth = SIN(theta)
LET cth = COS(theta)
FOR i=0 TO nx-1
LET x = b*i - leng/2.0
FOR j=0 TO ny-1
LET y = a*j - leng/2.0
IF MOD(i,2)=1 THEN LET y = y + 0.5*a
LET xp = x0 + xLen/2.0 + cth*x - sth*y
LET yp = y0 + yLen/2.0 + sth*x + cth*y
IF (xp>=x0 AND xp<=x0+xLen AND yp>=y0 AND yp<=y0+yLen) THEN
CALL setParticle(iip, xp, yp)
LET iip = iip + 1
END IF
NEXT j
NEXT i
LET setCrystalBlock = iip - 1
end function
EXTERNAL SUB setParticle(i, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ir=10 TO 1200
LET r = ir*hh
LET y = EXP(-Amrs*(r-r0mrs))
LET forceTable(ir) = cutoff(r)*2.0*Dmrs*Amrs*y*(y-1)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ir) = forceTable(10)
NEXT ir
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity,registerNearMolec
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
IF rij<rCutoff THEN
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
EXTERNAL FUNCTION force(r) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ir) + a*forceTable(ir+1))/hh
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (3.418e-10/r)^6
LET boundaryForce = (24.0*(0.5*1.711e-21)*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond,plotBondDirection
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:circle 1:circle+bond
call plotBondDirection(drawMode) !plotBond(drawMode)
ELSEIF drawMode=2 THEN
call velocitySpace
END IF
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING molecSTR$(molecKind)&" N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional molecular dynamics"
PLOT TEXT, AT 50,480 :"[.] exit [0] temp > value "
PLOT TEXT, AT 50,460 :"[1] dispMode [9] menu > select"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
SET LINE COLOR 8 ! gray
DRAW circle WITH SCALE(r0mrs/2.0*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
IF r<1.2*r0mrs THEN
IF r<0.93*r0mrs THEN
SET LINE COLOR 4 !red 13 !'oleave
ELSEIF r<1.03*r0mrs THEN
SET LINE COLOR 3 !green
ELSEIF r<1.08*r0mrs THEN
SET LINE COLOR 2 !blue
ELSE
SET LINE COLOR 8 !gray
END IF
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT k
NEXT i
END IF
END sub
EXTERNAL SUB plotBondDirection(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET COLOR MIX(240) 1.0,0.2,0.2
SET COLOR MIX(241) 0.6,0.6,0.0
SET COLOR MIX(242) 0.0,1.0,0.0
SET COLOR MIX(243) 0.0,0.6,0.6
SET COLOR MIX(244) 0.2,0.2,1.0
SET COLOR MIX(245) 0.8,0.0,0.8
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
SET LINE COLOR 8 ! gray
DRAW circle WITH SCALE(r0mrs/2.0*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR j=i TO nMolec
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
IF r<1.2*r0mrs THEN
LET yij = yy(i)-yy(j)
IF yij=0.0 THEN LET yij = 1e-20
LET th = 3.0*(ATN((xx(i)-xx(j))/yij)+PI/2.0)/PI
LET col = 240 + INT((th-INT(th))*6)
SET LINE COLOR col
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT j
NEXT i
END IF
END sub
EXTERNAL sub velocitySpace
LET boxSize = 300
LET xp = 100
LET yp = 100
SET LINE COLOR 1 !black : axis
PLOT LINES: xp,boxSize/2+yp; boxSize+xp,boxSize/2+yp !vx-axis
PLOT LINES: boxSize/2+xp,yp; boxSize/2+xp,boxSize+yp !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize+xp,boxSize/2+yp: "vx"
PLOT TEXT, AT boxSize+xp,boxSize/2-12+yp: "2000m/s"
PLOT TEXT, AT boxSize/2-12+xp,boxSize+yp: "vy 2000m/s"
PLOT TEXT, AT boxSize/2-8+xp,boxSize/2-10+yp: "0"
PLOT TEXT, AT xp,boxSize+8+yp: "velocity space (vx,vy)"
LET mag = boxSize/4000
FOR i=1 TO nMolec
SET LINE COLOR 2 ! blue
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+boxSize/2+xp,vy(i)*mag+boxSize/2+yp)
NEXT i
END sub
!Paract BASIC 30n+k篩 Ver.12 10兆 5/9 (1E8) step
DECLARE STRUCTURE struct1: 1 OF NUMERIC
DECLARE STRUCTURE struct2: 1 OF NUMERIC(227650)
DECLARE STRUCTURE struct4: 3 OF NUMERIC
DECLARE SHARED sha OF struct2
DECLARE MESSAGE mes2 OF struct4
DECLARE MESSAGE mes3 OF struct4
DECLARE MESSAGE mes4 OF struct4
DECLARE MESSAGE mes5 OF struct4
DECLARE MESSAGE mes6 OF struct4
DECLARE MESSAGE mes7 OF struct4
DECLARE MESSAGE mes8 OF struct4
DECLARE MESSAGE met2 OF struct1
DECLARE MESSAGE met3 OF struct1
DECLARE MESSAGE met4 OF struct1
DECLARE MESSAGE met5 OF struct1
DECLARE MESSAGE met6 OF struct1
DECLARE MESSAGE met7 OF struct1
DECLARE MESSAGE met8 OF struct1
PARACT PART1
OPTION ARITHMETIC NATIVE
LET k=3162319
LET k3=227650
DECLARE EXTERNAL SUB prime
CALL prime(k,k3)
WAIT EVENT Ok5
LET S=1E8 !pi(1E12),37607912018
LET E=1E9 !pi(1E11),4118054813
LET ST=1E8
START Part2
START PART3
START PART4
START PART5
START PART6
START PART7
START PART8
SEND TO mes2 FROM S,E,ST
SEND TO mes3 FROM S,E,ST
SEND TO mes4 FROM S,E,ST
SEND TO mes5 FROM S,E,ST
SEND TO mes6 FROM S,E,ST
SEND TO mes7 FROM S,E,ST
SEND TO mes8 FROM S,E,ST
LET TOTAL=5761455
DECLARE EXTERNAL FUNCTION cprime
!DECLARE NUMERIC X,Y,Z
FOR I=S TO E-ST STEP ST
LET t0=TIME
LET L=cprime(I,I+ST/8)
RECEIVE FROM met2 TO X
RECEIVE FROM met3 TO Y
RECEIVE FROM met4 TO Z
RECEIVE FROM met5 TO X1
RECEIVE FROM met6 TO Y1
RECEIVE FROM met7 TO Z1
RECEIVE FROM met8 TO X2
LET L=L+X+Y+Z+X1+Y1+Z1+X2
LET TOTAL=TOTAL+L
!IF MOD(I+ST,1E9)=0 THEN PRINT (I+ST)/1E9;TOTAL
!PRINT TOTAL
PRINT (I+ST)/1E8;TOTAL;L;
LET TM=TIME-t0
PRINT USING"###.##":TM;
PRINT "秒"
NEXT I
END PARACT
PARACT PART2
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes2 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/8,I+ST/4)
SEND TO met2 FROM L
NEXT I
END PARACT
PARACT PART3
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes3 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/4,I+3*ST/8)
SEND TO met3 FROM L
NEXT I
END PARACT
PARACT PART4
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes4 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/8,I+ST/2)
SEND TO met4 FROM L
NEXT I
END PARACT
PARACT PART5
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes5 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+ST/2,I+5*ST/8)
SEND TO met5 FROM L
NEXT I
END PARACT
PARACT PART6
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes6 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+5*ST/8,I+3*ST/4)
SEND TO met6 FROM L
NEXT I
END PARACT
PARACT PART7
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes7 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+3*ST/4,I+7*ST/8)
SEND TO met7 FROM L
NEXT I
END PARACT
PARACT PART8
OPTION ARITHMETIC NATIVE
RECEIVE FROM mes8 TO X,Y,Z
LET S=X
LET E=Y
LET ST=Z
DECLARE EXTERNAL FUNCTION cprime
DECLARE NUMERIC L
FOR I=S TO E-ST STEP ST
LET L=cprime(I+7*ST/8,I+ST)
SEND TO met8 FROM L
NEXT I
END PARACT
EXTERNAL FUNCTION cprime(k4,k6)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(227650) !素数
GET FROM sha TO G
DIM B(8)
DATA 1,7,11,13,17,19,23,29
MAT READ B
LET Q=30
LET U=INT(k6/Q)
LET W=INT(k4/Q)
LET kd=INT(k6/207)
DIM D(0 TO U-W)
DIM BA(48)
DATA 17,19,23,7,11,13,29,13,11,19,17,1,7,29,13,17,1,23,11,7,29,1,23,19
DATA 19,23,1,29,7,11,23,1,17,13,29,7,1,17,19,11,13,29,13,11,7,23,19,17
MAT READ BA
LET L=0
LET COUNT=0
FOR r=1 TO 8
LET rr=B(r)
MAT D = ZER
LET MD=0
LET t=4
DO
LET x=G(t)
IF x^2>k6 THEN EXIT DO
LET G1=INT(W/x)
LET Lz=1
IF MOD(x+rr,Q)=0 THEN
LET y=-(x+rr)/Q
GOTO 800
END IF
IF MOD(x-rr,Q)=0 THEN
LET y=(x-rr)/Q
GOTO 800
END IF
DO
IF BA(Lz+L)=MOD(x,Q) THEN
LET y=-(INT(x/(Q/B(Lz+1)))+1)
GOTO 800
EXIT DO
END IF
LET Lz=Lz+1
LOOP UNTIL Lz=7
800 FOR f=G1 TO kd
IF x*f+y<W THEN GOTO 900
IF x*f+y>U THEN GOTO 1000
LET D(x*f+y-W)=1
900 NEXT f
1000 LET t=t+1
LOOP
FOR n=0 TO U-W
LET ST=n+W
IF D(n)=0 THEN
IF Q*ST+rr>k4 AND Q*ST+rr<k6 THEN LET COUNT=COUNT+1
END IF
NEXT n
LET L=L+6
NEXT r
LET cprime=COUNT
END FUNCTION
EXTERNAL SUB prime(k,k2)
OPTION ARITHMETIC NATIVE
DECLARE NUMERIC G(227650) !素数
!エラトステネスの篩
LET Fu=1783 !5633
LET Fm=276 !739
DIM P(Fu)
DIM A(Fm)
MAT P=ZER
MAT A=ZER
LET A(1)=2
LET H1=1
FOR I=3 TO SQR(Fu) STEP 2
IF P(I)=0 THEN
FOR J=I*I TO Fu STEP I
LET P(J)=1
NEXT J
END IF
NEXT I
FOR I=3 TO Fu STEP 2
IF P(I)=0 THEN
LET H1=H1+1
LET A(H1)=I
END IF
NEXT I
LET Q=6
LET k7=k !篩の計算範囲
LET k5=IP(k7/Q)+1
DIM Au(k5),Av(k5)
MAT Au = ZER !(6*n-1)
MAT Av = ZER !(6*n+1)
FOR n=3 TO Fm
LET Pu=A(n)
IF MOD(Pu+1,Q)=0 THEN !(6*n-1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Au(Pu*i+ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Au(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu+1,Q)=0 THEN !(6*n+1)
LET ru=(Pu+1)/Q
FOR i=1 TO k5
IF Pu*i-ru>k5 THEN EXIT FOR
LET Av(Pu*i-ru)=1
NEXT i
END IF
IF MOD(Pu-1,Q)=0 THEN
LET ru=(Pu-1)/Q
FOR i=1 TO k5
IF Pu*i+ru>k5 THEN EXIT FOR
LET Av(Pu*i+ru)=1
NEXT i
END IF
NEXT n
LET G(1)=2
LET G(2)=3
LET cz=2
FOR n=1 TO k5
IF 6*n-1>k7 THEN GOTO 100
IF Au(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n-1
END IF
100 IF 6*n+1>k7 THEN EXIT FOR
IF Av(n)=0 THEN
LET cz=cz+1
LET G(cz)=6*n+1
END IF
NEXT n
PUT TO sha FROM G
SIGNAL Ok5
END SUB
----------------------------------------------------
AMD Athlon(tm) 64 Processor 3800+
周波数 : 2.40 GHz
メモリー : 3.00 GB
Microsoft Windows 8.1(32 ビット)
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
DIM P(5,5),ROTXY(5,5),ROTXZ(5,5),ROTXU(5,5),ROTXV(5,5),ROTYZ(5,5),ROTYU(5,5),ROTYV(5,5),ROTZU(5,5),ROTZV(5,5),ROTUV(5,5)
DIM T(15),POINT(5)
SET POINT STYLE 1
LET LMIN=1E+10
LET LMAX=-1E+10
LET L=100
LET MODE=0
DO
LET S$=""
CHARACTER INPUT NOWAIT:S$
IF S$=" " OR S$=CHR$(13) THEN
DO
CHARACTER INPUT NOWAIT:SS$
LOOP WHILE SS$=" " OR SS$=CHR$(13)
LET MODE=MOD(MODE+1,3)
LET FLG=0
LET GLG=0
LET HLG=0
END IF
IF S$<>"" AND POS("012",S$)>0 THEN
LET MODE=VAL(S$)
LET FLG=0
LET GLG=0
LET HLG=0
END IF
IF S$="." OR S$=CHR$(27) THEN STOP
SELECT CASE MODE
CASE 0
IF FLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -180 TO 180,AT T(1):XY
LOCATE VALUE NOWAIT(2),RANGE -180 TO 180,AT T(2):XZ
LOCATE VALUE NOWAIT(3),RANGE -180 TO 180,AT T(3):XU
LOCATE VALUE NOWAIT(4),RANGE -180 TO 180,AT T(4):XV
LOCATE VALUE NOWAIT(5),RANGE -180 TO 180,AT T(5):YZ
LET FLG=1
ELSE
LOCATE VALUE NOWAIT(1):XY
LOCATE VALUE NOWAIT(2):XZ
LOCATE VALUE NOWAIT(3):XU
LOCATE VALUE NOWAIT(4):XV
LOCATE VALUE NOWAIT(5):YZ
END IF
LET T(1)=XY
LET T(2)=XZ
LET T(3)=XU
LET T(4)=XV
LET T(5)=YZ
CASE 1
IF GLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -180 TO 180,AT T(6):YU
LOCATE VALUE NOWAIT(2),RANGE -180 TO 180,AT T(7):YV
LOCATE VALUE NOWAIT(3),RANGE -180 TO 180,AT T(8):ZU
LOCATE VALUE NOWAIT(4),RANGE -180 TO 180,AT T(9):ZV
LOCATE VALUE NOWAIT(5),RANGE -180 TO 180,AT T(10):UV
LET GLG=1
ELSE
LOCATE VALUE NOWAIT(1):YU
LOCATE VALUE NOWAIT(2):YV
LOCATE VALUE NOWAIT(3):ZU
LOCATE VALUE NOWAIT(4):ZV
LOCATE VALUE NOWAIT(5):UV
END IF
LET T(6)=YU
LET T(7)=YV
LET T(8)=ZU
LET T(9)=ZV
LET T(10)=UV
CASE 2
IF HLG=0 THEN
LOCATE VALUE NOWAIT(1),RANGE -200 TO 200,AT T(11):XMOVE
LOCATE VALUE NOWAIT(2),RANGE -200 TO 200,AT T(12):YMOVE
LOCATE VALUE NOWAIT(3),RANGE -200 TO 200,AT T(13):ZMOVE
LOCATE VALUE NOWAIT(4),RANGE -200 TO 200,AT T(14):UMOVE
LOCATE VALUE NOWAIT(5),RANGE -200 TO 200,AT T(15):VMOVE
LET HLG=1
ELSE
LOCATE VALUE NOWAIT(1):XMOVE
LOCATE VALUE NOWAIT(2):YMOVE
LOCATE VALUE NOWAIT(3):ZMOVE
LOCATE VALUE NOWAIT(4):UMOVE
LOCATE VALUE NOWAIT(5):VMOVE
END IF
LET T(11)=XMOVE
LET T(12)=YMOVE
LET T(13)=ZMOVE
LET T(14)=UMOVE
LET T(15)=VMOVE
END SELECT
MAT P=IDN
MAT ROTXY=IDN
LET ROTXY(1,1)=COS(XY)
LET ROTXY(1,2)=SIN(XY)
LET ROTXY(2,1)=-SIN(XY)
LET ROTXY(2,2)=COS(XY)
MAT ROTXZ=IDN
LET ROTXZ(1,1)=COS(XZ)
LET ROTXZ(1,3)=SIN(XZ)
LET ROTXZ(3,1)=-SIN(XZ)
LET ROTXZ(3,3)=COS(XZ)
MAT ROTXU=IDN
LET ROTXU(1,1)=COS(XU)
LET ROTXU(1,4)=SIN(XU)
LET ROTXU(4,1)=-SIN(XU)
LET ROTXU(4,4)=COS(XU)
MAT ROTXV=IDN
LET ROTXV(1,1)=COS(XV)
LET ROTXV(1,5)=SIN(XV)
LET ROTXV(5,1)=-SIN(XV)
LET ROTXV(5,5)=COS(XV)
MAT ROTYZ=IDN
LET ROTYZ(2,2)=COS(YZ)
LET ROTYZ(2,3)=SIN(YZ)
LET ROTYZ(3,2)=-SIN(YZ)
LET ROTYZ(3,3)=COS(YZ)
MAT ROTYU=IDN
LET ROTYU(2,2)=COS(YU)
LET ROTYU(2,4)=SIN(YU)
LET ROTYU(4,2)=-SIN(YU)
LET ROTYU(4,4)=COS(YU)
MAT ROTYV=IDN
LET ROTYV(2,2)=COS(YV)
LET ROTYV(2,5)=SIN(YV)
LET ROTYV(5,2)=-SIN(YV)
LET ROTYV(5,5)=COS(YV)
MAT ROTZU=IDN
LET ROTZU(3,3)=COS(ZU)
LET ROTZU(3,4)=SIN(ZU)
LET ROTZU(4,3)=-SIN(ZU)
LET ROTZU(4,4)=COS(ZU)
MAT ROTZV=IDN
LET ROTZV(3,3)=COS(ZV)
LET ROTZV(3,5)=SIN(ZV)
LET ROTZV(5,3)=-SIN(ZV)
LET ROTZV(5,5)=COS(ZV)
MAT ROTUV=IDN
LET ROTUV(4,4)=COS(UV)
LET ROTUV(4,5)=SIN(UV)
LET ROTUV(5,4)=-SIN(UV)
LET ROTUV(5,5)=COS(UV)
CALL MATRIX5(P,ROTXY)
CALL MATRIX5(P,ROTXZ)
CALL MATRIX5(P,ROTXU)
CALL MATRIX5(P,ROTXV)
CALL MATRIX5(P,ROTYZ)
CALL MATRIX5(P,ROTYU)
CALL MATRIX5(P,ROTYV)
CALL MATRIX5(P,ROTZU)
CALL MATRIX5(P,ROTZV)
CALL MATRIX5(P,ROTUV)
SET DRAW MODE HIDDEN
CLEAR
CALL CUBE(XMOVE,YMOVE,ZMOVE,UMOVE,VMOVE,L)
CALL CUBE(XMOVE,YMOVE,ZMOVE,UMOVE,VMOVE,L/2)
SET LINE COLOR 1
CALL PLOTLINE(X+XMOVE+L/2,Y+YMOVE+L/2,Z+ZMOVE+L/2,UMOVE,VMOVE,X+XMOVE+L/4,Y+YMOVE+L/4,Z+ZMOVE+L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE+L/2,Y+YMOVE+L/2,Z+ZMOVE-L/2,UMOVE,VMOVE,X+XMOVE+L/4,Y+YMOVE+L/4,Z+ZMOVE-L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE+L/2,Y+YMOVE-L/2,Z+ZMOVE+L/2,UMOVE,VMOVE,X+XMOVE+L/4,Y+YMOVE-L/4,Z+ZMOVE+L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE+L/2,Y+YMOVE-L/2,Z+ZMOVE-L/2,UMOVE,VMOVE,X+XMOVE+L/4,Y+YMOVE-L/4,Z+ZMOVE-L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE-L/2,Y+YMOVE+L/2,Z+ZMOVE+L/2,UMOVE,VMOVE,X+XMOVE-L/4,Y+YMOVE+L/4,Z+ZMOVE+L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE-L/2,Y+YMOVE+L/2,Z+ZMOVE-L/2,UMOVE,VMOVE,X+XMOVE-L/4,Y+YMOVE+L/4,Z+ZMOVE-L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE-L/2,Y+YMOVE-L/2,Z+ZMOVE+L/2,UMOVE,VMOVE,X+XMOVE-L/4,Y+YMOVE-L/4,Z+ZMOVE+L/4,UMOVE,VMOVE)
CALL PLOTLINE(X+XMOVE-L/2,Y+YMOVE-L/2,Z+ZMOVE-L/2,UMOVE,VMOVE,X+XMOVE-L/4,Y+YMOVE-L/4,Z+ZMOVE-L/4,UMOVE,VMOVE)
IF FL=0 THEN
SET WINDOW LMIN*2,LMAX*2,LMIN*2,LMAX*2
LET FL=1
END IF
SET DRAW MODE EXPLICIT
LOOP
SUB PLOT(X,Y,Z,U,V)
LET POINT(1)=X
LET POINT(2)=Y
LET POINT(3)=Z
LET POINT(4)=U
LET POINT(5)=V
CALL MATRIX(POINT,P,POINT)
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1),POINT(2);
END IF
END SUB
SUB PLOTLINE(X1,Y1,Z1,U1,V1,X2,Y2,Z2,U2,V2)
PLOT LINES
CALL PLOT(X1,Y1,Z1,U1,V1)
CALL PLOT(X2,Y2,Z2,U2,V2)
PLOT LINES
END SUB
SUB CUBE(X,Y,Z,U,V,L)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y+L/2,Z-L/2,U,V)
CALL PLOT(X+L/2,Y+L/2,Z-L/2,U,V)
SET LINE COLOR 4
CALL PLOT(X+L/2,Y+L/2,Z+L/2,U,V)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y+L/2,Z+L/2,U,V)
SET LINE COLOR 4
CALL PLOT(X-L/2,Y+L/2,Z-L/2,U,V)
PLOT LINES
CALL PLOT(X-L/2,Y-L/2,Z-L/2,U,V)
SET LINE COLOR 2
CALL PLOT(X+L/2,Y-L/2,Z-L/2,U,V)
SET LINE COLOR 4
CALL PLOT(X+L/2,Y-L/2,Z+L/2,U,V)
SET LINE COLOR 2
CALL PLOT(X-L/2,Y-L/2,Z+L/2,U,V)
SET LINE COLOR 4
CALL PLOT(X-L/2,Y-L/2,Z-L/2,U,V)
PLOT LINES
SET LINE COLOR 3
CALL PLOTLINE(X-L/2,Y+L/2,Z-L/2,U,V,X-L/2,Y-L/2,Z-L/2,U,V)
CALL PLOTLINE(X+L/2,Y+L/2,Z-L/2,U,V,X+L/2,Y-L/2,Z-L/2,U,V)
CALL PLOTLINE(X+L/2,Y+L/2,Z+L/2,U,V,X+L/2,Y-L/2,Z+L/2,U,V)
CALL PLOTLINE(X-L/2,Y+L/2,Z+L/2,U,V,X-L/2,Y-L/2,Z+L/2,U,V)
END SUB
END
EXTERNAL SUB MATRIX5(P(,),X(,))
DIM A(5,5)
FOR I=1 TO 5
FOR J=1 TO 5
FOR K=1 TO 5
LET S=S+P(I,K)*X(K,J)
NEXT K
LET A(I,J)=S
LET S=0
NEXT J
NEXT I
MAT P=A
END SUB
EXTERNAL SUB MATRIX(V(),P(,),X())
DIM VV(5)
FOR I=1 TO 5
FOR J=1 TO 5
LET S=S+P(I,J)*X(J)
NEXT J
LET VV(I)=S
LET S=0
NEXT I
MAT V=VV
END SUB
OPTION BASE 0
PUBLIC NUMERIC X,Y,ALPHA,KK,XX(8500),YY(8500)
DIM FR(8500),FI(8500),TX(8500),TY(8500)
CALL GINIT(800,600)
LET N=10
LET L=400
CALL JUMP(200,450)
CALL RECURSIVE(N,L)
LET LV=INT(LOG2(KK))+1
MAT TX=XX
MAT TY=YY
DO
MAT XX=TX
MAT YY=TY
FOR I=1 TO KK-1
LET FR(I+1)=XX(I+1)-XX(I)
LET FI(I+1)=YY(I+1)-YY(I)
NEXT I
CALL FFT(LV,FR,FI,1)
LOCATE VALUE ,RANGE 2 TO 2^(LV-1)-1:NCUT
LET NCUT=INT(NCUT)
FOR I=NCUT+1 TO 2^LV-NCUT-1
LET FR(I)=0
LET FI(I)=0
NEXT I
CALL FFT(LV,FR,FI,-1)
CLEAR
PLOT LINES
FOR I=1 TO KK
LET XX(I+1)=XX(I)+FR(I+1)
LET YY(I+1)=YY(I)+FI(I+1)
IF I=1 THEN PLOT LINES:XX(I),YY(I);
PLOT LINES:XX(I+1),YY(I+1);
NEXT I
LOOP
END
EXTERNAL SUB RECURSIVE(LEV,L)
IF LEV=0 THEN
CALL MOVE(L)
ELSE
CALL TURN(45)
CALL RECURSIVE(LEV-1,L/SQR(2))
CALL TURN(-90)
CALL RECURSIVE(LEV-1,L/SQR(2))
CALL TURN(45)
END IF
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
SET COLOR 7
END SUB
EXTERNAL SUB MOVE(L)
LET X=X+L*COS(ALPHA*PI/180)
LET Y=Y-L*SIN(ALPHA*PI/180)
PLOT LINES:X,Y;
LET KK=KK+1
LET XX(KK)=X
LET YY(KK)=Y
END SUB
EXTERNAL SUB TURN(R)
LET ALPHA=MOD(ALPHA+R+360,360)
END SUB
EXTERNAL SUB JUMP(XA,YA)
LET X=XA
LET Y=YA
PLOT LINES:X,Y;
LET KK=KK+1
LET XX(KK)=X
LET YY(KK)=Y
END SUB
EXTERNAL SUB FFT(M,XR(),XI(),INVERSE)
LET N=2^M
LET L=N/2
LET J=L+1
FOR I=2 TO N-2
IF I<J THEN
SWAP XR(I),XR(J)
SWAP XI(I),XI(J)
END IF
LET K=L
DO WHILE K<J
LET J=J-K
LET K=K/2
LOOP
LET J=J+K
NEXT I
IF INVERSE=1 THEN
LET PX=-PI
ELSE
FOR I=1 TO N
LET XR(I)=XR(I)/N
LET XI(I)=XI(I)/N
NEXT I
LET PX=PI
END IF
LET L=1
FOR K=1 TO M
LET LL=L+L
LET P=PX/L
FOR J=1 TO L
LET W=(J-1)*P
LET WR=COS(W)
LET WI=SIN(W)
FOR I=J TO N STEP LL
LET IL=I+L
LET TR=XR(IL)*WR-XI(IL)*WI
LET TI=XR(IL)*WI+XI(IL)*WR
LET XR(IL)=XR(I)-TR
LET XI(IL)=XI(I)-TI
LET XR(I)=XR(I)+TR
LET XI(I)=XI(I)+TI
NEXT I
NEXT J
LET L=LL
NEXT K
END SUB
OPTION BASE 0
PUBLIC NUMERIC KK,XX(8500),YY(8500)
DIM FR(8500),FI(8500),TX(8500),TY(8500)
CALL GINIT(800,700)
LET N=6
LET B$="LF"
LET L=INT(750/2^N)
LET X0=50
LET Y0=650
LET TH=0
SET LINE COLOR 7
PLOT LINES:X0,Y0;
LET KK=KK+1
LET XX(KK)=X0
LET YY(KK)=Y0
FOR LEV=1 TO N
LET A$=B$
LET B$=""
FOR K=1 TO LEN(A$)
SELECT CASE MID$(A$,K,1)
CASE "F"
LET B$=B$&""
CASE "L"
LET B$=B$&"-RF+LF+RF-"
CASE "R"
LET B$=B$&"+LF-RF-LF+"
CASE "+"
LET B$=B$&"+"
CASE "-"
LET B$=B$&"-"
CASE ELSE
END SELECT
NEXT K
NEXT LEV
FOR I=1 TO LEN(B$)
SELECT CASE MID$(B$,I,1)
CASE "+"
LET TH=TH-60
CASE "-"
LET TH=TH+60
CASE "F"
LET X1=X0+L*COS(TH*PI/180)
LET Y1=Y0-L*SIN(TH*PI/180)
PLOT LINES:X1,Y1;
LET X0=X1
LET Y0=Y1
LET KK=KK+1
LET XX(KK)=X1
LET YY(KK)=Y1
CASE "L","R"
END SELECT
NEXT I
LET LV=INT(LOG2(KK))+1
LET N=2^LV
MAT TX=XX
MAT TY=YY
DO
MAT XX=TX
MAT YY=TY
MAT FR=ZER
MAT FI=ZER
FOR I=1 TO KK-1
LET FR(I+1)=XX(I+1)-XX(I)
LET FI(I+1)=YY(I+1)-YY(I)
NEXT I
CALL CDFT(2*N,COS(PI/N),SIN(PI/N),FR,FI)
LOCATE VALUE ,RANGE 2 TO 2^(LV-1)-1:NCUT
LET NCUT=INT(NCUT)
FOR I=NCUT+1 TO 2^LV-NCUT-1
LET FR(I)=0
LET FI(I)=0
NEXT I
CALL CDFT(2*N,COS(PI/N),-SIN(PI/N),FR,FI)
CLEAR
PLOT LINES
FOR I=1 TO KK
LET XX(I+1)=XX(I)+FR(I+1)/N
LET YY(I+1)=YY(I)+FI(I+1)/N
IF I=1 THEN PLOT LINES:XX(I),YY(I);
PLOT LINES:XX(I+1),YY(I+1);
NEXT I
LOOP
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB CDFT(N,WR,WI,AR(),AI())
OPTION BASE 0
DIM A(N)
FOR I=0 TO N/2-1
LET A(2*I)=AR(I)
LET A(2*I+1)=AI(I)
NEXT I
LET WMR=WR
LET WMI=WI
LET M=N
DO WHILE M>4
LET L=M/2
LET WKR=1
LET WKI=0
LET WDR=1-2*WMI*WMI
LET WDI=2*WMI*WMR
LET SS=2*WDI
LET WMR=WDR
LET WMI=WDI
FOR J=0 TO N-M STEP M
LET I=J+L
LET XR=A(J)-A(I)
LET XI=A(J+1)-A(I+1)
LET A(J)=A(J)+A(I)
LET A(J+1)=A(J+1)+A(I+1)
LET A(I)=XR
LET A(I+1)=XI
LET XR=A(J+2)-A(I+2)
LET XI=A(J+3)-A(I+3)
LET A(J+2)=A(J+2)+A(I+2)
LET A(J+3)=A(J+3)+A(I+3)
LET A(I+2)=WDR*XR-WDI*XI
LET A(I+3)=WDR*XI+WDI*XR
NEXT J
FOR K=4 TO L-4 STEP 4
LET WKR=WKR-SS*WDI
LET WKI=WKI+SS*WDR
LET WDR=WDR-SS*WKI
LET WDI=WDI+SS*WKR
FOR J=K TO N-M+K STEP M
LET I=J+L
LET XR=A(J)-A(I)
LET XI=A(J+1)-A(I+1)
LET A(J)=A(J)+A(I)
LET A(J+1)=A(J+1)+A(I+1)
LET A(I)=WKR*XR-WKI*XI
LET A(I+1)=WKR*XI+WKI*XR
LET XR=A(J+2)-A(I+2)
LET XI=A(J+3)-A(I+3)
LET A(J+2)=A(J+2)+A(I+2)
LET A(J+3)=A(J+3)+A(I+3)
LET A(I+2)=WDR*XR-WDI*XI
LET A(I+3)=WDR*XI+WDI*XR
NEXT J
NEXT K
LET M=L
LOOP
IF M>2 THEN
FOR J=0 TO N-4 STEP 4
LET XR=A(J)-A(J+2)
LET XI=A(J+1)-A(J+3)
LET A(J)=A(J)+A(J+2)
LET A(J+1)=A(J+1)+A(J+3)
LET A(J+2)=XR
LET A(J+3)=XI
NEXT J
END IF
IF N>4 THEN CALL BITRV2(N,A)
FOR I=0 TO N/2-1
LET AR(I)=A(2*I)
LET AI(I)=A(2*I+1)
NEXT I
END SUB
EXTERNAL SUB BITRV2(N,A())
LET M=N/4
LET M2=2*M
LET N2=N-2
LET K=0
FOR J=0 TO M2-4 STEP 4
IF J<K THEN
LET XR=A(J)
LET XI=A(J+1)
LET A(J)=A(K)
LET A(J+1)=A(K+1)
LET A(K)=XR
LET A(K+1)=XI
ELSEIF J>K THEN
LET J1=N2-J
LET K1=N2-K
LET XR=A(J1)
LET XI=A(J1+1)
LET A(J1)=A(K1)
LET A(J1+1)=A(K1+1)
LET A(K1)=XR
LET A(K1+1)=XI
END IF
LET K1=M2+K
LET XR=A(J+2)
LET XI=A(J+3)
LET A(J+2)=A(K1)
LET A(J+3)=A(K1+1)
LET A(K1)=XR
LET A(K1+1)=XI
LET L=M
DO WHILE K>=L
LET K=K-L
LET L=L/2
LOOP
LET K=K+L
NEXT J
END SUB
OPTION BASE 0
OPTION ARITHMETIC COMPLEX
PUBLIC NUMERIC KK,XX(8500),YY(8500),X,Y,ALPHA
DIM F(8500),TX(8500),TY(8500)
CALL GINIT(800,800)
SET LINE COLOR 7
LET N=5
LET L=800/2^N
CALL JUMP(5,790)
CALL RECURSIVE(N,L,90)
LET LV=INT(LOG2(KK))+1
MAT TX=XX
MAT TY=YY
DO
MAT XX=TX
MAT YY=TY
FOR I=1 TO KK-1
LET F(I+1)=COMPLEX(XX(I+1)-XX(I),YY(I+1)-YY(I))
NEXT I
CALL FFT(2^LV,F)
LOCATE VALUE ,RANGE 2 TO 2^(LV-1)-1:NCUT
LET NCUT=INT(NCUT)
FOR I=NCUT+1 TO 2^LV-NCUT-1
LET F(I)=0
NEXT I
CALL IFFT(2^LV,F)
CLEAR
PLOT LINES
FOR I=1 TO KK
LET XX(I+1)=XX(I)+RE(F(I+1))
LET YY(I+1)=YY(I)+IM(F(I+1))
IF I=1 THEN PLOT LINES:XX(I),YY(I);
PLOT LINES:XX(I+1),YY(I+1);
NEXT I
LOOP
END
EXTERNAL SUB RECURSIVE(LEV,L,RR)
OPTION ARITHMETIC COMPLEX
IF LEV<>0 THEN
CALL TURN(RR)
CALL RECURSIVE(LEV-1,L,-RR)
CALL MOVE(L)
CALL TURN(-RR)
CALL RECURSIVE(LEV-1,L,RR)
CALL MOVE(L)
CALL RECURSIVE(LEV-1,L,RR)
CALL TURN(-RR)
CALL MOVE(L)
CALL RECURSIVE(LEV-1,L,-RR)
CALL TURN(RR)
END IF
END SUB
EXTERNAL SUB MOVE(L)
OPTION ARITHMETIC COMPLEX
LET X=X+L*COS(ALPHA*PI/180)
LET Y=Y-L*SIN(ALPHA*PI/180)
PLOT LINES:X,Y;
LET KK=KK+1
LET XX(KK)=X
LET YY(KK)=Y
END SUB
EXTERNAL SUB TURN(R)
OPTION ARITHMETIC COMPLEX
LET ALPHA=MOD(ALPHA+R+360,360)
END SUB
EXTERNAL SUB JUMP(XA,YA)
OPTION ARITHMETIC COMPLEX
LET X=XA
LET Y=YA
PLOT LINES:X,Y;
LET KK=KK+1
LET XX(KK)=X
LET YY(KK)=Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB FFT0(N,Q,X(),Y())
OPTION ARITHMETIC COMPLEX
LET J=COMPLEX(0,1)
LET N0=0
LET N1=N/4
LET N2=N/2
LET N3=N1+N2
LET THETA0=2*PI/N
IF N=1 THEN
ELSEIF N=2 THEN
LET A=X(Q+0)
LET B=X(Q+1)
LET X(Q+0)=A+B
LET X(Q+1)=A-B
ELSEIF N>2 THEN
FOR P=0 TO N1-1
LET W1P=COMPLEX(COS(P*THETA0),-SIN(P*THETA0))
LET W2P=W1P*W1P
LET W3P=W1P*W2P
LET A=X(Q+P+N0)
LET B=X(Q+P+N1)
LET C=X(Q+P+N2)
LET D=X(Q+P+N3)
LET APC=A+C
LET AMC=A-C
LET BPD=B+D
LET JBMD=J*(B-D)
LET Y(Q+P+N0)=APC+BPD
LET Y(Q+P+N1)=W1P*(AMC-JBMD)
LET Y(Q+P+N2)=W2P*(APC-BPD)
LET Y(Q+P+N3)=W3P*(AMC+JBMD)
NEXT P
CALL FFT0(N/4,Q+N0,Y,X)
CALL FFT0(N/4,Q+N1,Y,X)
CALL FFT0(N/4,Q+N2,Y,X)
CALL FFT0(N/4,Q+N3,Y,X)
FOR P=0 TO N1-1
LET X(Q+4*P+0)=Y(Q+P+N0)
LET X(Q+4*P+1)=Y(Q+P+N1)
LET X(Q+4*P+2)=Y(Q+P+N2)
LET X(Q+4*P+3)=Y(Q+P+N3)
NEXT P
END IF
END SUB
EXTERNAL SUB IFFT0(N,Q,X(),Y())
OPTION ARITHMETIC COMPLEX
LET J=COMPLEX(0,1)
LET N0=0
LET N1=N/4
LET N2=N/2
LET N3=N1+N2
LET THETA0=2*PI/N
IF N=1 THEN
ELSEIF N=2 THEN
LET A=X(Q+0)
LET B=X(Q+1)
LET X(Q+0)=A+B
LET X(Q+1)=A-B
ELSEIF N>2 THEN
FOR P=0 TO N1-1
LET W1P=COMPLEX(COS(P*THETA0),SIN(P*THETA0))
LET W2P=W1P*W1P
LET W3P=W1P*W2P
LET A=X(Q+P+N0)
LET B=X(Q+P+N1)
LET C=X(Q+P+N2)
LET D=X(Q+P+N3)
LET APC=A+C
LET AMC=A-C
LET BPD=B+D
LET JBMD=J*(B-D)
LET Y(Q+P+N0)=APC+BPD
LET Y(Q+P+N1)=W1P*(AMC+JBMD)
LET Y(Q+P+N2)=W2P*(APC-BPD)
LET Y(Q+P+N3)=W3P*(AMC-JBMD)
NEXT P
CALL IFFT0(N/4,Q+N0,Y,X)
CALL IFFT0(N/4,Q+N1,Y,X)
CALL IFFT0(N/4,Q+N2,Y,X)
CALL IFFT0(N/4,Q+N3,Y,X)
FOR P=0 TO N1-1
LET X(Q+4*P+0)=Y(Q+P+N0)
LET X(Q+4*P+1)=Y(Q+P+N1)
LET X(Q+4*P+2)=Y(Q+P+N2)
LET X(Q+4*P+3)=Y(Q+P+N3)
NEXT P
END IF
END SUB
EXTERNAL SUB FFT(N,X())
OPTION ARITHMETIC COMPLEX
OPTION BASE 0
DIM Y(N)
CALL FFT0(N,0,X,Y)
MAT X=(1/N)*X
END SUB
EXTERNAL SUB IFFT(N,X())
OPTION ARITHMETIC COMPLEX
OPTION BASE 0
DIM Y(N)
CALL IFFT0(N,0,X,Y)
END SUB
試験環境：
本プログラムは十進BASIC 6.6.3.0 / macOS 10.7.5, 十進BASIC Ver 7.8.0 / windows 10 でテストしました。
------------------
!
! ========= steepest descent method 1D ==========
!
! 016periodicPSD1D.bas
! Copyright(C) 2017 Mitsuru Ikeuchi
! Released under the MIT license ( https://opensource.org/licenses/MIT )
!
! ver 0.0.1 2017.05.29 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB psd1d.setInitialCondition,psd1d.SDiteration,psd1d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET stateMax = 10 !state 0,1,...,stateMax-1
LET vIndex = 1 !0:harmonic potential, 1:quantum well
LET iterMax = 10 ! 10 = iteration in SDiteration()
CALL setInitialCondition(stateMax,vIndex)
DO
CALL SDiteration(stateMax,iterMax)
CALL drawState
LET S$=INKEY$
IF S$="0" THEN
LET vIndex = 0
CALL setInitialCondition(stateMax,vIndex)
ELSEIF S$="1" THEN
LET vIndex = 1
CALL setInitialCondition(stateMax,vIndex)
ELSEIF S$="." THEN
EXIT DO
END IF
LOOP
END
EXTERNAL FUNCTION INKEY$ !from decimal BASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- periodic steepest descent method 1D ----------
!
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy set { Ei }, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
!
MODULE psd1d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, dx, iterCount
SHARE NUMERIC sdEnergy(20) ! electron state energy
SHARE NUMERIC sdState(20,400) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(400) ! state work space in steepestDescent
SHARE NUMERIC vv(400) ! external potential
LET NNx = 256 ! max number of sdState(,NNx,NNy)
LET dx = 1/16 ! (au) x-division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential
LET iterCount = 0
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
! set window
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=0 TO NNx-1
LET sdState(ist,i) = RND-0.5
NEXT i
LET sdState(ist,0) = 0
LET sdState(ist,NNx-1) = 0
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
LET x0 = 0.5*NNx*dx
IF vIndex=0 THEN !--- free space
FOR i=0 TO NNx-1
LET vv(i) = 0
NEXT i
ELSEIF vIndex=1 THEN !--- well
LET el = NNx*dx
FOR i=0 TO NNx-1
LET x = i*dx
IF sin(2*PI*4*x/el)>0 THEN LET vv(i) = 10 ELSE LET vv(i) = 0
NEXT i
END IF
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
LET damp = 0.003 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
CALL sortState(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist,damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=0 TO NNx-1 !--- |wrk> = (H-E_ist)|ist>
LET ip1 = MOD(i+1,NNx)
LET im1 = mod(i-1+NNx,NNx)
LET wrk(i) = (2*sdState(ist,i)-sdState(ist,ip1)-sdState(ist,im1))/h2+(vv(i)-ei)*sdState(ist,i)
NEXT i
FOR i=0 TO NNx-1 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
LET sdState(ist,i) = sdState(ist,i)-damp*wrk(i)
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=0 TO NNx-1
LET ip1 = MOD(i+1,NNx)
LET im1 = mod(i-1+NNx,NNx)
LET s = s+sdState(ist,i)*((2*sdState(ist,i)-sdState(ist,ip1)-sdState(ist,im1))/h2+vv(i)*sdState(ist,i))
LET sn = sn + sdState(ist,i)*sdState(ist,i)
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=0 TO NNx-1
LET sdState(istate,i) = sdState(istate,i) - s*sdState(ist,i)
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
LET w = sdState(ist,i)
LET sdState(ist,i) = sdState(ist+1,i)
LET sdState(ist+1,i) = w
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=0 TO NNx-1
LET s = s + sdState(ist,i)*sdState(jst,i)
NEXT i
LET innerProduct = s*dx
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=0 TO NNx-1
LET s = s + sdState(ist,i)*sdState(ist,i)*dx
NEXT i
LET a = SQR(1/s)
FOR i=0 TO NNx-1
LET sdState(ist,i) = a*sdState(ist,i)
NEXT i
END SUB
! ---------- drawState
EXTERNAL SUB drawState !public
DECLARE EXTERNAL SUB dispInnerProduct
LET sc = 20
LET xp = 50
LET yp = 180
LET vMag = 10
LET stMag = 100
SET DRAW MODE HIDDEN
CLEAR
SET LINE COLOR 1 ! black : PLOT x-axis
PLOT LINES: xp,yp;dx*NNx*sc+xp,yp
!---plot V(x)
SET LINE COLOR 10 ! dark green : PLOT potential V(x);
FOR i=0 TO NNx-1
PLOT LINES: dx*i*sc+xp,vv(i)*vMag+yp;
NEXT i
PLOT LINES
SET TEXT HEIGHT 5
FOR ist=0 TO 9
IF sdEnergy(ist)<12 THEN
SET LINE COLOR 1+ist
SET TEXT COLOR 1+ist
FOR i=0 TO NNx-1 !plot wave function |psi(x,t)>
PLOT LINES: i*dx*sc+xp, sdState(ist,i)*stMag+sdEnergy(ist)*20+yp;
NEXT i
PLOT LINES
PLOT TEXT, AT xp-20,sdEnergy(ist)*20+yp :"|"&STR$(ist)&">"
END IF
NEXT ist
CALL dispInnerProduct(0,dx*NNx*sc+xp+20,yp)
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,100 ,USING "count =###### ":iterCount
PLOT TEXT, AT 50, 85 ,USING "E0 =###.########## E5 =###.##########(au)":sdEnergy(0),sdEnergy(5)
PLOT TEXT, AT 50, 70 ,USING "E1 =###.########## E6 =###.##########(au)":sdEnergy(1),sdEnergy(6)
PLOT TEXT, AT 50, 55 ,USING "E2 =###.########## E7 =###.##########(au)":sdEnergy(2),sdEnergy(7)
PLOT TEXT, AT 50, 40 ,USING "E3 =###.########## E8 =###.##########(au)":sdEnergy(3),sdEnergy(8)
PLOT TEXT, AT 50, 25 ,USING "E4 =###.########## E9 =###.##########(au)":sdEnergy(4),sdEnergy(9)
PLOT TEXT, AT 50, 10 :"periodic steepest descent method 1D"
PLOT TEXT, AT 50,470 :"[.] exit "
PLOT TEXT, AT 50,450 :"[0] free space [1] 1d-crystal "
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB dispInnerProduct(ist,xp,yp)
DECLARE EXTERNAL FUNCTION innerProduct
SET TEXT HEIGHT 5
SET TEXT COLOR 1 ! black
FOR jst=0 TO 9
PLOT TEXT, AT xp,yp+15*jst ,USING "("&STR$(ist)&"|"&STR$(jst)&") = -%.###^^^^":innerProduct(ist,jst)
NEXT jst
PLOT TEXT, AT xp,yp+15*10 :"(i|j) inner product"
END SUB
実験プログラムです。
----------------------------------------
!v1
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE 640*1+1,640*1+1 ! x軸方向にデフォルトのn倍拡張
LET Wi=10
SET WINDOW -wi,wi,-wi,wi
DRAW GRID(1,1)
SET POINT STYLE 7
LET s=COMPLEX(0,1)
!LET s=COMPLEX(0.5,14.13472514173469379)
!LET s=2
LET z=0
FOR n=1 TO 100 STEP 0.1 !半径
LET Z=Z+1/n*s
LET z1=RE(z)
LET z2=IM(z)
SET POINT COLOR 2
PLOT POINTS:z1+0.5,z2
NEXT n
PRINT z
END
-----------------------------------------------
!v2
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE 640*1+1,640*1+1 ! x軸方向にデフォルトのn倍拡張
LET Wi=10
SET WINDOW -wi,wi,-wi,wi
DRAW GRID(1,1)
SET POINT STYLE 7
!LET s=COMPLEX(0,1)
LET s=COMPLEX(.5,14.13472514173469379)
!LET s=2
LET z=0
FOR n=1 TO 100 STEP 0.1 !半径
LET Z=Z+1/n^s
LET z1=RE(z)
LET z2=IM(z)
SET POINT COLOR 2
PLOT POINTS:z1,z2
NEXT n
PRINT z
END
------------------------------------------------
!v3
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE 640*1+1,640*1+1 ! x軸方向にデフォルトのn倍拡張
LET Wi=15
SET WINDOW -1,1,13,15
DRAW GRID(.1,.1)
SET POINT STYLE 7
!LET s=COMPLEX(0,1)
LET s=COMPLEX(.5,14.13472514173469379)
!LET s=2
LET z=0
FOR n=1 TO 100 STEP 0.1 !半径
LET Z=Z+1/n*s
LET z1=RE(z)
LET z2=IM(z)
SET POINT COLOR 2
PLOT POINTS:z1,z2
NEXT n
PRINT z
END
------------------------------------------------
!v4
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE 640*1+1,640*1+1 ! x軸方向にデフォルトのn倍拡張
LET Wi=10
SET WINDOW -wi,wi,-wi,wi
DRAW GRID(1,1)
SET POINT STYLE 7
LET s=COMPLEX(0.5,14.13472514173469379)
!LET s=2
LET z=0
FOR n=1 TO 100 STEP 0.1 !半径
LET Z=Z+1/n^s
LET z1=RE(z)
LET z2=IM(z)
SET POINT COLOR 2
PLOT POINTS:z2-z1,z1-z2
SET POINT COLOR 4
PLOT POINTS:z1-z2,z2-z1
NEXT n
PRINT z
END
-------------------------------------------
LOCATE VALUE スライドバーを10本使用しています
lazaus版BASIC.exe ver 6.6.3.0 又はParact Basic,Basic Accを使用してください
OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
RANDOMIZE
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET LMIN=1E+10
LET LMAX=-1E+10
LET NN=40 !'分割数
LET MM=40
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM XX(0 TO NN,0 TO MM),YY(0 TO NN,0 TO MM),ZZ(0 TO NN,0 TO MM)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
LET XDT=RND-.5
LET YDT=RND-.5
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 3,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT 1 : K
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT 0 : RR
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT 5 : R0
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT 10 : R1
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT 1 : R2
LOCATE VALUE NOWAIT(8),RANGE -100 TO 100,AT 0:XMOVE
LOCATE VALUE NOWAIT(9),RANGE -100 TO 100,AT 0:YMOVE
LOCATE VALUE NOWAIT(10),RANGE -100 TO 100,AT 0:ZMOVE
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): K
LOCATE VALUE NOWAIT(4): RR
LOCATE VALUE NOWAIT(5): R0
LOCATE VALUE NOWAIT(6): R1
LOCATE VALUE NOWAIT(7): R2
LOCATE VALUE NOWAIT(8): XMOVE
LOCATE VALUE NOWAIT(9): YMOVE
LOCATE VALUE NOWAIT(10): ZMOVE
FOR J=0 TO MM
FOR I=0 TO NN
LET ALPHA=I*360/NN
LET BETA=J*360/MM
LET XX(I,J)=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*COS(BETA)
LET ZZ(I,J)=(R1+R0*COS(ALPHA))*(R2+RR*COS(K*BETA))*SIN(BETA)
LET YY(I,J)=R0*SIN(ALPHA)*(R2+RR*COS(K*BETA))
NEXT I
NEXT J
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR J=0 TO MM-1
FOR I=0 TO NN-1
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
CALL PLOT(XX(I,J+1),YY(I,J+1),ZZ(I,J+1))
CALL PLOT(XX(I+1,J+1),YY(I+1,J+1),ZZ(I+1,J+1))
CALL PLOT(XX(I+1,J),YY(I+1,J),ZZ(I+1,J))
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
PLOT LINES
NEXT I
NEXT J
IF FL=0 THEN
SET WINDOW -LMAX*1.2,LMAX*1.2,-LMAX*1.2,LMAX*1.2
LET WW=LMAX*2.4
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN EXIT DO
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X+XMOVE
LET POINT(2)=Y+YMOVE
LET POINT(3)=Z+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
> たろささんへのお返事です。
>
> > トーラスを球体付近から、平面付近にに、変形出来たら、と思いました。
>
> LOCATE VALUE スライドバーを10本使用しています
> lazaus版BASIC.exe ver 6.6.3.0 又はParact Basic,Basic Accを使用してください
>
有難うございました。
Paract Basic Ver.902 動作確認
ゼータ関数の非自明な零点グラフと似た図形が取れました。
OPTION ARITHMETIC COMPLEX
LET wi=3
SET WINDOW -wi+1,wi+1,-wi,wi!-2.5,2.5,-2.5,2.5 !x,y
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0 !背景色黒
SET COLOR MIX(1) 0,0,1 !青
SET COLOR MIX(2) 1,0,0 !赤
SET COLOR MIX(3) 0,1,0 !緑
SET COLOR MIX(4) 1,0,1 !赤紫
SET COLOR MIX(5) 0,1,1 !水色
SET COLOR MIX(6) 1,1,0 !黄色
SET COLOR MIX(7) 1,1,1 !白
CLEAR !CLEAR文は，モード切替え前にSET COLOR MIX(0)で割り当てられた色で画面を塗りつぶす。
DRAW grid
SET POINT STYLE 7
LET c=0
FOR x=30.42487 TO 40.91871 STEP 0.01 !ρ_4～ρ_7
IF x=1 THEN GOTO 100
LET m=Zeta(COMPLEX(1/2,X))
LET R=RE(m)
LET I=IM(m)
! PRINT m
LET c=c+1
LET Ca=MOD(c,3)+1
SET POINT COLOR Ca
PLOT POINTS:r,i
PLOT
100 NEXT x
END
EXTERNAL FUNCTION ZETA(S) !'ゼータ関数
OPTION ARITHMETIC COMPLEX
FOR M=1 TO 300
LET SS=0
FOR J=1 TO M
LET SS=SS+(-1)^(J-1)*COMB(M-1,J-1)*J^(-S)
NEXT J
LET SUM=SUM+SS*2^(-M)
IF ABS(SUM-S0)<1E-14 THEN
LET ZETA=SUM/(1-2^(1-S))
EXIT FUNCTION
END IF
LET S0=SUM
NEXT M
PRINT "収束エラー"
STOP
END FUNCTION
!LOCATE VALUE スライドバーを12本使用しています
!lazaus版BASIC.exe ver 6.6.3.0 又はParact Basic,Basic Accを使用してください
OPTION ARITHMETIC COMPLEX
!OPTION ARITHMETIC NATIVE
OPTION ANGLE DEGREES
RANDOMIZE
!ASK MAX VALUE DEVICE nv
!PRINT nv
LET zi=COMPLEX(0,1)
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET LMIN=1E+10
LET LMAX=-1E+10
LET NN=40 !'分割数
LET MM=40
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM XX(0 TO NN,0 TO MM),YY(0 TO NN,0 TO MM),ZZ(0 TO NN,0 TO MM)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
LET XDT=RND-.5
LET YDT=RND-.5
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1 : SCALE
LOCATE VALUE NOWAIT(2),RANGE -3 TO 3,AT 1 : SPEED
LOCATE VALUE NOWAIT(3),RANGE 0 TO 20,AT 0.5 : K
LOCATE VALUE NOWAIT(4),RANGE 0 TO 20,AT 1.5 : RR
LOCATE VALUE NOWAIT(5),RANGE 0 TO 20,AT 1.5 : R0
LOCATE VALUE NOWAIT(6),RANGE 0 TO 20,AT 5.4 : R1
LOCATE VALUE NOWAIT(7),RANGE 0 TO 20,AT 1.5 : R2
LOCATE VALUE NOWAIT(8),RANGE -100 TO 100,AT 0:XMOVE
LOCATE VALUE NOWAIT(9),RANGE -100 TO 100,AT 0:YMOVE
LOCATE VALUE NOWAIT(10),RANGE -100 TO 100,AT 0:ZMOVE
LOCATE VALUE NOWAIT(11),RANGE 1 TO 20,AT 3.58 : Wa
LOCATE VALUE NOWAIT(13),RANGE 1 TO 20,AT 3.58 : Wb
DO
LOCATE VALUE NOWAIT(1): SCALE
LOCATE VALUE NOWAIT(2): SPEED
LOCATE VALUE NOWAIT(3): K
LOCATE VALUE NOWAIT(4): RR
LOCATE VALUE NOWAIT(5): R0
LOCATE VALUE NOWAIT(6): R1
LOCATE VALUE NOWAIT(7): R2
LOCATE VALUE NOWAIT(8): XMOVE
LOCATE VALUE NOWAIT(9): YMOVE
LOCATE VALUE NOWAIT(10): ZMOVE
LOCATE VALUE NOWAIT(11): Wa
LOCATE VALUE NOWAIT(13): Wb
LET LL=0
FOR J=0 TO MM
FOR I=0 TO NN
LET LL=LL+0.00383
LET ALPHA=I*360/NN !トーラス
LET BETA=J*360/MM
LET XX(I,J)=(R1+R0*wa*COS(ALPHA))*(R2+RR*COS(K*BETA))*RE(EXP(LL*zi))!*COS(BETA)
LET ZZ(I,J)=(R1+R0*wb*COS(ALPHA))*(R2+RR*COS(K*BETA))*IM(EXP(LL*zi))!*SIN(BETA)
LET YY(I,J)=R0*SIN(ALPHA)*(R2+RR*COS(K*BETA))
NEXT I
NEXT J
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M * ROTX * ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR J=0 TO MM-1
FOR I=0 TO NN-1
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
CALL PLOT(XX(I,J+1),YY(I,J+1),ZZ(I,J+1))
CALL PLOT(XX(I+1,J+1),YY(I+1,J+1),ZZ(I+1,J+1))
CALL PLOT(XX(I+1,J),YY(I+1,J),ZZ(I+1,J))
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
PLOT LINES
NEXT I
NEXT J
IF FL=0 THEN
SET WINDOW -LMAX*1.2,LMAX*1.2,-LMAX*1.2,LMAX*1.2
LET WW=LMAX*2.4
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN EXIT DO
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT= (X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X+XMOVE
LET POINT(2)=Y+YMOVE
LET POINT(3)=Z+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
SET LINE COLOR 2
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
--------------------------------------------
初期値はオオム貝型
螺旋型
k 0.52
RR 1.54
R0 1.54
R1 5.54
R2 1.54
ゼータ関数の桃型
k 1.3
RR 1.5
R0 1.5
R1 5.4
R2 1.5
フェルマー螺旋型
k 0.24
RR 3.52
R0 3.52
R1 0
R2 0
ハート型
k 1.02
RR 1.54
R0 1.54
R1 5.54
R2 1.54
毎度、力不足で申し訳ありませんが、トーラス型の半球の継ぎ手が出てます。
出来たら、二重螺旋も出来たらと、思います。
ご協力をお願いします。
家のパソコンでは、LOCATE VALUE NOWAIT(12)が調子悪い。別プログラムで確かめましたが
特に問題ナシです。
Lazarus 1.6.4 (FPC 3.0.2) BASIC Accelerator Ver. 1.0.3 を使用しました。
LACATE VALUE スライドバー個数の上限20本を確認です。
Windows Lazarus版 Basic Ver6.6.3.0 でもLOCATE VALUE NOWAIT(12)のおかしなところ確認できました。
注釈外すと正常に見えますが、バー(2)を動かすとその値がバー(12)にも表示されます。
!LOCATE VALUE NOWAIT(2),RANGE -5 TO 5,AT 0:B
LOCATE VALUE NOWAIT(11),RANGE -5 TO 5,AT 0:K
LOCATE VALUE NOWAIT(12),RANGE -5 TO 5,AT 0:L
LOCATE VALUE NOWAIT(13),RANGE -5 TO 5,AT 0:M
DO
!LOCATE VALUE NOWAIT(2): B
LOCATE VALUE NOWAIT(11): K
LOCATE VALUE NOWAIT(12): L
LOCATE VALUE NOWAIT(13): M
LOOP
END
>
> 注釈外すと正常に見えますが、バー(2)を動かすとその値がバー(12)にも表示されます。
>
> !LOCATE VALUE NOWAIT(2),RANGE -5 TO 5,AT 0:B
> LOCATE VALUE NOWAIT(11),RANGE -5 TO 5,AT 0:K
> LOCATE VALUE NOWAIT(12),RANGE -5 TO 5,AT 0:L
> LOCATE VALUE NOWAIT(13),RANGE -5 TO 5,AT 0:M
> DO
> !LOCATE VALUE NOWAIT(2): B
> LOCATE VALUE NOWAIT(11): K
> LOCATE VALUE NOWAIT(12): L
> LOCATE VALUE NOWAIT(13): M
> LOOP
> END
>
> >
> > 注釈外すと正常に見えますが、バー(2)を動かすとその値がバー(12)にも表示されます。
> >
> > !LOCATE VALUE NOWAIT(2),RANGE -5 TO 5,AT 0:B
> > LOCATE VALUE NOWAIT(11),RANGE -5 TO 5,AT 0:K
> > LOCATE VALUE NOWAIT(12),RANGE -5 TO 5,AT 0:L
> > LOCATE VALUE NOWAIT(13),RANGE -5 TO 5,AT 0:M
> > DO
> > !LOCATE VALUE NOWAIT(2): B
> > LOCATE VALUE NOWAIT(11): K
> > LOCATE VALUE NOWAIT(12): L
> > LOCATE VALUE NOWAIT(13): M
> > LOOP
> > END
> >
>
> 現象を確認しました。
> どこか間違えている気がします。
>
間違えている箇所を特定しました。
順次，修正版を用意します。
----------------------------------------
!sin(x)+cos(x)=ρ_n ,sin(x)+cos(x)=zeta(n),
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE 640*2+1,640*2+1 ! x軸方向にデフォルトのn倍拡張
LET Wi=50
SET WINDOW -.5,2,-5,wi
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0 !背景色黒
SET COLOR MIX(1) 0,0,1 !青
SET COLOR MIX(2) 1,0,0 !赤
SET COLOR MIX(3) 1,0,1 !赤紫
SET COLOR MIX(4) 0,1,0 !緑
SET COLOR MIX(5) 0,1,1 !水色
SET COLOR MIX(6) 1,1,0 !黄色
SET COLOR MIX(7) 1,1,1 !白
CLEAR !CLEAR文は，モード切替え前にSET COLOR MIX(0)で割り当てられた色で画面を塗りつぶす。
DRAW GRID(.5,10)
SET LINE COLOR 5
LET ZERO1=14.1435658457259942670362036372 !abs(ρ_1)
DRAW circle WITH SCALE(ZERO1)*SHIFT(0,0)
LET ZERO2=21.0279849385071248276781391990
DRAW circle WITH SCALE(ZERO2)*SHIFT(0,0)
LET ZERO3=25.0158549103229941605743395159
DRAW circle WITH SCALE(ZERO3)*SHIFT(0,0)
LET ZERO4=30.4289843286609910063177407380
DRAW circle WITH SCALE(ZERO4)*SHIFT(0,0)
LET ZERO5=32.9388567164704955328815401721
DRAW circle WITH SCALE(ZERO5)*SHIFT(0,0)
LET A9=19
DATA 0.3751071671920218266 !ρ_n
DATA 0.3808358315180773568
DATA 0.3827206823919593268
DATA 0.3844917185921564522
DATA 0.3851159549678919465
DATA 0.3860527943271225999
DATA 0.3865933572251905934
DATA 0.3869323439242140375
DATA 0.3874937533934756098
DATA 0.3876785568691843285
DATA 0.392699081698724 !zeta(2)
DATA 0.11527703852715692264
DATA 0.0430686148913785
DATA 0.018822570327114491965
DATA 0.00874851187966394
DATA 0.0041922627745319701263
DATA 0.00204285704164369
DATA 0.0010052075320191288978
DATA 0.000497535187258165
DIM A(A9)
MAT READ A
DATA -1.4991587101393674264 !ρ_n
DATA -1.6967776724345700568
DATA -1.7834404027948773685
DATA -1.8812542252228525807
DATA -1.9208434596511019464
DATA -1.9868259982857292363
DATA -2.0292671172330924267
DATA -2.0578419991380527779
DATA -2.1090764852814033995
DATA -2.1271575682140434683
DATA -0.281861187900338 !zeta(2)
DATA 0
DATA 0
DATA 0
DATA 0
DATA 0
DATA 0
DATA 0
DATA 0
DIM B(A9)
MAT READ B
SET POINT STYLE 7
LET i=COMPLEX(0,1)
FOR n=1 TO A9
FOR nn=1 TO 4
IF n<11 THEN
LET x=2*(PI*nn - COMPLEX(A(n) ,B(n))) !ρ_n
ELSE
LET x=2*(PI*nn + COMPLEX(A(n) ,B(n))) !zeta(n)
END IF
LET z1=(1/2 + i/2)*EXP(-i*x) + (1/2 - i/2)*EXP(i*x)
LET s1=(1/2 + i/2)*EXP(-i*x)
LET s2=(1/2 - i/2)*EXP(i*x)
SET POINT COLOR 2
PLOT POINTS: RE(s1)+RE(s2) ,IM(s1)+IM(s2)
PRINT ROUND(n,2);":";z1;RE(s1)+RE(s2);IM(s1)+IM(s2)
NEXT nn
NEXT n
END
------------------------------------------
LET P=1 !step 1 (π周期)
LET x=2*(PI*P+COMPLEX(0.76771859766171526356,-1.32462990506382773366))!(cos(x)+ i sin(x)=ρ_1)https://www.wolframalpha.com/
!LET x=2*(PI*P+COMPLEX(-0.7677185976617152636,- 1.3246299050638277337))!(cos(x)- i sin(x)=ρ_1)
!LET x=2*(PI*P-COMPLEX( .767718597661715,1.32462990506383))!CONJ(+)ρ_1
!LET x=2*(PI*P+COMPLEX(0.7735081242682836818,- 1.5229270833490052893))!(cos(x)+ i sin(x)=ρ_2)
!LET x=2*(PI*P+COMPLEX(-0.7735081242682836818,- 1.5229270833490052893))!(cos(x)- i sin(x)=ρ_2)
!LET x=2*(PI*P-COMPLEX( .773508124268284, 1.52292708334901)) !CONJ(+)ρ_2
!LET x=2*(PI*P+COMPLEX(0.775403835822546139279,-1.609754910131780344447))!(cos(x)+ i sin(x)=ρ_3)
!LET x=2*(PI*P+COMPLEX(-0.7754038358225461393, - 1.6097549101317803444))!(cos(x)- i sin(x)=ρ_3)
!LET x=2*(PI*P-COMPLEX( .775403835822546, 1.60975491013178) )!CONJ(+)ρ_3
!LET x=2*(PI*P+COMPLEX(0.7771819426816583383, - 1.7076977930242792999))!(cos(x)+ i sin(x)=ρ_4)
!LET x=2*(PI*P+COMPLEX(-0.7771819426816583383, -1.7076977930242792999))!(cos(x)- i sin(x)=ρ_4)
!LET x=2*(PI*P-COMPLEX( .777181942681658, 1.70769779302428)) !CONJ(+)ρ_4
!PRINT CONJ(COMPLEX(0.76771859766171526356,-1.32462990506382773366))
!PRINT CONJ(COMPLEX(0.7735081242682836818,- 1.5229270833490052893))
!PRINT CONJ(COMPLEX(0.775403835822546139279,-1.609754910131780344447))
!PRINT CONJ(COMPLEX(0.7771819426816583383, - 1.7076977930242792999))
LET i=COMPLEX(0,1)
FOR n=0 TO 100
LET s=s+(i*x)^n/FACT(n)
PRINT s
NEXT n
!PRINT s
PRINT
PRINT EXP(i*x)
!非自明な零点の変換
!e^(i*x)=ρ_n
!Σ(i*x)^n/FACT(n)=ρ_n
DATA 14.13472514173469379045725 !(ρ_1)
DATA 21.02203963877155499262847
DATA 25.0108575801456887632137
DATA 30.4248761258595132103118
DATA 32.9350615877391896906623
DATA 37.5861781588256712572177
DATA 40.9187190121474951873981
DATA 43.3270732809149995194961
DATA 48.0051508811671597279424
DATA 49.7738324776723021819167 !(ρ_10)
DIM A(10)
MAT READ A
LET P=1 !step 1 (π周期)
LET x=2*PI*P - COMPLEX(0,1)* LOG(COMPLEX(.5,A(1)))!(ρ_n)
LET i=COMPLEX(0,1)
FOR n=0 TO 80
LET s=s+((i*x)^n/FACT(n))
PRINT s
NEXT n
PRINT
PRINT EXP(i*x)
END
EXTERNAL FUNCTION GAMMA(Z)
LET X$=PACKDBL$(Z)
IF Z>0 THEN
LET GAMMA=GAMMA_(X$)
ELSE
IF FP(Z)=0 THEN
PRINT "定義域エラー"
STOP
END IF
LET GAMMA=GAMMA_(X$)
END IF
FUNCTION GAMMA_(X$)
ASSIGN ".\DLL\gamma_.dll","tgamma_",FPU
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION LGAMMA(Z)
LET X$=PACKDBL$(Z)
LET LGAMMA=LGAMMA_(X$)
FUNCTION LGAMMA_(X$)
ASSIGN ".\DLL\gamma_.dll","lgamma_",FPU
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION DIGAMMA(Z)
LET X$=PACKDBL$(Z)
LET DIGAMMA=DIGAMMA_(X$)
FUNCTION DIGAMMA_(X$)
ASSIGN ".\DLL\gamma_.dll","digamma_",FPU
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION TRIGAMMA(Z)
LET X$=PACKDBL$(Z)
LET TRIGAMMA=TRIGAMMA_(X$)
FUNCTION TRIGAMMA_(X$)
ASSIGN ".\DLL\gamma_.dll","trigamma_",FPU
END FUNCTION
END FUNCTION
EXTERNAL FUNCTION POLYGAMMA(N,Z)
LET X$=PACKDBL$(Z)
LET POLYGAMMA=POLYGAMMA_(INT(N),X$)
FUNCTION POLYGAMMA_(N,X$)
ASSIGN ".\DLL\gamma_.dll","polygamma_",FPU
END FUNCTION
END FUNCTION
-------------------------------------------------------------------------------------------
gamma_.cpp
#include <boost/math/special_functions/gamma.hpp>
#include <boost/math/special_functions/digamma.hpp>
#include <boost/math/special_functions/trigamma.hpp>
#include <boost/math/special_functions/polygamma.hpp>
using namespace boost::math;
using namespace std;
OPTION ARITHMETIC DECIMAL_HIGH
LET X=1/5
CALL LATAN(1000,STR$(X),RESULT$)
LET S=16*VAL(RESULT$)
LET X=1/239
CALL LATAN(1000,STR$(X),RESULT$)
LET S=S-4*VAL(RESULT$)
PRINT S
PRINT PI
END
EXTERNAL SUB LATAN(KETA,X$,RESULT$)
OPTION ARITHMETIC DECIMAL_HIGH
LET B$=REPEAT$(CHR$(0),KETA+100)
CALL ATAN1000(KETA,X$,B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB ATAN1000(KETA,X$,Y$)
ASSIGN ".\DLL\atan1000.dll","atan1000"
END SUB
END SUB
EXTERNAL SUB LACOTAN(KETA,X$,RESULT$)
OPTION ARITHMETIC DECIMAL_HIGH
LET B$=REPEAT$(CHR$(0),KETA+100)
CALL ACOTAN1000(KETA,X$,B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB ACOTAN1000(KETA,X$,Y$)
ASSIGN ".\DLL\atan1000.dll","acotan1000"
END SUB
END SUB
-------------------------------------------------------------------------------------------
atan1000.cpp
DO
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode)
LET S$=INKEY$
IF S$="0" THEN
LOCATE VALUE (1),RANGE 0 TO 4000 : temp
IF temp>1 THEN
LET tempMode = 1
LET contTemp = temp
ELSE
LET tempMode = 0
END IF
ELSEIF S$="D" OR S$="d" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$="9" THEN
LOCATE CHOICE (menu$) :nmenu
IF nmenu=1 THEN !--- Fe Al box=6x6nm
CALL setInitialCondition(3,5,6.0,contTemp)
ELSEIF nmenu=2 THEN !--- Fe Mo
CALL setInitialCondition(3,1,6.0,contTemp)
ELSEIF nmenu=3 THEN !--- Fe Hg
CALL setInitialCondition(3,20,6.0,contTemp)
ELSEIF nmenu=4 THEN !--- W Pb
CALL setInitialCondition(0,6,6.0,contTemp)
ELSEIF nmenu=5 THEN !--- Ni Cr
CALL setInitialCondition(4,2,6.0,contTemp)
ELSEIF nmenu=6 THEN !--- Ag Cu
CALL setInitialCondition(8,7,6.0,contTemp)
ELSEIF nmenu=7 THEN !--- Al Ar
CALL setInitialCondition(5,17,6.0,contTemp)
ELSEIF nmenu=8 THEN !contine
END IF
END IF
LOOP UNTIL S$=CHR$(27)
END
EXTERNAL FUNCTION INKEY$ !from decimalBASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- molecular dynamics 2D - Morse potential ----------
!
! method: velocity Verlet algorithm
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Morse V(r) = D*((1-EXP(-A*(r-r0)))^2-1)
! = D*(EXP(-2*A*(r-r0))-2*EXP(-A*(r-r0)))
! (D:dissociation energy, r0:bond length, A:width parameter { A=SQR(k/(2*D)) }
! force F(r) = -dV(r)/dr
! = 2*D*A*y*(y-1), y=EXP(-A*(r-r0))
MODULE mmd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC molecKind1,molecKind2, sysTime, dt, nMolec, xMax, yMax, rCutoff, hh
SHARE NUMERIC xx(500),yy(500) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(500),vy(500) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(500),ffy(500) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC kind(500),mas(500) ! kind(i),mas(i) : molec kind, mass of i-th particle
SHARE NUMERIC reg(500,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 20,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE STRING molecSTR$(0 TO 20) ! molec string
SHARE NUMERIC forceTable(0 TO 20, 0 TO 20,0 TO 1001) ! force table
LET molecKind1 = 3 ! molecule kind1 - 3:Fe
LET molecKind2 = 1 ! molecule kind2 - 1:Mo
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 5.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET rCutoff = 1.0e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(kind1,kind2,boxSizeInNM,contTemp)
DECLARE EXTERNAL SUB setMolecData,setMolecules,ajustVelocity,setForceTable
DECLARE EXTERNAL FUNCTION setCrystalBlock
RANDOMIZE
CALL setMolecData
LET molecKind1 = kind1
LET molecKind2 = kind2
LET sysTime = 0.0
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
! set particles
LET s = 0.1*xMax
LET xtalSize = 0.35*xMax
LET ss = 0.55*xMax
LET ii = setCrystalBlock(1, kind1, s, s, xtalSize, xtalSize, PI/4)
LET ii = setCrystalBlock(ii+1, kind2, s, ss, xtalSize, xtalSize, 0)
LET ii = setCrystalBlock(ii+1, kind2, ss, s, xtalSize, xtalSize, 0)
LET nMolec = setCrystalBlock(ii+1, kind1, ss, ss, xtalSize, xtalSize, 0)
CALL ajustVelocity(contTemp)
LET rCutoff = MIN(1.0e-9, 3.0*MAX(molecData(kind1,3),molecData(kind2,3)))
CALL setForceTable
SET COLOR MIX(240) 1.0,0.2,0.2 !for bond direction color
SET COLOR MIX(241) 0.6,0.6,0.0
SET COLOR MIX(242) 0.0,1.0,0.0
SET COLOR MIX(243) 0.0,0.6,0.6
SET COLOR MIX(244) 0.2,0.2,1.0
SET COLOR MIX(245) 0.8,0.0,0.8
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMolecData
! Morse potential data
! 0:mass(AU) 1:D(eV) 2:A(m^-1) 3:r0(m)
DATA 183.85 , 0.9906, 1.4116e10, 3.032e-10 ! 0 W
DATA 95.94 , 0.8032, 1.5079e10, 2.976e-10 ! 1 Mo
DATA 51.996, 0.4414, 1.5721e10, 2.754e-10 ! 2 Cr
DATA 55.847, 0.4174, 1.3885e10, 2.845e-10 ! 3 Fe
DATA 58.71 , 0.4205, 1.4199e10, 2.780e-10 ! 4 Ni
DATA 26.98 , 0.2703, 1.1646e10, 3.253e-10 ! 5 Al
DATA 207.19 , 0.2348, 1.1836e10, 3.733e-10 ! 6 Pb
DATA 63.54 , 0.3429, 1.3588e10, 2.866e-10 ! 7 Cu
DATA 107.87 , 0.3323, 1.3690e10, 3.115e-10 ! 8 Ag
DATA 40.08 , 0.1623, 0.8054e10, 4.569e-10 ! 9 Ca
DATA 87.62 , 0.1513, 0.7878e10, 4.988e-10 ! 10 Sr
DATA 137.34 , 0.1416, 0.6570e10, 5.373e-10 ! 11 Ba
DATA 22.99 , 0.0633, 0.5900e10, 5.336e-10 ! 12 Na
DATA 39.102, 0.0542, 0.4977e10, 6.369e-10 ! 13 K
DATA 85.47 , 0.0464, 0.4298e10, 7.207e-10 ! 14 Rb
DATA 132.905, 0.0449, 0.4157e10, 7.557e-10 ! 15 Cs
DATA 20.183, 0.0031, 1.6500e10, 3.076e-10 ! 16 Ne
DATA 39.948, 0.0104, 1.3400e10, 3.816e-10 ! 17 Ar
DATA 83.80 , 0.0141, 1.2500e10, 4.097e-10 ! 18 Kr
DATA 131.30 , 0.0200, 1.2400e10, 4.467e-10 ! 19 Xe
DATA 200.59 , 0.0734, 1.4900e10, 3.255e-10 ! 20 Hg
DATA "W" ,"Mo","Cr","Fe","Ni","Al","Pb","Cu","Ag","Ca","Sr"
DATA "Ba","Na","K" ,"Rb","Cs","Ne","Ar","Kr","Xe","Hg"
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 20
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.602e-19 !eps(eV) --> (J)
NEXT i
MAT READ molecSTR$
END IF
END SUB
EXTERNAL SUB setGas(nMolecule)
DECLARE EXTERNAL SUB ajustVelocity
LET r0 = molecData(knd,3)
FOR j=1 TO nMolecule
LET loopCount = 0
DO
LET xx(j) = (xMax-2*r0)*RND + r0
LET yy(j) = (yMax-2*r0)*RND + r0
FOR i=1 TO j-1
IF (xx(i)-xx(j))^2+(yy(i)-yy(j))^2 < 2*r0^2 THEN EXIT FOR
NEXT i
LET loopCount = loopCount + 1
IF loopCount>1000 THEN EXIT DO
LOOP UNTIL i>=j
IF loopCount>1000 THEN
LET nMolec = j - 1
EXIT FOR
END IF
NEXT j
FOR i=1 TO nMolec
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
END SUB
EXTERNAL FUNCTION setCrystalBlock(ii, knd, x0, y0, xLen, yLen, theta)
DECLARE EXTERNAL SUB setParticle
LET iip = ii
LET a = 0.98*molecData(knd,3) !r0 of knd
LET b = 0.866025*a
LET leng = xLen
IF (leng<yLen) THEN LET leng = yLen
LET leng = 1.5*leng
LET nx = INT(leng/b) + 1
LET ny = INT(leng/a) + 1
LET sth = SIN(theta)
LET cth = COS(theta)
FOR i=0 TO nx-1
LET x = b*i - leng/2.0
FOR j=0 TO ny-1
LET y = a*j - leng/2.0
IF MOD(i,2)=1 THEN LET y = y + 0.5*a
LET xp = x0 + xLen/2.0 + cth*x - sth*y
LET yp = y0 + yLen/2.0 + sth*x + cth*y
IF (xp>=x0 AND xp<=x0+xLen AND yp>=y0 AND yp<=y0+yLen) THEN
CALL setParticle(iip, knd, xp, yp)
LET iip = iip + 1
END IF
NEXT j
NEXT i
LET setCrystalBlock = iip - 1
end function
EXTERNAL SUB setParticle(i, knd, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET mas(i) = molecData(knd,0)
LET kind(i) = knd
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ki=0 TO 20
FOR kj=0 TO 20
LET dd = SQR(molecData(ki,1)*molecData(kj,1))
LET aa = 0.5*(molecData(ki,2)+molecData(kj,2))
LET r0 = 0.5*(molecData(ki,3)+molecData(kj,3))
FOR ir=10 TO 1001
LET r = ir*hh
LET y = EXP(-aa*(r-r0))
LET forceTable(ki,kj,ir) = cutoff(r)*2.0*dd*aa*y*(y-1)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ki,kj,ir) = forceTable(ki,kj,10)
NEXT ir
NEXT kj
NEXT ki
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity,registerNearMolec
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
IF rij<rCutoff THEN
LET f = force(rij,kind(i),kind(j))
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
EXTERNAL FUNCTION force(r,ki,kj) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ki,kj,ir) + a*forceTable(ki,kj,ir+1))/hh
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (3.418e-10/r)^6
LET boundaryForce = (24.0*(0.5*1.711e-21)*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mas(i)*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:circle 1:circle+bond
call plotBond(drawMode)
ELSEIF drawMode=2 THEN
call velocitySpace
END IF
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING molecSTR$(molecKind1)&","&molecSTR$(molecKind2)&" N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional molecular dynamics"
PLOT TEXT, AT 50,480 :"[esc] exit [0] temp > value "
PLOT TEXT, AT 50,460 :"[D] dispMode [9] menu > select"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
IF kind(i)=molecKind1 THEN SET LINE COLOR 11 ELSE SET LINE COLOR 12
DRAW circle WITH SCALE(molecData(kind(i),3)/2.0*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
LET r0 = 0.5*(molecData(kind(i),3)+molecData(kind(j),3))
IF r<1.2*r0 THEN
LET yij = yy(i)-yy(j)
IF yij=0.0 THEN LET yij = 1e-20
LET th = 3.0*(ATN((xx(i)-xx(j))/yij)+PI/2.0)/PI
LET col = 240 + INT((th-INT(th))*6)
SET LINE COLOR col
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT k
NEXT i
END IF
END sub
EXTERNAL sub velocitySpace
LET boxSize = 300
LET xp = 100
LET yp = 100
SET LINE COLOR 1 !black : axis
PLOT LINES: xp,boxSize/2+yp; boxSize+xp,boxSize/2+yp !vx-axis
PLOT LINES: boxSize/2+xp,yp; boxSize/2+xp,boxSize+yp !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize+xp,boxSize/2+yp: "vx"
PLOT TEXT, AT boxSize+xp,boxSize/2-12+yp: "2000m/s"
PLOT TEXT, AT boxSize/2-12+xp,boxSize+yp: "vy 2000m/s"
PLOT TEXT, AT boxSize/2-8+xp,boxSize/2-10+yp: "0"
PLOT TEXT, AT xp,boxSize+8+yp: "velocity space (vx,vy)"
LET mag = boxSize/4000
FOR i=1 TO nMolec
IF kind(i)=molecKind1 THEN SET LINE COLOR 11 ELSE SET LINE COLOR 12
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+boxSize/2+xp,vy(i)*mag+boxSize/2+yp)
NEXT i
END sub
END MODULE
下記のプログラムです。
コメントアウトして発生場所を絞り込むと、
SUB setInitialCondition で発生しているものと推定できます。
!set density
FOR i=0 TO NNp-1
LET s = 0.0
FOR j=0 TO NNp-1
LET s = s + mass(j)*kernel(distance(i,j), (hh(i)+hh(j))/2.0)
NEXT j
LET density(i) = s
NEXT i
の部分を下記のように変更するとエラーは回避できそうですが
!set density
FOR i=0 TO NNp-1
LET s = 0.0
FOR j=0 TO NNp-1
LET r = distance(i,j)
LET s = s + mass(j)*kernel(r, (hh(i)+hh(j))/2.0)
NEXT j
LET density(i) = s
NEXT i
まだ未完ですが、全体のプログラムを載せます。
-------------
!
! ========= smoothed particle hydrodynamics 2D ==========
!
! 0xxgasSPH2D.bas
!
! Copyright(C) 2017 Mitsuru Ikeuchi
! Released under the MIT license ( https://opensource.org/licenses/MIT )
!
! ver 0.0.0 2017.06.22 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB sph2d.setInitialCondition, sph2d.timeEvolution, sph2d.drawParticles
CALL setInitialCondition
LET t0 = TIME
FOR it=1 TO 1000
!CALL timeEvolution(10)
!CALL drawParticles
NEXT it
PRINT TIME - t0
END
! ---------- smoothed particle hydrodynamics 2D ----------
!
! - particle base Lagrangian method
! Monaghan; "Smoothed Particle Hydrodynamics"
! Annu. Rev. Astron. Astrophys.1992. 30:543-74
!
! W(x-xi,h) : kernel weight function (q=|x-xi|/h)
! = aKernel*(1-1.5*q^2+0.75*q^3) (q<1)
! = aKernel*0.25*(2-q)^3 (1<=q<2)
! = 0 (q>=2)
!
! aKernel = 2/3/h (1D)
! = 10/(7Pi)/h^2 (2D)
! = 1/Pi/h^3 (3D)
!
! f(x) --> sum[mj/rhoj*f(xj)*W(x-xj,h), j]
! grad f(x) --> -sum[mj/rhoj*f(xj)*grad W(x-xj,h), j]
!
! - time step
! (1) registration - set section (not implemented in this code)
! (2) set density
! (3) set pressure
! (4) Verlet step1 (t = t + dt/2)
! (5) set acceleration ax ay and power <-- x(t+dt/2),y(t+dt/2)
! (6) Verlet step2 (t = (t + dt/2) + dt/2)
! (7) set boundary
! goto (1)
!
MODULE sph2d
MODULE OPTION ARITHMETIC NATIVE
MODULE OPTION BASE 0
PUBLIC SUB setInitialCondition,timeEvolution,drawParticles
SHARE NUMERIC sysTime, dt, xMax, yMax, hh0, NNp
SHARE NUMERIC xx(5000),yy(5000) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(5000),vy(5000) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ax(5000),ay(5000) ! (ax(i),ay(i)) : total force/mass of i-th particle
SHARE NUMERIC hh(5000),mass(5000),cp(5000)
SHARE NUMERIC density(5000),pressure(5000),energy(5000),power(5000)
LET sysTime = 0.0 ! (s) system time
LET dt = 0.0001 ! (s) time step
LET xMax = 5.0 ! (m) x-Box size
LET yMax = 5.0 ! (m) y-Box size
LET hh0 = 0.25 ! (m) h of weight function
LET NNp = 400 ! number of smoothed particle
! ---------- set initial condition
EXTERNAL SUB setInitialCondition
! i,j, s
DECLARE EXTERNAL FUNCTION kernel,distance
RANDOMIZE
LET sysTime = 0.0
!set smoothed particles
FOR i=0 TO NNp-1
LET mass(i) = (0.029/0.0224)/4.0 !air
LET cp(i) = 1000.0 !air
LET xx(i) = 0.1*MOD(i,20)+0.5
LET yy(i) = 0.1*INT(i/20)+1.0
LET vx(i) = 0.0
LET vy(i) = 0.0
LET ax(i) = 0.0
LET ay(i) = 0.0
LET hh(i) = hh0
NEXT i
! set energy and power
FOR i=0 TO NNp-1
LET energy(i) = mass(i)*cp(i)*300 ! 300=temp(K)
LET power(i) = 0.0
NEXT i
!set density
FOR i=0 TO NNp-1
LET s = 0.0
FOR j=0 TO NNp-1
LET s = s + mass(j)*kernel(distance(i,j), (hh(i)+hh(j))/2.0)
NEXT j
LET density(i) = s
NEXT i
! set window
SET WINDOW 0,500, 0,500
END SUB
! ---------- time evolution
EXTERNAL SUB timeEvolution(nCalc)
! i
DECLARE EXTERNAL SUB timeStep
FOR i=0 TO NNp-1
CALL timeStep
LET sysTime = sysTime + dt
NEXT i
END SUB
EXTERNAL SUB timeStep
! i,j, dtv2,s,rr
DECLARE EXTERNAL SUB accCalc
DECLARE EXTERNAL FUNCTION kernel,distance
LET dtv2 = dt/2.0
!(2) set density
FOR i=0 TO NNp-1
LET s = 0.0
FOR j=0 TO NNp-1
LET s = s + mass(j)*kernel(distance(i,j), (hh(i)+hh(j))/2.0)
Next j
LET density(i) = s
NEXT i
!(3) SET pressure
FOR i=0 TO NNp-1
LET pressure(i) = 8.31*density(i)*(energy(i)/(mass(i)*cp(i)))
NEXT i
!(4) Verlet step1 (t = t + dt/2)
FOR i=0 TO NNp-1
LET vx(i) = vx(i) + dtv2*ax(i)
LET vy(i) = vy(i) + dtv2*ay(i)
LET xx(i) = xx(i) + vx(i)*dt
LET yy(i) = yy(i) + vy(i)*dt
NEXT i
!(5) set acceleration ax[] ay[] and power[]
CALL accCalc
!(6) Verlet step2 (t = t + dt/2 + dt/2)
FOR i=0 TO NNp-1
LET vx(i) = vx(i) + dtv2*ax(i)
LET vy(i) = vy(i) + dtv2*ay(i)
LET energy(i) = energy(i) + power(i)*dt
NEXT i
!(7) boundary
LET rr = 1.0
FOR i=0 TO NNp-1
if (xx(i) < 0.0) then
LET xx(i) = 0.0
LET vx(i) = -rr*vx(i)
LET vy(i) = rr*vy(i)
END IF
if (xx(i) > xMax) then
LET xx(i) = xMax
LET vx(i) = -rr*vx(i)
LET vy(i) = rr*vy(i)
end if
if (yy(i) < 0.0) then
LET yy(i) = 0.0
LET vx(i) = rr*vx(i)
LET vy(i) = -rr*vy(i)
END IF
if (yy(i) > yMax) then
LET yy(i) = yMax
LET vx(i) = rr*vx(i)
LET vy(i) = -rr*vy(i)
END IF
NEXT i
END SUB
! --- (5) set acceleration ax[] ay[] and power[]
EXTERNAL SUB accCalc
! i,j, ai,aj,b,rij,gradW,gradWx,gradWy
DECLARE EXTERNAL FUNCTION dwwvdr
FOR i=0 TO NNp-1
LET ax(i) = 0.0
LET ay(i) = 0.0
LET power(i) = 0.0
LET ai = pressure(i)/(density(i)*density(i))
FOR j=0 TO NNp-1
LET rij = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
IF (rij>0) THEN
LET aj = pressure(j)/(density(j)*density(j))
LET b = mass(j)*(ai+aj)
LET gradW = dwwvdr(rij, (hh(i)+hh(j))/2.0)
LET gradWx = gradW*(xx(i)-xx(j))/rij
LET gradWy = gradW*(yy(i)-yy(j))/rij
LET ax(i) = ax(i) - b*gradWx
LET ay(i) = ay(i) - b*gradWy
LET power(i) = power(i) + 0.5*b*((vx(i)-vx(j))*gradWx+(vy(i)-vy(j))*gradWy)
END IF
NEXT j
NEXT i
END SUB
! --- smoothed particle
EXTERNAL FUNCTION distance(i,j)
! x,y
LET x = xx(i)-xx(j)
LET y = yy(i)-yy(j)
LET distance = SQR(x*x+y*y)
END FUNCTION
EXTERNAL FUNCTION kernel(r,h)
! a,q,ret
LET ret = 0.0
LET q = r/h
LET a = 10.0/(7.0*3.141592)/(h*h)
if (q<1.0) then
LET ret = a*(1.0-1.5*q*q+0.75*q*q*q)
ELSEIF (q<2.0) THEN
LET ret = a*0.25*(2.0-q)*(2.0-q)*(2.0-q)
END IF
LET kernel = ret
END FUNCTION
EXTERNAL FUNCTION dwwvdr(r,h)
! a,q,ret
LET ret = 0.0
LET q = r/h
LET a = 10.0/(7.0*3.141592)/(h*h*h)
if (q<1.0) then
LET ret = a*(-3.0*q+2.25*q*q)
elseif (q<=2.0) then
LET ret = -a*0.75*(2.0-q)*(2.0-q)
END IF
LET dwwvdr = ret
END FUNCTION
! ---------- utility
! ---------- draw particles
EXTERNAL SUB drawParticles
DECLARE EXTERNAL FUNCTION systemTemprature
LET boxsize = 300
LET sc = boxsize/xMax
LET xp = 100
LET yp = 80
LET vScate = 100*dt
LET fScale = 1000*dt*dt/mass(0)
SET DRAW MODE HIDDEN
CLEAR
SET LINE COLOR 1 ! black : wall
PLOT LINES: xp,yp; xp+boxSize,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
!draw Balls, velocity and force
FOR i=1 TO nMolec
SET LINE COLOR 2 ! blue : molecule
DRAW circle WITH SCALE(sigma/2.0*sc)*SHIFT(xx(i)*sc+xp,yy(i)*sc+yp)
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xx(i)*sc+xp,yy(i)*sc+yp;
PLOT LINES: (xx(i)+vx(i)*vScate)*sc+xp,(yy(i)+vy(i)*vScate)*sc+yp
!SET LINE COLOR 1 ! black : force
!PLOT LINES: xx(i)*sc+xp,yy(i)*sc+yp;
!PLOT LINES: (xx(i)+ffx(i)*fScale)*sc+xp,(yy(i)+ffy(i)*fScale)*sc+yp
NEXT i
SET TEXT HEIGHT 6
SET LINE COLOR 4 ! red : velocity
PLOT LINES: xp+0.6*boxsize,yp+boxsize+25;xp+0.6*boxsize+50,yp+boxsize+25
SET TEXT COLOR 4 ! red
PLOT TEXT, AT xp+0.6*boxsize+55,yp+boxsize+22: "velosity"
SET LINE COLOR 1 ! black : force
PLOT LINES: xp+0.6*boxsize,yp+boxsize+10;xp+0.6*boxsize+50,yp+boxsize+10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp+0.6*boxsize+55,yp+boxsize+7: "force"
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50, 50 ,USING "time =####.#### ":sysTime
PLOT TEXT, AT 50, 35 ,USING "N =####":NNp
PLOT TEXT, AT 50, 20 :"Ar in the box (2-dimensional molecular dynamics)"
SET TEXT HEIGHT 6
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (m)":xMax,yMax
SET DRAW MODE EXPLICIT
END SUB
試験環境：
本プログラムは十進BASIC 6.6.3.1 / macOS 10.7.5, 十進BASIC Ver 7.8.0 / windows 10 でテストしました。
------------
!
! ========= periodic steepest descent method 2D ==========
!
! 018periodicPSD2D.bas
! Copyright(C) 2017 Mitsuru Ikeuchi
! Released under the MIT license ( https://opensource.org/licenses/MIT )
!
! ver 0.0.1 2017.06.26 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB psd2d.setInitialCondition,psd2d.SDiteration,psd2d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET stateMax = 10 !state 0,1,...,stateMax-1
LET vIndex = 0 !0:free space, 1:2d-crystal
LET iterMax = 5 !5 -iteration in SDiteration()
LET drawMode = 1 !0:draw3DPsi, 1:drawPsi
CALL setInitialCondition(stateMax,vIndex)
DO
CALL SDiteration(stateMax, iterMax)
CALL drawState(drawMode,vIndex)
LET S$=INKEY$
IF S$="6" THEN CALL setInitialCondition(stateMax,0) !Hermonics
IF S$="7" THEN CALL setInitialCondition(stateMax,1) !Well
IF S$="8" THEN LET drawMode = 0 !0:draw3DPsi
IF S$="9" THEN LET drawMode = 1 !1:drawPsi
LOOP UNTIL S$=CHR$(27)
END
EXTERNAL FUNCTION INKEY$ !from decimal BASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- periodic steepest descent method 2D ----------
!
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy Ei, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
!
MODULE psd2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, NNy, dx, dy, iterCount
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(20) ! electron state energy
SHARE NUMERIC sdState(20,200,200) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(200,200) ! state work space in steepestDescent
SHARE NUMERIC vv(200,200) ! external potential
SHARE NUMERIC psicol(64,64) ! MAT PLOT CELL matrix for psi(x,y)
SHARE NUMERIC vcol(64,64) ! MAT PLOT CELL matrix for potential V(x,y)
LET NNx = 64 ! max number of sdState(,NNx,NNy)
LET NNy = 64 ! max number of sdState(,NNx,NNy)
LET dx = 0.25 ! (au) x division
LET dy = 0.25 ! (au) y division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential,initDraw
LET iterCount = 0
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
CALL initDraw
! set window
LET xMargin = 60
LET yMargin = 120
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=0 TO NNx-1
FOR j=0 TO NNx-1
LET sdState(ist,i,j) = RND-0.5
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
LET x0 = 0.5*NNx*dx
LET y0 = 0.5*NNy*dy
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET x = i*dx
LET y = j*dy
IF vIndex=0 THEN
LET vv(i,j) = 0
ELSEIF vIndex=1 THEN
IF (x-x0)*(y-y0)>0 THEN LET vv(i,j)=10 ELSE LET vv(i,j)=0
ELSE
LET vv(i,j)=0
END IF
NEXT j
NEXT i
END SUB
EXTERNAL SUB initDraw !--- set set color pallet and MAT PLOT matrix vcol(,)
FOR i = 0 TO 50 !--- set color pallet
SET COLOR MIX( 40+i) 0.02*i,0.02*i,0 ! red for |psi> +
SET COLOR MIX(100+i) 0,0.02*i,0.02*i ! blue for |psi> -
SET COLOR MIX(160+i) 0,0.02*i,0 ! green for V(x)
NEXT i
FOR i=0 TO NNx-1 !--- set vcol(,)
FOR j=0 TO NNy-1
LET col = 0.02*vv(i,j)
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET vcol(i,j) = 160+INT(col*50)
NEXT j
NEXT i
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
LET damp = 0.01 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
CALL sortState(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist,damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=0 TO NNx-1 !--- |wrk> = (H-E_ist)|ist>
LET ip1 = MOD(i+1,NNx)
LET im1 = MOD(i-1+NNx,NNx)
FOR j=0 TO NNy-1
LET jp1 = MOD(j+1,NNy)
LET jm1 = MOD(j-1+NNy,NNy)
LET pij = sdState(ist,i,j)
LET wrk(i,j) = (4*pij-sdState(ist,ip1,j)-sdState(ist,im1,j)-sdState(ist,i,jm1)-sdState(ist,i,jp1))/h2+(vv(i,j)-ei)*pij
NEXT j
NEXT i
FOR i=0 TO NNx-1 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=0 TO NNy-1
LET sdState(ist,i,j) = sdState(ist,i,j)-damp*wrk(i,j)
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=0 TO NNx-1
LET ip1 = MOD(i+1,NNx)
LET im1 = MOD(i-1+NNx,NNx)
FOR j=0 TO NNy-1
LET jp1 = MOD(j+1,NNy)
LET jm1 = MOD(j-1+NNy,NNy)
LET pij = sdState(ist,i,j)
LET pij = sdState(ist,i,j)
LET s = s+pij*((4*pij-sdState(ist,ip1,j)-sdState(ist,im1,j)-sdState(ist,i,jm1)-sdState(ist,i,jp1))/h2+vv(i,j)*pij)
LET sn = sn+pij*pij
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET sdState(istate,i,j) = sdState(istate,i,j) - s*sdState(ist,i,j)
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET w = sdState(ist,i,j)
LET sdState(ist,i,j) = sdState(ist+1,i,j)
LET sdState(ist+1,i,j) = w
NEXT j
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET s = s + sdState(ist,i,j)*sdState(jst,i,j)
NEXT j
NEXT i
LET innerProduct = s*dx*dy
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET s = s + sdState(ist,i,j)*sdState(ist,i,j)*dx*dy
NEXT j
NEXT i
LET a = SQR(1/s)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET sdState(ist,i,j) = a*sdState(ist,i,j)
NEXT j
NEXT i
END SUB
! ---------- utility
!EXTERNAL FUNCTION iterationCount
! LET iterationCount = iterCount
!END FUNCTION
EXTERNAL FUNCTION stateEnergy(ist)
LET stateEnergy = sdEnergy(ist)
END FUNCTION
! ---------- 3D graphics
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z,xShift,yShift) !shift*xRotateAx*yRotateAy*(shift^-1)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0+xShift, y1+cy0+yShift; !z=z1+cz0
END SUB
! ---------- drawState
EXTERNAL SUB drawState(drawMode,vIndex)
DECLARE EXTERNAL SUB setRotateXYParameters,drawState3D,draw3DPsix6,drawPsix6
IF vIndex=0 THEN LET v$="free space" ELSE LET v$="2D-crystal"
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 THEN
CALL setRotateXYParameters(-PI/6,-PI/12,NNx/2,NNy/2,0)
CALL draw3DPsix6
ELSEIF drawMode=1 THEN
CALL drawPsix6
END IF
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,100 ,USING "iteration count =##### ":iterCount
PLOT TEXT, AT 50, 85 ,USING "E0 =###.########### E5 =###.###########(au)":sdEnergy(0),sdEnergy(5)
PLOT TEXT, AT 50, 70 ,USING "E1 =###.########### E6 =###.###########(au)":sdEnergy(1),sdEnergy(6)
PLOT TEXT, AT 50, 55 ,USING "E2 =###.########### E7 =###.###########(au)":sdEnergy(2),sdEnergy(7)
PLOT TEXT, AT 50, 40 ,USING "E3 =###.########### E8 =###.###########(au)":sdEnergy(3),sdEnergy(8)
PLOT TEXT, AT 50, 25 ,USING "E4 =###.########### E9 =###.###########(au)":sdEnergy(4),sdEnergy(9)
PLOT TEXT, AT 50, 10 :"periodic steepest descent method 2D"
PLOT TEXT, AT 50,480 :"potential -> [6] free space [7] 2d-crystal "
PLOT TEXT, AT 50,465 :"display -> [8] psi3D [9] psi "
PLOT TEXT, AT 50,450 :"[esc] exit "
PLOT TEXT, AT 50,420 :"potential : "&v$
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB draw3DPsix6
DECLARE EXTERNAL SUB drawState3D
CALL drawState3D(0,2,0.5, 30,120) !(ist,sc,zMag,xShift,yShift)
CALL drawState3D(1,2,0.5,180,120)
CALL drawState3D(2,2,0.5,330,120)
CALL drawState3D(3,2,0.5, 30,270)
CALL drawState3D(4,2,0.5,180,270)
CALL drawState3D(5,2,0.5,330,270)
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,130:"|0>"
PLOT TEXT, AT 180,130:"|1>"
PLOT TEXT, AT 330,130:"|2>"
PLOT TEXT, AT 30,280:"|3>"
PLOT TEXT, AT 180,280:"|4>"
PLOT TEXT, AT 330,280:"|5>"
END SUB
EXTERNAL SUB drawState3D(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j)),xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + 2*vv(i,j)),xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
EXTERNAL SUB drawPsix6
DECLARE EXTERNAL SUB drawPsi
CALL drawPsi(0, 30,135) !(ist,xPos,yPos)
CALL drawPsi(1,180,135)
CALL drawPsi(2,330,135)
CALL drawPsi(3, 30,285)
CALL drawPsi(4,180,285)
CALL drawPsi(5,330,285)
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,120:"|0>"
PLOT TEXT, AT 180,120:"|1>"
PLOT TEXT, AT 330,120:"|2>"
PLOT TEXT, AT 30,270:"|3>"
PLOT TEXT, AT 180,270:"|4>"
PLOT TEXT, AT 330,270:"|5>"
END SUB
EXTERNAL SUB drawPsi(ist,xPos,yPos) !drawMode=0
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j)
IF abs(psi)>0.002 THEN
IF psi>=0 THEN
LET col = psi*10
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 40+INT(col*50)
ELSE
LET col = -psi*10
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 100+INT(col*50)
END IF
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN xPos,yPos; xPos+128,yPos+128 :psicol
END SUB
DO
CALL moveParticles(tempMode,contTemp)
CALL drawParticles(tempMode,contTemp,drawMode)
LET S$=INKEY$
IF S$="0" THEN
LOCATE VALUE (1),RANGE 0 TO 4000 : temp
IF temp>1 THEN
LET tempMode = 1
LET contTemp = temp
ELSE
LET tempMode = 0
END IF
ELSEIF S$="1" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$="9" THEN
LOCATE CHOICE (menu$) :nmenu
IF nmenu=1 THEN !--- Fe Al box=6x6nm
CALL setInitialCondition(3,5,6.0,contTemp)
ELSEIF nmenu=2 THEN !--- Fe Mo
CALL setInitialCondition(3,2,6.0,contTemp)
ELSEIF nmenu=3 THEN !--- Fe Hg
CALL setInitialCondition(3,20,6.0,contTemp)
ELSEIF nmenu=4 THEN !--- W Pb
CALL setInitialCondition(0,6,6.0,contTemp)
ELSEIF nmenu=5 THEN !--- Ni Cr
CALL setInitialCondition(4,2,6.0,contTemp)
ELSEIF nmenu=6 THEN !--- Ag Cu
CALL setInitialCondition(8,7,6.0,contTemp)
ELSEIF nmenu=7 THEN !--- Al Ar
CALL setInitialCondition(5,17,6.0,contTemp)
ELSEIF nmenu=8 THEN !contine
!
END IF
END IF
LOOP UNTIL S$=CHR$(27)
END
EXTERNAL FUNCTION INKEY$ !from decimal BASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- molecular dynamics 2D - Morse potential ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Morse V(r) = D*((1-EXP(-A*(r-r0)))^2-1)
! = D*(EXP(-2*A*(r-r0))-2*EXP(-A*(r-r0)))
! (D:dissociation energy, r0:bond length, A:width parameter { A=SQR(k/(2*D)) }
! force F(r) = -dV(r)/dr
! = 2*D*A*y*(y-1), y=EXP(-A*(r-r0))
MODULE mmd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC molecKind1,molecKind2, sysTime, dt, nMolec, xMax, yMax, rCutoff, hh
SHARE NUMERIC xx(1000),yy(1000) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(1000),vy(1000) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(1000),ffy(1000) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC kind(1000),mas(1000) ! kind(i),mas(i) : molec kind, mass of i-th particle
SHARE NUMERIC reg(1000,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC molecData(0 TO 20,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE STRING molecSTR$(0 TO 20) ! molec string
SHARE NUMERIC forceTable(0 TO 20, 0 TO 20,0 TO 1001) ! force table
LET molecKind1 = 3 ! molecule kind1 - 3:Fe
LET molecKind2 = 1 ! molecule kind2 - 1:Mo
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 5.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET rCutoff = 1.0e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(kind1,kind2,boxSizeInNM,contTemp)
DECLARE EXTERNAL SUB setMolecData,ajustVelocity,setForceTable
DECLARE EXTERNAL FUNCTION setCrystalBlock
RANDOMIZE
CALL setMolecData
LET molecKind1 = kind1
LET molecKind2 = kind2
LET sysTime = 0.0
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
! set particles
LET s = 0.07*xMax
LET xtalSize = 0.4*xMax
LET ss = 0.53*xMax
LET ii = setCrystalBlock(1, kind1, s, s, xtalSize, xtalSize, PI/4)
LET ii = setCrystalBlock(ii+1, kind2, s, ss, xtalSize, xtalSize, 0)
LET ii = setCrystalBlock(ii+1, kind2, ss, s, xtalSize, xtalSize, 0)
LET nMolec = setCrystalBlock(ii+1, kind1, ss, ss, xtalSize, xtalSize, 0)
CALL ajustVelocity(contTemp)
LET rCutoff = MIN(1.0e-9, 3.0*MAX(molecData(kind1,3),molecData(kind2,3)))
CALL setForceTable
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMolecData
! Morse potential data
! 0:mass(AU) 1:D(eV) 2:A(m^-1) 3:r0(m)
DATA 183.85 , 0.9906, 1.4116e10, 3.032e-10 ! 0 W
DATA 95.94 , 0.8032, 1.5079e10, 2.976e-10 ! 1 Mo
DATA 51.996, 0.4414, 1.5721e10, 2.754e-10 ! 2 Cr
DATA 55.847, 0.4174, 1.3885e10, 2.845e-10 ! 3 Fe
DATA 58.71 , 0.4205, 1.4199e10, 2.780e-10 ! 4 Ni
DATA 26.98 , 0.2703, 1.1646e10, 3.253e-10 ! 5 Al
DATA 207.19 , 0.2348, 1.1836e10, 3.733e-10 ! 6 Pb
DATA 63.54 , 0.3429, 1.3588e10, 2.866e-10 ! 7 Cu
DATA 107.87 , 0.3323, 1.3690e10, 3.115e-10 ! 8 Ag
DATA 40.08 , 0.1623, 0.8054e10, 4.569e-10 ! 9 Ca
DATA 87.62 , 0.1513, 0.7878e10, 4.988e-10 ! 10 Sr
DATA 137.34 , 0.1416, 0.6570e10, 5.373e-10 ! 11 Ba
DATA 22.99 , 0.0633, 0.5900e10, 5.336e-10 ! 12 Na
DATA 39.102, 0.0542, 0.4977e10, 6.369e-10 ! 13 K
DATA 85.47 , 0.0464, 0.4298e10, 7.207e-10 ! 14 Rb
DATA 132.905, 0.0449, 0.4157e10, 7.557e-10 ! 15 Cs
DATA 20.183, 0.0031, 1.6500e10, 3.076e-10 ! 16 Ne
DATA 39.948, 0.0104, 1.3400e10, 3.816e-10 ! 17 Ar
DATA 83.80 , 0.0141, 1.2500e10, 4.097e-10 ! 18 Kr
DATA 131.30 , 0.0200, 1.2400e10, 4.467e-10 ! 19 Xe
DATA 200.59 , 0.0734, 1.4900e10, 3.255e-10 ! 20 Hg
DATA "W" ,"Mo","Cr","Fe","Ni","Al","Pb","Cu","Ag","Ca","Sr"
DATA "Ba","Na","K" ,"Rb","Cs","Ne","Ar","Kr","Xe","Hg"
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 20
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.602e-19 !eps(eV) --> (J)
NEXT i
MAT READ molecSTR$
END IF
END SUB
EXTERNAL FUNCTION setCrystalBlock(ii, knd, x0, y0, xLen, yLen, theta)
DECLARE EXTERNAL SUB setParticle
LET iip = ii
LET a = 0.98*molecData(knd,3) !r0 of knd
LET b = 0.866025*a
LET leng = xLen
IF (leng<yLen) THEN LET leng = yLen
LET leng = 1.5*leng
LET nx = INT(leng/b) + 1
LET ny = INT(leng/a) + 1
LET sth = SIN(theta)
LET cth = COS(theta)
FOR i=0 TO nx-1
LET x = b*i - leng/2.0
FOR j=0 TO ny-1
LET y = a*j - leng/2.0
IF MOD(i,2)=1 THEN LET y = y + 0.5*a
LET xp = x0 + xLen/2.0 + cth*x - sth*y
LET yp = y0 + yLen/2.0 + sth*x + cth*y
IF (xp>=x0 AND xp<=x0+xLen AND yp>=y0 AND yp<=y0+yLen) THEN
CALL setParticle(iip, knd, xp, yp)
LET iip = iip + 1
END IF
NEXT j
NEXT i
LET setCrystalBlock = iip - 1
end function
EXTERNAL SUB setParticle(i, knd, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET mas(i) = molecData(knd,0)
LET kind(i) = knd
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ki=0 TO 20
FOR kj=0 TO 20
LET dd = SQR(molecData(ki,1)*molecData(kj,1))
LET aa = 0.5*(molecData(ki,2)+molecData(kj,2))
LET r0 = 0.5*(molecData(ki,3)+molecData(kj,3))
FOR ir=10 TO 1001
LET r = ir*hh
LET y = EXP(-aa*(r-r0))
LET forceTable(ki,kj,ir) = cutoff(r)*2.0*dd*aa*y*(y-1)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ki,kj,ir) = forceTable(ki,kj,10)
NEXT ir
NEXT kj
NEXT ki
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity,registerNearMolec
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
FOR i=1 TO nMolec !periodic condition
IF xx(i)<0.0 THEN LET xx(i) = xx(i) + xMax
IF xx(i)>xMax THEN LET xx(i) = xx(i) - xMax
IF yy(i)<0.0 THEN LET yy(i) = yy(i) + yMax
IF yy(i)>yMax THEN LET yy(i) = yy(i) - yMax
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
IF xij>0.5*xMax THEN LET xij = xij - xMax !x-periodic
IF xij<-0.5*xMax THEN LET xij = xij + xMax !x-periodic
LET yij = yy(i)-yy(j)
IF yij>0.5*yMax THEN LET yij = yij - yMax !y-periodic
IF yij<-0.5*yMax THEN LET yij = yij + yMax !y-periodic
LET rij = SQR(xij*xij+yij*yij)
IF rij<rCutoff THEN
LET f = force(rij,kind(i),kind(j))
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
END SUB
EXTERNAL FUNCTION force(r,ki,kj) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ki,kj,ir) + a*forceTable(ki,kj,ir+1))/hh
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET xij = xx(i)-xx(j)
IF xij>0.5*xMax THEN LET xij = xij - xMax !x-periodic
IF xij<-0.5*xMax THEN LET xij = xij + xMax !x-periodic
LET yij = yy(i)-yy(j)
IF yij>0.5*yMax THEN LET yij = yij - yMax !y-periodic
IF yij<-0.5*yMax THEN LET yij = yij + yMax !y-periodic
LET r2 = xij*xij+yij*yij
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mas(i)*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:circle 1:circle+bond
call plotBond(drawMode)
ELSEIF drawMode=2 THEN
call velocitySpace
END IF
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING molecSTR$(molecKind1)&","&molecSTR$(molecKind2)&" N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"periodic molecular dynamics 2D"
PLOT TEXT, AT 50,480 :"[esc] exit [0] temp > value "
PLOT TEXT, AT 50,460 :"[1] dispMode [9] menu > select"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 8 !gray !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
IF kind(i)=molecKind1 THEN SET LINE COLOR 11 ELSE SET LINE COLOR 12
DRAW circle WITH SCALE(molecData(kind(i),3)/2.0*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
LET r0 = 0.5*(molecData(kind(i),3)+molecData(kind(j),3))
IF r<1.2*r0 THEN
IF r<0.93*r0 THEN
SET LINE COLOR 4 !red
ELSEIF r<1.03*r0 THEN
SET LINE COLOR 3 !green
ELSEIF r<1.08*r0 THEN
SET LINE COLOR 2 !blue
ELSE
SET LINE COLOR 8 !gray
END IF
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT k
NEXT i
END IF
END sub
EXTERNAL sub velocitySpace
LET boxSize = 300
LET xp = 100
LET yp = 100
SET LINE COLOR 1 !black : axis
PLOT LINES: xp,boxSize/2+yp; boxSize+xp,boxSize/2+yp !vx-axis
PLOT LINES: boxSize/2+xp,yp; boxSize/2+xp,boxSize+yp !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize+xp,boxSize/2+yp: "vx"
PLOT TEXT, AT boxSize+xp,boxSize/2-12+yp: "2000m/s"
PLOT TEXT, AT boxSize/2-12+xp,boxSize+yp: "vy 2000m/s"
PLOT TEXT, AT boxSize/2-8+xp,boxSize/2-10+yp: "0"
PLOT TEXT, AT xp,boxSize+8+yp: "velocity space (vx,vy)"
LET mag = boxSize/4000
FOR i=1 TO nMolec
IF kind(i)=molecKind1 THEN SET LINE COLOR 11 ELSE SET LINE COLOR 12
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+boxSize/2+xp,vy(i)*mag+boxSize/2+yp)
NEXT i
END sub
試験環境：
本プログラムは十進BASIC 6.6.3.3 / macOS 10.7.5, 十進BASIC Ver 7.8.0 / windows 10 でテストしました。
-----------
!
! ========= periodic steepest descent method 3D ==========
!
! 020periodicPSD3D.bas
! Copyright(C) 2017 Mitsuru Ikeuchi
! Released under the MIT license ( https://opensource.org/licenses/MIT )
!
! ver 0.0.1 2017.07.10 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB psd3d.setInitialCondition,psd3d.SDiteration,psd3d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET Ax = PI/12 !rotate angle around x-axis
LET Ay = -PI/6 !rotate angle around y-axis
LET ddAy = PI/180 !Ay=Ay+ddAy
LET vIndex = 3 !vIndex=0: V=1/r, 1: V=(1/2)r^2, 2:V=0(r<=4) or V=16(r>4) 3:V=0
LET stateMax = 6 !state 0,1,...,stateMax-1
LET drawMode = 0 !drawMode=0:density3D, 1:grid |i> in (x,y,0)
LET ist = 0 !display state |i>
CALL setInitialCondition(stateMax,vIndex)
DO
LET Ay = Ay + ddAy
CALL SDiteration(stateMax, 2) !2 - iteration in SDiteration()
CALL drawState(ist,Ax,Ay,drawMode)
LET S$=INKEY$
IF S$="0" OR S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" THEN
LET ist = VAL(S$)
ELSEIF S$="W" OR S$="w" THEN
if ddAy=0.0 then LET ddAy=-pi/180 else LET ddAy = 0.0
ELSEIF S$="E" OR S$="e" THEN
IF ddAy=0.0 THEN LET ddAy= PI/180 ELSE LET ddAy = 0.0
ELSEIF S$="D" OR S$="d" THEN
LET drawMode = MOD(drawMode+1,2)
END IF
LOOP UNTIL S$=CHR$(27)
END
EXTERNAL FUNCTION INKEY$ !from decimal BASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- periodic steepest descent method 3D ----------
!
! system Hamiltonian: H = -delta/2 + V(r) , delta r = div grad r
! eigen energy set { Ei }, eigen function set { |i> }
!
! procedure : successive approximation
! (i) trial function set { |0>,|1>,..,|i>,.. }
! (2) energy of |i> : ei = <i|H|i>/<i|i>
! (3) steepest gradient direction (H-ei)|i>
! (4) next generation : |i(next)> = |i> - dampingFactor*(H-ei)|i>
! (5) orthogonalization { |0>,|1>,..,|i>,.. } (Gram-Schmidt)
! (6) goto (2)
!
MODULE psd3d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, SDiteration, drawState
SHARE NUMERIC NNx, NNy, NNz, dx, dy, dz, iterCount
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(10) ! electron state energy
SHARE NUMERIC sdState(10,65,65,65) ! electron states 0...20 0:ground state
SHARE NUMERIC wrk(65,65,65) ! state work space in steepestDescent
SHARE NUMERIC vv(65,65,65) ! external potential
SHARE NUMERIC xApex(0 TO 7),yApex(0 TO 7),zApex(0 TO 7) ! boxApex x- y- z-coordinate
SHARE NUMERIC pxApex(0 TO 7),pyApex(0 TO 7),pzApex(0 TO 7) ! rotated boxApex x- y- z-coordinate
SHARE NUMERIC boxEdge(0 TO 11,0 TO 2)! boxEdge(i,j) i-th edge j=0,1:j-th apex, j=2:for marking
LET NNx = 16 ! x-max number of sdState(,NNx,NNy,NNz)
LET NNy = 16 ! y-max number of sdState(,NNx,NNy,NNz)
LET NNz = 16 ! z-max number of sdState(,NNx,NNy,NNz)
LET dx = 0.5 ! (au) x division
LET dy = 0.5 ! (au) y division
LET dz = 0.5 ! (au) y division
LET iterCount = 0 ! sd iteration count
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex) !public
DECLARE EXTERNAL SUB setInitialState,setPotential,setBox
RANDOMIZE
CALL setInitialState(stateMax)
CALL setPotential(vIndex)
CALL setBox
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET sdState(ist,i,j,k) = RND-0.5
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setPotential(vIndex)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET x = i*dx
LET y = j*dy
LET z = k*dz
IF vIndex=0 THEN
LET v0 = 10.0
IF SQR((x-8)*(x-8)+(z-8)*(z-8))<2 THEN LET V0 = 0.0
LET vv(i,j,k) = v0
ELSEIF vIndex=1 THEN
LET vv(i,j,k) = MIN(0.5*r*r,18)
ELSEIF vIndex=2 THEN
IF r<=4 THEN LET vv(i,j,k) = 0 ELSE LET vv(i,j,k) = 16
ELSE
LET vv(i,j,k) = 0
END IF
NEXT k
NEXT j
NEXT i
END SUB
EXTERNAL SUB setBox
IF boxEdge(11,1)<>7 THEN
DATA 0,0,0, 1,0,0, 0,1,0, 1,1,0, 0,0,1, 1,0,1, 0,1,1, 1,1,1
FOR i=0 TO 7
READ x,y,z
LET xApex(i) = x*NNx*dx
LET yApex(i) = y*NNy*dy
LET zApex(i) = z*NNz*dz
NEXT i
DATA 0,1,9, 0,2,9, 0,4,9, 1,3,9, 1,5,9, 2,3,9, 2,6,9, 3,7,9, 4,5,9, 4,6,9, 5,7,9, 6,7,9
MAT READ boxEdge !(0 TO 11,0 TO 2)
END IF
END SUB
! ---------- steepest descent iteration
EXTERNAL SUB SDiteration(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
LET damp = 0.05 !damping factor in steepest descent
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist, damp)
NEXT ist
CALL GramSchmidt(stateMax)
CALL sortState(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist, damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=0 TO NNx-1 !--- |wrk> = (H-E_ist)|ist>
LET ip1 = MOD(i+1,NNx)
LET im1 = MOD(i-1+NNx,NNx)
FOR j=0 TO NNy-1
LET jp1 = MOD(j+1,NNy)
LET jm1 = MOD(j-1+NNy,NNy)
FOR k=0 TO NNz-1
LET kp1 = MOD(k+1,NNz)
LET km1 = MOD(k-1+NNz,NNz)
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,ip1,j,k)-sdState(ist,im1,j,k)&
&-sdState(ist,i,jp1,k)-sdState(ist,i,jm1,k)-sdState(ist,i,j,kp1)-sdState(ist,i,j,km1))/h2
LET wrk(i,j,k) = kesdState+(vv(i,j,k)-ei)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
FOR i=0 TO NNx-1 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET sdState(ist,i,j,k) = sdState(ist,i,j,k)-damp*wrk(i,j,k)
NEXT k
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=0 TO NNx-1 !--- |wrk> = (H-E_ist)|ist>
LET ip1 = MOD(i+1,NNx)
LET im1 = MOD(i-1+NNx,NNx)
FOR j=0 TO NNy-1
LET jp1 = MOD(j+1,NNy)
LET jm1 = MOD(j-1+NNy,NNy)
FOR k=0 TO NNz-1
LET kp1 = MOD(k+1,NNz)
LET km1 = MOD(k-1+NNz,NNz)
LET kesdState = (6*sdState(ist,i,j,k)-sdState(ist,ip1,j,k)-sdState(ist,im1,j,k)&
&-sdState(ist,i,jp1,k)-sdState(ist,i,jm1,k)-sdState(ist,i,j,kp1)-sdState(ist,i,j,km1))/h2
LET s = s + sdState(ist,i,j,k)*(kesdState+vv(i,j,k)*sdState(ist,i,j,k))
LET sn = sn+sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET sdState(istate,i,j,k) = sdState(istate,i,j,k) - s*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET w = sdState(ist,i,j,k)
LET sdState(ist,i,j,k) = sdState(ist+1,i,j,k)
LET sdState(ist+1,i,j,k) = w
NEXT k
NEXT j
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET s = s + sdState(ist,i,j,k)*sdState(jst,i,j,k)
NEXT k
NEXT j
NEXT i
LET innerProduct = s*dx*dy*dz
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET s = s + sdState(ist,i,j,k)*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
LET a = SQR(1/(s*dx*dy*dz))
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
FOR k=0 TO NNz-1
LET sdState(ist,i,j,k) = a*sdState(ist,i,j,k)
NEXT k
NEXT j
NEXT i
END SUB
! ---------- 3D graphics aid
EXTERNAL SUB setRotateXY(angleX,angleY)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = 0.5*NNx*dx
LET cy0 = 0.5*NNy*dy
LET cz0 = 0.5*NNz*dz
END SUB
EXTERNAL SUB rotateXY !particles and box apex
FOR i=0 TO 7
LET pxApex(i) = cosAy*(xApex(i)-cx0)+sinAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cx0
LET pyApex(i) = cosAx*(yApex(i)-cy0)-sinAx*(zApex(i)-cz0) + cy0
LET pzApex(i) =-sinAy*(xApex(i)-cx0)+cosAy*(sinAx*(yApex(i)-cy0)+cosAx*(zApex(i)-cz0)) + cz0
NEXT i
END SUB
EXTERNAL SUB drawDisk3D(x,y,z,r,mag,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cx0
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0) + cy0
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cz0
DRAW disk WITH SCALE(r)*SHIFT(x1*mag+xShift,y1*mag+yShift)
END SUB
EXTERNAL SUB plotLines3D(x,y,z,mag,xShift,yShift)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cx0
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0) + cy0
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0)) + cz0
PLOT LINES: x1*mag+xShift, y1*mag+yShift;
END SUB
EXTERNAL SUB markFarEdge
! seek far apex --> iMin
LET zMin = pzApex(0)
LET iMin = 0
FOR i=1 TO 7
IF zMin>pzApex(i) THEN
LET zMin = pzApex(i)
LET iMin = i
END IF
NEXT i
!mark far edge
FOR iEdge = 0 TO 11
LET boxEdge(iEdge,2) = 0
IF (boxEdge(iEdge,0)=iMin OR boxEdge(iEdge,1)=iMin) THEN LET boxEdge(iEdge,2) = 1
NEXT iEdge
END SUB
EXTERNAL SUB plotNearEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=0 THEN !far edge mark = 0
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotFarEdge(mag,xp,yp,lineColor)
DECLARE EXTERNAL SUB plotEdge
FOR iEdge=0 TO 11
IF boxEdge(iEdge,2)=1 THEN !far edge mark = 1
CALL plotEdge(iEdge,mag,xp,yp,lineColor)
END IF
NEXT iEdge
END SUB
EXTERNAL SUB plotEdge(iEdge,mag,xp,yp,lineColor)
SET LINE COLOR lineColor
FOR i=0 TO 1
LET iApex = boxEdge(iEdge,i)
PLOT LINES: pxApex(iApex)*mag+xp, pyApex(iApex)*mag+yp;
NEXT i
PLOT LINES
END SUB
! ---------- draw state
EXTERNAL SUB drawState(ist,xRotateAngle,yRotateAngle,drawMode)
DECLARE EXTERNAL SUB drawDensity3D,setRotateXY,drawDensity3D,drawStateGrid
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 THEN
CALL drawDensity3D(ist,xRotateAngle,yRotateAngle,200/(NNx*dx),140,150) !!(ist,Ax,Ay,sc,xp,yp)
ELSEIF drawMode=1 THEN
CALL drawStateGrid(ist,200/(NNx*dx),0.1,140,200) !(ist,sc,zMag,xp,yp)
END IF
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50, 70 ,USING "iterarion count =##### ":iterCount
PLOT TEXT, AT 50, 55 ,USING "E0 =###.######### E3 =###.#########(au)":sdEnergy(0),sdEnergy(3)
PLOT TEXT, AT 50, 40 ,USING "E1 =###.######### E4 =###.#########(au)":sdEnergy(1),sdEnergy(4)
PLOT TEXT, AT 50, 25 ,USING "E2 =###.######### E5 =###.#########(au)":sdEnergy(2),sdEnergy(5)
PLOT TEXT, AT 50, 10 :"periodic steepest descent method 3D"
PLOT TEXT, AT 50,470 :"[0],[1],...,[5] view state [esc] exit "
PLOT TEXT, AT 50,455 :"[D] change drawMode"
PLOT TEXT, AT 50,440 :"[W] rotateLeft/stop [E] rotateRight/stop"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB drawDensity3D(ist,xRotateAngle,yRotateAngle,sc,xp,yp) !----- drawMode=0
DECLARE EXTERNAL SUB setRotateXY,rotateXY,markFarEdge,plotFarEdge,drawDisk3D,plotNearEdge
CALL setRotateXY(xRotateAngle,yRotateAngle)
CALL rotateXY !rotateXY BOX
CALL markFarEdge ! boxEdge(iEdge,2)=1:far side edge or 0:near side edge
CALL plotFarEdge(sc,xp,yp,8) !8:gray
FOR ii=0 TO NNx-1
LET i=ii
IF (pzApex(1)-pzApex(0)<0) THEN LET i=NNx-ii-1
FOR jj=0 TO NNy-1
LET j=jj
IF (pzApex(2)-pzApex(0)<0) THEN LET j=NNy-jj-1
FOR kk=0 TO NNz-1
LET k=kk
IF (pzApex(4)-pzApex(0)<0) THEN LET k=NNz-kk-1
LET psi = sdState(ist,i,j,k)
LET psi2 = psi*psi
IF psi2>0.001 THEN
IF psi>0 THEN SET AREA COLOR 4 ELSE SET AREA COLOR 2
CALL drawDisk3D(i*dx,j*dy,k*dz,ABS(psi)*10,sc,xp,yp)
END IF
NEXT kk
NEXT jj
NEXT ii
!SET AREA COLOR 1
!CALL drawDisk3D(0,0,0,5,sc,xp,yp)
CALL plotNearEdge(sc,xp,yp,1) !1:black
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,100:"|"&STR$(ist)&">"
PLOT TEXT, AT 50, 85 ,USING "Ax =###.#(deg) Ay =###.#(deg)":MOD(xRotateAngle*180/PI,360),MOD(yRotateAngle*180/PI,360)
END SUB
EXTERNAL SUB drawStateGrid(ist,sc,zMag,xp,yp) !--- drawMode=1
DECLARE EXTERNAL SUB setRotateXY,drawGridXY
CALL setRotateXY(-PI/3,-PI/6)
CALL drawGridXY(ist,sc,zMag,xp,yp)
SET TEXT COLOR 1
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,100:"|"&STR$(ist)&"> in (x,y,0)"
END SUB
EXTERNAL SUB drawGridXY(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*dx,j*dx,zMag*(psi + 2*vv(i,j,NNz/2)),sc,xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j,NNz/2)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*dx,j*dx,zMag*(psi + 2*vv(i,j,NNz/2)),sc,xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
END MODULE
INPUT PROMPT "choice 0:fast 1:faster ":a$
IF VAL(a$)=1 THEN
LET fasterSW=1
PRINT "faster mode"
ELSE
LET fasterSW=0
PRINT "fast mode"
END IF
LET t0 = TIME
FOR it=1 TO 20
CALL moveParticles(tempMode,contTemp,fasterSW)
CALL drawParticles(tempMode,contTemp,drawMode)
NEXT it
PRINT TIME-t0
stop
END
! ---------- molecular dynamics 2D - Morse potential ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (6) goto (1)
! potential: Morse V(r) = D*((1-EXP(-A*(r-r0)))^2-1)
! = D*(EXP(-2*A*(r-r0))-2*EXP(-A*(r-r0)))
! (D:dissociation energy, r0:bond length, A:width parameter { A=SQR(k/(2*D)) }
! force F(r) = -dV(r)/dr
! = 2*D*A*y*(y-1), y=EXP(-A*(r-r0))
MODULE mmd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC molecKind,sysTime,dt,nMolec,xMax,yMax, Nsx,Nsy, mass,Dmrs,Amrs,r0mrs, rCutoff, hh
SHARE NUMERIC xx(8000),yy(8000) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(8000),vy(8000) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(8000),ffy(8000) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC reg(8000,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC section(0 TO 101,0 TO 101,0 TO 20) !use pre-registration
SHARE NUMERIC molecData(0 TO 18,0 TO 3) ! molecule 0:mass, 1:epsilon, 2:sigma, 3:dt
SHARE NUMERIC forceTable(0 TO 1200) ! force table
SHARE STRING molecSTR$(0 TO 18) ! molec string
LET molecKind = 3 ! 3:Fe
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 5.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET Nsx = 80
LET Nsy = 80
LET mass = 55.847*1.661e-27! mass of Fe (kg)
LET Dmrs = 0.4174*1.602e-19! D of Morse potential (J) : energy of dissociation
LET Amrs = 1.3885e10 ! A of Morse potential (1/m) : width parameter
LET r0mrs = 2.845e-10 ! r0 of Morse potential (m) : bond length
LET rCutoff = 1.0e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET molecData(0,0)=0 ! if molecData(0,0)=0 then set molecData(,)
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
DECLARE EXTERNAL SUB setMolecData,setMolecules,ajustVelocity,setForceTable
DECLARE EXTERNAL FUNCTION setCrystalBlock
RANDOMIZE
CALL setMolecData
LET molecKind = molKind
LET mass = molecData(molecKind,0)
LET Dmrs = molecData(molecKind,1)
LET Amrs = molecData(molecKind,2)
LET r0mrs = molecData(molecKind,3)
LET sysTime = 0.0
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
! set particles
LET s = 0.5*(boxSizeInNM-xtalSizeInNM)*1.0e-9
LET nMolec = setCrystalBlock(1, s, s, xtalSizeInNM*1.0e-9, xtalSizeInNM*1.0e-9, PI/4)
CALL ajustVelocity(contTemp)
LET rCutoff = MIN(1.0e-9, 3.0*r0mrs)
CALL setForceTable
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setMolecData
! Morse potential data
! 0:mass(AU) 1:D(eV) 2:A(m^-1) 3:r0(m)
DATA 183.85 , 0.9906, 1.4116e10, 3.032e-10 ! 0 W
DATA 95.94 , 0.8032, 1.5079e10, 2.976e-10 ! 1 Mo
DATA 51.996, 0.4414, 1.5721e10, 2.754e-10 ! 2 Cr
DATA 55.847, 0.4174, 1.3885e10, 2.845e-10 ! 3 Fe
DATA 58.71 , 0.4205, 1.4199e10, 2.780e-10 ! 4 Ni
DATA 26.98 , 0.2703, 1.1646e10, 3.253e-10 ! 5 Al
DATA 207.19 , 0.2348, 1.1836e10, 3.733e-10 ! 6 Pb
DATA 63.54 , 0.3429, 1.3588e10, 2.866e-10 ! 7 Cu
DATA 107.87 , 0.3323, 1.3690e10, 3.115e-10 ! 8 Ag
DATA 39.948, 0.0104, 1.3400e10, 3.816e-10 ! 9 Ar
DATA 200.59 , 0.0734, 1.4900e10, 3.255e-10 ! 10 Hg
DATA 40.08 , 0.1623, 0.8054e10, 4.569e-10 ! 11 Ca
DATA 87.62 , 0.1513, 0.7878e10, 4.988e-10 ! 12 Sr
DATA 137.34 , 0.1416, 0.6570e10, 5.373e-10 ! 13 Ba
DATA 22.99 , 0.0633, 0.5900e10, 5.336e-10 ! 14 Na
DATA 39.102, 0.0542, 0.4977e10, 6.369e-10 ! 15 K
DATA 20.183, 0.0031, 1.6500e10, 3.076e-10 ! 16 Ne
DATA 83.80 , 0.0141, 1.2500e10, 4.097e-10 ! 17 Kr
DATA 131.30 , 0.0200, 1.2400e10, 4.467e-10 ! 18 Xe
DATA "W" ,"Mo","Cr","Fe","Ni","Al","Pb","Cu","Ag","Ar","Hg"
DATA "Ca","Sr","Ba","Na","K" ,"Ne","Kr","Xe"
IF molecData(0,0)=0 THEN
MAT READ molecData
FOR i=0 TO 18
LET molecData(i,0) = molecData(i,0)*1.661e-27 !mass(AU)--> (kg)
LET molecData(i,1) = molecData(i,1)*1.602e-19 !eps(eV) --> (J)
NEXT i
MAT READ molecSTR$
END IF
END SUB
EXTERNAL function setCrystalBlock(ii, x0, y0, xLen, yLen, theta)
DECLARE EXTERNAL SUB setParticle
LET iip = ii
LET a = 0.98*r0mrs
LET b = 0.866025*a
LET leng = xLen
IF (leng<yLen) THEN LET leng = yLen
LET leng = 1.5*leng
LET nx = INT(leng/b) + 1
LET ny = INT(leng/a) + 1
LET sth = SIN(theta)
LET cth = COS(theta)
FOR i=0 TO nx-1
LET x = b*i - leng/2.0
FOR j=0 TO ny-1
LET y = a*j - leng/2.0
IF MOD(i,2)=1 THEN LET y = y + 0.5*a
LET xp = x0 + xLen/2.0 + cth*x - sth*y
LET yp = y0 + yLen/2.0 + sth*x + cth*y
IF (xp>=x0 AND xp<=x0+xLen AND yp>=y0 AND yp<=y0+yLen) THEN
CALL setParticle(iip, xp, yp)
LET iip = iip + 1
END IF
NEXT j
NEXT i
LET setCrystalBlock = iip - 1
end function
EXTERNAL SUB setParticle(i, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
FOR ir=10 TO 1200
LET r = ir*hh
LET y = EXP(-Amrs*(r-r0mrs))
LET forceTable(ir) = cutoff(r)*2.0*Dmrs*Amrs*y*(y-1)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ir) = forceTable(10)
NEXT ir
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp,fasterSW) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity,registerNearMolec,registration
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
IF fasterSW=1 THEN
CALL registration !faster registration
ELSE
CALL registerNearMolec !fast registration
END IF
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
LET a = 0.5*dt/mass
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
!LET a = 0.5*dt/mass(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
IF rij<rCutoff THEN
LET f = force(rij)
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
!EXTERNAL FUNCTION force(r) ! force(r) = -dV(r)/dr
! LET y = EXP(-Amrs*(r-r0mrs))
! LET force = 2*Dmrs*Amrs*y*(y-1)
!END FUNCTION
EXTERNAL FUNCTION force(r) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ir) + a*forceTable(ir+1))/hh
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (3.418e-10/r)^6
LET boundaryForce = (24.0*(0.5*1.711e-21)*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec !fast registeration
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
EXTERNAL SUB registration !faster registration
DECLARE EXTERNAL SUB preRegistration
CALL preRegistration
LET rreg = rCutoff+20*2000*dt
LET rreg2 = rreg*rreg
FOR ipp=1 TO nMolec-1
LET kp = 1
LET i0 = INT(Nsx*(xx(ipp)-rreg)/xMax)
IF (i0<0) THEN LET i0 = 0
LET i1 = INT(Nsx*(xx(ipp)+rreg)/xMax )
IF (i1>=Nsx) THEN LET i1 = Nsx-1
LET j0 = INT(Nsy*(yy(ipp)-rreg)/yMax )
IF (j0<0) THEN LET j0 = 0
LET j1 = INT(Nsy*(yy(ipp)+rreg)/yMax )
IF (j1>=Nsy) THEN LET j1 = Nsy-1
FOR i=i0 TO i1
FOR j=j0 TO j1
FOR iq=1 TO section(i,j,0)
LET jp = section(i,j,iq)
IF (jp>ipp) THEN
LET r2=(xx(ipp)-xx(jp))*(xx(ipp)-xx(jp))+(yy(ipp)-yy(jp))*(yy(ipp)-yy(jp))
IF (r2<rreg2) THEN
LET reg(ipp,kp) = jp
LET kp = kp + 1
END IF
END IF
NEXT iq
NEXT j
NEXT i
LET reg(ipp,0) = kp
NEXT ipp
END SUB
EXTERNAL SUB preRegistration
FOR i=0 TO Nsx-1
FOR j=0 TO Nsy-1
LET section(i,j,0) = 0
NEXT j
NEXT i
FOR ipp=1 TO nMolec
LET i = INT(Nsx*xx(ipp)/xMax)
IF i>=Nsx THEN LET i = Nsx-1
LET j = INT(Nsy*yy(ipp)/yMax)
IF j>=Nsy THEN LET j = Nsy-1
LET iq = section(i,j,0) + 1
LET section(i,j,0) = iq
LET section(i,j,iq) = ipp
NEXT ipp
END SUB
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mass*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:circle 1:circle+bond
call plotBond(drawMode)
ELSEIF drawMode=2 THEN
call velocitySpace
END IF
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 ,USING molecSTR$(molecKind)&" N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional molecular dynamics"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
SET LINE COLOR 8 ! gray
DRAW circle WITH SCALE(r0mrs/2.0*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
IF r<1.2*r0mrs THEN
IF r<0.93*r0mrs THEN
SET LINE COLOR 4 !red 13 !'oleave
ELSEIF r<1.03*r0mrs THEN
SET LINE COLOR 3 !green
ELSEIF r<1.08*r0mrs THEN
SET LINE COLOR 2 !blue
ELSE
SET LINE COLOR 8 !gray
END IF
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT k
NEXT i
END IF
END sub
EXTERNAL sub velocitySpace
LET boxSize = 300
LET xp = 100
LET yp = 100
SET LINE COLOR 1 !black : axis
PLOT LINES: xp,boxSize/2+yp; boxSize+xp,boxSize/2+yp !vx-axis
PLOT LINES: boxSize/2+xp,yp; boxSize/2+xp,boxSize+yp !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize+xp,boxSize/2+yp: "vx"
PLOT TEXT, AT boxSize+xp,boxSize/2-12+yp: "2000m/s"
PLOT TEXT, AT boxSize/2-12+xp,boxSize+yp: "vy 2000m/s"
PLOT TEXT, AT boxSize/2-8+xp,boxSize/2-10+yp: "0"
PLOT TEXT, AT xp,boxSize+8+yp: "velocity space (vx,vy)"
LET mag = boxSize/4000
FOR i=1 TO nMolec
SET LINE COLOR 2 ! blue
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+boxSize/2+xp,vy(i)*mag+boxSize/2+yp)
NEXT i
END sub
LET MODE=0
SELECT CASE MODE
CASE 0
LET T=TIME
LET X=FACT(12)
CALL POW(X,X,RESULT$) !'X^N
PRINT RESULT$
PRINT TIME-T
!2.16136854137681821022184125634148248819277439276856614943668779759374015927471583106592012734245952019394970811589706056678555509602666892262853286963399272624718192094412355351855126976834619525882212314189739932773415168630756169900513658510182323332373473499827943602913845866193736546382782945259951879659321847521838639531976483388098572301935336416235494360371625249430543171712585820018204557600757659419294850500417373875788626819825199950337907403249688891357217862083761274130969418499307206106124775263607305819648633066733354877683318544283412749937741320358307160031045916238726656414998645969668486063799136387061569535403249857358744409290597217065826574844652429571085685396226665454889018425548129950363668417167709598931948788021370222023373478957578453869374042172871420547662647531104912996278899652524570542599912981658810875761529791724632424261687434245565068590484867082473812801455874989871262294862658856398056257782919304106334636474909267649153798992665460574519126362677282548109387566698144e+4157895294
! 6.00000000122236E-2
CASE 1
LET T=TIME
LET N=12
CALL POWFACT(N,RESULT$) !' (N!)^(N!)
PRINT RESULT$
PRINT TIME-T
!2.16136854137681821022184125634148248819277439276856614943668779759374015927471583106592012734245952019394970811589706056678555509602666892262853286963399272624718192094412355351855126976834619525882212314189739932773415168630756169900513658510182323332373473499827943602913845866193736546382782945259951879659321847521838639531976483388098572301935336416235494360371625249430543171712585820018204557600757659419294850500417373875788626819825199950337907403249688891357217862083761274130969418499307206106124775263607305819648633066733354877683318544283412749937741320358307160031045916238726656414998645969668486063799136387061569535403249857358744409290597217065826574844652429571085685396226665454889018425548129950363668417167709598931948788021370222023373478957578453869374042172871420547662647531104912996278899652524570542599912981658810875761529791724632424261687434245565068590484867082473812801455874989871262294862658856398056257782919304106334636474909267649153798992665460574519126362677282548109387566698144e+4157895294
! 5.99999999976717E-2
CASE 2
LET T=TIME
LET N=100000000
CALL LFACT(N,RESULT$) !' 2 * 3 * 4 * 5 * 6 * 7 * 8 * 9 *...* (N-1) * N
PRINT RESULT$
PRINT TIME-T
!1.617203794921462386338773185612804043292374530648735079789813462666737154407504386580500876929190785730659306997709526379072095316295179654167179073513009006634129337747061591098685297097001582503472866301385800430032150945662267422861318875599783688513582747708092357961161833291289737062618637215019469899671053443152756646656487690303084660412647294491564580376647772129380120207037940015370921432087635413424927860657596349753458123900398747077870811819146068196799068285805276780342699291909785817326004701598706171485200668534925511351721008280251885258366413790982774377048289170918554487709474512123782332682445769981037301850337091283801728542366418127850072350755894754427590475945724598891919272598883437250343540668568318110852233598880090166164148355169172329626842127353660159845036832550429220759703016224818725548782786942271616990913661405300333388635357873739104632007105374412990250693891528936041921842151622873513865541985938245791021807671861353403161524245569590956406240525270162218772164532514879e+756570556
! 682.120000000003
CASE 3
LET T=TIME
LET N=10
CALL DOUBLEFACT(N,RESULT$) !' (N!)!
PRINT RESULT$
PRINT TIME-T
!9.05199383547993459066223334541125889552198008664676868116314684779771059925518196453479041306538539527348189982329395778742235835651919605262124430846948778576764869559997043450588358061928072056124053527199058676605381825380218545252893543490674379874682902832717881991350611759327438286087082893716928362722869514941184566224960239661223087820620654988693997209045226577413230551325238368145865183939219774507733773526942850610284588755921757033509597723710534792930741070551439957695535284309143461400603472683366857009617354558034731296338086943875630076158484363480326013561877788402404321547742395651713816120381647441147623336006797943428300341263884257264797238025712931763921792106198924511782304221981368602255187251376620790571651695312481368830266300012667706495970524334606110206318956844192728556930489510830894015380706494724588299721349272612934424245289039282358777312680822791908369313735461594023948162097772384089698577582027209192522851246823823690027225358916556410761710770943207249755384549728357e+22228103
! 24.3600000000006
CASE 4
LET T=TIME
LET N=10000000
CALL SUPERFACT(N,RESULT$) !' 2! * 3! * 4! * 5! * 6! * 7! *...* (N-1)! * N!
PRINT RESULT$
PRINT TIME-T
!7.57878063697632117934715725034689887850671089443406030271039160509233584481021403298076663336844755155915921583136881963888696144823115311974475153652320052328567687659313122147525926979022065775096814149543780943831056005639617612529134106891342492205025312880072030110524448270901118158556779555922457929864716128158926304472044534907981834912866729470185803624587740859802958368016614391696499517054601914699582368295366201916833259354724597499035431744478719547535112048420085182135883183139640075048794059050861979118486547704710303906662116743881780796260260607839867444471378390091965608185269472213075704781769727546420860395320469358545090857923155193441929471103031866923296551225088390710078737054395326253048465352243419256199723124194271758472079381545351720056285172965339286261523760459249713701343864777816002666323040324461827576855665076282487404193204553774230151726249949958799269190261940238395540732979558437696555627226806719086098708609655790391738629544475963536580065298185018462037113821528992e+317427983505213
! 519.520000000004
CASE 5
LET T=TIME
LET N=1000000
CALL HYPERFACT(N,RESULT$) !' 2^2 * 3^3 * 4^4 * 5^5 * 6^6 * 7^7 *...* N^N
PRINT RESULT$
PRINT TIME-T
!6.23843686069241708059018283397497948396261032852709731523416295394277029282373398540713998575786733916012178463248223335823564645677499951494357410270839598310702765729112864006872878210039192370858067631070477998029933192482095612942476222728193754789852046900542637350103218384857392408531746283262373870131749000590618579432431865685268475514639336933206256949748969056305754856297026364320874076956431488052821375046045014638177390507897654960469730334797389190814704272105505552145212856118896574432939226143059057550973687604971378550419066289193097660009196503168010347848334618250277928124959562240318573539372896774337790426664723720446835857225634766789091996454216139135180235792568662383244534617370354298146218164699181831236845991726175424266619170479398316619116762592250453383101685685868627057862815641617259768873342240171953069022117764243910963990193443081142526456850279800179901219903311799202766853622229530523474152006391596501481823711359357236984255316292254520259892322621873560620869753255813e+2891429379524
! 1174.98
CASE 6
LET T=TIME
LET N=100
CALL ULTRAFACT(N,RESULT$) !' 2!^2! * 3!^3! * 4!^4! * 5!^5! *...* (N!)^(N!) (※勝手に定義しました)
PRINT RESULT$
PRINT TIME-T
!3.307080960022281488149685181352176531550030000680108534032717033505076494123338098391176644134271120923715544294326669107069219167043537761730096895592066843656679310779891205726619124126162841982779761492884571376859784533052299617920561168804808615757107870620134900273753181513620811433142712532260956074341430989241833002971570815290974543714913248254203286851480130951709685133299150786700397824107119153942159169775818240783061500294959931370412314159465834265700234915886098417613309965099149322128100572876169863206201780236823398411259753726291735981632356338054952252766969178844309737447458012208298750966505513188884915009461058844365777426551026604473623309791600908689872794148411741116573428111446864855182302393146522821144797551410563113777231534035768396111470722190923370955356992550575488022965531058889991735748065665507261010356836086850738831636682033967132801946334926843099424816607830075479676752197329292022559261874282671751989524980904001955577795260859806643024209758925103865456149835089471e+14889769765873800652572367200821121336307811992644550853047524406583971799601810165018835448400401070603264427270304269629350367510485185954426320887983405520084
! 1.95000000000437
CASE 7
CALL LMAX(RESULT$)
PRINT RESULT$
END SELECT
END
EXTERNAL SUB POW(X,N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL POW1000(ABS(X),ABS(N),B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB POW1000(X,N,Y$)
ASSIGN ".\DLL\ipow1000_128.dll","ipow1000" !'指数部 128bit 仮数部 3392bit(1000桁)
!' ASSIGN ".\DLL\ipow1000_256.dll","ipow1000" !'指数部 256bit 仮数部 3392bit(1000桁)
END SUB
END SUB
EXTERNAL SUB LFACT(N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL FACT1000(ABS(N),B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB FACT1000(N,Y$)
ASSIGN ".\DLL\ipow1000_256.dll","fact1000"
END SUB
END SUB
EXTERNAL SUB SUPERFACT(N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL SUPERFACT1000(ABS(N),B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB SUPERFACT1000(N,Y$)
ASSIGN ".\DLL\ipow1000_512.dll","superfact1000"
END SUB
END SUB
EXTERNAL SUB HYPERFACT(N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL HYPERFACT1000(ABS(N),B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB HYPERFACT1000(N,Y$)
ASSIGN ".\DLL\ipow1000_512.dll","hyperfact1000"
END SUB
END SUB
EXTERNAL SUB ULTRAFACT(N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL ULTRAFACT1000(ABS(N),B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB ULTRAFACT1000(N,Y$)
ASSIGN ".\DLL\ipow1000_1024.dll","ultrafact1000"
END SUB
END SUB
EXTERNAL SUB DOUBLEFACT(N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL DOUBLEFACT1000(N,B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB DOUBLEFACT1000(N,Y$)
ASSIGN ".\DLL\ipow1000_128.dll","doublefact1000"
END SUB
END SUB
EXTERNAL SUB POWFACT(N,RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL POWFACT1000(ABS(N),B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB POWFACT1000(N,Y$)
ASSIGN ".\DLL\ipow1000_128.dll","powfact1000"
END SUB
END SUB
EXTERNAL SUB LMAX(RESULT$)
LET B$=REPEAT$(CHR$(0),3000)
CALL MAX1000(B$)
FOR I=LEN(B$) TO 1 STEP -1
IF B$(I:I)<="9" AND B$(I:I)>="0" THEN
EXIT FOR
END IF
NEXT I
LET RESULT$=B$(1:I)
SUB MAX1000(Y$)
ASSIGN ".\DLL\ipow1000_3072.dll","max1000"
END SUB
END SUB
------------------------------------------------------------------------------------------
ipow1000.cpp
#include <ttmath/ttmath.h>
#include <string>
#include <boost/lexical_cast.hpp>
using namespace std;
using boost::lexical_cast;
!
! ========= RSDFT - local density approximation 1D ==========
!
! 022sampleLDA1D.bas
! Copyright(C) 2017 Mitsuru Ikeuchi
! Released under the MIT license ( https://opensource.org/licenses/MIT )
!
! ver 0.0.1 2017.07.28 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB lda1d.setInitialCondition,lda1d.setNumberOfElectron,lda1d.iterateLDA,lda1d.drawState
DECLARE EXTERNAL FUNCTION INKEY$
LET stateMax = 10 !state 0,1,...,stateMax-1
LET vIndex = 0 !0:harmonic potential, 1:quantum well
LET nElectron = 4
LET iterMax = 10 ! 10 = iteration in iterateLDA
LET dispMode = 1 !0:Vext+rho, 1:Vext+rho+orbit, 2:rho+Vext+Veff+Vh+Vx+Vc
CALL setInitialCondition(stateMax,vIndex,nElectron)
DO
CALL iterateLDA(stateMax, iterMax)
CALL drawState(dispMode)
LET S$=INKEY$
IF S$="D" OR S$="d" THEN
LET dispMode = mod(dispMode+1,3)
ELSEIF S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" OR S$="6" THEN
LET nElectron = VAL(s$)
CALL setNumberOfElectron(nElectron)
ELSEIF S$="7" THEN
LET vIndex = 0
CALL setInitialCondition(stateMax,vIndex,nElectron)
ELSEIF S$="8" THEN
LET vIndex = 1
CALL setInitialCondition(stateMax,vIndex,nElectron)
END IF
LOOP UNTIL S$=chr$(27)
END
EXTERNAL FUNCTION INKEY$ !from decimal BASIC library
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- RSDFT - local density approximation 1D ----------
!
! - real space density functional theory - local density approximation
! - solve Kohn-Sham equation - successive approximation
! - Vxc : LDA(local density approximation)
! J. P. Perdew and A. Zunger; Phys. Rev., B23, 5048 (1981)
!
! procedure
! (1) given: trial |i>, occupation(i)
!
! (2) set electron density rho
! rho <-- |i>, occupation[(i), mixing rho(iter-1)
!
! (3) set effective potential
! Veff = Vext + Vh + Vx + Vc
! Vh <-- rho (Poisson eq. ,SOR iteration)
! Vx,Vc <-- rho (LDA:Perdew-Zunger)
!
! (4) solve Kohn-Sham equation (successive approximation)
! |i> steepest descent method: |i(next)> = |i> - dump{H-E}|i>
! E(i) <-- <i|H|i>
! {|0>,..,|i>,..,|N>} orthogonallization : Gram-Schmidt
!
! (5) sort state
! sort orbit by E(i)
!
! (6) set occupation
! occupation(i) <-- E(i)
!
! (7) goto (2)
!
MODULE lda1d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, setNumberOfElectron, iterateLDA, drawState
SHARE NUMERIC NNx, dx, lylz, iterCount
SHARE NUMERIC numberOfElectron, numberOfElectronBounds, numberOfOrbit, errorDecisionOrbit
SHARE NUMERIC energyMem, iterationError, convergenceErrorMax, dampingFactor
SHARE NUMERIC mixing,broadening
SHARE NUMERIC sdEnergy(20) ! electron state energy
SHARE NUMERIC sdState(20,400) ! electron states 0...20 0:ground state
SHARE NUMERIC occupation(20) ! occupation of orbit
SHARE NUMERIC wrk(400) ! state work space in steepestDescent
SHARE NUMERIC vv(400) ! effective potential
SHARE NUMERIC vvext(400) ! external potential
SHARE NUMERIC vvh(400) ! Hartree potential
SHARE NUMERIC vvx(400) ! exchange potential
SHARE NUMERIC vvc(400) ! correlation potential
SHARE NUMERIC rho(400) ! charge density
LET NNx = 64 ! max number of sdState(,NNx,NNy)
LET dx = 0.25 ! (au) x-division
LET lylz = 16.0*16.0 ! (au) v=dx*ly*lz
LET iterCount = 0 ! sd iteration count
LET numberOfElectron = 4 !
LET numberOfElectronBounds = 6! selection bounds OF numberOfElectron
LET numberOfOrbit = 10 !
LET energyMem = 0.0
LET iterationError = 1.0
LET convergenceErrorMax = 1.0e-5
LET dampingFactor = 0.03 ! steepest descent method
LET mixing = 0.5 ! charge mixing in setRho()
LET broadening = 0.001 ! (au) level broadening IN setOccupation
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex,nElectron) !public
DECLARE EXTERNAL SUB setInitialState,setExternalPotential
LET iterCount = 0
LET numberOfElectron = nElectron
CALL setInitialState(stateMax)
CALL setExternalPotential(vIndex)
! set window
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setNumberOfElectron(nElectron) !public
LET iterCount = 0
LET numberOfElectron = nElectron
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
LET sdState(ist,i) = RND-0.5
NEXT i
LET sdState(ist,0) = 0
LET sdState(ist,NNx-1) = 0
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setExternalPotential(vIndex)
LET x0 = 0.5*NNx*dx
IF vIndex=0 THEN !--- hermonic
FOR i=0 TO NNx-1
LET x = i*dx
LET vvext(i) = MIN(0.5*(x-x0)^2,24.5)
NEXT i
ELSEIF vIndex=1 THEN !--- well
FOR i=0 TO NNx-1
LET x = i*dx
IF ABS(x-x0)<4 THEN LET vvext(i) = 0 ELSE LET vvext(i) = 18
NEXT i
END IF
END SUB
EXTERNAL SUB setInitialOccupation(nOrbit, nElectron)
LET occ = 1.0*nElectron/nOrbit
FOR iState=0 TO nOrbit
LET occupation(iState) = occ
NEXT iState
END SUB
! ---------- iterate LDA
EXTERNAL SUB iterateLDA(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB setElectronDensity,setEffectivePotential,solveKohnSham,sortState,setOccupation
LET errorDecisionOrbit = (numberOfElectron-1)/2
CALL setElectronDensity
CALL setEffectivePotential
CALL solveKohnSham(numberOfOrbit,iterMax)
CALL sortState(numberOfOrbit)
CALL setOccupation(numberOfOrbit,numberOfElectron)
LET iterationError = sdEnergy(errorDecisionOrbit) - energyMem
LET energyMem = sdEnergy(errorDecisionOrbit)
END SUB
!--- (2) set electron density rho <-- sdState(), occupation()
EXTERNAL SUB setElectronDensity
FOR i=0 TO NNx-1
LET rho(i) = rho(i)*(1.0-mixing)
FOR ie=0 TO numberOfOrbit-1
IF occupation(ie)>0.0 THEN
LET rho(i) = rho(i) + mixing*occupation(ie)*(sdState(ie,i)*sdState(ie,i))/lylz
END IF
NEXT ie
NEXT i
END SUB
!--- (3) set effective potential <-- electron density
EXTERNAL SUB setEffectivePotential
DECLARE EXTERNAL SUB poisson,setVxc
CALL poisson(20) !setVh
CALL setVxc
FOR i=0 TO NNx-1
LET vv(i) = vvext(i)+vvh(i)+vvx(i)+vvc(i)
NEXT i
END SUB
EXTERNAL SUB poisson(iterMax)
LET h2 = 4.0*PI*dx*dx
LET omegav2 = 0.5*1.8
FOR iter=0 TO iterMax-1
FOR i=1 TO NNx-2
LET vvh(i) = vvh(i)+omegav2*(vvh(i+1)+vvh(i-1)-2.0*vvh(i) +h2*rho(i))
NEXT i
NEXT iter
END SUB
EXTERNAL SUB setVxc !set exchage and correlation potential (Perdew and Zunger)
LET c1 = -0.984745022
FOR i=0 TO NNx-1
LET rh = rho(i)
LET rh3 = rh^0.33333333
LET vvx(i) = c1*rh3
LET rs = 0.6204/(rh3+1.0e-20)
IF rs>=1.0 THEN
LET sqrtrs = SQR(rs)
LET ec = -0.1423/(1.0+1.0529*sqrtrs+0.3334*rs)
LET vvc(i) = ec*(1.0+1.22838*sqrtrs+0.4445*rs)/(1.0+1.0529*sqrtrs+0.3334*rs)
ELSE
LET vvc(i) = -0.05837-0.0084*rs +(0.0311+0.00133*rs)*LOG(rs)
END IF
NEXT i
END SUB
EXTERNAL FUNCTION eeCorrelation(rh)
LET r = 0.6204/(rh^0.33333333+1.0e-20)
IF r>=1.0 THEN
LET ec = -0.1423/(1.0+1.0529*SQR(r)+0.3334*r)
ELSE
LET ec = -0.0480-0.0116*r+(0.0311+0.0020*r)*LOG(r)
END IF
LET eeCorrelation = ec
END FUNCTION
!--- (4) solve Kohn-Sham equation
EXTERNAL SUB solveKohnSham(stateMax, iterMax)
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist,dampingFactor)
NEXT ist
CALL GramSchmidt(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist,damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
LET wrk(i) = (2*sdState(ist,i)-sdState(ist,i+1)-sdState(ist,i-1))/h2+(vv(i)-ei)*sdState(ist,i)
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
LET sdState(ist,i) = sdState(ist,i)-damp*wrk(i)
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
LET s = s+sdState(ist,i)*((2*sdState(ist,i)-sdState(ist,i+1)-sdState(ist,i-1))/h2+vv(i)*sdState(ist,i))
LET sn = sn + sdState(ist,i)*sdState(ist,i)
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
LET sdState(istate,i) = sdState(istate,i) - s*sdState(ist,i)
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
!--- (5) sort state
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
LET w = sdState(ist,i)
LET sdState(ist,i) = sdState(ist+1,i)
LET sdState(ist+1,i) = w
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
!--- (6) set occupation
EXTERNAL SUB setOccupation(stateMax, nElectron)
DECLARE EXTERNAL FUNCTION trialOcc,FermiDirac
LET eUpper = sdEnergy(stateMax-1)+1.0
LET eLower = sdEnergy(0)-1.0
FOR i=0 TO stateMax-1
IF sdEnergy(i)>eUpper THEN LET eUpper = sdEnergy(i)
IF sdEnergy(i)<eLower THEN LET eLower = sdEnergy(i)
NEXT i
DO WHILE (eUpper-eLower>1.0e-12)
LET eFermi = (eUpper+eLower)/2.0
LET ntrial = trialOcc(stateMax, eFermi)
IF ntrial<nElectron THEN
LET eLower = eFermi
ELSE
LET eUpper = eFermi
END IF
LOOP
LET eFermi = (eUpper+eLower)/2.0
FOR i=0 TO stateMax-1
LET occupation(i) = 2.0*FermiDirac(sdEnergy(i), eFermi)
IF (occupation(i)<0.0001) THEN LET occupation(i) = 0.0
IF (2.0-occupation(i)<0.0001) THEN LET occupation(i) = 2.0
NEXT i
END SUB
EXTERNAL FUNCTION trialOcc(stateMax, eFermi)
DECLARE EXTERNAL FUNCTION FermiDirac
LET s = 0.0
FOR i=0 TO stateMax-1
LET s = s + 2.0*FermiDirac(sdEnergy(i), eFermi)
NEXT i
LET trialOcc = s
END FUNCTION
EXTERNAL FUNCTION FermiDirac(ee, ef)
LET et = broadening !level width
LET a = (ee-ef)/et
IF a>100 THEN LET ret = 0.0 ELSE LET ret = 1.0/(EXP(a)+1.0)
LET FermiDirac = ret
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
LET s = s + sdState(ist,i)*sdState(jst,i)
NEXT i
LET innerProduct = s*dx
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
LET s = s + sdState(ist,i)*sdState(ist,i)*dx
NEXT i
LET a = SQR(1/s)
FOR i=1 TO NNx-2
LET sdState(ist,i) = a*sdState(ist,i)
NEXT i
END SUB
EXTERNAL FUNCTION totalEnergy
DECLARE EXTERNAL FUNCTION eeCorrelation
LET sei = 0.0
FOR i=0 TO numberOfOrbit-1
LET sei = sei + occupation(i)*sdEnergy(i)
NEXT i
LET s = 0.0
FOR i=1 TO NNx-1
LET s = s + (-0.5*vvh(i)-0.25*vvx(i)+eeCorrelation(rho(i))-vvc(i))*rho(i)
NEXT i
LET s = s*dx
LET totalEnergy = sei + s
END FUNCTION
! ---------- drawState
EXTERNAL SUB drawState(dispMode) !public
DECLARE EXTERNAL SUB dispInnerProduct,plotfn
DECLARE EXTERNAL FUNCTION totalEnergy
LET sc = 20
LET xp = 50
LET yp = 180
LET vMag = 10
LET stMag = 100
SET DRAW MODE HIDDEN
CLEAR
SET LINE COLOR 1 ! black : PLOT x-axis
PLOT LINES: xp,yp;dx*NNx*sc+xp,yp
!---plot rho
SET AREA COLOR 8 ! gray : PLOT rho;
FOR i=0 TO NNx-2
PLOT AREA: dx*i*sc+xp,yp;dx*i*sc+xp,rho(i)*20000+yp;dx*(i+1)*sc+xp,rho(i+1)*20000+yp;dx*(i+1)*sc+xp,yp
NEXT i
CALL plotFN(vvext,sc,vMag,xp,yp,0,1) !black, plot external potential vvext(x)
!
IF dispmode=2 THEN !---plot Vext,Veff(),vvh(),vvxc()x10
SET TEXT HEIGHT 6
CALL plotFN(vv,sc,vMag,xp,yp,0,10) !dark green, plot effective potential vv(x)
CALL plotFN(vvh,sc,vMag,xp,yp,0,2) !blue, plot Hartree potential vvh(x)
CALL plotFN(vvx,sc,vMag*10,xp,yp,0,4) !red, plot exchange potential vvx(x)
CALL plotFN(vvc,sc,vMag*10,xp,yp,0,7) !magenta, plot correlation potential vvc(x)
SET TEXT COLOR 1
PLOT TEXT, AT 50, yp+65 :"Vext()"
SET TEXT COLOR 10
PLOT TEXT, AT 50, yp+50 :"Veff()"
SET TEXT COLOR 2
PLOT TEXT, AT 50, yp+35 :"Vh()"
SET TEXT COLOR 4
PLOT TEXT, AT 50, yp+20 :"Vx() x 10"
SET TEXT COLOR 7
PLOT TEXT, AT 50, yp+5 :"Vc() x 10"
END IF
IF dispMode=1 THEN !--- plot Vext(),|i>
SET TEXT HEIGHT 5
FOR ist=0 TO 4
IF sdEnergy(ist)<12 THEN
SET LINE COLOR 1+ist
SET TEXT COLOR 1+ist
FOR i=0 TO NNx-1 !plot wave function |psi(x,t)>
PLOT LINES: i*dx*sc+xp, sdState(ist,i)*stMag+sdEnergy(ist)*20+yp;
NEXT i
PLOT LINES
PLOT TEXT, AT xp-20,sdEnergy(ist)*20+yp :"|"&STR$(ist)&">"
END IF
NEXT ist
END IF
CALL dispInnerProduct(0,dx*NNx*sc+xp+20,yp)
!--- caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
PLOT TEXT, AT 50,115 ,USING "iteration count =###### error =#.##########":iterCount,iterationError
PLOT TEXT, AT 50,100 ,USING "total energy =###.##########":totalEnergy
PLOT TEXT, AT 50, 85 ,USING "E0 =###.########## Occ =#.#####":sdEnergy(0),occupation(0)
PLOT TEXT, AT 50, 70 ,USING "E1 =###.########## Occ =#.#####":sdEnergy(1),occupation(1)
PLOT TEXT, AT 50, 55 ,USING "E2 =###.########## Occ =#.#####":sdEnergy(2),occupation(2)
PLOT TEXT, AT 50, 40 ,USING "E3 =###.########## Occ =#.#####":sdEnergy(3),occupation(3)
PLOT TEXT, AT 50, 25 ,USING "E4 =###.########## Occ =#.#####":sdEnergy(4),occupation(4)
PLOT TEXT, AT 50, 10 :"RS-DFT - Local Density Approximation 1D"
PLOT TEXT, AT 50,470 :"[esc] exit [D] chage dispMode"
PLOT TEXT, AT 50,455 :"[1] ... [6] number of electron"
PLOT TEXT, AT 50,440 :"[7] hermonics k*x^2 [8] quantum well"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB dispInnerProduct(ist,xp,yp)
DECLARE EXTERNAL FUNCTION innerProduct
SET TEXT HEIGHT 5
SET TEXT COLOR 1 ! black
FOR jst=0 TO numberOfOrbit-1
PLOT TEXT, AT xp,yp+15*jst ,USING "("&STR$(ist)&"|"&STR$(jst)&") = -%.###^^^^":innerProduct(ist,jst)
NEXT jst
PLOT TEXT, AT xp,yp+15*10 :"(i|j) inner product"
END SUB
EXTERNAL SUB plotFN(a(),sc,mag,xp,yp,offset,col)
SET LINE COLOR col
FOR i=0 TO NNx-1
PLOT LINES: dx*i*sc+xp,a(i)*mag+offset+yp;
NEXT i
PLOT LINES
END SUB
DO
LET contTemp = contTemp + ddTemp
IF contTemp>3000 THEN LET contTemp = 3000
IF contTemp<10 THEN LET contTemP = 10
IF pauseFlag=0 THEN CALL moveParticles(tempMode,contTemp) ELSE WAIT DELAY 0.05
CALL drawParticles(tempMode,contTemp,drawMode)
LET S$=INKEY$
IF S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" OR S$="6" OR S$="7" THEN
LET material = VAL(S$)
LET tempMode = 0
LET contTemp = 300
CALL setInitialCondition(material,6.0,contTemp)
ELSEIF S$="T" OR S$="t" THEN
LET tempMode = MOD(tempMode+1,2)
IF tempMode=0 THEN LET ddTemp = 0
ELSEIF S$="K" OR S$="k" THEN
LET tempMode = 1
IF ddtemp=0 THEN LET ddTemp = 1 ELSE LET ddTemp = 0
ELSEIF S$="J" OR S$="j" THEN
LET tempMode = 1
IF ddTemp=0 THEN LET ddTemp = -1 ELSE LET ddTemp = 0
ELSEIF S$="D" OR S$="d" THEN
LET drawMode = MOD(drawMode+1,3)
ELSEIF S$=" " THEN
LET pauseFlag = MOD(pauseFlag+1,2)
END IF
LOOP UNTIL S$=CHR$(27)
END
EXTERNAL FUNCTION INKEY$ !--- from decimal BASIC library inkey$.bas
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- molecular dynamics 2D - ion ----------
!
! method: velocity Verlet ( F=m*d^2r/dt^2 -> r(t+dt)=r(t)+v*dt,v=v+(F/m)*dt )
! (1) vi = vi + (Fi/mi)*(0.5dt)
! (2) ri = ri + vi*dt
! (3) calculation Fi <- {r1,r2,...,rn} Fi=sum(Fij,j=1 to n),Fij=F(ri-rj)
! (4) vi = vi + (Fi/mi)*(0.5dt)
! (5) goto (1)
!
! force: ion f(r) = fc + fr + fa
! fc = eForceConst*zi*zj*(EXP(-r/6.5e-10)/r)*(1.0/r+1.0/6.5e-10) !Debye-screened Coulomb force
! fr = 6.9742e-11*EXP((a-r)/b) !repulsive force
! fa = -6.9742e-21*(c/r^6) !attractive force
!
MODULE imd2d
MODULE OPTION ARITHMETIC NATIVE
PUBLIC SUB setInitialCondition !(molKind,boxSizeInNM,xtalSizeInNM,contTemp)
PUBLIC SUB moveParticles !(tempMode,contTemp)
PUBLIC SUB drawParticles !(drawMode:0:realSpace 1:velocitySpace)
SHARE NUMERIC ionKind1,ionKind2, sysTime, dt, nMolec, xMax, yMax, rCutoff, hh
SHARE NUMERIC xx(2000),yy(2000) ! (xx(i),yy(i)) : position of i-th particle
SHARE NUMERIC vx(2000),vy(2000) ! (vx(i),vy(i)) : velocity of i-th particle
SHARE NUMERIC ffx(2000),ffy(2000) ! (ffx(i),ffy(i)): total force of i-th particle
SHARE NUMERIC kind(2000),mas(2000) ! kind(i),mas(i) : molec kind, mass of i-th particle
SHARE NUMERIC reg(2000,0 TO 100) ! register near molec reg(i,0):number of near i-th molec
SHARE NUMERIC ion_m(0 TO 17),ion_z(0 TO 17) ! ion mass,ion charge
SHARE NUMERIC ion_a(0 TO 17),ion_b(0 TO 17) ! ion force param a,ion force param b
SHARE NUMERIC ion_c(0 TO 17),ion_r(0 TO 17) ! ion force param c, ion radius
SHARE NUMERIC ion_col(0 TO 17) ! ion draw color
SHARE STRING ion_str$(0 TO 17) ! ion string
SHARE NUMERIC forceTable(0 TO 17, 0 TO 17,0 TO 1001) ! force table
LET ionKind1 = 3 ! ion kind1 - 3:Na+
LET ionKind2 = 7 ! ion kind2 - 7:Cl-
LET sysTime = 0.0 ! system time (s) in the module
LET dt = 2.0*1.0e-15 ! time step (s)
LET nMolec = 100 ! number of particles
LET xMax = 6.0E-9 ! x-Box size (m)
LET yMax = 6.0E-9 ! y-Box size (m)
LET rCutoff = 1.0e-9 ! force cutoff radius (m)
LET hh = 1e-12 ! force table step (m)
LET ion_z(0)=0.0 ! if ion_z(0)=0.0 then set ion data
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(material,boxSizeInNM,contTemp)
DECLARE EXTERNAL SUB setIonData,ajustVelocity,setForceTable
DECLARE EXTERNAL FUNCTION setNaClTypeBlock
RANDOMIZE
LET sysTime = 0.0
CALL setIonData
CALL setForceTable
LET xMax = boxSizeInNM*1.0e-9
LET yMax = boxSizeInNM*1.0e-9
IF material=1 THEN !NaCl
LET ionKind1 = 3 !Na+
LET ionKind2 = 7 !Cl-
LET lattice = 5.6407e-10
ELSEIF material=2 THEN !MgO
LET ionKind1 = 4 !Mg++
LET ionKind2 = 1 !O--
LET lattice = 4.212e-10*0.94 !0.94: correction factor
ELSEIF material=3 THEN !CaO
LET ionKind1 = 9 !Ca++
LET ionKind2 = 1 !O--
LET lattice = 4.80e-10*0.94 !0.94: correction factor
ELSEIF material=4 THEN !BaO
LET ionKind1 = 12 !Ba++
LET ionKind2 = 1 !O--
LET lattice = 5.536e-10
ELSEIF material=5 THEN !NaF
LET ionKind1 = 3 !Na+
LET ionKind2 = 2 !F-
LET lattice = 4.62e-10
ELSEIF material=6 THEN !KF
LET ionKind1 = 8 !K+
LET ionKind2 = 2 !F-
LET lattice = 5.34e-10
ELSEIF material=7 THEN !KCl
LET ionKind1 = 8 !K+
LET ionKind2 = 7 !Cl-
LET lattice = 6.29e-10
END IF
LET s = 0.5*(xMax - lattice*6)
! setNaClTypeBlock(ii, knd1, knd2, nx, ny, lattice, xPos, yPos)
LET nMolec = setNaClTypeBlock(1, ionKind1, ionKind2, 6, 6, lattice, s, s)
CALL ajustVelocity(contTemp)
! set window
SET WINDOW 0,500,0,500
END SUB
EXTERNAL SUB setIonData
! ion potential data
! 0 mass,1 charge, 2 a , 3 b , 4 c , 5 r-ion, 6 color 7 str$
DATA 10.81, 3.0, 0.720e-10, 0.080e-10, 0.0, 0.23e-10, 13 , "B+++" !0
DATA 16.00, -2.0, 1.626e-10, 0.085e-10, 20.0, 1.40e-10, 2 , "O--" !1
DATA 19.00, -1.0, 1.565e-10, 0.085e-10, 20.0, 1.33e-10, 2 , "F-" !2
DATA 22.99, 1.0, 1.260e-10, 0.080e-10, 20.0, 1.02e-10, 4 , "Na+" !3
DATA 24.31, 2.0, 1.161e-10, 0.080e-10, 10.0, 0.72e-10, 4 , "Mg++" !4
DATA 26.98, 3.0, 1.064e-10, 0.080e-10, 2.0, 0.53e-10, 13 , "Al+++" !5
DATA 28.09, 4.0, 1.012e-10, 0.080e-10, 0.0, 0.40e-10, 7 , "Si++++" !6
DATA 35.45, -1.0, 1.950e-10, 0.090e-10, 30.0, 1.81e-10, 2 , "Cl-" !7
DATA 39.10, 1.0, 1.595e-10, 0.080e-10, 15.0, 1.38e-10, 4 , "K+" !8
DATA 40.08, 2.0, 1.414e-10, 0.080e-10, 10.0, 1.00e-10, 4 , "Ca++" !9
DATA 47.88, 4.0, 1.235e-10, 0.080e-10, 0.0, 0.61e-10, 7 , "Ti++++" !10
DATA 87.62, 2.0, 1.632e-10, 0.080e-10, 15.0, 1.16e-10, 4 , "Sr++" !11
DATA 137.3, 2.0, 1.820e-10, 0.080e-10, 20.0, 1.36e-10, 4 , "Ba++" !12
DATA 4.003, 0.0, 1.200e-10, 0.110e-10, 4.76, 1.28e-10, 3 , "He" !13
DATA 20.18, 0.0, 1.415e-10, 0.112e-10,11.03, 1.37e-10, 3 , "Ne" !14
DATA 39.95, 0.0, 1.878e-10, 0.117e-10,38.53, 1.70e-10, 3 , "Ar" !15
DATA 83.80, 0.0, 2.041e-10, 0.130e-10,55.33, 1.83e-10, 3 , "Kr" !16
DATA 131.3, 0.0, 2.258e-10, 0.145e-10,85.55, 1.99e-10, 3 , "Xe" !17
IF ion_z(0)=0.0 THEN
FOR i=0 TO 17
READ ion_m(i),ion_z(i),ion_a(i),ion_b(i),ion_c(i),ion_r(i),ion_col(i),ion_str$(i)
LET ion_m(i) = ion_m(i)*1.661e-27
LET ion_z(i) = ion_z(i)*1.602e-19
NEXT i
END IF
END SUB
EXTERNAL FUNCTION setNaClTypeBlock(ii, knd1, knd2, nx, ny, lattice, xPos, yPos)
DECLARE EXTERNAL SUB setParticle
LET ipp = ii
LET a = lattice/2.0
FOR i=0 TO 2*nx-1
FOR j=0 TO 2*ny-1
LET x = xPos + a*i
LET y = yPos + a*j
IF MOD(i+j,2)=0 THEN
LET knd = knd1
ELSE
LET knd = knd2
END IF
CALL setParticle(ipp, knd, x, y)
LET ipp = ipp + 1
NEXT j
NEXT i
LET setNaClTypeBlock = ipp - 1
END FUNCTION
EXTERNAL SUB setParticle(i, knd, x, y)
LET xx(i) = x
LET yy(i) = y
LET vx(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET vy(i) = 200.0*(RND+RND+RND+RND+RND+RND-3)
LET ffx(i) = 0.0
LET ffy(i) = 0.0
LET mas(i) = ion_m(knd)
LET kind(i) = knd
END SUB
EXTERNAL SUB setForceTable
DECLARE EXTERNAL FUNCTION cutoff
LET eForceConst = 1.0/(4.0*PI*8.8542e-12) !epsilon0=8.8542e-12
FOR ki=0 TO 17
FOR kj=0 TO 17
LET a = ion_a(ki)+ion_a(kj)
LET b = ion_b(ki)+ion_b(kj)
LET c = ion_c(ki)*ion_c(kj)*1.0e-60
LET zi = ion_z(ki)
LET zj = ion_z(kj)
FOR ir=10 TO 1001
LET r = ir*hh
LET fc = eForceConst*zi*zj*(EXP(-r/6.5e-10)/r)*(1.0/r+1.0/6.5e-10) !Debye-screened Coulomb force
LET fr = 6.9742e-11*EXP((a-r)/b) !repulsive force
LET fa = -6.9742e-21*(c/(r*r*r*r*r*r)) !attractive force
LET forceTable(ki,kj,ir) = cutoff(r)*(fc + fr + fa)
NEXT ir
FOR ir=0 TO 9
LET forceTable(ki,kj,ir) = forceTable(ki,kj,10)
NEXT ir
NEXT kj
NEXT ki
END SUB
EXTERNAL FUNCTION cutoff(r)
IF r>0 AND r<0.8*rCutoff THEN
LET ret = 1
ELSEIF r>=0.8*rCutoff AND r<rCutoff THEN
LET ret = 0.5+0.5*COS(PI*(r-0.8*rCutoff)/(0.2*rCutoff))
else
LET ret = 0
END IF
LET cutoff = ret
END FUNCTION
! ---------- move particles
EXTERNAL SUB moveParticles(tempMode,contTemp) !tempMode 0:adiabatic 1:constant-temp
DECLARE EXTERNAL SUB moveParticlesDT,ajustVelocity,registerNearMolec
IF (tempMode=1) THEN CALL ajustVelocity(contTemp)
CALL registerNearMolec
FOR i=1 TO 20
CALL moveParticlesDT
NEXT i
END SUB
EXTERNAL SUB moveParticlesDT ! velocity Verlet method
DECLARE EXTERNAL SUB calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
LET xx(i) = xx(i)+vx(i)*dt
LET yy(i) = yy(i)+vy(i)*dt
NEXT i
CALL calcForce
FOR i=1 TO nMolec
LET a = 0.5*dt/mas(i)
LET vx(i) = vx(i)+a*ffx(i)
LET vy(i) = vy(i)+a*ffy(i)
NEXT i
LET sysTime=sysTime+dt
END SUB
EXTERNAL SUB calcForce
DECLARE EXTERNAL FUNCTION force,boundaryForce
LET s = 0.5*3.418e-10
FOR i=1 TO nMolec
LET ffx(i) = 0.0
LET ffy(i) = 0.0
NEXT i
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET xij = xx(i)-xx(j)
LET yij = yy(i)-yy(j)
LET rij = SQR(xij*xij+yij*yij)
IF rij<rCutoff THEN
LET f = force(rij,kind(i),kind(j))
LET fxij = f*xij/rij
LET fyij = f*yij/rij
LET ffx(i) = ffx(i)+fxij
LET ffy(i) = ffy(i)+fyij
LET ffx(j) = ffx(j)-fxij
LET ffy(j) = ffy(j)-fyij
END IF
NEXT k
NEXT i
FOR i=1 TO nMolec ! boundary force
LET ffx(i) = ffx(i)+boundaryForce(xx(i)+s)+boundaryForce(xx(i)-xMax-s)
LET ffy(i) = ffy(i)+boundaryForce(yy(i)+s)+boundaryForce(yy(i)-yMax-s)
NEXT i
END SUB
EXTERNAL FUNCTION force(r,ki,kj) !force(r) <-- forceTable - linear interporation
LET ir = INT(r/hh)
LET a = r - ir*hh
LET force = ((hh-a)*forceTable(ki,kj,ir) + a*forceTable(ki,kj,ir+1))/hh
END FUNCTION
EXTERNAL FUNCTION boundaryForce(r)
LET r6 = (3.418e-10/r)^6
LET boundaryForce = (24.0*(0.5*1.711e-21)*r6*(2.0*r6-1.0)/r)
END FUNCTION
EXTERNAL SUB registerNearMolec
LET rCut = rCutoff+20*2000*dt
LET rcut2 = rCut*rCut
FOR i=1 TO nMolec-1
LET k = 1
FOR j=i+1 TO nMolec
LET r2 = (xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j))
IF (r2<rcut2) THEN
LET reg(i,k) = j
LET k = k + 1
END IF
NEXT j
LET reg(i,0) = k
NEXT i
END SUB
EXTERNAL FUNCTION maxNearMolec
LET mx = 0
FOR i=1 TO nMolec-1
IF mx<reg(i,0) THEN LET mx = reg(i,0)
NEXT i
LET maxNearMolec = mx-1
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION systemTemprature
LET kB = 1.38e-23 ! Boltzman's constant (J/K)
LET ek= 0.0 !kinetic energy (J)
FOR i=1 TO nMolec
LET ek = ek + 0.5*mas(i)*(vx(i)^2+vy(i)^2)
NEXT i
LET systemTemprature = ek/(nMolec*kB) !2D: E/N=kT, 3D: E/N=(3/2)kT
END FUNCTION
EXTERNAL SUB ajustVelocity(temp)
DECLARE EXTERNAL FUNCTION systemTemprature
LET r = sqr(temp/systemTemprature)
FOR i=1 TO nMolec
LET vx(i) = r*vx(i)
LET vy(i) = r*vy(i)
NEXT i
END SUB
! ---------- draw particles
EXTERNAL SUB drawParticles(tempMode,contTemp,drawMode)
DECLARE EXTERNAL FUNCTION systemTemprature,maxNearMolec
DECLARE EXTERNAL sub realSpace,velocitySpace,plotBond
SET DRAW MODE HIDDEN
CLEAR
IF drawMode=0 OR drawMode=1 THEN !--- 0:circle 1:circle+bond
call plotBond(drawMode)
ELSEIF drawMode=2 THEN
call velocitySpace
END IF
!--- draw caption
SET TEXT HEIGHT 10
SET TEXT COLOR 1 ! black
LET tmp$ = "adiabatic constantTemp "
PLOT TEXT, AT 50, 70 ,USING "time =#####.## (ps) temp =####.## (K)":sysTime*1E12,systemTemprature
PLOT TEXT, AT 50, 55 :ion_str$(ionKind1)&","&ion_str$(ionKind2)
PLOT TEXT, AT 150, 55 ,USING "N =####":nMolec
PLOT TEXT, AT 50, 40 ,USING "tempMode = ## ":tempMode
PLOT TEXT, AT 200, 40 :tmp$(tempMode*12+1:tempMode*12+12)
PLOT TEXT, AT 50, 25 ,USING "controled Temperature =####.# (K)":contTemp
PLOT TEXT, AT 50, 10 :"2-dimensional ion - molecular dynamics"
PLOT TEXT, AT 50,480 :"[esc] exit [space]pause/go [D]change draw mode"
PLOT TEXT, AT 50,460 :"[1]NaCl [2]MgO [3]CaO [4]BaO [5]NaF [6]KF [7]KCl"
PLOT TEXT, AT 50,440 :"[T] toggle 0:adiabatic/1:constant temperature"
PLOT TEXT, AT 50,420 :"temp control -> [J]coolDown/stop [k]heatUp/stop"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL sub plotBond(drawMode)
LET boxSize = 300
LET mag = boxSize/xMax
LET xp = 100
LET yp = 100
SET LINE COLOR 1 ! black : !--- box
PLOT LINES: xp,yp; boxSize+xp,yp; boxSize+xp,boxSize+yp; xp,boxSize+yp; xp,yp
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT xp,boxSize+2+yp ,USING "box size =##.# x ##.# (nm)":xMax*1e9,yMax*1e9
FOR i=1 TO nMolec
SET LINE COLOR ion_col(kind(i))
DRAW circle WITH SCALE(ion_r(kind(i))*mag)*SHIFT(xx(i)*mag+xp,yy(i)*mag+yp)
NEXT i
IF drawMode=1 THEN
FOR i=1 TO nMolec-1
FOR k=1 TO reg(i,0)-1
LET j = reg(i,k)
LET r = SQR((xx(i)-xx(j))*(xx(i)-xx(j))+(yy(i)-yy(j))*(yy(i)-yy(j)))
LET r0 = (ion_r(kind(i))+ion_r(kind(j)))
IF r<1.1*r0 AND kind(i)<>kind(j) THEN
SET LINE COLOR 8 !gray
PLOT LINES: xx(i)*mag+xp,yy(i)*mag+yp;xx(j)*mag+xp,yy(j)*mag+yp
END IF
NEXT k
NEXT i
END IF
END sub
EXTERNAL sub velocitySpace
LET boxSize = 300
LET xp = 100
LET yp = 100
SET LINE COLOR 1 !black : axis
PLOT LINES: xp,boxSize/2+yp; boxSize+xp,boxSize/2+yp !vx-axis
PLOT LINES: boxSize/2+xp,yp; boxSize/2+xp,boxSize+yp !vy-axis
SET TEXT HEIGHT 6
SET TEXT COLOR 1 ! black
PLOT TEXT, AT boxSize+xp,boxSize/2+yp: "vx"
PLOT TEXT, AT boxSize+xp,boxSize/2-12+yp: "2000m/s"
PLOT TEXT, AT boxSize/2-12+xp,boxSize+yp: "vy 2000m/s"
PLOT TEXT, AT boxSize/2-8+xp,boxSize/2-10+yp: "0"
PLOT TEXT, AT xp,boxSize+8+yp: "velocity space (vx,vy)"
LET mag = boxSize/4000
FOR i=1 TO nMolec
IF kind(i)=ionKind1 THEN SET LINE COLOR 4 ELSE SET LINE COLOR 2 !4:red, 2:blue
DRAW circle WITH SCALE(5)*SHIFT(vx(i)*mag+boxSize/2+xp,vy(i)*mag+boxSize/2+yp)
NEXT i
END sub
主プログラムに
DECLARE EXTERNAL SUB m.segment
DECLARE EXTERNAL NUMERIC m.j
を書くと，以後，jと書くだけでモジュール内の変数jの参照が可能です。
そして，副プログラムsegmentをモジュールm内に書いてください。
MODULE m
DECLARE PUBLIC SUB segment
DECLARE PUBLIC NUMERIC j
LET j=0 ! 主プログラム実行前に実行される
EXTERNAL SUB segment(z1,z2,col)
・・・・・・
LET j=j+1
END SUB
END MODULE
なお，Full BASICの関数は引数はすべて値渡しですが，
副プログラムは実引数に変数を書くと参照渡しになるで，
副プログラムなら
EXTERNAL SUB segment(z1,z2,col,j)
・・・・・・
LET j=j+1
END SUB
のようにjを引数に追加しておく手も使えます。
!
! ========= RSDFT - local density approximation 2D ==========
!
! 024sampleLDA2D.bas
! Copyright(C) 2017 Mitsuru Ikeuchi
! Released under the MIT license ( https://opensource.org/licenses/MIT )
!
! ver 0.0.1 2017.09.06 created
!
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL SUB lda2d.setInitialCondition,lda2d.iterateLDA,lda2d.drawState,lda2d.setNumberOfElectron
DECLARE EXTERNAL FUNCTION INKEY$
LET stateMax = 10 !state 0,1,...,stateMax-1
LET vIndex = 0 !0:harmonic potential, 1:quantum well
LET nElectron = 4
LET iterMax = 5 !5 = iteration in iterateLDA
LET dispMode = 0 !0:Vext+rho, 1:Vext+rho+orbit, 2:rho+Vext+Veff+Vh+Vx+Vc
CALL setInitialCondition(stateMax,vIndex,nElectron)
DO
CALL iterateLDA(stateMax, iterMax)
CALL drawState(dispMode)
LET S$=INKEY$
IF S$="D" OR S$="d" THEN
LET dispMode = mod(dispMode+1,3)
ELSEIF S$="1" OR S$="2" OR S$="3" OR S$="4" OR S$="5" OR S$="6" THEN
LET nElectron = VAL(s$)
CALL setNumberOfElectron(nElectron)
ELSEIF S$="7" THEN
LET vIndex = 0
CALL setInitialCondition(stateMax,vIndex,nElectron)
ELSEIF S$="8" THEN
LET vIndex = 1
CALL setInitialCondition(stateMax,vIndex,nElectron)
END IF
LOOP UNTIL S$=chr$(27)
END
EXTERNAL FUNCTION INKEY$
OPTION ARITHMETIC NATIVE
SET ECHO "OFF"
LET S$=""
CHARACTER INPUT NOWAIT: S$
LET INKEY$=S$
END FUNCTION
! ---------- RSDFT - local density approximation 2D ----------
!
! - real space density functional theory - local density approximation
! - solve Kohn-Sham equation - successive approximation
! - Vxc : LDA(local density approximation)
! J. P. Perdew and A. Zunger; Phys. Rev., B23, 5048 (1981)
!
! procedure
! (1) given: trial |i>, occupation(i)
!
! (2) set electron density rho
! rho <-- |i>, occupation[(i), mixing rho(iter-1)
!
! (3) set effective potential
! Veff = Vext + Vh + Vx + Vc
! Vh <-- rho (Poisson eq. ,SOR iteration)
! Vx,Vc <-- rho (LDA:Perdew-Zunger)
!
! (4) solve Kohn-Sham equation (successive approximation)
! |i> steepest descent method: |i(next)> = |i> - dump{H-E}|i>
! E(i) <-- <i|H|i>
! {|0>,..,|i>,..,|N>} orthogonallization : Gram-Schmidt
!
! (5) sort state
! sort orbit by E(i)
!
! (6) set occupation
! occupation(i) <-- E(i)
!
! (7) goto (2)
!
MODULE lda2d
MODULE OPTION ARITHMETIC NATIVE
OPTION BASE 0
PUBLIC SUB setInitialCondition, setNumberOfElectron, iterateLDA, drawState
SHARE NUMERIC NNx,NNy, dx,dy, lz, iterCount
SHARE NUMERIC numberOfElectron, numberOfElectronBounds, numberOfOrbit, errorDecisionOrbit
SHARE NUMERIC energyMem, iterationError, convergenceErrorMax, dampingFactor
SHARE NUMERIC mixing,broadening
SHARE NUMERIC cosAx,sinAx,cosAy,sinAy,cx0,cy0,cz0 !--- 3D graphics
SHARE NUMERIC sdEnergy(20) ! electron state energy
SHARE NUMERIC sdState(20,200,200) ! electron states 0...20 0:ground state
SHARE NUMERIC occupation(20) ! occupation of orbit
SHARE NUMERIC wrk(200,200) ! state work space in steepestDescent
SHARE NUMERIC vv(200,200) ! effective potential
SHARE NUMERIC vvext(200,200) ! external potential
SHARE NUMERIC vvh(200,200) ! Hartree potential
SHARE NUMERIC vvx(200,200) ! exchange potential
SHARE NUMERIC vvc(200,200) ! correlation potential
SHARE NUMERIC rho(200,200) ! charge density
SHARE NUMERIC psicol(64,64) ! MAT PLOT CELL matrix for psi(x,y)
SHARE NUMERIC vcol(64,64) ! MAT PLOT CELL matrix for potential V(x,y)
LET NNx = 64 ! max number of sdState(,NNx,NNy)
LET NNy = 64 !
LET dx = 0.25 ! (au) x-division
LET dy = 0.25
LET lz = 12.0 ! (au) v=dx*dy*lz
LET iterCount = 0 ! sd iteration count
LET numberOfElectron = 4 !
LET numberOfElectronBounds = 6! selection bounds OF numberOfElectron
LET numberOfOrbit = 10 !
LET energyMem = 0.0
LET iterationError = 1.0
LET convergenceErrorMax = 1.0e-5
LET dampingFactor = 0.01 ! steepest descent method
LET mixing = 0.5 ! charge mixing in setRho()
LET broadening = 0.01 ! (au) level broadening IN setOccupation
! ---------- set initial condition
EXTERNAL SUB setInitialCondition(stateMax,vIndex,nElectron) !public
DECLARE EXTERNAL SUB setInitialState,setExternalPotential,initDraw
LET iterCount = 0
LET numberOfElectron = nElectron
CALL setInitialState(stateMax)
CALL setExternalPotential(vIndex)
CALL initDraw
! set window
SET WINDOW 0,500, 0,500
END SUB
EXTERNAL SUB setNumberOfElectron(nElectron) !public
LET numberOfElectron = nElectron
END SUB
EXTERNAL SUB setInitialState(stateMax)
DECLARE EXTERNAL SUB normalizeState
RANDOMIZE
FOR ist=0 TO stateMax-1
FOR i=1 TO NNx-2
FOR j=1 TO NNx-2
LET sdState(ist,i,j) = RND-0.5
NEXT j
NEXT i
CALL normalizeState(ist)
NEXT ist
END SUB
EXTERNAL SUB setExternalPotential(vIndex)
LET x0 = 0.5*NNx*dx
LET y0 = 0.5*NNy*dy
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET x = i*dx
LET y = j*dy
IF vIndex=0 THEN
LET vvext(i,j) = 0.5*((x-x0)*(x-x0)+(y-y0)*(y-y0))
ELSEIF vIndex=1 THEN
LET r = SQR((x-x0)*(x-x0)+(y-y0)*(y-y0))
IF r>5 THEN LET vvext(i,j)=20 ELSE LET vvext(i,j)=0
ELSE
LET vvext(i,j)=0
END IF
NEXT j
NEXT i
END SUB
EXTERNAL SUB setInitialOccupation(nOrbit, nElectron)
LET occ = 1.0*nElectron/nOrbit
FOR iState=0 TO nOrbit
LET occupation(iState) = occ
NEXT iState
END SUB
EXTERNAL SUB initDraw !--- set set color pallet and MAT PLOT matrix vcol(,)
FOR i = 0 TO 50 !--- set color pallet
SET COLOR MIX( 40+i) 0.02*i,0.02*i,0 ! red for |psi> +
SET COLOR MIX(100+i) 0,0.02*i,0.02*i ! blue for |psi> -
SET COLOR MIX(160+i) 0,0.02*i,0 ! green for V(x)
NEXT i
FOR i=0 TO NNx-1 !--- set vcol(,)
FOR j=0 TO NNy-1
LET col = 0.02*vvext(i,j)
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET vcol(i,j) = 160+INT(col*50)
NEXT j
NEXT i
END SUB
! ---------- iterate LDA
EXTERNAL SUB iterateLDA(stateMax, iterMax) !public
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB setElectronDensity,setEffectivePotential,solveKohnSham,sortState,setOccupation
LET errorDecisionOrbit = int((numberOfElectron-1)/2)
CALL setElectronDensity
CALL setEffectivePotential
CALL solveKohnSham(numberOfOrbit,iterMax)
CALL sortState(numberOfOrbit)
CALL setOccupation(numberOfOrbit,numberOfElectron)
LET iterationError = sdEnergy(errorDecisionOrbit) - energyMem
LET energyMem = sdEnergy(errorDecisionOrbit)
END SUB
!--- (2) set electron density rho <-- sdState(), occupation()
EXTERNAL SUB setElectronDensity
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET rho(i,j) = rho(i,j)*(1.0-mixing)
FOR ie=0 TO numberOfOrbit-1
IF occupation(ie)>0.0 THEN
LET rho(i,j) = rho(i,j) + mixing*occupation(ie)*(sdState(ie,i,j)*sdState(ie,i,j))/lz
END IF
NEXT ie
NEXT j
NEXT i
END SUB
!--- (3) set effective potential <-- electron density
EXTERNAL SUB setEffectivePotential
DECLARE EXTERNAL SUB poisson,setVxc
CALL poisson(20) !setVh
CALL setVxc
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET vv(i,j) = vvext(i,j)+vvh(i,j)+vvx(i,j)+vvc(i,j)
NEXT j
NEXT i
END SUB
EXTERNAL SUB poisson(iterMax)
LET h2 = 4.0*PI*dx*dx
LET omegav4 = 1.8/4.0
FOR iter=0 TO iterMax-1
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET vvh(i,j) = vvh(i,j)+omegav4*(vvh(i+1,j)+vvh(i-1,j)+vvh(i,j+1)+vvh(i,j-1)-4.0*vvh(i,j) +h2*rho(i,j))
NEXT j
NEXT i
NEXT iter
END SUB
EXTERNAL SUB setVxc !set exchage and correlation potential (Perdew and Zunger)
LET c1 = -0.984745022
FOR i=0 TO NNx-1
FOR j=1 TO NNy-2
LET rh = rho(i,j)
LET rh3 = rh^0.33333333
LET vvx(i,j) = c1*rh3
LET rs = 0.6204/(rh3+1.0e-20)
IF rs>=1.0 THEN
LET sqrtrs = SQR(rs)
LET ec = -0.1423/(1.0+1.0529*sqrtrs+0.3334*rs)
LET vvc(i,j) = ec*(1.0+1.22838*sqrtrs+0.4445*rs)/(1.0+1.0529*sqrtrs+0.3334*rs)
ELSE
LET vvc(i,j) = -0.05837-0.0084*rs +(0.0311+0.00133*rs)*LOG(rs)
END IF
NEXT j
NEXT i
END SUB
EXTERNAL FUNCTION eeCorrelation(rh)
LET r = 0.6204/(rh^0.33333333+1.0e-20)
IF r>=1.0 THEN
LET ec = -0.1423/(1.0+1.0529*SQR(r)+0.3334*r)
ELSE
LET ec = -0.0480-0.0116*r+(0.0311+0.0020*r)*LOG(r)
END IF
LET eeCorrelation = ec
END FUNCTION
!--- (4) solve Kohn-Sham equation
EXTERNAL SUB solveKohnSham(stateMax, iterMax)
DECLARE EXTERNAL FUNCTION steepestDescent
DECLARE EXTERNAL SUB GramSchmidt,sortState
FOR i=0 TO iterMax-1
FOR ist=0 TO stateMax-1
LET sdEnergy(ist) = steepestDescent(ist,dampingFactor)
NEXT ist
CALL GramSchmidt(stateMax)
LET iterCount = iterCount + 1
NEXT i
END SUB
EXTERNAL FUNCTION steepestDescent(ist,damp) !--- steepest descent method
DECLARE EXTERNAL FUNCTION energyOfState
DECLARE EXTERNAL SUB normalizeState
LET h2 = 2*dx*dx
LET ei = energyOfState(ist) !--- E_ist = <ist|H|ist>
FOR i=1 TO NNx-2 !--- |wrk> = (H-E_ist)|ist>
FOR j=1 TO NNy-2
LET pij = sdState(ist,i,j)
LET wrk(i,j) = (4*pij-sdState(ist,i+1,j)-sdState(ist,i-1,j)-sdState(ist,i,j-1)-sdState(ist,i,j+1))/h2+(vv(i,j)-ei)*pij
NEXT j
NEXT i
FOR i=1 TO NNx-2 !--- |ist(next)> = |ist> - damp*|wrk> ( norm(|ist(next)>) <>1 )
FOR j=1 TO NNy-2
LET sdState(ist,i,j) = sdState(ist,i,j)-damp*wrk(i,j)
NEXT j
NEXT i
CALL normalizeState(ist)
LET steepestDescent = ei
END FUNCTION
EXTERNAL FUNCTION energyOfState(ist) !--- E_ist = <ist|H|ist>/<ist|ist>
LET h2 = 2*dx*dx
LET s = 0
LET sn=0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET pij = sdState(ist,i,j)
LET s = s+pij*((4.0*pij-sdState(ist,i+1,j)-sdState(ist,i-1,j)-sdState(ist,i,j-1)-sdState(ist,i,j+1))/h2+vv(i,j)*pij)
LET sn = sn+pij*pij
NEXT j
next i
LET energyOfState = s/sn
END FUNCTION
EXTERNAL SUB GramSchmidt(stateMax) !--- Gram-Schmidt orthonormalization
DECLARE EXTERNAL FUNCTION innerProduct
DECLARE EXTERNAL SUB normalizeState
CALL normalizeState(0)
FOR istate=1 TO stateMax-1
FOR ist=0 TO istate-1
LET s = innerProduct(ist,istate)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET sdState(istate,i,j) = sdState(istate,i,j) - s*sdState(ist,i,j)
NEXT j
NEXT i
NEXT ist
CALL normalizeState(istate)
NEXT iState
END SUB
!--- (5) sort state
EXTERNAL SUB sortState(stateMax)
FOR ist=stateMax-2 TO 0 STEP -1
IF sdEnergy(ist)>sdEnergy(ist+1)+0.00001 THEN
FOR i=0 TO NNx-1
FOR j=0 TO NNy-1
LET w = sdState(ist,i,j)
LET sdState(ist,i,j) = sdState(ist+1,i,j)
LET sdState(ist+1,i,j) = w
NEXT j
NEXT i
LET w = sdEnergy(ist)
LET sdEnergy(ist) = sdEnergy(ist+1)
LET sdEnergy(ist+1) = w
END IF
NEXT ist
END SUB
!--- (6) set occupation
EXTERNAL SUB setOccupation(stateMax, nElectron)
DECLARE EXTERNAL FUNCTION trialOcc,FermiDirac
LET eUpper = sdEnergy(stateMax-1)+1.0
LET eLower = sdEnergy(0)-1.0
FOR i=0 TO stateMax-1
IF sdEnergy(i)>eUpper THEN LET eUpper = sdEnergy(i)
IF sdEnergy(i)<eLower THEN LET eLower = sdEnergy(i)
NEXT i
DO WHILE (eUpper-eLower>1.0e-12)
LET eFermi = (eUpper+eLower)/2.0
LET ntrial = trialOcc(stateMax, eFermi)
IF ntrial<nElectron THEN
LET eLower = eFermi
ELSE
LET eUpper = eFermi
END IF
LOOP
LET eFermi = (eUpper+eLower)/2.0
FOR i=0 TO stateMax-1
LET occupation(i) = 2.0*FermiDirac(sdEnergy(i), eFermi)
IF (occupation(i)<0.0001) THEN LET occupation(i) = 0.0
IF (2.0-occupation(i)<0.0001) THEN LET occupation(i) = 2.0
NEXT i
END SUB
EXTERNAL FUNCTION trialOcc(stateMax, eFermi)
DECLARE EXTERNAL FUNCTION FermiDirac
LET s = 0.0
FOR i=0 TO stateMax-1
LET s = s + 2.0*FermiDirac(sdEnergy(i), eFermi)
NEXT i
LET trialOcc = s
END FUNCTION
EXTERNAL FUNCTION FermiDirac(ee, ef)
LET et = broadening !level width
LET a = (ee-ef)/et
IF a>100 THEN LET ret = 0.0 ELSE LET ret = 1.0/(EXP(a)+1.0)
LET FermiDirac = ret
END FUNCTION
! ---------- utility
EXTERNAL FUNCTION innerProduct(ist,jst) !--- <ist|jst>
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET s = s + sdState(ist,i,j)*sdState(jst,i,j)
NEXT j
NEXT i
LET innerProduct = s*dx*dy
END FUNCTION
EXTERNAL SUB normalizeState(ist)
LET s = 0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET s = s + sdState(ist,i,j)*sdState(ist,i,j)*dx*dy
NEXT j
NEXT i
LET a = SQR(1/s)
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET sdState(ist,i,j) = a*sdState(ist,i,j)
NEXT j
NEXT i
END SUB
EXTERNAL FUNCTION totalEnergy
DECLARE EXTERNAL FUNCTION eeCorrelation
LET sei = 0.0
FOR i=0 TO numberOfOrbit-1
LET sei = sei + occupation(i)*sdEnergy(i)
NEXT i
LET s = 0.0
FOR i=1 TO NNx-2
FOR j=1 TO NNy-2
LET s = s + (-0.5*vvh(i,j)-0.25*vvx(i,j)+eeCorrelation(rho(i,j))-vvc(i,j))*rho(i,j)
NEXT j
NEXT i
LET s = s*dx*dy
LET totalEnergy = sei + s
END FUNCTION
EXTERNAL SUB setRotateXYParameters(angleX,angleY,xCenter,yCenter,zCenter)
LET cosAx = COS(angleX)
LET sinAx = SIN(angleX)
LET cosAy = COS(angleY)
LET sinAy = SIN(angleY)
LET cx0 = xCenter
LET cy0 = yCenter
LET cz0 = zCenter
END SUB
EXTERNAL SUB plotLines3D(x,y,z,xShift,yShift) !shift*xRotateAx*yRotateAy*(shift^-1)
LET x1 = cosAy*(x-cx0)+sinAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
LET y1 = cosAx*(y-cy0)-sinAx*(z-cz0)
LET z1 =-sinAy*(x-cx0)+cosAy*(sinAx*(y-cy0)+cosAx*(z-cz0))
PLOT LINES: x1+cx0+xShift, y1+cy0+yShift; !z=z1+cz0
END SUB
! ---------- drawState
EXTERNAL SUB drawState(drawMode)
DECLARE EXTERNAL SUB setRotateXYParameters,drawState3D,draw3DPsix6,drawPsix6,drawRho
DECLARE EXTERNAL FUNCTION totalEnergy
SET DRAW MODE HIDDEN
CALL setRotateXYParameters(-PI/6,-PI/12,NNx/2,NNy/2,0)
CLEAR
SET TEXT HEIGHT 8
SET TEXT COLOR 1 ! black
IF drawMode=0 THEN
CALL drawRho(4,1.0,100,150) !(sc,zMag,xShift,yShift)
PLOT TEXT, AT 100, 150 :"electron density rho(x,y) and Veff(x,y)"
ELSEIF drawMode=1 THEN
CALL draw3DPsix6
ELSEIF drawMode=2 THEN
CALL drawPsix6
END IF
!--- caption
PLOT TEXT, AT 50,115 ,USING "iteration count =###### error =##.##########":iterCount,iterationError
PLOT TEXT, AT 50,100 ,USING "total energy =###.########## N of electron =##":totalEnergy,numberOfElectron
PLOT TEXT, AT 50, 85 ,USING "E0 =###.########## Occ =#.#####":sdEnergy(0),occupation(0)
PLOT TEXT, AT 50, 70 ,USING "E1 =###.########## Occ =#.#####":sdEnergy(1),occupation(1)
PLOT TEXT, AT 50, 55 ,USING "E2 =###.########## Occ =#.#####":sdEnergy(2),occupation(2)
PLOT TEXT, AT 50, 40 ,USING "E3 =###.########## Occ =#.#####":sdEnergy(3),occupation(3)
PLOT TEXT, AT 50, 25 ,USING "E4 =###.########## Occ =#.#####":sdEnergy(4),occupation(4)
PLOT TEXT, AT 50, 10 :"RS-DFT - Local Density Approximation 2D"
SET TEXT HEIGHT 10
PLOT TEXT, AT 50,470 :"[esc] exit [D] chage dispMode"
PLOT TEXT, AT 50,455 :"[1] ... [6] number of electron"
PLOT TEXT, AT 50,440 :"[7] hermonics k*x^2 [8] quantum well"
SET DRAW MODE EXPLICIT
END SUB
EXTERNAL SUB draw3DPsix6
DECLARE EXTERNAL SUB drawState3D
CALL drawState3D(0,2,0.5, 30,120) !(ist,sc,zMag,xShift,yShift)
CALL drawState3D(1,2,0.5,180,120)
CALL drawState3D(2,2,0.5,330,120)
CALL drawState3D(3,2,0.5, 30,270)
CALL drawState3D(4,2,0.5,180,270)
CALL drawState3D(5,2,0.5,330,270)
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,140:"|0>"
PLOT TEXT, AT 180,140:"|1>"
PLOT TEXT, AT 330,140:"|2>"
PLOT TEXT, AT 30,290:"|3>"
PLOT TEXT, AT 180,290:"|4>"
PLOT TEXT, AT 330,290:"|5>"
END SUB
EXTERNAL SUB drawRho(sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = rho(i,j)*2000
IF psi>1 THEN
SET LINE COLOR 13
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + vv(i,j)),xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = rho(i,j)*2000
IF psi>1 THEN
SET LINE COLOR 13
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + vv(i,j)),xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
EXTERNAL SUB drawState3D(ist,sc,zMag,xShift,yShift)
DECLARE EXTERNAL SUB plotLines3D
FOR j=0 TO NNy-1 STEP 1
FOR i=0 TO NNx-1
LET psi = sdState(ist,i,j)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + vv(i,j)),xShift,yShift) !(x,y,z)
NEXT i
PLOT LINES
NEXT j
FOR i=0 TO NNx-1 STEP 1
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j)*200
IF psi>1 THEN
SET LINE COLOR 4 ! red
ELSEIF psi<-1 THEN
SET LINE COLOR 2 ! blue
ELSE
SET LINE COLOR 3 ! potential:green
END IF
CALL plotLines3D(i*sc,j*sc,zMag*(psi + vv(i,j)),xShift,yShift) !(x,y,z)
NEXT j
PLOT LINES
NEXT i
END SUB
EXTERNAL SUB drawPsix6
DECLARE EXTERNAL SUB drawPsi
CALL drawPsi(0, 30,135) !(ist,xPos,yPos)
CALL drawPsi(1,180,135)
CALL drawPsi(2,330,135)
CALL drawPsi(3, 30,285)
CALL drawPsi(4,180,285)
CALL drawPsi(5,330,285)
SET TEXT HEIGHT 10
PLOT TEXT, AT 30,140:"|0>"
PLOT TEXT, AT 180,140:"|1>"
PLOT TEXT, AT 330,140:"|2>"
PLOT TEXT, AT 30,290:"|3>"
PLOT TEXT, AT 180,290:"|4>"
PLOT TEXT, AT 330,290:"|5>"
END SUB
EXTERNAL SUB drawPsi(ist,xPos,yPos) !drawMode=0
MAT psicol = vcol !--- psicol(,) <- Vcol(,) setted SUB initDraw
FOR i=0 TO NNx-1 !--- set psicol(,) for MAT PLOT CELLS
FOR j=0 TO NNy-1
LET psi = sdState(ist,i,j)
IF abs(psi)>0.002 THEN
IF psi>=0 THEN
LET col = psi*10
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 40+INT(col*50)
ELSE
LET col = -psi*10
IF col>1 THEN LET col = 1
IF col<0 THEN LET col = 0
LET psicol(i,j) = 100+INT(col*50)
END IF
END IF
NEXT j
NEXT i
MAT PLOT CELLS,IN xPos,yPos; xPos+128,yPos+128 :psicol
END SUB
FOR I1=2 TO 14
FOR J1=I1+1 TO 15
FOR K1=J1+1 TO 16
LET W$="123456789ABCDEFG"
LET A$=W$(1:1)&W$(I1:I1)&W$(J1:J1)&W$(K1:K1)
LET W$(1:1)="*"
LET W$(I1:I1)="*"
LET W$(J1:J1)="*"
LET W$(K1:K1)="*"
CALL ERASE(W$)
FOR I2=2 TO 10
FOR J2=I2+1 TO 11
FOR K2=J2+1 TO 12
LET X$=W$
LET A$=A$(1:4)&X$(1:1)&X$(I2:I2)&X$(J2:J2)&X$(K2:K2)
LET X$(1:1)="*"
LET X$(I2:I2)="*"
LET X$(J2:J2)="*"
LET X$(K2:K2)="*"
CALL ERASE(X$)
FOR I3=2 TO 6
FOR J3=I3+1 TO 7
FOR K3=J3+1 TO 8
LET Y$=X$
LET A$=A$(1:8)&Y$(1:1)&Y$(I3:I3)&Y$(J3:J3)&Y$(K3:K3)
LET Y$(1:1)="*"
LET Y$(I3:I3)="*"
LET Y$(J3:J3)="*"
LET Y$(K3:K3)="*"
CALL ERASE(Y$)
LET A$=A$&Y$
LET C=C+1
PRINT C;":";A$(1:4);" ";A$(5:8);" ";A$(9:12);" ";A$(13:16) !' 2627625 まで
LET A$=A$(1:12)
NEXT K3
NEXT J3
NEXT I3
NEXT K2
NEXT J2
NEXT I2
NEXT K1
NEXT J1
NEXT I1
END
EXTERNAL SUB ERASE(A$)
DO
LET FL=0
FOR I=1 TO LEN(A$)
IF A$(I:I)="*" THEN
LET A$(I:I)=""
LET FL=1
END IF
NEXT I
LOOP UNTIL FL=0
END SUB
OPTION ARITHMETIC NATIVE
RANDOMIZE
DIM B(15)
LET L=100000000 !'試行回数
FOR I=1 TO L
LET COUNT=0
LET N=INT(RND*6+1) !'1投目
DO
LET A=INT(RND*6+1) !'2投目以降
IF A=N THEN
LET COUNT=COUNT+1
LET B(COUNT)=B(COUNT)+1
END IF
LOOP WHILE A=N
NEXT I
FOR I=1 TO 15
PRINT I;":";B(I),B(I)/L,1/6^I
NEXT I
END
OPTION ARITHMETIC NATIVE
RANDOMIZE
FOR N=1 TO 10 !'同じ目が連続 n回
LET I=0
DO
LET I=I+1
LET COUNT=0
LET NN=INT(RND*6+1)
DO
LET A=INT(RND*6+1)
IF A=NN THEN LET COUNT=COUNT+1
LOOP WHILE A=NN
LOOP UNTIL COUNT=N
PRINT N;":";I
NEXT N
END
CALL GINIT(800,800)
LOCATE VALUE NOWAIT(1),RANGE 0 TO 300,AT 150 : R0
LOCATE VALUE NOWAIT(2),RANGE 0 TO 300,AT 120 : R1
LOCATE VALUE NOWAIT(3),RANGE 0 TO 300,AT 50 : P
LOCATE VALUE NOWAIT(4),RANGE 1 TO 200,AT 50 : SP
LOCATE VALUE NOWAIT(5),RANGE 1 TO 20,AT 3 : N
DO
LET T0=R0
LET T1=R1
LET RR=P
LET SS=SP
LET NN=N
DO
LOCATE VALUE NOWAIT(1): R0
LOCATE VALUE NOWAIT(2): R1
LOCATE VALUE NOWAIT(3): P
LOCATE VALUE NOWAIT(4): SP
LOCATE VALUE NOWAIT(5): N
LET R0=INT(R0)
LET R1=INT(R1)
LET P=INT(P)
LET SP=INT(SP)
LET N=INT(N)
LOOP WHILE R0=T0 AND R1=T1 AND P=RR AND SP=SS AND NN=N
CLEAR
LET R=R0-R1
LET XX=400+R-P
LET YY=400
LET D=0
FOR I=1 TO 360*N
LET D=D+SP
LET S1=D*PI/180
LET S0=S1*R1/R0
LET X=R*COS(S0)-P*COS(S1)
LET Y=R*SIN(S0)+P*SIN(S1)
CALL LINE(XX,YY,400+X,400+Y,7)
LET XX=400+X
LET YY=400+Y
NEXT I
LOOP
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB LINE(XS,YS,XE,YE,C)
SET COLOR C
PLOT LINES:XS,YS;XE,YE
END SUB
CALL GINIT(600,600)
OPTION ANGLE DEGREES
SET LINE COLOR 7
INPUT PROMPT "何角形 =":N
LET A=360/N
FOR T=0 TO 360
LET X=200*COS(T)*COS(A/2)/COS(A*(T/A-IP(T/A))-A/2)
LET Y=200*SIN(T)*COS(A/2)/COS(A*(T/A-IP(T/A))-A/2)
PLOT LINES:X+300,Y+300;
NEXT T
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
CALL GINIT(600,600)
OPTION ANGLE DEGREES
SET LINE COLOR 7
INPUT N !'N>=5
LET A=360/N
FOR T=0 TO 360
LET X=200*COS(T)*COS(A)/COS(A-1/N*ACOS(COS(N*T)))
LET Y=200*SIN(T)*COS(A)/COS(A-1/N*ACOS(COS(N*T)))
PLOT LINES:X+300,Y+300;
NEXT T
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
SET POINT STYLE 1
SET COLOR MODE "REGULAR"
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
OPTION ARITHMETIC NATIVE
RANDOMIZE
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET N=30
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM XX(0 TO N,0 TO N),YY(0 TO N,0 TO N),ZZ(0 TO N,0 TO N)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
DEF A(N)=360/N
DEF S1(X)=FP(X)
DEF CNP(N,T)=COS(A(N)*S1(T/A(N))-A(N)/2)
DEF PC(N,T)=COS(T)*COS(A(N)/2)/CNP(N,T)
DEF PS(N,T)=SIN(T)*COS(A(N)/2)/CNP(N,T)
DEF P3X(N,U,V)=PS(N,U)*PC(N,V)
DEF P3Y(N,U,V)=PS(N,U)*PS(N,V)
DEF P3Z(N,U)=PC(N,U)
INPUT PROMPT "何角形 =":NN
FOR I=0 TO N
FOR J=0 TO N
LET ALPHA=I*180/N
LET BETA=J*360/N
LET XX(I,J)=P3X(NN,ALPHA,BETA)
LET YY(I,J)=P3Y(NN,ALPHA,BETA)
LET ZZ(I,J)=P3Z(NN,ALPHA)
LET XMIN=MIN(XMIN,XX(I,J))
LET XMAX=MAX(XMAX,XX(I,J))
LET YMIN=MIN(YMIN,YY(I,J))
LET YMAX=MAX(YMAX,YY(I,J))
LET ZMIN=MIN(ZMIN,ZZ(I,J))
LET ZMAX=MAX(ZMAX,ZZ(I,J))
NEXT J
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET LMIN=1E+10
LET LMAX=-1E+10
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1:SCALE
LOCATE VALUE NOWAIT(2),RANGE-3 TO 5,AT 1:SPEED
LOCATE VALUE NOWAIT(3),RANGE-RANGE TO RANGE,AT 0:XMOVE
LOCATE VALUE NOWAIT(4),RANGE-RANGE TO RANGE,AT 0:YMOVE
LOCATE VALUE NOWAIT(5),RANGE-RANGE TO RANGE,AT 0:ZMOVE
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):SPEED
LOCATE VALUE NOWAIT(3):XMOVE
LOCATE VALUE NOWAIT(4):YMOVE
LOCATE VALUE NOWAIT(5):ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M*ROTX*ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=0 TO N
FOR J=0 TO N
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
NEXT J
PLOT LINES
NEXT I
FOR J=0 TO N
FOR I=0 TO N
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
NEXT I
PLOT LINES
NEXT J
IF FL=0 THEN
SET WINDOW LMIN*1.2,LMAX*1.2,LMIN*1.2,LMAX*1.2
LET WW=(LAMX-LMIN)*1.2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0 !'マウスでドラッグ
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT=(X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X+XMOVE
LET POINT(2)=Y+YMOVE
LET POINT(3)=Z+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
OPTION ARITHMETIC NATIVE
RANDOMIZE
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET N=30
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM XX(0 TO N,0 TO N),YY(0 TO N,0 TO N),ZZ(0 TO N,0 TO N)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
DEF FF(X)=.5*(IP(X)-IP(-X)-1)
DEF S2(X)=X+IP(-X)+1
DEF A(N)=360/N
DEF K(A,B,X)=FF((X+A)/(A+B))-FF(X/(A+B))
DEF KK(A,B,X)=2*(K(A,B,X)-.5)
DEF S(A,X)=2*ABS(S2(X/(A*2))-.5)*KK(A*2,A*2,X+A)
!'DEF ACC(X)=-.5*PI*(S(.5*PI,X)+1)
DEF ACC(X)=ACOS(COS(X))
DEF CNS(N,T)=COS(A(N))/COS(A(N)-ACC(N*T)/N)
DEF PC(N,T)=COS(T)*CNS(N,T)
DEF PS(N,T)=SIN(T)*CNS(N,T)
DEF P3X(N,U,V)=PS(N,U)*PC(N,V)
DEF P3Y(N,U,V)=PS(N,U)*PS(N,V)
DEF P3Z(N,U)=PC(N,U)
INPUT PROMPT "何角形 =":NN !'NN>=5
FOR I=0 TO N
FOR J=0 TO N
LET ALPHA=I*180/N
LET BETA=J*360/N
LET XX(I,J)=P3X(NN,ALPHA,BETA)
LET YY(I,J)=P3Y(NN,ALPHA,BETA)
LET ZZ(I,J)=P3Z(NN,ALPHA)
LET XMIN=MIN(XMIN,XX(I,J))
LET XMAX=MAX(XMAX,XX(I,J))
LET YMIN=MIN(YMIN,YY(I,J))
LET YMAX=MAX(YMAX,YY(I,J))
LET ZMIN=MIN(ZMIN,ZZ(I,J))
LET ZMAX=MAX(ZMAX,ZZ(I,J))
NEXT J
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET LMIN=1E+10
LET LMAX=-1E+10
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1:SCALE
LOCATE VALUE NOWAIT(2),RANGE-3 TO 5,AT 1:SPEED
LOCATE VALUE NOWAIT(3),RANGE-RANGE TO RANGE,AT 0:XMOVE
LOCATE VALUE NOWAIT(4),RANGE-RANGE TO RANGE,AT 0:YMOVE
LOCATE VALUE NOWAIT(5),RANGE-RANGE TO RANGE,AT 0:ZMOVE
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):SPEED
LOCATE VALUE NOWAIT(3):XMOVE
LOCATE VALUE NOWAIT(4):YMOVE
LOCATE VALUE NOWAIT(5):ZMOVE
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M*ROTX*ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=0 TO N
FOR J=0 TO N
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
NEXT J
PLOT LINES
NEXT I
FOR J=0 TO N
FOR I=0 TO N
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
NEXT I
PLOT LINES
NEXT J
IF FL=0 THEN
SET WINDOW LMIN*1.2,LMAX*1.2,LMIN*1.2,LMAX*1.2
LET WW=(LAMX-LMIN)*1.2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT=(X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT*SPEED
LET YTH=YTH+YDT*SPEED
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X+XMOVE
LET POINT(2)=Y+YMOVE
LET POINT(3)=Z+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
OPTION ARITHMETIC NATIVE
RANDOMIZE
OPTION ANGLE DEGREES
LET ZTH=0 ! z軸のまわりの回転角
LET XTH=0 ! x軸のまわりの回転角初期値
LET YTH=0 ! y軸のまわりの回転角初期値
LET N=40
DIM M(4,4),POINT(4),ROTX(4,4),ROTY(4,4)
DIM XX(0 TO N,0 TO N),YY(0 TO N,0 TO N),ZZ(0 TO N,0 TO N)
MAT M=ROTATE(ZTH)
SET POINT STYLE 1
DEF HCYC(N,H,T)=((N-1)*COS(T)+H*COS(T*(N-1)))/N
DEF HCYS(N,H,T)=((N-1)*SIN(T)-H*SIN(T*(N-1)))/N
DEF HC3X(N,H,U,V)=HCYS(N,H,U)*HCYC(N,H,V)
DEF HC3Y(N,H,U,V)=HCYS(N,H,U)*HCYS(N,H,V)
DEF HC3Z(N,H,U)=HCYC(N,H,U)
LET NN=3
LET H=1
FOR I=0 TO N
FOR J=0 TO N
LET ALPHA=I*180/N
LET BETA=J*360/N
LET XX(I,J)=HC3X(NN,H,ALPHA,BETA)
LET YY(I,J)=HC3Y(NN,H,ALPHA,BETA)
LET ZZ(I,J)=HC3Z(NN,H,ALPHA)
LET XMIN=MIN(XMIN,XX(I,J))
LET XMAX=MAX(XMAX,XX(I,J))
LET YMIN=MIN(YMIN,YY(I,J))
LET YMAX=MAX(YMAX,YY(I,J))
LET ZMIN=MIN(ZMIN,ZZ(I,J))
LET ZMAX=MAX(ZMAX,ZZ(I,J))
NEXT J
NEXT I
LET RANGE=MAX(XMAX-XMIN,MAX(YMAX-YMIN,ZMAX-ZMIN))
LET XDT=RND-.5
LET YDT=RND-.5
LET LMIN=1E+10
LET LMAX=-1E+10
LOCATE VALUE NOWAIT(1),RANGE 0 TO 2,AT 1:SCALE
LOCATE VALUE NOWAIT(2),RANGE 0 TO 10,AT 1:H
LOCATE VALUE NOWAIT(3),RANGE 3 TO 15,AT 3:NN
DO
LOCATE VALUE NOWAIT(1):SCALE
LOCATE VALUE NOWAIT(2):H
LOCATE VALUE NOWAIT(3):NN
LET NN=INT(NN)
IF H<>H0 OR NN<>NN0 THEN
FOR I=0 TO N
FOR J=0 TO N
LET ALPHA=I*180/N
LET BETA=J*360/N
LET XX(I,J)=HC3X(NN,H,ALPHA,BETA)
LET YY(I,J)=HC3Y(NN,H,ALPHA,BETA)
LET ZZ(I,J)=HC3Z(NN,H,ALPHA)
NEXT J
NEXT I
LET H0=H
LET NN0=NN
END IF
MAT ROTX=IDN ! x軸のまわりの回転
LET ROTX(2,2)=COS(XTH)
LET ROTX(2,3)=SIN(XTH)
LET ROTX(3,2)=-SIN(XTH)
LET ROTX(3,3)=COS(XTH)
MAT ROTY=IDN ! y軸のまわりの回転
LET ROTY(1,1)=COS(YTH)
LET ROTY(1,3)=-SIN(YTH)
LET ROTY(3,1)=SIN(YTH)
LET ROTY(3,3)=COS(YTH)
MAT M=M*ROTX*ROTY
SET DRAW MODE HIDDEN
CLEAR
FOR I=0 TO N
FOR J=0 TO N
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
NEXT J
PLOT LINES
NEXT I
FOR J=0 TO N
FOR I=0 TO N
CALL PLOT(XX(I,J),YY(I,J),ZZ(I,J))
NEXT I
PLOT LINES
NEXT J
IF FL=0 THEN
SET WINDOW LMIN*1.2,LMAX*1.2,LMIN*1.2,LMAX*1.2
LET WW=(LAMX-LMIN)*1.2
END IF
LET FL=1
SET DRAW MODE EXPLICIT
MOUSE POLL X,Y,L,R
IF R<>0 THEN STOP
LET XTH=0
LET YTH=0
IF L<>0 THEN
DO WHILE L<>0
MOUSE POLL X,Y,L,R
LOOP
LET XDT=-(Y-Y0)/WW*5
LET YDT=(X-X0)/WW*5
LET XDT=MAX(-5,MIN(5,XDT))
LET YDT=MAX(-5,MIN(5,YDT))
ELSE
LET XTH=XTH+XDT
LET YTH=YTH+YDT
END IF
LET X0=X
LET Y0=Y
LOOP
SUB PLOT(X,Y,Z)
LET POINT(1)=X+XMOVE
LET POINT(2)=Y+YMOVE
LET POINT(3)=Z+ZMOVE
MAT POINT=POINT*M
IF FL=0 THEN
LET LMIN=MIN(LMIN,POINT(1))
LET LMAX=MAX(LMAX,POINT(1))
LET LMIN=MIN(LMIN,POINT(2))
LET LMAX=MAX(LMAX,POINT(2))
ELSE
PLOT LINES:POINT(1)*SCALE,POINT(2)*SCALE;
END IF
END SUB
END
OPTION CHARACTER BYTE
OPEN #1:NAME "edid_data.bin"
ERASE #1
DO
READ IF MISSING THEN EXIT DO: A$
PRINT #1:CHR$(BVAL(A$,16));
LOOP
DATA 00,FF,FF,FF,FF,FF,FF,00,4C,A3,58,42,00,00,00,00
DATA 00,0C,01,03,80,FF,FF,FF,EA,00,00,A0,57,49,9B,26
DATA 10,48,4F,21,08,00,01,01,01,01,01,01,01,01,01,01
DATA 01,01,01,01,01,01,64,19,00,40,41,00,26,30,18,88
END
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
FILE GETNAME N$
IF N$="" THEN STOP
OPEN #1:NAME N$
ASK #1: FILESIZE L
PRINT "FILE SIZE=";L;"Byte"
LET S$=REPEAT$(CHR$(0),L)
LET T=TIME
FOR I=1 TO L
CHARACTER INPUT #1: S$(I:I)
NEXT I
LET K=TIME-T
PRINT K;"second"
PRINT L/K/1024;"KByte/s"
CLOSE #1
END
実行結果
FILE SIZE= 4784092 Byte
59.9100000000035 second
77.9830553121303 KByte/s
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET SEEK=0
FILE GETNAME F$
IF F$="" THEN STOP
OPEN #1:NAME F$
ASK #1: FILESIZE SIZE
CLOSE #1
PRINT "FILE SIZE=";SIZE;"Byte"
LET GETDATA$=REPEAT$(CHR$(0),SIZE+1)
LET T=TIME
LET K=GETBINARY(F$,SEEK,SIZE,GETDATA$)
LET L=TIME-T
PRINT L;"second"
IF K=0 THEN
IF L>0 THEN PRINT SIZE/L/1024/1024;"MByte/s"
!' FOR I=1 TO SIZE
!' PRINT RIGHT$("0"+BSTR$(ORD(GETDATA$(I:I)),16),2);" ";
!' IF MOD(I,16)=0 THEN PRINT
!' IF MOD(I,256)=0 THEN PRINT
!' NEXT I
ELSE
PRINT "READ ERROR!"
END IF
END
EXTERNAL FUNCTION GETBINARY(NAME$,SEEK,SIZE,DA$)
ASSIGN ".\DLL\fileread.dll","fileread"
END FUNCTION
-----------------------------------------------------------------------------------------
fileread.c
OPTION CHARACTER BYTE
OPEN #1:NAME "fileread.dll"
DO
READ IF MISSING THEN EXIT DO: X$
FOR I=1 TO LEN(X$) STEP 2
PRINT #1:CHR$(BVAL(X$(I:I+1),16));
NEXT I
LOOP
DATA "4D5A90000300000004000000FFFF0000B800000000000000400000000000000000000000000000000000000000000000000000000000000000000000080100000E1FBA0E00B409CD21B801"
DATA "4CCD21546869732070726F6772616D2063616E6E6F742062652072756E20696E20444F53206D6F64652E0D0D0A2400000000000000ED64F769A905993AA905993AA905993A1D99683AA005"
DATA "993A1D996A3AD405993A1D996B3AB105993A1D99763AAC05993AA905983AFB05993AC75E9A3BBB05993AC75E9C3BBF05993AC75E9D3BA605993A7B5E9D3BA805993A7B5E993BA805993A7B"
DATA "5E9B3BA805993A52696368A905993A000000000000000000000000000000000000000000000000504500004C0103007487075A0000000000000000E00002210B010E0000A0000000100000"
DATA "00F00000809501000000010000A001000000001000100000000200000600000000000000060000000000000000B00100001000000000000002004001000010000010000000001000001000"
DATA "000000000010000000B4A001004800000000A00100B4000000000000000000000000000000000000000000000000000000FCA0010010000000000000000000000000000000000000000000"
DATA "00000000000000000000000000004C9701005C00000000000000000000000000000000000000000000000000000000000000000000000000000000000000555058300000000000F0000000"
DATA "1000000000000000040000000000000000000000000000800000E0555058310000000000A00000000001000098000000040000000000000000000000000000400000E05550583200000000"
DATA "0010000000A0010000020000009C0000000000000000000000000000400000C000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000332E393400555058210D0902080CC86F3EDA1A9758A97D01007B95000000420100261100536CFFFFFF558BEC8B4D0C56578B7D0885C975038D4F208B451089"
DATA "47300514FFFFFFBF348D47185057680000012351E8110015148BF083C41085F6740D7E1E0FEE6FFFF6B7F681CE190780EB138B4F040D0150516A025725EDB6FBDD0059235F8BC65E5DC35C"
DATA "FF7534450805BF7DCBB710020CFF701C184854221485C07E08B63DF66E36C00D432A568B75287622D9B6FDC8769783661800031C4E59492FFFEDB7460C33D256BE8CD16485C074108BD08D"
DATA "4A017FFBB7FF8A024284C075F92BD1C5088D420183610434610C00893189DDDF2DD9410837DE33FF38688BD73A16BB7DFB2702668B0283C2053BC775F53ED1FA4061B75BFB045502263C79"
DATA "04020C5F430D7F433728386A298B5510538B5D1C2F200AFF7FFB83E900742A0401752884D274060FB6CA41EB05B92A2FDD42EB3F08283D4805180C8958C3CDFD0B4F7814EB0683200010E4"
DATA "703040F8F085060834112457535120CE52B3FFBB761DFDF70B5CFFD65E5F5B5DC22400BB7CDBDA850B8E742D754C4A02420C234D9BB7DDAD100BC8C4421012142345103B63B76F6F0B7505"
DATA "3B0D740432C0AFB001B3837BD8B6EDEC10A08D1BAD55B4CA5B81AF6D7BEB7E011AA081C9E10BFA8945F44204056DBB1596F80806A54DF09D1C0EE7B676F8FC8B460451458EBC010C9F0D1B"
DATA "0A06BDA856140010C7F63737C2410C2351134441188D45F05013BE7009E61C01BCD1DF1C5E8BE5B3E377DC87CC563DD150FF74240C401D9ADDEEDFCA08AD8D46015EC36A001810561923F8"
DATA "765DF776566A010C24032C0F1F8B151C5B3808EF4A2033C05EC683E8703304BBB7E77901742011051D40EB302A0698E05EF80A7C067987C0EB1FB1EEBAFF9F4E02F559EB10837D10000F95"
DATA "C01950120407591EDE6E145D216A1099011E38726CDBD671D78706070859490750E90B036EDBFFBFF44B1E8845E3B301885DE78365FCFE3D2E38E4DF7BEFDE80076A071B09E3C7050FF62A"
DATA "6B6FB7FB6E3A74654B06EF0B350908E5261C99E4F69CC704241009ACC0D128DFB6F13D1618F8EDDF85762944532BCFF7352018141D109168ED42B7390232DB8BC7A2FEFF006B78F6771C03"
DATA "FD84DB0F854C0C09DD5A3E9E4A8ECD771E56CAD8741354926F301A1B078B36615AFF4C6F6B7F86E0340FB2C38A4F1FE39CDEC8C3C265598D0C1158A12683F0BEDD977F042AEB4F48A30D11"
DATA "E4F84B72090C021BD883250886974521A00475E086B317DAED0882C733C99385C18BC17A2213B27D32FB7CE4786D61A1F4615FEEFFDF0A04740D2F6D65057008EB31D3570853355D5E7647"
DATA "058D8975E40F84D6003833C9EF191602A2A73F220FFB2BCE170EE859220996DDA4EBF81A2B861E17504456A6EFCD2609652604ADAD6D6F6B03130B1258590A8F0D3B656F17037548757435"
DATA "12B0B451FA9FEB244FB401DF30374E92DBCC02A61AE306A5D618C34010DC8D8B2F33F6382F0D2330A130170835FF54ABE03E4E26DE123BC0212B9C1E0BC1E325A12D0FEC47F708FA600484"
DATA "0CA56F0682227D4F483C03C8AEEBBFE1FE41148D511803D008AFF02803F23BD67419D270DBF596380C720A0503420AC872F7D674BB76C2281875EA765DA3C2EBF94F307CAB630D68A2035B"
DATA "C364A1185815F82F1884E8E88B5004EB043BD089B3D57DAB295FF00FB10E23F07F5EF4358235033420B0C7364EDA8E9A2A2018C369410959B49BFD9990251214845A0B2F6E8B7DEEEF8014"
DATA "1FEBED2C12790E0C0EB1C39CCA8918F616EB9A840667501555A81C0247B2E5535524325D845A2E94DFDF383D2DAD59142814C9F52047E87ED6C98F2F9359E9654E500800EC62376D82C625"
DATA "390401BB9711E658F745C05A2C5C0C0A37814960EB122A5CE96D0C63C3B60DC7051DFE9C7C7B8069B2862AC5267FCAEB2E7FE4FBA4EB5712F8F7D8591AC0FE44A1FFFB1758304E75F45783"
DATA "E01FBF316A20592BC8833060E0FDC8FFD3C833051BB2AFB9D9D71AA3A50020F81032E90874CD1387155F746A0594ED499E1ECC6A085398B84D5AF2DFDD6DE36639056CF0E460A1063C81B8"
DATA "0C508E9BEFB74517754FB90B011E8818754137CEAE12BFB91B2BC1D8A705DA168C77DDCEF740BE00807521B67697365A816D2A6500DE8138C6C32C6DA500E294DCD77808490E32C0130F80"
DATA "4FF8D878650937B9478740803D61D9B60E73C0061C0C12D54168983D2F8107695968EE86C308258B112183E11F20103EC60B1F83F8FF382D97EB0B6C6BDF50E02EE75A1BC0F7D023CA3A84"
DATA "6783158BAA16D848B811BB5D18141BF40003F8005A5A34D76F2BBF4EE640BB57BB1A25DCF62DE985C6740942A31AC325B68DC2668D706F151AD052C18E9D0B7733450E083108D138B2999C"
DATA "24ECD1049EDE5A6B6B670F33070205C83BCF28DDC0DDA3B94F5B9185CEAABF4DDC5E250D114725C1E0CE890D7AF7D14CA609630714C5FAC176C48EEDCD39085A10C30BC612568756AC5BB8"
DATA "0B100549EDBE56E2A5B4E3048308CF050DBAF6EF6746022241D8E881EC240346A2D9B0C4536717870EA805B76F6FEDF2CD29848D85DCBDFF68CC02655650B7773DCD8935207C4489858CFD"
DATA "1A898DF97C3EBF880595849D80B57CBD7823478EBD668C95A4068D989D7485F3E6C89170A56CAD689C8F859CE6E96E053BA78594088DA0D9BEA1B1C781013C8B40FC6A501D90D6B9581BA8"
DATA "8E88308BC70F0B27B686074006AC757AB4D8C9FD2314568D58FFF7DB2C0A47B230B6E11ADB97FEC31E1CB2F8286CD17518390D03C3F87B70F85DFC2105E45E5B67B60BF8F7D7560A53D61E"
DATA "2CBB043BF373183FEB06366C3EEB098BCF5DD783C60479066B6F1672EA5F352A343426DB7128FF25080CCC00686EB199DFC1109064FF35EB44FC896C23C6B6D9038D2BE054578041A146A9"
DATA "B033C50240AE9B855E905A0B46DC69778E8EDF64A337F2C358642B00595F5F945E8C63C651F2CCCBA09A70F76FD32C5333DB43091D4F106A0AEFBDB461E8F27438E8ECABC0830DF0DFADF4"
DATA "1A02B474891D338D7DD4530F757CE16FC9F35B89078977954F088957E3D48BB7DFB568E06481F1696E65490EDC356EE574F95B636CAE09D83547656E75F7D9A7ECAD2FB6581AC96A11C101"
DATA "594074436F7FFB774225F03FFF0F3DC0067B74233D600602061C3D70B334DB3F153D500603140E030715FBAF370675118B072883CF018908D7B5072B37107DF4074C8CE486B52D1E0105E8"
DATA "7C327D58C136CBF69F758D5DD489038973B94B53D8A9154C1F257424ECA8999B6161B24E022CA9806D6DDCF9D00900045C392417DE967AB71A745506704E560F01D058162ED13DD855F405"
DATA "F0F402BCD5169306136606753326CDD902EF2FA13C99083E03F6936D7B6D6920243B1217204E5A889905136F5BD139F0481FEC1741D4FA3BF1F27502A36076B0B7F27C0DAD45B20B3CC335"
DATA "A7B1680910C02DE919630A2CC3305DC9C7AE3C20C76A0259693A30149A9B9B37052C891528891D248935209AED2BFDFD3A1C861848060D3CB334DB57201814051425AE3D374B102D0C9C8F"
DATA "40FBC0DFC6B36C0734043882080744DED358A48B67E580B5A11C69EC8DED19393C1330B70934AACDF6CFD809406A04586BC00F8044761F6192028B0B894C05F80FC1E03C3A754E14079084"
DATA "3E1D0A853F4BD02420100AF0510B7DD72A2F3419E03853E005A466890F85B737F63BC6750F163412104477FEF8522437083A4C77676444D7DBABEDD08D8DF46C6823D773A1EE525150AE6B"
DATA "E07DBB26FE302005765AA820A700BF0F57B7D594D91E01975D3F6BD4377DADF0BAA16C3628104850DBD9BEB306E412DB0BB4D66A4619B97442681AB1D389C2CED7C18B13CDDB749B902B90"
DATA "237CEDF6B76D8CB750006864E8CDEF3229375B82DEC30D46109F130676C3CC009D088B06B3FF124B2FFE408B4E0403CF330C384EFB1A22DB46080F0C91E912CC3FA1045B23BD1C62DC595C"
DATA "D8B8C645FF0B43047310FF28B240830DFBF47EDBCED5680250104C6710B6190A3168DF192DFCF64004660FD81FDD60A3DBE48D02897DA77BC543FCC0035B4BB2FEFFC0744D9789EDBF4847"
DATA "028D04478B1C81058128241B7FF725D374668BD64718AAB101884DFF36781FFE16EE6A7E5752D363736DE075347341DC69DBBD5B372B680728B51C6D047B402967AA1AAB119F030A4BAA07"
DATA "9E00E6F0953281B45D54DABE7D811BBC39780E5FEB4B8A5C8BFB83FB746F0DDC8C8573D584772FEB21D500EC426BD4EBD7AA301E68EB59FB04788BCBBA4618F3565AEDC14EA0BD552CF1C3"
DATA "27FB335FA1D70C63F32789580C2A7FDB73157D2D8B499518C1CC25F5ED76051A8E04174B09237653AF1CE419D51A5F3BA8C7E8D5BE175DDFAAEB1927112A24A959848EC0848EC5BE123208"
DATA "3722176FA37048B358152B9D3CBAC0C7D62811A930782FC0C6598937989A14F190EF8B4C240C946161B7440808C77C2451C9A52F7FF7723C0169C0010083F9200F8EDF0081F980F81F3C77"
DATA "050F8C8BBAE428017309F3AA0DBC0B994164FAC312660114B61BEE0F83B220006EC00370ECCFBEC06F660F110783C7A8E7F02BCF427E4CEE36D8E18DA4246C0690287F0703CFF33CDF4710"
DATA "042030405060A3777C3F708DBF3D81B013AFF7C11A257BD89BDAC5EB1377733E7346B4D3DDB2721CF354F37C25D9EFB6DD201373EC351F4174628D7C39E01FE2CF162CBF1B030E880747C1"
DATA "D99E354F0D75F21504B6D9B6AECFC304170477F87420C1B26DE21D9B056D47041F0892D4ECC90875ED542B952356AE4D48CD9938238648D3083C28DD0A2C658D37133C5CE47A63EC05C30B"
DATA "8B1532CFA4CA8BF20513FC9B5D33F0D3CE3BF7746904B71B6EDCC0EB63783B7514F5FF36CA1493767BD105BA2FED1375EC3BA0010D6D47EC298ABF0BBACFB1588BF03B139513D6598703EB"
DATA "73EDD9B3B926EBD9078BC29CA19F31477BABD314FA873B3EDD9F74CDEF5C03A05733C08D3C9D4C9E0FF6436F6AEAA90B8D4101C423C1EB26F62CB0EB1C9DE48C56090853736DCDE0335C75"
DATA "27018357DB62B20BF6565619EBF4F61D762116A0095787ECEB11D6C55807B407A9562154DF8E986DB85F80BAD240043C20D0316209E413F303052438C517B976ECB9EC3FFAEB036A32585E"
DATA "3F5450096799B056213F1A18117B8EB214426C6809ECB9092BE84211374239427E9E23807C806A0330139C6520202F821AC49E019C94092F86116EC2480F345D0E1B89E63102A54439B0D7"
DATA "1E107BA80996393750B2CE353C353C0B39BE011BA1E67D5073C039B801994A7EC06A0648B247C49ED4CC099F3919B0216C0C3C4CEAE82126E4E7E0E86A08148799B1D929EB0C0E45408ED3"
DATA "18237157D2BF55D778FF901A63766A0959F3AB5F698AC6AB113F2745D733B6526BB51004D845368276E0B7E98326005381FE4075E0270006BE6E5AB08B542438143A45905DFD1855525051"
DATA "51531840D556069E3EC489512125B6F8EE8365308B58082D2C33198B703EFEA92DB90D633B4319FA08B9D0A0ED7FF2762E8D34768D5CB3530BADAE40A16D8204993B7B38E887B9BF43E61B"
DATA "C1B90B0CE0EBB0647BD508E71A00C2DF56B95FF7969841040611B82774336FD822B1B46C48BAC8F0EC688D58B6D660740210149AE1F5F7CC17AC23C68902B8EB122622D15AFD10C65596ED"
DATA "5673521C41711C021828A2D5B6C934C29955FD16ADA55B359ADC33D2C633EDEEF4EDD0D15BD8128BF18BC15FAED45ECD631DC933D2E64632AC5DF0B0B85222F2C7BA425FE132771B6C6452"
DATA "517694C2935AB98240170E95D819B41A7D8015B2597CC42D388150606C7427C61ABF23EC750E1F168E22195990FB3ED6690FC8595956CD0B9BAB95258EAD60FF6C338A9331D8CE30AA138B"
DATA "F83B59C76EE0EC931A6464426A28CA3109C06CF6731A1B1256305A30D936EC732DE3EB38FECD457BB61056AC8BC7E31D7F23E162BF0F311AA39AB5F0687824967DD7504AF808EBE56DCC92"
DATA "99B1DDD5870DEDA39D88BAF8B9CEA86298876D472AA00F5A573505416307352A15543CC0B2168DF8B637C702FE1872DB144F72AE706D6F89CE1F59B741FB756B236FB80D90B557FC32F670"
DATA "FF0D3AEFEE0175EB5F3A6E490903B43CC5CDE884D23CC409D155B34CE8E1B461C88BD55D14254B73658F3214FC65C7ED8DE85028520324528E1B11D4F2949208644455A516D2B71CFE64D0"
DATA "5B45F374021360895B28B7D20BA755363A837C6306063BE4E24D9774762D558B0CB389DF263D69FA567CB3571744B3589DE03DCD0854B7B6D11E2BB42458F9D20F8179041B2DD0F5837B51"
DATA "EC524751D1ED5EAB08D2DAA651BB91700E3814AC02084BFF37B67AA343D26B0C553058B6595B19AF851DB8FFD016FFDFB3E0B9C2DD157334CCC7E0430A894B6D34C84651990C57F77DDB8F"
DATA "BFC1E80DA80174394939A130F80763DC0FFCF80D36A41435890BC079052A146AE12DFF837E1C600DF6E7C7A96277AC823865DD19A11CFB63B87B896B8E1C5BCC3306534185356AE6023B81"
DATA "C7157F7FD6820848EBE88365E42037DE59169DE8CFC35F1BE3597269B905894E1CCF3E66E4FF5A64B05F2FF2597FD8798B919CC5FD7C1408763BF2AE73217D0C85FF74DE0D38070AEA802D"
DATA "7CD3803EBA0D31EBD173D9EDEB59509F06937DE41C18A216BDDBB4A6E000AADC259FE1E710B13ED936B3E0CCBDB8E41D83E0912FF38323BCD908C0B66A40735FF15E271CD9A816B853859B"
DATA "E90408584B7D148956B6198017C42819DC860AF0901C4D18584256FF02860C6C21F7F639451476248D3BC5D28DB30F534F576B23147AC9B383C4B977AD72FDE8066A59E5A9C004928B41AD"
DATA "B6D2068CF0E4CDF00DB5DE505392AF0AD3897DFC8472B66DAA8C231F3C200C2A4A1D6F68C4084146400F8803B63B91FB5BE3F873051D2BF43BC20F87CFA246765BB52731FEFC7C203B10A9"
DATA "2DFCAEE22BF88B55F8012B293D326E0DFF772BD0533A3B7DF07265B83C7F4376053BC736EB54EB48FBF085AA75F0DB6ECE7C39C21C5E777456F47E63BCC06E045C8361DB518901C659DD52"
DATA "BC0FB944DFE4128781788EBBF6BA6E322B6E6981EB295164BB8552CB4A15C8B91A5A1C85D2E85E8A02F18B8808401F4FDBC284259B4A016D891C0F615730D4850EBF26A51DE24D70A009E6"
DATA "0EB0447FF733838F2222DB6AE1EC59F009082BF78BD8D668B504B710396E76128A70EBE7D9906AFF45936A09781FA82F5D23082D579DF8D3DBF6A150CDC62C3F182D15C80163659D36567B"
DATA "0B05A4A71973555656B2D00E19041DB13BD2F8BA0B07A46420336EEBC16C8BCC57C0D81556A05714B274A2AB2B6D3D5F13820E623F6A165E893075D55381CBADD51239A01439720F60E275"
DATA "E64385BA5C3536EB14AC63763AB3C309400119AC2B602E734E22708ABDB6031B58628007138531A24C131B12FD5BDC7E63C041B60C7F0B7C0506087351D99A93ED52F58BD8111410D12C61"
DATA "2D6ED03BDAAE2715BD350AFCF87F067CC46C0BC83BD15CA8D14A64D2949B83480968016F48B81602EFD784172DE03124499490E582F51F186346DE5536CA304728210A8470F81D260275DA"
DATA "834DE4E388C23ABD8485229D0DEA180813F221BA0888BA25B6EA0E02ED0775E93B647E36481B8A8B4086EC0CA80675E24A7CA9AB1033D570087E6804E82FB1D45D2ECA6C3FC1F9066BC05B"
DATA "FFBFDD260C8DCB3D48F644012880754A807C0129DB4313B7588039DB449056562F7CC3C2FB507D8BFA9318FE24273BCE7223C4422C347A8D4350D999B910CCBEAF1BFA5751C1E620BCAE0C"
DATA "5BF57909155FAA29A386FF8546630E2BC1993B55107FEAAC7C7FE2BBEE7BC777E13A3911D80EF877D203CF64E916DD06890E9B297911C684168359BD9B5C59879A330454571CE4C261F885"
DATA "F73FC00CF02108636900DC133E40531F21C4B2CF96EADD7C8582329D0F174ED4DD8357F803D85913FA0C0EEF49599821D850396008C373B00BB932020AA06AFC60AC7C8976EB2117D0E041"
DATA "3C4198417784390882C7401873846ECC77161080503323C201CB922158220B02A95D419AE2EA0B0C99C554303358A93D1ACE18B0A2D70A0CE3C69B5C23D88203CC95171BDB0ACD02FFF7D3"
DATA "23D8741C8B0661F80B9657ADC6A3773D9440BC95A271473BFB21C96D33CD5B58361B52CC5B5A5B78D1A7ADEB17C174CF40B5670906D7D80A0C43C5856CAFB045445EB88666EA301AF074F8"
DATA "12F20A60E547552452C0680113FC2F57129772438D5AD478031676A20C0E3600C3829093450EBBBE012CD13939A9C18475F58BCB42F0E00E81078B79CF921A352A31255767F8B6C10ADC0B"
DATA "8959850F014CF1B666C1E13E5523F8890883BF212E95968185C41F42248D506CEB0D0C850A1B9FB70EEE7FABFE75F68B5E08B891A23901774F744481398D0B9EE5D95A00078E228F119ED8"
DATA "B85990756FC79581CF66699EE6E908865D83548206D99EE64B84424C9293BAE6C941B402B50222288D799AA77B19088E108507061BA7A08A3C32CF0256AD3D847F5989AC24FE6DD112DC04"
DATA "EE95CC5929C170E1E4E75F5B9392AC1F0A0B1D8146960F94C09A5170B13938B6BC287BCFD8A04FB2273221096F27760062FD825952581E7C5B65166E833D0C003F997FB9D0035C770E0487"
DATA "017C02F5432CF11D75DA1DB7D383E2A1DB2223A2CA7E0D2B08BA0B0FBA550D33D92FDFD3E1DD6085CBC5B8D3883D20EB0AC28B047C65010B2C8D74D27404DD5311F43C2C70419E6F104440"
DATA "BC5E02DB09969E010B26E2F8013CEB162CCA26F186FF30E700CA0D4625C583FA3E0167662FA5E466FDB7056E2E05132B715CBB64A13028E73AFDDD4068C65F4F0F4BC240732A1874CC0047"
DATA "9C50A9288FD66D1270555A3DF38B17FFE409F803C1813852E6481875DB83789283EF1BE376D583B84A7223235CE5005682ADBC4D83EDF6DB046178D6235611C425C542A9F8510D81424C38"
DATA "775E78F9129D1D5A3BD42254BF7138041242A3A2CC260CD016013D6C25D861AEC0CD1D1129143EA0F082C8FABC3DB78B012E68BC1D62B004D3589D62653960032AD97B8F39E02873490F12"
DATA "50B9326A80D7FAD51568A6AC6B386C19E0969DFC53FBDFD08B7804F78A07EB183C3D740142D4EE3F117F8D59018A0141D5CB4603F18A060A19096EA5E4CDB5045015D89FECD27FDB746D89"
DATA "5DFCEB521B8D512ECA803F3DC1B6AB151C0C7437E550E86738204330571C81306C8BD60544F9E0FC99504FB1AE561B3CFC9A5D0336052FB4F843B8A9EB11C729448061ADC3BB59AB0AC13B"
DATA "A9969DC3CE50000ABC04F88E20CC60741F903816B4D8D6FEBA3B8D7F81611F36F3071FF0564085A05DE000F10B7E0476A0C110E8F656C48C08096C74811EEB7E15481205D2153B0EB8173C"
DATA "141CA8AF7B7604E4C21A184729B7C8F37D119F11730ED2149A8D7CEFFF35490A441836CEB3685834E9E11AE760E88675728F3C616B3A0E591C8BE92C56AD2A6AB9680141CAAFC99969B234"
DATA "108A50800A3992172B36BBD0542740150C374D83932B1330054F994DFA0C81B73C760E926832952725420312830D4618A5C1D1D86E0095538B97189E0CDA60A008A4382C47E717782B47E8"
DATA "DDF28B5BBBE61F55E017DA33FAD2A1CE33DAD3CF23AE400CA2FEC41A0807365C99B5D1D9F05A17881691CE3B66DF72FB422DF1603903741633D633F2D3CE3D36DB86748903FC95E8635F84"
DATA "0BF7B95C5A000180D5DAD6BE97CA894DF8402CD30649ABAEC01BF93B4DF47F5A3BBA92AB4B7774A00F898BF9C752B1495BEEEB8E805557084EDBC34A4BA9C299FAD3CA2EE8C7B642B33366"
DATA "0FA4100550047835886706085F2E74B3E130B2686615F856E021340AF7152D9268D1C2A4C62D1E65C3D67A5B1B7EABD88B7609ADF0148F548D36AFCB5FC62BF3B85CAAD44350C12C907702"
DATA "DB1AD12EFB8D3C46C8935F21D327A275721D126F65BCC980A13624C485435B61A6D696281C511F8AECAED50F908D04B1201E8D34B995D10A18F17DFC7E6132741B027D7E2BC78055FC2F19"
DATA "7D951BD2F7D223D08955FCB4C29BB88A55F42C89118D49A8461FC3D05CBCEF7C972B175389426DE14182A55D14A06CF77BFD0989018D47C7110B560F41040CC28E3E17950E081E5B5E4082"
DATA "481848943B256009BDD05A886BC7607BB10250DA2AC71A325A1E58D6859EC8288114B7D88A3B5F751F5459AEB97889064D0273939091ED2C5AF8600CF8B9C0DD64EF8B3790B9DC41A0C5C3"
DATA "5A11199D2DCA5C11D91CD90B2C337922E7BE3EE907021656D8C6A3D46D4DDA3512F9FC0AB9233305673869165CE1EAF36B7B27E03D10CB6041226BA056FFEFD7087C81685E0DAA41A40A43"
DATA "B61591E4A3891278C8C8256310A87C784D706386760D7C6A42DF55534D69F1638DABD02BD683C2F0482D0BEFEAC66CDA74296E2FFC06D5C9FFF00FC15416813E3735706DE05425D60CD8C7"
DATA "0680A941EA0F79D7E46CE07BC2A8BAA804304D6668880044CA09596026EC6C4355F824EB2164F886FB2CC34CCCA015BBC8A00456247468591CE86B1E2B08B024C2D14E897D453C177DF0C6"
DATA "37508BCF85FBDD742D565DF3742D6D233818849B893425F01BC72006A0D453591E5EF4A70F185383FEE077C31746EB14414730373C6BD885BB4C59297613D60656558812D9EB1902965106"
DATA "0C6408078558195652EC82D233EA680A9B17C6E7F0B7DCC836311CFA2BF28A043E26A8A1021CAD0570D25970D3F15FBF0B880A16EBA13F36F7F1F6EBD390FF74DC16495A590352F08FF6E2"
DATA "800274212907E520B6281A6848E2988B4F1232460E0927FED25B5B42C414E0FD58F7F6D14C641BF10C7234E00CF9086D620B81CCF9E1C647110560AC15F801BC03D4D0BDA1EB16A13DB087"
DATA "1278B855F95C4815074C03445615EA4B47ED8D57A707528D775A6DB1FBAD1638484850890E186E732D3706FD5AE007CD0F408150C0D4C52EFD5EA802750DFD02890D6C01A01BB030733510"
DATA "A00D9FF816C422ADB70441EB696F8F082DA873980D4852A6FC46A57B4D10A516BB04017E0E515ED61E16976FB5320D31E9E447302B94C328033CAC760471FF576D0AFEB4828DA082E03ADB"
DATA "8B0842ED7412305EA2D992FD20058985D8B65770E6081C897005E09EE7F9228DDCD8D4D019191979CCF8ECC819191919C4C0BCF0219F4106E8F430FD98034EC189325C97661973863D1108"
DATA "04EC45DC621185BD8BF84C16119B70B6731311100E1DAF0F0706036E21232A5F1C582B8051643D3821374087E10774358BB05C63A22B06CB5A08BC06E403081830141E6CC00388807272D9"
DATA "2A13ED7D6979D2D38C66D431DFBECBD8CC81D4BD339546C33F05AD405C88AABE17E1070E0438A4024156315E7FDDC1303F583B0CC5DD742740BBDD96FA83F82D72F19EED071177480D5894"
DATA "B66868748D8169F80E8FC8D72D6102CE5A08F7042FEBEE1BD6AC7791B94851890893A915A935A2582152DB760F82127506B8D988C33F1412198C9A0B841068C01785C92971CEDA9CDBA568"
DATA "FD8BD6C1FA06700B6BC80C04BEE8478A9508082801740BFE08E1D020ED79EB0ED409B03709E4845199355512E201C8728534DF9B34569C406BFE42B92F1CB0563674EB53A678373B9C6BED"
DATA "0DBE3F48732F70B5B0B87ECBE2C8B31420BD3561AC58D90D53EB1B4F9A7480653170916DE0AB7E06744B33045B4EA109DC9BE059BC09F6808836C51EDBB75A0D641CF640586B160617DEA1"
DATA "E12E159B37CFC674D07046B0C843128C92B678E1D7665B241973BA4FCF83E77C7C90AF78D7C6441128D80C2A52B823F69659982E6E8140CBD55A20AA1B63C04010B53C96035E0BB763E4D8"
DATA "38EB068B7D0728A3AF140C781941AC0EBB13318940FF500D0075206B2FB62B1F560B28251E54E3D057E0515B4C003661900F2C20811BFE7E5A5B7781408BD7928934B876002C13464E8B18"
DATA "C75F13D15E091704A2C746103D7A13708B323847EE313875AFF0F0C19D49ED013A4E42B563A77AAC8054FF34068C0C592F266C6C5206DB205C723BECC11B300C75D884B025AD76B2241C59"
DATA "5E392E685D13238341576CC8E0FF0468D054AE3ED68F1D8C2A54D9F1A059DF36414DEF06C4897821781C89386450636B047C48EBA124C09BE4385C08429DA003BD82735AC6DE8B359A050B"
DATA "3E0C14A4C746C605181C9E0C870816E0386C352A1D9A9FBBE0178E8883C791C3FD8D1C9F06418B74066D8E37362146232EA8A1F859DA8D560CBB238B566C0597CA0BCB410A05B3A8DBB52F"
DATA "24F6D0261BC6F61A2A105FB1BB712C01FF4DAA2B8430EBF26A3838ABAE268B41074007C1181B03F6D1B60700D5BE2DC883C089B9718D8A92C5C10AE086EBB25923006D09E50C346524F08C"
DATA "DE7C08061BFF760442B8BFA64E19DA44F021C5989D8A5BB08C08FC198D7135548B175524033CD46C4B75C1C5B60BA887F64013392BFA0D1CB55401E66D7E305750510DBA9C8CEA7C143BF8"
DATA "C0666B4FDB1058920653113878020BABD3ED066AFD132106623C88012CBF09B93A572E0937C258BDE6501E630B3B0B381940121576154AC03BC4E2DFE72F3AE39664B3771C200003DC0051"
DATA "528C080C78ADB203286C3D8D0486ADD49922833636B83BF074B13E72D89060C58442EC408116366AC247DFF8FBBD1137163ABFA53A07E3FF9FEB1CB26EB704761823D1E8220F1D5AA2F7FE"
DATA "75030945DC71114BD4A1B6D26D2FEB956D8B1CD841BDB99731C03B265E26E474034806A3016BC95D07D10A555DEDA2E8ED9708407DF0AB8D7503AB8BFB28DA43A582C9B45837A0FFD67363"
DATA "0146803E2074FA8A3A3C6160E2EEFF741F3C7274103C770F85D4CBC70301C4B646AFBD89890BC728DB301209BFFDCDF6180E028AD1884DFD8AE904FC468855FE86E2A6F8886DFFB101080F"
DATA "84E10207DBB7DBBEC0D6537F4E5D83E82012B88D6F0DD5859374421134041874275BB32D2F0A7415046C678A3E84D05CC4FFD2751F830B10EB35810BC94DB66E821BFA3C7C1C3DE6EB6301"
DATA "E1F7A0ED6132C90830143E84FAF6EEE56C5E36E820B201848ACAEB5452DF08D5F6547440040E87227511ED31B36C66060038B9EB2644C79EEC93FD62EBB90B40EBAD0720EB827B6B9106CE"
DATA "51598AC863471B7617E084C90D03F006851782EB03A55A107E79ED743E0916BF970D6A08959CC64308BA3D58535C8002E430DD10D2863760647F0C7F60C6035876D722F6F6380674FB323D"
DATA "756D09B42A0ADBC9C814840B280509C95758D81504773FD81E1CC8F3F20C0802206A072421B4B31C1607F3E2152383874DA397125B308629316257F1C9B1C433E43BBDF03938402B504733"
DATA "80BD2C0C2FEA0F4055688001D18966FB998597F02C86D27814A0293680DE65FFD54470AE16641A956211CEC8F61A524807051C0499F9E6AA830DFC89411084ABBA942B44CEA840282EBBB5"
DATA "14CF4033B0011ABAF6E46602CC1F85C20BC21EAC15DA1619A9F4201C0B0DCCF10D00471F468071F755B0381BE2001A814904F20F324397216104FFF7FFFF5705CE0155B8CB46AE6E70F08B"
DATA "4A62E0FED1B16B5560A3D7C917D9103121035998405D700F82F02E61825B302EB8B899965F0C537C926BF837009C269F8D034C3818065BB06A06F98C3A2FADEDA5ED07801228CA05806406"
DATA "FBA76AA93BEA0A8BDA6BF23BD0D3F42C5D6A3C65C851F91A85C747FD52CD086D0A880E4643A1ADB59B62400471C1731FD3462DD8F65DF8C302C6060AB602461A070B0D25F891833607065B"
DATA "10E85048341B153B16FFEC94B4AAA6C290F1E17DF5DBA1E70ADF9AA4DF8748CCFDF6D2741C3DFF80FA56048816EB3E4B1CB68D021F8854382AB24EFF190D15E84AEDE03BF2077446B5AB5E"
DATA "C012F3FF4D8FBDC26BC029232F85A77F85C02736AAD90F82307EB7C647BE1F6D0C8A4439282E360C02805D2BB8880905EBDD2BF28C841926DED956C26088119258561BB660B77C6A0A992D"
DATA "545955EC8E841F726DE066391A59722BFE3C79F05701020FB70BA1E5165C61835D9D602214A391BB6D365A3A55F445E2FFC1B074835466890E8D02574BD7B55BB141C2D8733374241023FE"
DATA "6C5B2BE80A592304C00483C67799FB4D4389163A37BF0720CB2538108702FCD00E6661DE8A8B09F613963D3F8BDA9158743A6671577744EDFC66BD7006EB67E0E1D0823907222B99A4ED6E"
DATA "B00F74382B0A5A162CEB3BADCE9DB0153612B00B35980564840D92EB29B5FEB359A3B747582B415D272034177E375DF0BBCEFE20B8069DB05D099C0B292B245AA116C2FEBF876371126002"
DATA "312F3E66E1156CE3C8037327A759950EDB8C672D4DC1A815F3D0098086A55AC07C382460C1467184BAC54345A073FFB17806258046F0E742E076ED25EADB42EB79FA047712140E4E4210B0"
DATA "BDF1E80680B8ECD7E98A0E0DC14880EB6DCE800EDFDB2F00BF322A502140B70403F29C51A056F653F93546DC364A0F362A4E02723ED8BA60DBFC6A46F0E62B1503736773B515F412851C15"
DATA "C006F4AD2CF1EB14F7DA68012E41124E674C122BF3503674090C5653C3E9FD4B8AC28FEC7C8BD085D28C07106C7756871E573BD6596DB86F77AE02C0325B2D24023005BC12C192AA01346A"
DATA "6FF5A7A89600F78D1447033BFA73B72FD5F85E8D4F0253CDFDFB1A7437040D756579D9F8203BCA731CA75F398B7D1118DFE7E65B83C01E83C1EB0C0AC0A1103C7CE1C1020372C3EB1A86C8"
DATA "F097829CAAD0421128025B2BF722CF4283D35D7414280D2B390347185C44808B9680D68C887AC14788624E3C8BDEC1FB63CB852006E94DE09DF0B62C01AD015614708DB65B04A284E51BC0"
DATA "A301049B2303A7167C5622D40A9E61CFFF44EE3DA045CD4951A2161C96EC368E41EBCC2B38106F3CA2822B70CB0B44B629D7820A034C305CD5A1B382D0BBA328ADB51442E1577C109A9E34"
DATA "171A3F1062031D56030F0E756418ECA033234BDBE1FBC1FF7C93F001BD55D7702BFAE88A4C022832F6C11C253047F670833B81F9207667162EEAD3208659F6023460E9EBADFFE385EC0259"
DATA "0C0DD076C1975E3B740218B9022988455B33F6ED5C4387E8671B04F3C1F7A9E5885DB474198BFA7B96BEA59D4B46599AEC1884271CED4616C76E2130862647A604E0BA4459D1E9DD237EB8"
DATA "B6E1052F3FDA301EB66156C56AF079DD726545579B78F8001BBE06DE59BEBEB9084B173622750041534888BDEB055C717C1D89440F801A558A7EC689540F24CE5B86680BB69633EEDCA533"
DATA "94A50F2C5DE0C31A87FFB1FFDB63CE6C108A5C1A2A885DFE80FB0A15D64E3D98B81DB002165221E8A0FBEC8818401949AF00E48F053BEAF0B304852E022A0A8660ED6C498417143ED5C406"
DATA "972BFE3CDD6FC26B0016E4CE37476A025F4309BBB0F02B0A8A6E3AE4753E4592419A932C292503D55C80072C0A53298A1B710722D84733E81C4E91668312C851D8E42B6CE1BA94244CD2DB"
DATA "4A4718D6B53270E050C6B51EF8215A580D1C980D1F847D1C125049415E468E5BBAA3540F6C8D3C4712C6BE2F06966C0049474392EF97BA5A2539767752037DE09955811ABFE602A9887417"
DATA "1ED245FC4C8026C841FB16BBD6FE00EB8CD1EF1E5B16DC53DA0BB8CD8E23434BEBE5099BEB12C152B3F4A1605F45558C47D217D089382E5FC3B4B1AA6DE437110B0FA910C80847E58A9285"
DATA "3821480856F018050562B7494A127AACE00D6844124384C35792DD09C48F0C108532DC40B4425B0FC40E6A10C4D857EA363F0E0A18F70974492775A28A715915BE08B6A81B089418709260"
DATA "09A0565243CC35D8BD4A989D2350082EC4D9F8B57BAC20FAFF8CA37DC07B4F685D4A32A035B96021960DFC270920E65A98506356540AD0595B7D74C03011035B5FEAFD6FA21A2632388A40"
DATA "2824823C82756E73839895BFBF6B8178328865EC7524F106748E77F51C7284C310FF21088A11AB060BB441D0CAC2CC327AA7BB5DB595C14B8D0CCDD852D4861618C0405C5B5E4030E0803B"
DATA "4894F0C500C2531C1A8C0B782AD94DA04BB156E393F0E0567DA10D41087D03D2535714FA15858D885062E54BDC3A0BD61065DB7FFD8C45980BA7ECF13882E48858019AA49F09BE252EB550"
DATA "66C71BBAD35EAED765830E95E6FDF8CE30C877E9D40CC2B3AB01297097BA950133072B4174490C57C70BB4997C8E03747CD80186A197546B7526473E072D34199EB55B7C741294AE4D39C9"
DATA "4E72349B6022FDB25B000BB5231065F0282B12F056BF53780439381BACD723F9A195DA39BE413F1F5880396CDDEDD20D890183D234473B1A75EE1CEBA1C5B288223E4D33FBEF08012EEB3A"
DATA "1ECF0BCB742FF03DEC16C1CC52568F4BB52928F53679EB19BBC497F00DEAA15238B7BA03F713D31DB00CA0041D53576EF0700974C816D0AEF80203373664AC83E14FC93081B8844A555507"
DATA "B3E884DB2E6433B6082975072B53B9FA3857EB08F756623F68220F55344D34F81482862536C11199D9B7768128BA629903074213DADBCCC613C480EFC6A2578596CA10A1F4DEDC3175D083"
DATA "BBB51B42753B572B5001AD5BA8C138CA4A3B093CB4463D36D1540D38051136D5DE13DF41FFB8D575ED3118368B9705EB6B570856081E1DA141CAFF0EC5E35B34947CDF7F2BB9FDA618C21B"
DATA "32F177206C4C2B1A108A13930618078E1D7BDFEB0B121899C24DE403D0EC6414E9047484ED26BC1A26FB6C0C8BFA1F8B50AE2E1063142BC61BD7502CD5B603DC13DA3C5F0975A493061810"
DATA "09B80CACC1F484345309D883793858BAA2182F4EC5A8989903C04F1ADE50CB8985F85D6BFFEE05B48995E8088BF36BF930C1FE0624AC49BB5B67B5443924032053475FA30CB31416B42EC2"
DATA "81B6D9DE8B95070DEC3B5427000E5B7B68E1DC443509D7A6B6D76EA968F01B5068130BFC629755775018E4B026A93584137A53CF29A7167B96E795C08D9DA04DDEC77E29C57C0A7F7B39BB"
DATA "77738DBD55E13DF6A5F403F88D8D09F6399519B574EB0B44B13C3BCF73CD013C28106F6FFE138D47A2C87318AC356A15261C4FF107E9205B08C003C84E3BB5A560F6633BC83BD375C4AF83"
DATA "1538BF8DC18185E81395231A600423505F7D273556FCBE4A208748127DE553182DFF014FD785FF4D7D27CDAC003DA0EDCF728934CB531D36C715D0558D33DA3A83106957EDB628F55113D4"
DATA "43E9D84A361AA35AE4F585E837A4BA1CC5474FE4CBC87C07F548DAFDB6ADBBC04FB709EB2EC28B158B1D57896EA3A4008C8BD68A3E28020CE8825634D1C5A1994F59B511BB0BB580E1B6EB"
DATA "4D8C8D4DF38B13A0F8C6508DD10001864E480FEBD31307BE5BA9F0984374C70BCE9D593F49579BF6643128FD5FAC732F2C68624EDFE61A262BC20201E24806C7A22DD6B8A5206682C0F528"
DATA "C1EA818B8A0B6F41909673308D5892040A6FA2A6337AB87D3BF07C0241CCF670AC8236A1C959117E076C41A1B57D5622A16A0D5108DB40040C96B6027D8A13F6C2380408A4518086668435"
DATA "A4210DCF16C56E496F320314D6FF05E8BED442A4038842281347B5308B36BA43753B53AD38FB80394740673DF03003343AC09BDB1E837E18730C057406804E74407CBB3EEB7B25C6462881"
DATA "D810B3BFD4DD076AF406EBF3F5EB026AF658F5366D44AEA040540D410953883B53CD9E15A21E25FFAF51A33A305E55495112CD5BA340090A03752408E4EE518FBF10C746183D3431ED51E5"
DATA "161404B874BA08E5DCD6FF03185509B8FD241A09E220680E07A42C940362336F5E53ECBE1E23475903139804514EF1CB3841189B52518AC313CD860153402AA17AB7A06A8B86FB53A87E4B"
DATA "AF5048D9A60F00597B0A3EF0E3C372DDE608814A5944E4A80B1530152DE4DC383060858E1755AD257BCA2D8B1802770E0720819C4FC8F2164C15820045DC3CC8E016640ACF1581F92F9BD4"
DATA "A7CF07516660532B76805C21E86A6257C8016CAB537688C00A1F244048F0EC4708A13867BE02906F959C52D62786C410C80B533782A9FEAA656E06416A43EBE08B0D1438DA682B88875670"
DATA "8EAF082FED8A22B7B7750A66236C061B72014418AA05924CA3C8202E9700055442B68265AEEF0475F248A0916715B8FE5955040D293015DB1A283947EB9818068F2AD986FDCD068EFF703C"
DATA "0B0A30E4924B2E343828924B2EB92C40443B643177B060CB0DCF53CA1089587E01C9541A34E29A6F5B03464CCD28FF764C8D4DC4D6A5F9464CE30598748AB74CC4143DA42F83780CFA10FD"
DATA "50997C8B4B591D4C5E13D0E06985078AAB2D04FC9EEA32683D56135AC82A772022ABC619C007F0EDCE1E567BE39157069B2C48BF370C36F856E5DE08E2496864CBB880812A0CF855C58880"
DATA "7D023DEB38575205DFF72E4B57EBE568AC575E6A1941A9927CF34B10C11ED064270BDCC0C662C6775678AFF29266C878F0F6305618C92043565603B3F608E07069C309AC40B2EE06F09241"
DATA "0E9051532B36C8CB2E53EF7509EB088847351AB03841C17EBB1554E76F1CA37F793623786AE1E357C3C8598462EB60A10D00D0DCF772830D10FF19CA02C003F9BB3F505B77B8E50291CD18"
DATA "40888A3801B1200E00BBDDC62041ED5835596DAA6B8D806501EF180545424B0EC807D740883F38A00B6CC94088476C3A8B7D3F93E19C0498097ACBC8CF3366B619F8F0F86A15921DFB1EE2"
DATA "100408096A17196005040B36D78415B0D040AA03D36123421E59679BB0027EB6993C908B0FCCE0AE0590DAB200DD305A25022BCDAA8C9DC0204C587DC60C2B2A97513C0356E721612B39AF"
DATA "B41510599AACD2036C6CB2840E5006854453B9B2092C6D55BC5240E4E7B4B06A04F005C8945D0C55505C253FCFC4BCC06A0548F2F35C80CCC4D46A06901C61070C584C3F0F17C808F05AE8"
DATA "E86A1396153021157E2C6405CC5B7F610E105C841AF69782E5D946274D282420C892A50C065F1B8C3D58D5D75C4D5073A83817C89024B114013B9C7A175E2048099F6E8F1B591D2A137242"
DATA "4940E01F5D2BA1DA545F2978415AAA998A5C5C2DDC01248C708907EB5458D4B6A0268485B10858272DA1514C7880B5C0DF162F687A750EA4BA4D41870A1AD5EFCD15FB0258B90E8701CF02"
DATA "C14AA061D4A81C484E409040DC2E843CD9F15D21280C0B9297D05DE3F05DAF0236A0C95D78D4B92A465B387DE3064D02F82ADEB8185051B56073BFE7467A06DC1E1C05190A1EBA454D0664"
DATA "75C4200FE85103FA8CFE6691BAB915120A813833BCABE2750EF95D1018AC8378347B4889016BB987410B13272DA436B8D564AB1B9C741CF80DC959031F42A1CC30062C6C93D1C928246110"
DATA "E5F0D10EE218223166E1416CE5DE17E812517512C7050EB64FC9F648C6B4EB2C16FDB0EB1558D6542DFC74F41902140AAD69BB731C48C247B75C83A183FDD4E8141029E2B7154B112D12EA"
DATA "56EEA0E67EA4897BB1040489BB1C61FB08AEC35B8D7B0CAB00BF11C31DD0FF2BFB8A0437880646AEF58D8B4F03F3B7C3BA5F153988014183EA1401B900253520074B053F55EB8D85E8CF57"
DATA "6B31D6A0507ABAB887591F6F3E848484F0C38884051D40FFFBEDFE3BC772F48A85EE2D8D8D05C6851620EB1F0FB6519CBD2D4B01B60D21730DC62D20D4ADBA005276EF558A01CA46B84B33"
DATA "DD535E0AF8DA02620D9737845318F6067B93561AFD841BBAEDF796DEB6ED2092B0FC4016FCB9C6B2572923D421A578FF8527248BCB0FB7844D66A1BED6BFFF0E804C0E19108A840D5BEB10"
DATA "A802DB1120DE1F36774DD60E2EEB07889C08DE2F712306CF721D596A9F8D960E775780DE4A582BC28C4B03D10309BD50224CE47ED719770AEDBD95885952FB1383BD17124BBCB5ED0E8D04"
DATA "6F485C14E088022E88007CB3D81A8B3A4B5ABA6D454A202254F5303DAB8B72F7F71DA95EA4BF0587424BF4F049483B4104E53A3E05B453532220EFABE28D4E530B83CBFF27B53FECA22E59"
DATA "B988AA7648F3A516FED16F435B8327246311A83BF3751DC0A42F83198BF35743C1A162489D0A74E964FAB46F6DF44878184B033AC0CD790C8178215337C619707048AE07CBCF1CFED85D20"
DATA "F2484807F680CC0275A7D56E6C880A3860739E8D143DD9CA8D2114C06CF45DBB18011BED688F577BC852B8A0A5B4A37E11AA38BFE06189182108FF7E1BF1AF7FA14D85875C741139774875"
DATA "B1834CEE7748865E3D7E6E7BBD53C72BFC16315D0C20412BD0EA66206BB62323CB06FE56895FAFF3E897B5E52A2903F2629FEBAA46BC6605494FECCBB3C0AE6AA641706B413A411FF04168"
DATA "682ACE374D8DDD46D46403337809600570743B36443FA856D66AFD0A614C35FA36BE10C61C70941F111EA2B1E3686350E8319026815955209154671478D85402D800FC35687F1DBA5F1759"
DATA "C582217E9D64F2F27BC79525DA6E27399836341AEA807FEA2EE9C030123DB072E681FBE84636B3B56619C80BE9BC4F27B1641BC34EACDCAA67AC2330845312B815AD639984838D4681A75B"
DATA "E60813895E1389BE684ADF2DFC43395DE87651C6EE39EE74218A48DC2DB6A525021AFBD10208805AC01B4F1504EBCA76F65315BC5D206175DF471AB9FEED337DDDB0080840A2F7C1DB6653"
DATA "D01D00EF048986517F03897E1E7EAF4BC18D7ED5E4E839796C67F8668DB4FA12EED107B5940BD9F19E9BEBE4775BC30BA8E08D800E9008E4788BC874EBAFE5ED358A419BC0742B119A1781"
DATA "FAD46B04DFFD73138A872678084416192022A0656B7D3BD076E5A4AC39CEEE774B514667084283FF0472B853FA0B2B4B003401B2D0EE25BA8B6C4EA6068D904A845FF5ADE052DF8D521F01"
DATA "8D49028419616B89E3EFB07C11AC2457DFF15625B8A1E4C466393A0F2A3F792BE88D71200183C1CED1F98D823757D0144A2F1F75E15E302049B59C562AFF624569BCD35E67650259579CB9"
DATA "DF680029572BDED1FB212280AF0399724A9D44282D32445F251C6E6F2DE126B7572550502238DF6BC16AAA4CDDDB130A108B18A45C5BD7C05A2BDA4109E765C7BDA20F59060C1B10730FE2"
DATA "103CB089EB4207BB7604B64C0B9DFB598667FF0F00F02CA0AFF6932E082EF09F60153BFE73112BF73F3B56AC55EE129C5F781EA841B9A265C4A3F6FB4E47C2CB8E7400511AC81819B967EC"
DATA "800ACC84181A8DA00B1A693BFD35AAADA1045D57B8F70C3A9205D0760E352708EF115028898404C4DB027C282CBA2614FC837E96952AD6B1133125331A4AD4853EEE08BAB4DD2B296A85A6"
DATA "A96977E96160822E39D9742351205FA40AC54CCF7BDC62C8D76375E2347FAFA4E851A4B64188608C5E216790FE17800334101B510B010C546FCA731B0274027248389193A2805118C483E0"
DATA "D701C73577D3CE1E006FC90367D938D90839096B2188548CE8900C946830DA29908D264D80310F0D48C067E2CF48ED2DC8B3D143FC13010906E4E4EC0DB87C069098A12A11EC8C41C59486"
DATA "AA41A5D158974D8527A0C1E0C2B6BD4610E0235582F075F65EB868774BF16B0DCCF89E0C03C82CAE806DD7A92639507C091249AA4AD5C175B75147C25F17F903EC3C5959DD8C3990C1220C"
DATA "909462108C0398044DB9502DB8B1772CB421685D14DFC0AA5DD4215DCC60E3056E3C44195FCA7F1810F33D401B60FF4C48052797B702FF754CEB1483FE0BC0040F740A147E825DDF973B16"
DATA "7F36565F64EFEB4519006E044FD8526B1A88C63E6B5CFF3322D76D8549C00260D012B054C1ED0EEBD19A32C985AB7DBC0E6EA6D0002A0BFA0E8A18F426A815A7C645E2007D7F9C05DDD81D"
DATA "14D7CA2010D3CAA045E072248F3B001B00A5DB22F865A8FFAD660A55C88855E284D20F8592EA713A07F7560827BA08DA8461F0FC0B85B72F6439238B430440D08363AA7365A86E17753BB4"
DATA "7D11B8335B6CCC09B08C18226B05337C5868C2FCBF03CBDB00C8238389A061C4CB25A7C71A0BAC6AEBF0DDA7E26505141F2D6B1A45E82E511F79756B5336A1046C050A3A0723DC6128C520"
DATA "6EDCB6946D8505075D558A0065C82C612FBB30E300C4C3562DCC2B410D2593D0F25B2B405BA40B29CC948B2328564070B433442B2F419CA1F3031A211356429C0ACE4E439E9B3ECE642DAC"
DATA "936E0E5247B0802E288AAC28010CC5D29EE4E63B23D1C2C1017F774B81B2231669346D286F2E8016AD24F2AB518902FCC5809498B60C181678FB501CA0A016E66D23238B9C2CDD164DA1C3"
DATA "90952B106E66AE363F35DF6A1F322E1814E8C1F80851AFA027147E93974852B75680138129AEC06A928D180BEE5DFD337C16A8B86EB7C806A92A17FC4118FD66AA30DB8FAA55F856FAAA56"
DATA "6A5865708F52AEEAB00A423F81B0A82D6970A35DC12F3845648467B763B7CCF5B9A06C41A97516BC58D6A2B58B5382C065BF6B062A6215F9C1E2080BD0DF69882531C26B04014D285D54F9"
DATA "13C891200E971C6856AD11240EC86BDE10539B4174B0048310B5118062457456146D8093723CB62DF657BD0B131E81F0A92683B8E3D155B4BC2B158B4DC969060EEC9670D4B147D36E4165"
DATA "ADC480E0115A4056336015FC867F7E273B5F047C2594B42536C450787704CB0905B9203746307C28ECECB604DF26722E807E01958B37EB3131E4DBBD366233814757357040112A1732071E"
DATA "4930A152AB3DC75F0033083E108A5A3E243920DA6D5F0F8B069C953B8BB517DD578101F02BE2978D989C408EEC812C6862FD80553388EA46830570612AE750BB6F04C949883E5A6F0A6B02"
DATA "41E46ECDBC0FC0D086BA1D53BB7B391E5C5F06A87C898E0FA617EA0A0E1A14AA955C7C0706FF82B04087017804861600660D1878514530F66814ECE8EB6F732E03BA06712300A4241BA6D3"
DATA "B227DDD839E017F0E3238D43013D8B770B868C3CBD2B630458EB7A90E4DC2C27CB95DCF0F1F272B7EDB40B8311C90CF141FCBB432477884A8201B9F050A5593EBD8D107C8F561C135A5790"
DATA "AFEC32E0A5177B64A301D02E5626EC56423064E0B24CA8DF808B576A306A40559788504D347D5AF7FBEBF006F5E8488D87C5CC3E568DE484EA52F5F8537CE0DCAD5E78834EF8A81E8D7676"
DATA "5ED414B7FEB7AD24D81C0A0AC646DC0A8066DD415EDE500B444715CC9D5E0096E498A6A7D82582F793F725538D9E64C1F559B401B40ECF83C730D166C01621F2AD35A582C8F36814E87501"
DATA "FC72017609751730A12463C4098F8049824F3C6A071BFEBC01A2BD99DF437C1F3934113FF444F475587087896DB8226202AAD05E06B14F088C71C5EBAC39FA2D63F6EF40A30747EBBB8B59"
DATA "B7D5F980012CC0300304AA574808FE68F1A4594EB64E6961DEFB6DD01D669D7E837C0100431E70405F8896D64522A1500BA518CA14DCCF6F2F3454E113B3F4EB0804F5EB032C838D2DF666"
DATA "D4408B89080E14C074E036CBC5C8FBB9F4B6023AAA51A11C31A081DCA321C85FD4C0D0435BFC0BD468316C439C7D4DBCBDEE984D6841535112E92F8305527001FAEF40CDE706B82155A76A"
DATA "B1AE30205370C6B07E7A3CA13D73B122CC8D88237F61A3091FF0AD589FDC3BF17460F6BF09978246E01A56650C7411E1EF1C276CF32603F0EBD52B75D86600BFC16D990C59F76AE3068D34"
DATA "03976CA71E777A79C901DB38042B0B3C2AE97C424261B71C430572C781EB66908611C757C8675F83E89687FE45FFD853BDEA8D60A11B039044CC0383B08943843DCBC8B42BF0963CCF81C9"
DATA "50505084E64680E24C3A2EC628965123E3B8C000D848F9BF438BB10D36C178970DA71F4EC067285CF6D1F98535004C06BD06295D16209004D92410CBA8925C220859E0A81A0000484700F8"
DATA "00CA74589204B03818110DFA494574163DA24E0053B066C0B0F25143032B3B2D4B025B27F90D4A2DE31F8324B00046EB9D17AF30AA1906171825004B3EC53722280FC1295976FDD6388013"
DATA "061877032120580E243FD81D001A0469A2B9569500AFB08B75E1B072082C808B75550C5800530D834B02581E9075ED1346C436C87B9638F39AE3B0060B53C689961C14B30D4694D02B4C6F"
DATA "947A96441818E1AFE546707003C7CF16E0AF8BC05533A40E06DC8C9AE8073BF90F833D7A2FA009FAAD6AE800886DE58B14E8E185FE1F4C1A2DF6C10474198A441A03E1FB880D08EE6EE2F4"
DATA "036DF5881A50EB3ABBA84B1C1B2B0FBAF0668547B1BDD41448233B7DDC52C1F9457D84A37AF16EB2011968AA1901D2985B6281921815571B1A3B681F5DB7D7C916E56A0544473F51ECE847"
DATA "50C6C8380DC5601CCC8491235B5796F4E02A501ED8DCD76A7B4158CE2B68EF78835628622D38E07266D71AD49755E50A752C1033DD09FB5C50E40359E438DFD6BEC138836601723AFF3E02"
DATA "04BE825B2D458EEE2A4A55E907E87004EA8B0C9541192EC0305AEEAF56182D0429096C2551C1C0C6E9263C28CC604558182A9E8521709110FCFFD72516EA3FFA1F536C5D59663BC3752801"
DATA "5BB6B783200283FBAF155B1796BDDCB9106B9B83C702FC72CB7644DFC2A0A86B56AE1FA2266692EB5857EA05E89291E6F630BD76483DA11F41404C3F121EB0C7D80F807C3029003C1A9B15"
DATA "20448D52FF779B4E52B1A3FB5F5EE010145C1DC44891C1B98265EA04B653D1C01CADB188FC4CBE96D10A7DA9F203C38366F303A928B041508DFD9DEF4AC5AEF805EB6527073BD8731EF6BB"
DATA "46F58A03433C65FDC6070D47880792FB7C6CE1FB47388B2772DE8D852BF807E5A10A66F4E164EB182B908451DA451B01ECDED98EF3721A388B6C5E729796225B25C1DEDBBDFDD9B3D333D2"
DATA "D589168956040208EB7535540B93DD2BFE0368F886876AB9E10D83027A17E6C964AE6B05E8FA08EAD14760674F83E7FE1357ED874D250320185635632D82EB54EC444DD4BD02B4FFF9586B"
DATA "F7C1F56C0D6A6382F4F45EED35D4B25FC8BA7AB510B265DBCADD50F9FBFE732117C7FBF9AABAE6B109F71083C008058D7DCD8DEE1772DB53BE550D8DC451EA56E0AF06382BC1D18B8D5053"
DATA "329B9B2C9180866CE8D731972B3519EE2BC31EC2DBA231FE033CB59B24C1C9874F27039DF01785E8CBFD1A0AB5612BF833BDA2730F0A24ECA2DA4A7B472CE655F28B4722487CF6D4A9E492"
DATA "968A7469A7E451591F7CFF7CD618185324301004ABA8502CA2C759142D1C6DB4851A89EAEA7EFB8A1F68386B5B022B962253F7FE327A06142E5DE48EA2FA2E6AD42F5C102980FB44A2B6D6"
DATA "D504E428D4BE91BD49DBA55350F28337A00EB1F66920740F7047F54C5479DAC2DDDF10BF0878A4B73984DB7422FECB530FB2C143D587EE13F89AECD8F75022AB28F04987168BDD2722EF76"
DATA "8441EBE6BA54881995D55FE92A3E46F8460FBEC3932E634B6EAD190453859A3C794FD80FECF9EBC10F7AE7EBB11F1AEBA11AD1A64A3AF7C95157DB0213D5022CD351238CD2309A94A81881"
DATA "6BEDED16358D75027DD8A50084184B74B4E26378C824265E18194B50CC140A06035A20993C88335812F516A2D0C36F183DC5DF3E407409803F1A231BAE4B8D16321CDF12E011858C8A5BD8"
DATA "44640A2A5F4554F4BBFF625C2414F7C3FF0074502BCAF7C2FE57BFF1A217C0040A3A0275473A4283EB0176036EDF80360375E98D1525FF8A6ECB76773DFC0477DA8B243BD31F047637E8ED"
DATA "8505B0FFFE0083C204A7C6A9DAD610BB800074D1E9C381CC0011C35DAA42C8010C84800EEA0105F147A76A64DC1275170B7695BE1FD5EB3E2BE3BE0C390DB5418CAC6026D31A2784F8045B"
DATA "96AC7B7FF00048462C5E908C38411F17849F4173BF2A620F7D085D115D0C06DDB411AB07113BCE764A049711534E9F0FE1428CB7BAE8756E972BFB2CCDFD82AD1F54F4BC6D4509161AEF82"
DATA "6D12030E8B43836D10605528910975B51548848C688848FE29E875A82192CD0BE81CB22268186D68467C0267830EFFC60115DA29CDEAFEBFAA5D37C914257F2AF7D8B974C74CAF28472453"
DATA "F34D02F10AE80156902CBB0E476586811C8201AEE181471903610DB76C11821363E0251A07236070198B0E4F958064E0406A2B3F36855134040D09591C2820F5A40A9444881F46E0AE8335"
DATA "807882738E24F7C6C0C542232F6925B72D19FA35F09F970D099EEED71EFB001CFC251E4381CE070FADB5DF58C60E3D0B7445065206344BD7B92C0D06250D022B0256334BB3240407068A5F"
DATA "D8688B8701BE0BC0BFB90103046DA17E4523C12907152FF5D2353D1F8100743CF69D4075361BFC0343E9F9C023C28B63F3A88D77734641740B06E36272141816AA16702AF1F2760B9E7647"
DATA "0404760E05743D255A11C2FD77CD02D9784900900BC28DCB070968D91539746BAA5BC41D81C1E91FA2F6461684A7BA209B2403072D856F2A7E44DF8BD052D27E098D4EE3D80C86FED91BC9"
DATA "23F183FAD71807026CDF0550FE1E513DEFBBBFE405925CB3F45AB2FFFE046CEB4A1F9ECC8B0075723DBC1D1B91EC61CA5AAB93D71315AD8E0EA003BDE7152D00B8A502483AF3A2395A2158"
DATA "B0124748D87DAEFD545EEB12C00B8F5E2F8EE557A241E15E61CDD5C3EAD809D3547C143C15EFF7BB664E03D83BF37FDB9870530030F46D197BE4200B452436139A11D9C218CE10B6864988"
DATA "E45FBABE00A8B945C3171AF100D77F287421A11D40A5D97E29741206023B1536A2D6541FAA8904F5DDC88DB6A6583F2A05000606198000D10ADC0386AB565D60B0EBD2D51DFC0376253F8B"
DATA "C345E00357BFEFF9A07D19C6405B4721048F0748412A2AB8576ED4A3C0EB23816FC9F6C32A1A019FCB22C82FC58D7A7C2FC7056D86C75354CDEACED83783E5597B4DD35DA8E345743E0335"
DATA "2C24D875816C66401A247E0428769B8B253603E902581A957A1D4172B4291C5180D8500CA253EE5DFB255E7903800E10C10C85DF751E977A920C4F6A13AB86757A39DA27A2DBBF7426804A"
DATA "85D97380AEAA07D1C48114B766BAA512074B01CA8D1281FD6933B54E5E76060498834E0C04ACE9DED052105B03094E100A200724A9D912ED0230FA090B5D40C0B06D0C0D1019C002ABE267"
DATA "8CE011113A2C816257C165929D8AA848417217ADDB339579F87C55FF6AFF1D0B556BEB23CFC723916814A8CB21AF32C3A278E0813883E14E9B28908B50EAFCFC500D4308AC0117F16B4B2C"
DATA "A1FC7710531598D114345698BC079E56CD0ED2840CB267EBABAFA0EF2912A2CD103B0AD88D45E196C52CCAFC57278301A3A956D486F27A821E45A54E2038D49005D05EA6517601A3BC2580"
DATA "A736069354BB44F71C74AADC87D9BC263E84559E85F852940DD80659F3A559A261F11264E07519397CE2B21A4730208A7D72A8F4B02E76E58903A81726893336C4805112CF6C75D48046E4"
DATA "AA4BF704B1958D4F0C7E1853E53ADE0914C1E80720C16DBED1DC03003DAE798112B9F6D2C0DAD50265D040A11A830B07D8543650685C435D35F6BA133BB73D2F473381E1B164892F8035D7"
DATA "1F4A47443F669092E22B8B0B759BA05D40A2DEDA873120442FC6FBA48F0B299BB0D9561E4457456610CCAE8CCE85D7040D1BEDA06251A7078ACD0CBD6B504B610AA80975020C0816C107BD"
DATA "67338845DAF1D6256BDBDD595D80CA0160880B6312560EB60BD46588547E5203CD1A05021BB12935E7129489F95885D107DA8552611CFEC6021768110A8714832D1E23EBE255471C817332"
DATA "1AF03538C253C4E6C6D78B03106C4B206DA8FE0E12EF616611297EDED13075DB90A43BC810321D2D245D819B6B450595FF48419B08940304170E724CC2240E6FAE75D8B9D8633282A987D7"
DATA "851CD47F26495C7B0661DDE6892EC1D8819912DDD0E77532BF15C240C1E6E673BA70D9B20FE18812C92589047A99A860AD56CF960181260DC7382426404A4E1CE78290000E07762256C110"
DATA "71C7B302BE3E3EBBF85390A2806902CDCE97B6808621450E9C40A245998A2DE7D4E662506DB70C1914AB780E5ADAAD2F9C8010358462066602708385D0407A487C31662236DA030A4E8843"
DATA "0C71C9814C808C565615F8063D48285E81155D6BB104C050D2114E18F4B01FFD028379F49951FC0FC11052FCEC4D2ED6FFB09CD98C95595E13612896061686FBC46EBBDB5C6C3D4C707465"
DATA "A67C0D5E83F49D6C4B80591C84180E1336D53B56AFFFB63193D059F67220E9218094CEFF767C367B4E9E172FE48C45400E9B998866902DEB4110D961BF6694BF5B2BC712980DCDC0906E4D"
DATA "8C090DC07DE161DFBE591B588D9EA00E4FF7097FFA7E28817F241D8B076E140F6868D86042338C797FE4E96E64380847FC230C078216D5D81BC3BAC6A4DA99FD5075B05C7944392A428185"
DATA "8946D591E53F990770B81B3D81B082590E30F68454BC2081FE2918768422B205B0A595735B83954D08A25864021672985848904B36469F734C4809399003390909094A86E4080A0A923C10"
DATA "E7EEB52253D1C42BD09F0D7E50D78DCE8F5E774CE5431F45B2A8A7FED2A0296806F08D474C508243384BC50B8DFEAB11042CA4A95E0413BAA0866E593C003650ADEA358B38E22E2D56BB72"
DATA "510FFF40E9EF57565178517CE33E16F58BFA75E281FF78DA57722019F03AEBD1466E8311F40116BBE3E2F8ECAA6B115893553F992BDB2688BFC8D1F96A415F8234CD11FE7103F88650A16A"
DATA "5A2BCE5BB7316641B1414BEB0D27776D06A8CDB010D0A5060653C1C8F3160B06C02DDD1A366A6DFCC866570518D0746EAE6CAE564F6C8B1E02D22BBA526BDB121F1B793D3B80EBCAA57617"
DATA "9E79018B3BFB7C6FFF607C0B2F6A4F047E5485C5918F6A371D8E5F7D54ECDE9578103DE4B67309ACED13D1AB05A5D51E44C0A380E516292BE8021F6D1C09162A75E8654D1C684123056EEC"
DATA "7F8546610ABB081F1C9960A939C6578BEBF1A83922045F302E2AD459FF7CAD20ADDE3A8299F21C024B083BE43508B6D1C085DF4A0A45D0CD3ED0083D2177190F69B9826CDFB0C2F4C860C7"
DATA "06CCCC18EBD94CCC2881221A4535148A72DDDD6958F7742826D41034BEEF0F4DC84436414F1C3540386688113E50FE35BE088611D096319073598007E90A164F0032E8C78D032CA2C365DC"
DATA "4D92950028754812FF66651525EB801A40E850D3715390187EFADA6F547C749A6265598D70017CB344A6021AE324A2D05A141FF58B970E30E1144DFC282B4CA539218749578D01143CCC46"
DATA "964AD1520A494AB17DC9831D3BD1DC85DB354C8417E140BF4D1C4D1521F2BDD8591E2D51309FA968B3C214186005F70A5E8E4885A49E8ABE82FF59F8BF803A191D5753AA5BD9F8B5EA462E"
DATA "DE20F7D58B74382D037D05E534CC6DB1CCB07DD48FC2505100509A3B647B42AF85A4789280E4363A902BB94A19FC4542C66ED964C707E019EE196B5FB0491ADCC7FF10E6820C87386769DF"
DATA "833B9E030658D7D3753A7C515D53FE57A524D3805AB3CFF82E573233F653085E9E544A362BECF7EBC0461AD6C12DEBD2504CF030A88746FFE7F4CE1419FA0DBA9093E656C56984E3DF5586"
DATA "A4A0052BE8F77015C132BA71EAA80E6C87199524317D0B02648AB040FEE076250D28610405334C3218413FE6DBC0BA092B1964EC13D8E628B40CE20C0D590EF8141418CD48258B41934861"
DATA "D41140142A6285B36CC3A8DA38387CCF1110C8C8808C801484C8808C0C18881C808C0CC88C20908C0CC8C8249438A80CC8C8803CAC40C8C8808CB044B4C8808C0C48B84C6A6131C9BC5E0F"
DATA "3220630D8E687004202303327408782303323230A034A404212A25990A342A1CDAC4C641F4120DB1CC03C1E9FC58038330D9273631478D76045921C1B11543F0DFA2C2B1E888D0CB07A837"
DATA "8D62614B41B60A50580C0A664728C968AC6A020D25DB9085ACA00AA461B16DC8A82EB45D3C675B0AD8D00D134410EC7B0DEC645B1C010DE86972D9242F5401580A5C68D1865C6058F527A3"
DATA "18A37EC0CD38C0B6893051A76A9CF90E3254880ADB6B0007D1E8651BFFE4F3E46A34B7DCCB04F0253B5147E2F00896005A682B3E7B56530C0B634D7F8BFF87E80CB741B35AB6208D499326"
DATA "0AE48A0774FF5D04DB270A392341C7013AE772063AE37751E9A6FB0202E63AC709C3C63AE0B60BB52D1CF29DC90A94B9A50BDC44E17202F731C15B9F5A5901A3C91E125A62D6A073D6AD01"
DATA "62002403396E3E1D04051B2BFF34BDF4D21F216716288A5C1629B1C881E12357B57823DC6A734DD33590905007804000406779960124021C8007E0BE86420C8088409D9F9FB2EFD9102901"
DATA "EB2E1302EB1A247FEB12D080C9601B0CA6D210E42AA11B06808E6ACDF71E84DB0A4013BA26B714AE121341E8057E1981038BEE510F17CDFA41238698CDE68A5F74841ECC0259E2A268515A"
DATA "A2DB11C974440EFE7343893E9BFF7C621960E096A951038B37864703C08F0886C52E73FC5639364B6598B27E0C4966F726552815068BDD2604882D69591B100EAAB1A05DF6BC54C00F9D57"
DATA "66F023CAC4043AA2D583F9BD8A658D27CA9A5CEA278A5D716900CA74DEC22BD8BED5DDDD571BC2BD0F88D8F17F32DE0F86CE049C0A9E3A014D390C8A657CC40C50FC1D1E99F86881589739"
DATA "59334037F043FCF57C117F833B89869CA17297067BC323F7296695D9364999783251B5C8FC311F6C666209ECC4654CF63B70D1DC2BE256FDF05731C88414617F788802D518973840281662"
DATA "4B920ACF386EEDD6410CEB51B57FB564DB73AF7861B3A8875074AFC896032B94F4864F587859419FEB81DA5BF541B4A48F0E381768402C9E0C20474080E00DA48E3C65F4DB008A8D7A2868"
DATA "E49682DD41C07F22080FAE5C2404D125807FAD3BEA12AB801F68D93C241937FC97B7040383E07FF87F8D64240875556A9D6490E720EC603F74323B0551BB17884C14DD1424C4A464FB6B9B"
DATA "4B1C9B248D543D1121529B38DEFE76B7744C4D0C6681097F027406D92D6A0FB8A94F117C0B8E7F745EA915411CBD8CFDD9ECD9C9D9F1C4CC851C095FB3677C01AE0DA0BA1B0DA4872940A1"
DATA "5AF417EBD4A91E6E0FB5A1053408162535C5DE17D0EFDDD8DB5670B813227BB093B385661B2AC5BE23093999791AB8026BB008809C847739A5835AC34FEE0BDF6D2B244FBD30EB00F30F7E"
DATA "A5EBBA772C660F281559C007C803F8A5DB6D8573E1047E10540518E077C1B5CBFAD0D3CADC85263DFF3CED72FB6D7C7D11F3CA3D320C0A7F0BD64C47C2EFDFBADD4BC30A2EFF7B24BAEC03"
DATA "90108961845DF7A5C8D483C214080803048983BD59CC71A5BF722E814A6CCDF6D279D8C2C1065E03255A040DD80FD6B083B0F20F58C866DD3BDD6EF714F06DC21D08D006261D22E87E14A4"
DATA "5C9C6A0302683852B82E51681D75E4A3A0310C3E9FC3A5B160A430E1B9F991C3A31D4E8850A35841BF75FF5821780883E4F0DD1C24B9046820D7FDCB9D6AC9861271C600BC4D736944E814"
DATA "C0D5C5CD119AA6E936B80E100715201D80EB9AA66925303540C2C10315EADD6E564C58E038C40025F0CC7996E6D225A01450B810F0BA86E6765CC60759F4F217FE0BC407D060E71F3558C6"
DATA "8CA970B781090269FD3E0F87BEDDED6714DAA20803CA2C2AF19CF642CCDDE2C1E10AC6B91019B3006CC260B72744D1A7D088AB07EBBA5D5159C803DB59CA13F0F2666B667B0F0B2D950BF5"
DATA "F98EED9AAA6099E5668D58FC37F2F2B9B664D894135BF79E758EEE15F60BCB1E0EC12215C0C985A6EBC8C103C6C7C513441B2C088E275D9E901FF6C06F77C2C84BC5C1B67748C55EEB0C09"
DATA "B3CDFE776C297080E13CDD2058C239D0C2F13505FD47420EB8C3BAE9AA4FFD755BCC3A2C245EA51240B0BA081777833DA6340EA0D0C1BACC509C61A32F506F09016B76D6DDEDD77C05733A"
DATA "2657C93DC9BA09DC33490D371CC4AD0110962E49B30604E0101CDDDDD97954BC7E7F73D22008D170F66D7060CD0BC1AFA0A8A6FE026615205FC685703FD8AFEF8EFE0AED753B99EB0D1032"
DATA "EDD9EADE12E5FEBBC963A12AD9E8DEC1F685611585C7B6FDBB0CF1F6C2407502D9FD337405E017A2568ADFD4276D0BE436BBEFEE56C216F6D54CE1EBAF1CF404A38FFD6CB05A9395106002"
DATA "C3D9ED6D9F75DF23E49BDDBD600E9B604175D283C32DF4B08221C6C30A6A5373DD2BB12EEC00320CAE23762AEE5EE4F459140ED9EE371B36EBAF0695437218D8D72ECDEDE9EBE52D3BE206"
DATA "0DDB46F6A3915882290FA91BB2D9844A0435C6039CC7DA36ECAF13A4C0F50A2EDEBCAC3BB2D9D9951CFC6D8A95AD2DD9EDCFD8E1133BD98FEB6EBF7D25D83CDFE09E751A0BDC0D4C421323"
DATA "1070E4DE740DDAB81B8FC008C0F8E1EBF1562B74B1CD5CDD8BF4050855055276DA76D9412CA9A6DD66110607ACCF1535E449F5A294778125BE807A0EF411DD9D5C807DFFC67F80CF0280E7"
DATA "FEB33FEB43BB3F1366899D5E95AD61F67EF705BB879ED9E589956CBCAF02E2FF673B00CA8DD0E1D0F9D0C18AC1240FD7DFC046AB9677047C8BDA03D88310006C8BC328236675C1DAAC2A67"
DATA "1D1710AD046CF38F78E5D0FDD0C58AC58AE085C395DD0AA6010AC48BE8011C8E2DB43CB4C309EBF6D4C7269C6D3DC30684F40CE8C36E16DEEEDBBD6261DBAD05C8694074086D77B0C190C3"
DATA "07DC05B48EC351B0831C602C09EB0708C026B0524B54203ED893612E01837080BD1C332E79C87F0AC984BD1CA56F6B12AFDDA096CDABF42361F012915ADCE1E8D2A9D189E07BE8D6DDD912"
DATA "4FDC558E4B81E20080CAF117DB16AE6FCB6C03C399C6C6D80AE8067BC3F5B0171B41CC0B2825E6DA788FC53DEB03DD0211870AEFDA4619F495443A0E8B0A0FA4D0B7DCADC887E10B0FBE0C"
DATA "24DB2C4301DDDB400AA93F1DC362101A1B30430110C34A8D458B7603D92CAA823DC74C77D10E1E882074150F080CB8168A2D8B08CF29A908B26711688BFC55EB14133E939DBD743D6B5F58"
DATA "2A7521950B9C4318E9FA1D2304F9825D646C55DC6A3E190C3931F7DC1DCC2B52037DA4B804FCC7BBB54686646CBF28D4C4031C168F6C769EE4EB961FC46D01A81572881805B20E0296F01C"
DATA "C8091680E8A078DD5DF86A45823E5438DAAAEC8DD52C016FA8E050515250AADD508F5C6842377D086D08C92946686509F4D090013C1F71741056E0F8ABB8102CE805826B939BCD6DB8BEF8"
DATA "1A0F8F216B480F050E82173C970EA7008E5E786B081A42789D6A04057456AEB9E28B039BD8A2CC5A018F8AF8BEDE9B09F8DA0EDCAFDD17BAE4B6AD6D6B07ADDC07EC8E5005F45DC1900045"
DATA "A1594F6AB02A2B210AA7C230FB826DDDDC4F0E8C0B0E834CB60DA217F4DC48BCC55AC41291128F0F7451878C75004043990110DF2A199004045FC2281DEC20EB7C61EBBB29F6F0F66D81DD"
DATA "181DC7601B745B094A740DF5CBF3157439280374172DAB80096C9D096280DE79DD44C60139DB9D083BA6330B10070619901804DCE5402A2164BE510037DE21C922E543DD1E09800152A463"
DATA "28C21BA2BE6356683F1B817143C0D6B82D08E20FB74D1DB45D6DDCF00523C8255266D1DD5200783720B3BC48211AF64D1002770E56532FBABFC11F6E6306EA1020538810D8C1DD5CDD1601"
DATA "9F246A0CB73F27ABDFD8E46EA655F8237EDDE1FCF6C4447A66B0D6D212561153AF44F84B7E37821ECA75E940D9C916B8D80431AC26E785016BFC03DD7DFCDBE20FBFCDCB1B6D07E89BD97D"
DATA "AD65F78C2368748B6AEF54660B7E48D852A9AC09F82BD5A8000D6CCFC6B4FD071A0D2E1028DB5DFC9B0E08B98699A91198114F9B0C8EE80DB2231034110C74ED5083092607B90D20B9CBDE"
DATA "02E8EB18869B9AED22B89098F743C8B41A080FCBBEE7A890754A121A4514FD7A28B41910182B121860EF3C99C11F3222F8DAE9205A6BBA82058909048506DB7A75C96947B9D465B8064351"
DATA "A8B5FF3924D7C6B4F6C36D7575B0D8D175057A0F6333DFDB543CA919F3AAC81776419D28375C72A9DA0007CE2587FD1ACB39453F350BCB2253F6203B9E5A0047BCB5CB0C810C752E30CEB6"
DATA "16895D36A1104841D65C14B44AE249555BFBC42E3F7B6272EB5C7432593D04F71163532C23A93C92BF5B8B3BFE3D8BC8C84175136BE802C4CA7520DD1C4E0ECF3E37E4110E1E1A0025F648"
DATA "519EB31897538BDC58A1105080852B35156CD0606B8FDE04099009306627E6B4FBD27F4310568B730C570808898D7CAB8B067410CFF7E729042017A30E22BEB1E9F17572A8EB0E6A12824F"
DATA "22961F1118085F51910BC40DF2505701ACF46F1B85E0478B4B2D52100416740B6FBF35285C5465C0FEEB129DC0DD467BDBC66F15E0E383C8034FB07FC03A03BC42546008DAD47E722BB844"
DATA "F88050A4AED439D2D3D88B9168BA5185833E05E8A3AA747F62F0FD415FDF0B56098F090862B1E85922603C64018BE35B9F48E570D0075B647EBA446C0CA8DD04B117A868F789581705B5A8"
DATA "041002EB5527A2094705F65881706B24B2020354086F406F51208D431805FF730817BACE3D0C2605501903101B0C2E3799DB062021F3F73701A8C3B66734ABF2CBF8E929E5EAA8DD6225DD"
DATA "38FF1833EA1C2DB239EE453847574468CB85DFB217EB740659B11A0087F07670A510B6375917860A017C80DF8BF338AA35DE22607416F681F97B77FBB5E93BCF5915F7E99AB18BC3231791"
DATA "4336431A1804FBCE04196A33881A378EB16789083A9008228BCAA996E88AB902234754632D15CDF6743706081A4D62E3C37473C4C6DC195CDEF8D13DFB92BD7B4CEB48150F2C1AEB320919"
DATA "E481157A1E1E6D1BECA40825EB07D95619A2B6936590FE02CB1009C1ED225A64AB430147E9AE57DB43DD014576740F8B91DF784826E2018395B2B950D80CAD7FC056FA53DAED5BCBDDAF5C"
DATA "EE3DCEFB0C7D074527DDEA8D7247EB59B833D2AF015836DAB7422CF6B903FC1CE50F10006E6E8B22F63EEF7D2B5239B6A63BF081F0563646866EB779D1E80CF40100BD26BAEB8A398009D1"
DATA "6DF496FDC4A3DBDADD0A85D2C70018EB0378D0B602E1325F2725ADA0FB4E7BFDBD11CF201AE888E0B02015EF5B5E829741A1CA436A003A1E2B8BE16B685D14C432A891D51D83CA2C9057BF"
DATA "8EC06C508B4196056410DDED001E1E58BF8F1809580426E25BA80F770C0F93917272B26D34021001910427CBC9C9048E0808902C808626DB08CEA5E21674C1E01533411C60A5E6DA103105"
DATA "16126A11430679C808D1E80473CF60ADC18C1202061412FA0177640523C3114E2A8BD0B69FE800D50708490C100B043964796945480C080804CE4139641002EC0B9C1C866BE59ABC3522EA"
DATA "FBD79C0C292E0803EB218B013F731D21988901E00EFD0BC3EBB28D7CBFF02220FC4503203E029441FE0C2220E3EB1AE72BCB600B4A0B4BEB0821BDD5CA91FE4B930881E1ADD8851ABCDC31"
DATA "08962006FE1AD07D20C3406020E1EEF61BFBA1D974D958101D60365D1C1AAF50B5EF60E1150317BD573C5D3BDB4120A4E30833DDDD37643B934D226045531FADC0DDA03B57907C91800E08"
DATA "3800B05D8216BAFC2DF65E10FC26FED33CCDD30808FB04F7023CBD3DCDEF01DFD2BAFFF30E03E844D055F235E6B7879B0E0A0D28810E63EB940625B74487A6FF510D6136100F206A77CFF7"
DATA "041DEE211645F67CCFD6464307193E091A189D35DBDBEB1A0623C22702090A03A57EE1E142265ED6D94150D91BF2D09288B7DD06DD1B5F19B42BF0A0DBD08D07771802522D604521A0A512"
DATA "C4C32E550C0822DE96BAF88BC13914C5B3688840371D7CF1E0EA5B0A290C106CAE9E2AD756EF55F05B14725592ADDBECE1C4A005B8DFB5C800BEA804A5FF24441170159D4CA0E0193C3867"
DATA "C92607566CD81DCCCAA85EEB1B352921B7BD53BC1B1A202B12A1875A03925C5738FE51D4E2093366B3855666E2476FD57CD4B7C6A9E2757C2A017188BB23AFADAE274904616AB8BFAB15A4"
DATA "8259BB8AB005B5BF550E10751F03C9D54879DBF7BBBB49C9010903D24F1774E8528945B9D15A1BB9EF967FF1E00EE7662A07D6620F0BF0EE21D0708E2E3EB38DA9B6642DDCEB23109F1293"
DATA "FE34FC8AEF15C1EF0481E71CEFFEB45ECD958C3E3F385F5079277A9B70BF454D250F5CBA8D89270389315A1404F0FEC943C1F0E8817D0C14DA3F4356C5CC4415C8125D56D01EB90F4C1170"
DATA "5458EAFB0EBAF87FB8CAEACA0381DFE106F0E8BA1C0D11F76DBAD8CE421A07D004DCCDC6EC0DABE0382704196D15B73BC2667A33DC1A72E56A2E2D2C18EB6216494A460247D22E1E5D78B8"
DATA "9F49B7C9CC78785D8428921E6E8906D286E8815C0FAD83E16E2703E7DC811F2B5E967A0CD0F6DC671CE08D41550B46082389CECD1A2B00017F280CC003D2D2911BC4160CF5035921180D51"
DATA "5BD103C1C91B9770F6B7DA5B87FE72091FC4CE3BF9720A421CC82655FC283BD372E8A74F504413F16AFE86A86841178CB9A1D0506C1165128AAEF80E041C429B897ABA82D8F109BBF00029"
DATA "DC3CECEB4654972D135019B4CCB2C02DB308A44024BF1F221805A5E3AE26404028E0146B81042864B930101C082B0FB9302182189EAA7E40708B18088139A40CBA8F04134751183B4ECC56"
DATA "2D6A53053E0BC0A82F38AA41A9FD5AF7F18B0B256788D8BD07E3906475FF967017DDC60703D1EB470B5CF6FFBFD2295423D1E9D1DBD1EAD1D80BC975F4F7F32FF776E9BA25142144F7E62D"
DATA "720E3B2762EBDE7D7708720F3B2B76094E2B181B1214D5174C578F0908FBDAF7D883E07B01A8B3BAD38BD9675E514845DCB000CC4F494514A8E352E2C84647E422F2F2E9A5F76686075FC4"
DATA "FA741D517251174E60F7EC9BD0BAE183530506D203095AC085FDE103D35B9ECCAC5CD427B48F437D144757735DE3D6CFD383D82813890E1B682E39A41C181C183309AF697718183F771085"
DATA "573E77D3EB410B19541378C84833C2D1D967DBF11CE06E33C91814073B2B76014E82D0EAA2764F2B5CB54AD602F7B5CF1344A1523FAD55178A5CB73FC42543A9F272946A6F402859948B99"
DATA "5B6DD0012C2A2DAE8572E7B007BB8CDF5533EDE1154745E2672490AB285A1824C8CE2018F28CD39C7C5A10181C645C42CAF84D79075D145D04FFDB9F80F9407315042073060FADD0D3EAC3"
DATA "D5024403138081E85619616B3C09C32F089E76C4ADD60F5E990BC151B80CEC3090C915075F4F20CFCB07A5C2D3E0D033C0E2AB5C6D8ABA39242C4861175E06F8F20F2C77C9C31B002C00DB"
DATA "1B1804B258144CA883AF74D3F1561460AC033620A4891ACCD2865EDF7C0EDF3418B41DDC756D3CDEE9D91ED956ABF8D44BC02481F17D81C1F1BB5474B883D0005B78EB2C1DB79C9C0517D8"
DATA "DA1408B1BDF6EFF7C21575B8D95C530398CCC2883D05F36005FDAE86EE471F8B747E4CB37C12C1BFC05BB6D103C67C76083BF80F8294416E22C217E282D204B30D89887353158E9744C406"
DATA "37BC83F1A4252E145E829936C733D8CCC425BB0F30750EE01F2B37B7EB160783A9D5F7C7120B859D04FF9E3CC6AC0125E702730D164081B8EEE904968BB605E0EE7F0412037311B20E1408"
DATA "B66D035808260F16083507B6466BAAF7651E5453B46DD17E00BE6F4EF420D4FF96DD6EDB095E102D30074620166E3030DDEDDBD7D00FD3033A0FD90C057F1F0DE09FA7FB3CC247100ECDEC"
DATA "6F20CBF76D6F62307DB7360CE8385AF8F80999CA0CC75B08EF03B990080808EB56B3C2064096FCFC0457E0402E64040404AE340BB7E67C13316F1025C9428B867F3110545DE18160805CE1"
DATA "D3C47FC29BF7C4FFE0A874138A068807495B50B308BB1213D12A11E51823AE0257FDC67E8191E203FF249536243DD490C1689AEE0403DCE8FC23C1FE81BD904C0B8A460188470111B66CCB"
DATA "0C63130502022B8C72EC1F8D34318D3C3975510160463043B439A9CE805EB6DDD7882BCA39FFFF4E4FB966C61AD1F3321EB3AAB62D54D81F83EE24E7FDB4FCB2354DB73BBD70ABBD800388"
DATA "98ACB664D986739B03030FB0812D6C9713CBECB5CF96930F0F4987D30E2CB99FF475F152726881EE0760EF9BDDAEE1AE06034E100456205E30B1D96C3666406E5076607E706C766714A14F"
DATA "267F577F5FE066B3D97F677F6F7F777F7F70DB75832E35BE2AC180117590FE2C60CBB67223F220206648B33D5BC7732027E0DD07FC1A86822B821A20275D3D733421291475EB4B0F04AF10"
DATA "6D18010FCA1E40B003EDE5CF412EEAA2D00F4F41E0EF70471AE17FC1EA077466009EE7D91EDFDF66666666F99EE7E9CB66666666F266E7F99EE7666666DF6666A4220E9F668DB633FC74B5"
DATA "A17B4A75A39B5FDAEA053E21B1B248457FE8AAB6ADA9DD20202DE59B1F2BE0E6D87BC109D18B16F64607B39BEEC604D11A03ED055B027F46474975F7BFEB35360493CFBA822BD06828F267"
DATA "5B11C235098A1688173499CED633590D65634818083C6C80598FB97F4680E2333301725F64D0706B441482DFDB6EDADA55376E5370DBDA16DB0BB90F0D5AC58A981891D6DC6EDD2BD1CE0A"
DATA "21EFD20374D1CB0707458BCDEBD7CA0F680BF8B780A1EBDC0FBCC103C27FE0568562DA44A845C13A57A2EBBD8A5F53A2605208F8ED13022F158A0A2F013ACB7459BA30DBA00D5114E30BD8"
DATA "21E0ED979CC3C1E31056088B0ABF1E54FBEF607E18F733CB03F003F983F161AEB6024B8BCFDF380430C4EDF9FD0101817521250674D3018481E6D01A000F42C4457656FCA5B82A42FFCE42"
DATA "FC3AC374362DE94AD4FFEA3AE3742784E474E28E1215EEB59BA6D706CFEB91322E338373D2B9FE3C06FDFCAF04258700C33324830A39C2E875099257C3743624D034DDFB3D849004038C98"
DATA "ACB7394560AFC420C430035518344D38485CAFBC08485EC570C5690A0617426F57B3A8F8815A43FD1B08777742062F509D8BC2C1E2BB3B70700CB723CF94B7F933182CA483D2B90FB5800D"
DATA "2EDD1807C90FBDB3C7EEF2C1AD3B45D0C5C7D053207AD897FFD923D8D1E133C02BC14923CB5B2444C2B5265E0B0B76EA391EBBF636086115110F3BCA1C21742094EB06A14767EB92C24FB1"
DATA "6BFDDF216347F0408D4C0FF00F42C10840B8F01BACE976D323C793C000AFBA1430D8779BB1E27CF823FA75141D40D8A8B7551F1013EEEC45CD5D965FD7EBBDFC7B43B7880B74F2AE4BF7D9"
DATA "1718E2967B8A450CFD0D6E3807CC00D67504FFFC680000E5D847140A3901079034CBA669BAA603C0D6EA063524344DD3343652667A9C59364DD3ACC2DA02360EA6699AA61C2A3442549AA6"
DATA "699A6672829AB2CA34CBA669D8EE04371A26D7344DD332404C5E7A834DD3745D82079203A0B0C2CCB94DD334D8E4FE183877D3344DD3033C4E6070844DD3344D90A0AEBAC8D82A5DD334E8"
DATA "F86E6760B71772103E190E36CE138F4B2EDD4B2E9D336F7C0F1C3796A0C9038473726243409D2905038027C3FEFF301B4D61696E20496E766F6B65642E0FD2749FFD52657475726E1000D1"
DATA "9C03B0EC22DBB7FFD22861006400760005700069008032EBBAEECF0D2D006D007305770B6E076395AC6BBA5B79006511666209721FADB2997B6C003105033B9AC936B71579110F68393230"
DATA "25EBC6C6776B536E056C8B0EEC6FFF004576656E74C367697374657213537DD9FFD6D7EA666F726D6174696F6E17556E72FDEDB1812D135772690F5472616E7366DBFEE6E1168D03466C73"
DATA "416C6C6F900013EDC0B6094640650F4769C82113F656616C75135302EDBE6D2D8B626911697A65436C6963EE60BFAD0A2263994578B5D498039AA6699AA4ACB8C4D0DC749BAD69ECF827D5"
DATA "D508071469BAE6D220D1642C03343CA6699AA64044484C509AA6699A545864686C70699AA66974787C8084A6699AA6888C9094989AA6699A9CA0A4A8ACB0699AA669B4B8BCC0C4A6699AA6"
DATA "C8CCD0D4D8CDA5699ADCE0ECF8D6000C344DD3342430446484692E4DD3A4C4E4D70824A6699AA6486890ACBCCDA5699AC0C8D8FCD80410344DD334203C5C84AC699AE6D2D4D9001C4064DD"
DATA "D799A690BC3FD10FE803FC4BBF692EDA182C4C5F5F62617315285BA1703B0B6364AC3613706E636628B91342640B6CB3C6916C7468510C2366D6301CB6740B76E3820D959EE46F33636C72"
DATA "656162001A65B7F553749F343772651AACA9E3D72F13756E2A67950015ED95DA3788201034078DD9361B8D6C5F5B3D3E3EF13CEB824C81326F21033EB7D1B55B5D2570C9617B2F2DE7BA06"
DATA "EA232AC62B0B2D030BE99AC7BA03261B2A002F25033CCBA67BDD3F3E57072C28297E74BBD3355E337C347C7C4F3DF36D9ACE032D2F253D8B3DF6A6335B3D233D035E60766674E887807CB7"
DATA "AE27000B6208A6F66E6F09607479A96F66120B6BB3BFA96D1420F0B263206775617264170C87B30F026E670B769701614277E813755C1560661634B73037281D1F0FDAB0D22F94756C7420"
DATA "636E180B5973D6DA6C73F88B73613FAE84CD025F3E30C096BD085F207F1E05364B961FBA4536BA02B723697288FD644970FEB6BADE8C63656D9720BC70DF656820816C16CA822386DCDC2A"
DATA "7B1F8647177079186C0F212860756492722F4BFE0B878EBB4548006052545449812D2C09ED0F50DB4BF263CF5B5D0A376FE1953EB66D5C201B7300730C952D9B2D253E1BA9F096B5411D4B"
DATA "3E47B251426967443C274328E1304063256C25ACB04F6B2DE8586E237B64796DEE69D8735B32201E6622DF1B64CBDA6D2A65781D9721815D658F5B90608C16D94A180B575D289090AF0376"
DATA "6164583FAC21B67F20222220B3B0A56DD354E72044C163CA706C17B0ED7720428F436C057319EDCC6D276C20281B41724A79300E905DC01D48695A4768794EDD636CB81F3C70234F626ABE"
DATA "20EB0A82B94C9F1CB50B24208334DD0B1D0496033248338D088E8F200332209091392003329293B4029A6E402EB50C030309DA103A640F0501ED818B858864E323CE586B6DC37245F75072"
DATA "C6E822002ECF063B2E2F07660F5C995D4673B93C6B630357E1583966382E5D3758492BA3179B03C752081BF6AC6B5E1B532F62B4590F4EF3E4370B2EAC2E5B417B41BA2FDB160302BB07A4"
DATA "69BAE60418D3050D0690EF051B07E3EF07097B01196C0A1B0B573B37D860DF070F57101311036C902F48121721350FB041061941435033C1061B6C52175307575FA61B6CB0597B6C176DAB"
DATA "20EF05699A701C72C72F061B6CB080B38107821F839A66B041848F91299E196C9041A1A46FA761B0C106B79FCE1FD70BF085270718076363E85554462D41F87FCCBC0731364C45554E4943"
DATA "4F4445A3F7A41A8ADD8EC8A7DE0803DD93FA4C500BFCB7DF38037899E6D234B4F0E0409854779ADA0BE138DB9C0B883ABA6F85CF1570136F8B65DA5CF36619720075741F15655B259592D9"
DATA "DB4794A5B06E613D65413F8D355D776C0963256C7A4B694B954CD6116E473205CA6AAC796200736CA56583FBDC04D8E7700761651F0298B1AE734768FF610FEC5B2513323F721500391060"
DATA "674B3046821BBB7315661325B26DB6CA3F110B747984D855963B78B9EFD94B25DFB732673FCC00EE6367751FF1235E0AAC3B641D778B3B4B4277D84F753D4B790F914DC218DB2966CB63FB"
DATA "73485937805765C57457D73D840C85EF61496B0560EFCD5E67BB75C7C5571FE6C252F164A16F2144D675536205784739D94A7A03FB354F2B48306C355BA3A34BBCC4776546694F41709252"
DATA "D87B7D414E5349AF17078596E0F500E3104383BA58A8A17297509F6B4D49E8C106DB83072303074C434DEC0491DADB53D70117ED2D7E9152654EF665546F236D9AEED9494455E23403404C"
DATA "586A2F1881CDC9B74AEB7A2DF878C102FD4E23E94B3B026711FB1754F75375F16009B6604D03548F5716AD6D17535468ED4679171CBEF71ABF1B64611A1F07237360DF59F708276E09002F"
DATA "720A066BEFBD37093B14134A422B6C85321765A9D13F34D76D852C034D164A73035F80E56F254175670053654FD84E6F7600BE86DE16B2632F24793372732F0EF1089BD1073FE75EF7A069"
DATA "9B3F6517431FB8C56BBF477573424BDF6D6261EE752FBD536F0957126FB693BD5F0B414D03504D4D2F64BDE66EEC642F794764002C204D2008D359FCAE141648483A6D6D3A61531BFBDC7B"
DATA "BC8F27FB0F8857059D0E5BAC640FA575075B7620D9E32F5537E566EC2C612F3F0F477311CE1276964F6E135B72D9B264CB11670F6FEE3397BD25134AAB464D1681D7BD627B0F72FF8D0F7B"
DATA "5FB06F294ADB076C1F07F73A74AF675337704F13BB93BD0E4D4E764B455F756CD96463557967721173BDC31C91BB776963364B76987341772F7B59C3DE697571839F924D768A3F8F6F0FD8"
DATA "B081CD9721A3136E90CF5D418D07504D01DF9BB9E62F00642F7D7F0D012C4BF63D17FD1F0120112506CDDDD92948013A006D3AD124F7352B7B4155B39BA6699A6E6403686C70749AA6699A"
DATA "787C80889098699AA669A4B0B8C4C8A6699AA6CCD0D4D8DC9AA6699AE0E4E8ECF0F4EE597369FCE308102FE318039AA6699A2028303C44506A9AA6695C60647084699ADD046503E39098A0"
DATA "A6699AA6A8B0B8C0C84D73699AD8E8F8E40C2030344DD334444C545C64D3354DD36C747C842F8C4DD3344D949CA4B4C8D4B934DD20E003ECF8E508A6699AA61C2C40545C24A0699A6478A0"
DATA "B45B85B8010020018E5532C92820C5194026B21001841002199009810119900119108202601C16023B20027FA24806808182838485FFFFFFFF868788898A8B8C8D8E8F9091929394959697"
DATA "98999A9B9C9D9E9FA0A1A2A3A4A5FFFFFFFFA6A7A8A9AAABACADAEAFB0B1B2B3B4B5B6B7B8B9BABBBCBDBEBFC0C1C2C3C4C5FFFFFFFFC6C7C8C9CACBCCCDCECFD0D1D2D3D4D5D6D7D8D9DA"
DATA "DBDCDDDEDFE0E1E2E3E4E544FFFFFFE6E7E8E9EAEBECEDEEEFF0F1F2F3F4F5F6F7F8F9FAFBFCFDFFFFFF4BA20102030405060708090A0B0C0D0E0F10111213141516171819FFFFFFFF1A1B"
DATA "1C1D1E1F202122232425262728292A2B2C2D2E2F30313233343536373839FFDFA0FF3A3B3C3D3E3F40616244666768696A6B6C6D6E6F7071A27F8B165241767778797A5B5CB2BFC216EB60"
DATA "1F7B7C7D7E7FFF5315C2A87F416E10FCFF42434445464748494A4B4C4D4E4FCF535436E1A588CE58595A7F1F240084157F3C79F619BBF44802075003580493274F9E60057006780779F2E4"
DATA "C980088809900A980B274F9E3CA00CA80DB00EB8F2E4C9930FC010C811D0124F9E3C79D813E014E815F016F2E49127F818F50019081A4F9E3C79101B181C201D281EE4C99327301F382040"
DATA "219E3C79F24822502358246025C993274F6826702778293C79F2E4802A882B902C982D93274F9EA02FA836B03779F2E4C9B838C039C83ED03F274F9E3CD840E041E843F079F2C89344F846"
DATA "F600470849274F9E3C104A184B204E28F2E4C9934F305038564057479E3C79485A5065587FD168F2ECC9CF0104F660026C030F780467CF9E3CE2580584060790070F9C7BF2C89308A809E5"
DATA "B40BB40C0727CF9E3CC00DCC0E5FD80FE4F6ECC99310F0113412074C1317274F1E7BFC1407F70815141620F2E4C993182C19381A441B4F9E3C79501C5C1D681E741FE4C9932780208C2198"
DATA "229E3C79F2A423B024BC25C826C993274FD427E029EC2A9E3C79E4F82BF8042C102D282FC993274F343240344C353C79F2E45836643770387C3993274F9E883A943BA03E79F2E4C9AC3FB8"
DATA "40C441D04393479E3CDC44F445F9004679F2E4C90C471849244A304B274F9E3C3C4C484E544F60F2E4C993506C52785684574F9E3C79905AA065B06BC06C73E49327D081DC0108E8048F3D"
DATA "5B8283070FF40907FA000AE4C993270C0C181024139E3C79F230143C16481A541DC993274F6C2C783B903E8E7CF2E49C43A86BC0010CD004C893274FDC07E809F40A9E3C79F2FB000C0C1A"
DATA "183B306BE4C9914F3C01104C0458079E3C79F26409700A7C0C881AE4C8274F943BA00114B0049E3C79F2BC07C809D40AE00CF291274FEC1AF83BFC1001184F9E3C3920092C0A380C441A72"
DATA "E49327503B68011C78094F9E3C79840A901A9C3BB401F2E4C99120C409D00ADC3B93478E7CE80124F809FD040A3C39F2C9103B1C01282C09380AC993239F44012C50095C0A9F3C39F26801"
DATA "307409800A8C0134F2C993239809A40AB0013827473E39BC0AC8013CD40AE0E5FBE4C80140EC0AF80A44A7FE1E79E4B14807100A4C1C0A5028047CCF802747341A4461FB620046BC039967"
DATA "E3001F1E106C0B465317C329CED90B3D0765D104B3C9D9076E276076367BCF075F682FBD62F2BDA9276967F23D62F2576A8B576E0926830D6E0F70EBD90B26DF17724D57839CB9B3677341"
DATA "07717623670F3A51077275B3D92126230F37769664B062D7736F6C47D820830D6CAF6676E72C5877BE7F79157A3797CD66DDEC6D571766DF37574CBE075D3F688FEB6667B31F2F6B4F1577"
DATA "9F26839D0557747F702126DF210B0F74099684D9D93F6E57171F77980D766D1767DF6F7167A077A0E72943E9DD8C868F172DFB411B0B42C3758F13931F0B4519131B2FF631235A37177C4B"
DATA "8A1923630B65451F91B7C7D95B47130B4600498CEE7D917217682F154C1F7DC1E8182D7555231753E9668C8C0B74541B2F4E8C7423DD0B624F1770506EC6F78827B3522B23B191B1915272"
DATA "5F526883CDF81E914837EF4B3BF445BAD347411776CB74887CCF8C13540B3B54C6C8D8F74B774BA76444531B19A4614355655953D2CD18196C495F5F45F2C5BA376C6B75560BEF4C461EDE"
DATA "236B5343765605E39BE1F173A74D7787748AF70B5A35EB8F753BDB2309AF8BA74D1FCF6223DD9B5A78D70B7A00C7B0479275B30BB764648487C745BB6F4F3A63235F8F496DB34D46BE0927"
DATA "159717735991B1E7836B6B5A0B79C6BE178C47E70B5F75CB553B84474AFBBB62BFA764A7D9770B0B0F926EC96117740B6506ECB2531BB36C0B72191B90C93B736D2F4D8449DD1B63B3B142"
DATA "435B210D9B9447314FF49274B6F5535745C1EA6667A171E5474FE75D779884736B6D53475A93611C48D22051579306E1B0096F87655F582C495B92571545332F204F6FD23317336E7016E4"
DATA "21B350B1508CD3A4907703B767797AC52E43E347276521E13B24EF6B4ECBACDAB2652FFF2F016B32F8DEE70D477B484BEC7BB101419FF30B55F364DF9B907BF35D41C3379BAD2C9FC37BF5"
DATA "5BB26ED9457BF1597B3F474B36D8647B4C6F6E637B266B403E470054484F42CB2634CC87056A656303F2645D155A634D004F49C0D98424F763436667CC82379FF7736313769612A36F53D3"
DATA "4D9BEC8C60AFEF455750176113BE17572343375712B6944D61C7F94E1358F606645A44254BDBC85E4A834BA3314D8B4DF2644B4A004D56253378971DDE0DB933591BDD64B24993427F4333"
DATA "6E9C30292589634262933D9605234A3FE34CC2F723E3548741270163C02642FB578B1B1B6CB243234B176E5F489F0161B2014C23418F05E47BB1559B179B48926E0997175167234FC9B664"
DATA "5BD7560B394E0B124293BD4EFD4752D3822F9BF0D9A700D16842EFE4874ECB2C41010570F48E9327CF7E0F7CD80788DA94B179F2E4C9A0A0AC8FB8CFC4D5274F9E3CD0D2DCA9E8B9F479F2"
DATA "E491C40600DC0C4318CC3B0B9E3C24BF30C87B2917274F9E3C3C9B546B58216C67CF4E8863E3010F784407846727C4937D90B7FB020FA8F1ECC993457004B44707C087F2E4D9190B050FCC"
DATA "4880064F9E3C7BD8A207E491F049FCB3CF4EDE056B010708AB410F148B4F9E9D114B070F244A9008E4C9B32730A3073CCD48AC9E3C79F254C960926CBA78C5C993274F84B490D69CD03C79"
DATA "F6E4A84BB4C06FC0D398099327CF9ECCD107D8DDE4D73C79E4C9F0CAFCB50808C114D493274F9E20A42CAD38DF79F2E4C9449350E05CBB68CE274F9E3C74E180DB8CDE986767C493D9A4C6"
DATA "8B230FB0F2E4C99365A02ABC6C8026F2ECA478C868830A1FD44C4F9E3C79C02EE073A80BEC94F2E4916707F8A50904AE104D76463C791CB628BC3B3E0F299E3C7934880837407FEB76463C"
DATA "3B0C0F4C4EE32F0FCF9E3C795874101864AF37705A27C59327B80D7C4F5328E2C993670F886A481F9461E4C9B3B3430E0FA050C80FECAC78F6AC9507B8515B1047523C79F2C452B82DD072"
DATA "739E3C797631CFDC78203AE8829E3C3B2B931117483FF4899E9DBC29AB010A0453320F1079C993274F78251C6770243C79F2EC286617348EA82B406D3C3B299E4C83A33D0F58863C797652"
DATA "C33B376484D0309327CF9E709D077C778875B36727D0945543120FA09607B313E8C9AC54B8975B136709F4E4C9C48D0036D07E737BF2E4D9140FDC56F815E8570793278F3CF4980B008C10"
DATA "9F936727D020A8A3160F3058B3B3E2C908173C59933C0F7AF2E4D948850754A760766C9C79F2EC04D3190F785B6022274F9E3D84640790BEA0C3B0F4E4C993B0C0B8D0CBE0C779E4D9191B"
DATA "1A0FF05CFE44E393278F3DFCC2070C14BD2CA6936767D044994B1B175C9A09F4E4C9685DE833747A4B7AF2E4D9400F808A1038908079F2EC04A3393F9C81301C3B839E3DA85E07B46EAB1D"
DATA "0F274F9E3CC05FF835CC7C50F2E4C99320D862401EE46079073D79F034F09EB3010D087B4F9E3D3B270F2069072C6F3803E4C9932748E2589064A19E3C79F270B27CAA88469470C2410C01"
DATA "0BF9DB926D438F05650BA1680B645B922764007A21670B644BC9B68D710BF16F0B409E6C83C5770B6C0062D62D9B64796D77396D174BD8804C71730B3B90B3092DC9B3794BE8EC51FD0563"
DATA "9F80653461176C03BC59F0CEBB62530B057C076202832B1773F182908D613B2FA73B2C78852F637700752F8874EF673B056B82612F490F3F0B22D99B3D1B0B050B25C0652E890B7563F405"
DATA "23DC6D059B6372F6BDD8248B61270BAB7A0B4C72D94BA50B62679227EB965B65476A006D449207646E700068B047303BA90BAF6B9250B7E47A0B77A3E620861DA10BBD0B4BD8B26F8F6C0B"
DATA "172F7B044B2E64D70B96E4492E73670074A55BB22DD96E0BC9780B15694CF688640B610B65920CC8807279587216296917752323DF29799B746575F1C68224DB69536F16BC191F05630518"
DATA "F64856A7850BF6925C76AF0B68050BC09DCD18130B6D25C60B929DAF7727BB780533627F77B2B3652FCF1777610B8837235E05A3056F42B843836161FB0549F08611BB058759F166B3A70B"
DATA "05F31443888F4B705F62DD84300B23037A0B257BC19263630D6264EC9B0F27720B79670523DE303B05538864BCE00557AF7B4388F70B05035517B16464E46E6E7208D12D9B970B0579F304"
DATA "9A146F058BB14B7678C16FB30B05923420DF236E730FDE29863D6D6BC7056FF60E0B9F62E30B0565939604C3290F3163D98CFD0FB99B152F5803050305BC2020DD77732397ECCD667F0BA7"
DATA "0B05464646BE0B6B6B6C692D9B2D03DB310F9221399B351F6A6A849C251B6E7D0F73908C37C671676C0B9795C06C21BF1783BD04F6BD1769702F17652FD9912F76790BFB96C120DD770B6B"
DATA "79696566401A4774740BB4ACF7CC68050BFF6152BC083F05D78FC8D8093433752375947CF0DC70110BB375045AD8B217C3278259646C768378774CD8E974038B990F74923CD9846E0B6800"
DATA "6B641B6682D90B3F67B321D0963B773B67CF4B06F46C6F6731FD07F03956F0903F33047E3304C1017202FF07805B828670E18B55C3242FB1646303000F07000DFB3DECC0DB3F0710F8178F"
DATA "4207FF7FB2EE4B087F07789F501344D33F58B3121F31EF1F085BB6B03D5700CFBCB017D8C5304307F0FFFF1F92837F01F9CE97C6148935403D812964FFFFFFFF099308C05584356A80C925"
DATA "C0D23596DC026AFC3FF799187E9FAB164035B177DCA08DECFFF27AF2BF08412EBF6C7A5A77CBC3FE9F1DA4D5DCA7D7B9856671B10D40CBFB83FD6F09F736430C9819F695FD39E03F036578"
DATA "703FCCED5725A69FF103A2FAFFDB84EDADA1215FC04335C26821A2DA0FC9FFFD21E1B03F09FE05084008040808D84998FC0300040C2F7F023501264F783E4051EF7FC5365890DD0798C0B5"
DATA "F0D1FC92F1185357B4706F8FF1186F75617369F061636FD0737172CCBCA584749FDC8010440B1BD5CA180098C5E4F0FFE6FF0AA8037C3F1BF7512D3805DEB69D578B3F0530FBFE096BBFFB"
DATA "FF0BB28096DEAE70943F1DE1910C78FC391F3E8E2EDA9A3F250258FE1A706E9ED11B35C0B5FF776FEAADA03F4B09512A1B1F63C6F7FAA33F3FF581F162EF6EFFCD3608EF591E17A73FDB54"
DATA "CF33BD163FC702903EE6FF97FFAA3F86D3D0C857D22140C32D3332AD3F1F44D9F8DB7AFFBFFBFFA0D6701128B03F7650AF288BF34F60F1EC1F9CB13FD455531E3FE03EFFDDFF3765FD1B15"
DATA "B33F95678C0480E2371FC5802793B43FF3A562DFFD7FF7CDACC42FAFE95E7305B63F9F7DA123CFC3174F4A8D776BB7BBFF77FF3F7A6EA012E8031C3FE44E0BD6B83F824C4ECCE500CF4024"
DATA "FFBBBFF022B433BAD357673470F1363FA754B695BB3FC74E76245FFEFFED5E0E294FE0E90226EABC3FCBCB2E8229D1EB3C6CC1B442E5FFBBFFBE3FE94D8DF30FE5257F6AB1058DBF3FA777"
DATA "B7A2A58E2AFF3FFCFF203CC59B6DC03F45FAE1EE8D81324FAC3E0DC13FAEF083CB458A6FFEE5B71E0FD074153FB8D4FF93F1190B014F05FE51F2FFB7FFC23FC077284009ACFE5FE0F41C30"
DATA "F7C23F41631A0DC7F530EFB6BFF050790F7EC33F64721A79741FCFB4537429FDDB9BFFC43F344BBCC509CE3EFEFA24CA0F5168E64243202EDB9BFFBF7F3009127562C53F2D17AAB3ECDF30"
DATA "F61A1AF20F136FFFDFFC613E2D1BEF3F9016A28DC63FD09996FC2C94ED6F00286CFEF6E6FF5820C73FCD544062A8203D1CFF95B40FC53391682C01DFFEC2EFDFA0CE66A23FC84F238786C1"
DATA "C6200FF0560C0EFEBFFB97CCDFA0CFA1B4E336BFE7EFDF59C93FE5E0FF7A022024777C6BEF8FD2471FE90F0AF26C0E331F40038BFF777FE3A46ECAFF5B2BB9ACEB333F52C5B700CB3F73AA"
DATA "644C69EFFEEDBBF46F70F97CE6880F72A0782223FF322F2EBAE306FCCB77FFCC3F7CBD55CD15CB0F006CD49D9172ACE69446B60EE597FFBF901361FB11CD3F0B96AE91DB341A10FDAB599F"
DATA "BBFFDFFD736CD7BC237B9F607E523D16CE3FE4932EF2699D31BF02DCADF1CDFF2C9ACE3F87F18190F5EB909476581F8B07DDBFBDFB17EAEBAF077FDB1F80990F6896F2F77D7322CF0997DF"
DATA "FEF6455B0AD0AF2553235B6B1F0FE8FB378048C612E55F7EFBB9B9936A1B1FA821563187AEF3BF7DDA6132CB9B7FF9B86A1D71C632C1308D4AE935D2CDD9FF8035FEEFF89DF1F60E35EF78"
DATA "C2BE2F40D13F8BBA22421AFCF26FDF8F906919977A0F995C2D2179F22158AC307AB5FEEDDDBF7E84FF623ECF3D4F3A15DBF00FDF0E0C232E5827EDCDFFDF4F48424F0E26D23FF91FA42810"
DATA "7E1511A662620FF9975FFE12190C2E1AB012D843C0719879379EAC69392BDB2F507E800B76C1D5280FBEDEEA3A9F3008987EF9BBA7B30CD3D8B6199992CFEF72B60C062F0751424EC817F0"
DATA "E8DAE0804EC817F2C01FA0BED9805DC817F242500320A9D809F9424EE05528FFD7F2425EC860AF985FD00F424EC81780C3D6A87A4EC817F2D03170ECD510A79017F24228654023177242BE"
DATA "D0E4D460A668F285BC906BF82C78F5D385BC901380BA00837C212FE4F84E781770E3D2212FE484E0B2D87E5FC80B79484EB81DA0F0D1C80B392188C3709617F2425E5869B83FA07242BE90"
DATA "1200E9D0D8C285BC90173899107379212FE47049C02698002127E40BE0B4CF806F27E40B79202AC0E4CE609FC80B7921005A901B0B39215F30D6CDC097F9425EC85059E01A60E3CC425EC8"
DATA "09F0A4706D4EC817F2002F80F7CB00C011C850481D2379E4D9169B1D07041A0FF41B93278F3CF81F19501358217BF6ECD9600E2F080D07100F17681007674F9E3D700517181E7812077CF2"
DATA "E4C99320800C840B8C154F9E3C79941C9C19A411AC18E4C99327B416BC17C4229E3C79F2CC23D024D425D826E845864EE04656983B3B66460774610F6108076EEF39733227231F0765692F"
DATA "5868AC8466946F77469F9BE86162730A6D6F646C645AB9853E7B5F63185F6879B27427A63BC8CF201F667279300331AD7D0D956EE062136E1B6360942482669C0BF2052DA333BC80285032"
DATA "045CE4D85B298D031A90031BD10CB9DC9E2D0690200F4028D02A08FF0F3F45545730EB860E04882B058ABB05F0424159BE02202F4EADBEA120495669614352CC2F0C84822265B602466912"
DATA "D66251CF613B321340A1E4DC39219B50908F3AEB1616FE022B004D696372B06F4A2E2C500AFFBF6B787669645413D073504FCF898247B3E0DCE8C9047667E876B3BAC9B45F0266747F0F26"
DATA "3DC865601267C5246D6E16991DCDDC130C0149162435DC6F80B20FE1CA2E303063666746F65577C30F742458430A1413E7843C175A18494142BE4B9A1C0C432728F39C90EF5A132C504130"
DATA "5AC877490858273836B6B0AF973C134F4013E7429E135441445AE4ED749B503C49FF72AF902A019A2DF6D80F2473781617A010D27D8F4B7A133FB017770B593E1731272B2C9E0B699E3253"
DATA "013954EEDE966CD40200646267C7282E011336F24F7274632449412C135A76726063C730275434136B65CE12273865673DCB6FA4787827D03248650DC3D19EEC18330FFE13F35CD28DB740"
DATA "13143354E4F299640C01346034CC047BE6F299360040E008120FBD5AE6B2E0480809494A9D6D9FCD345B886766357393881A205DD2131C79CACBCE67224007D00FA7E440761F03FED40479"
DATA "03EB5E21055B037A1F45D69D90D8084403577F17C98BEC1CD09F1D8420853C2FB2311F21BBE40AEB063B26E307CB03DB672BE445F22A6B2ABCC85E64DD2FD103D53F35561F4EC981BC385D"
DATA "C43B27941CF612ED3AFA47CC17D98BE444B44FB28752487E2B8452EF1F53C26543C9963FCE2F1F2279910D7A9F62A0037991F05DB3C767DA5C24A78CB48F6B0F68B94838946F0E7F73483A"
DATA "8530BF71C62F227B91BC755075E25F22E145F27CD481457F88EE15F28DFFB5A903BC481E2AA4538E350101C808F91E3901A84AAA123958144458FFF85721218BD5B119BF44EC6526220314"
DATA "1B285F25FFFF23AB90EC5E22C0B244A5DDFD716A222A15C07E24E7190E200593190FA9492BE202A73BDD05C92901200237015052432402AE900C6543010002845032C80300EFB295B58F80"
DATA "000A00170046A6908110002090503042C4292C8244AF29248209064FD0480018E160D8778C11D1A4516082798221957D463C39A6DFA1A51D9FE0FCF0CBF707C67E80FC2FA800C1A3DAA306"
DATA "397B84CC81FE0740B5BB4186C02F41B65FCFA263AF90FFE4A21A00E5A2E8A25B7EA10951AFE4B7BB0503DA5EDA5F5FDA6ADA32D3D8C96CC8EDDEE0F939317E0016404893179311AA901004"
DATA "E860190C8328BBC36B1411C8CF590F2597250217708C90CBEDEAA886EC28E5C0068A0C45F98792EECAA843272E572E6047C9ED640341B87F00DE086BBA2F68BC035F44C801296F75988020"
DATA "4B14035936CBA3D239B7633E41C9419AAE5B0763ACB4725936CBED5376035E6208C7679BB9ED9AAEA31749380339682BE16735CBED3703466D0B996C662FCBE572D903E764CE4696474B9F"
DATA "7CA0592E977F937B1CAD33369665591630494C0A0D6423020A5951051010521810944BD4619608D07E5030193454484964FF0210C7135379AA6D54696D65417388F60C140E0918E7B62701"
DATA "4D534C6920482F14BFB9ED7F7344656275676765725040734812556E68616E3300F1B764356445786365706E432BAC6C9B4F725A531C88850A7E7774618F700205AF0342575A84256BAD7D"
DATA "6F72466B175F62031BDBDE2B4D6F647546484C57C9DBDEB660341254556D696E3865116B6DDB25244C61B9452752442F081401F173F77EDBBA6E8B6C2E6BA0466C757368E96FED08030848"
DATA "417E0610DFDB537064436F759654BB5B06106F09A10C18400CA453CB5F6CBBBD055D6272F2798BA54110AC70EC646472A94C6F5C1CB672E1AE289752746C397769C4532E646F4245B0943E"
DATA "2A98B20B2F766515448382941DAF16EE6D2C252C597C4D0EA15DD86E2942793A5496696440C1256BC35C7809131E20BCD9B2774870DD090B70B860DB4305734EC835B5429B706FB17EDC0B"
DATA "026116CC701910CF70C31E469A74644A0DB22030C79C7970DA779B21C63A6DA043585061670BF6D8672B414350074F454D09060A0AB147690A46EECC6DAD0A7C6D6F4473456F42027BC918"
DATA "AD95A975077BE6CA6D6D974C21336F361B5910313EAD5F8C84750F53C96ACB42210843E1756666CE861C66FA46C227B643A61985209F70576E53697A407709B309703C4A53DEC7878FF764"
DATA "4F66340463156F69382C49E5859C5261698B2C636BC15E271F181151B58720DA46845003D606D57BB46E28EB3A078C76D62B452E461650FF7F2C7A303336A5288D39F0F4000F759A2F1017"
DATA "1111FFFFFFFF0519050D4D1D0A0E12153ED9339FB0314F13130C101126150706120A610D2708FFFFFFFF193A1B0C0F090D2F081106060C062331AB1F0A110C09052605250F1D420E1B0BF2"
DATA "FDDFFE8F0908470F0736210B090F0A16090B0720060007DFDABB72082C060A0A10001F16171B23DBFFFFF710182B2604220E708108125128A65313789E13140C3C8C08B22CDBFF2A1C0F0C"
DATA "0E22100505360239303FFFCDC9ED270903240C2730080B0D16120C290CF7B6FDFFF0170132151A1A0E06151C120B15C11B971C200EB7FEFFFF7F120512650C781A099880F0CF02F09501CC"
DATA "F08D0134271A4CF03401163730FF7FFBD68586070C13054A116A0712094812080A0911121B2CFFFFB7FF073305F02601182D1B7F0A050B0B1451A4130F21590B4F184A96177EF6B6FDDB44"
DATA "12920D0C19133D0C0B7E06010E381041FF85BFFD2005211D316E3E06876D063806BDEE0A0D3312301DFF7FA1F00B5207136C45339E165A3D0A1B461A0F0E0C0C0EFFFFFFFF101517231B0D"
DATA "0E0E0B161409A008F0A9011F05D0F06A012B1F1F8FF054019114FFFFBFFC1D5149BD1E235A653F0F3E13360C188918331D4AAA24F009012450C2BFFDFF152F172F1D14220A3E1C48F05601"
DATA "3D1D013023DEF00DE185DBFFFF5A154A8A5633202AC00A2A5339301B3B37A7235A5D7D7BFBFF5031304BF0FC00147CB907281AED35111BB736112909A1E17FA108150D0A22110D192D070B"
DATA "2A1BA1F3E1D8425010021D0881271991217BF91219210B1B0A1C051ED00A0BFF21101C34241C1F238615250E34C3B6BDC80F24123481104BF0EC0BFF5F2804EC58381BF014022D300C1244"
DATA "3CBE0D1AFFC2FF040604190B1B37361392864B72232622870711DFF8C63715050E2434072D121C24462C1E0B7D6BFC6F773E3E410D0017C77D0918122D2E347C5815FEFF7F081817F01C02"
DATA "36550A230A191D60234EF061011A4051FF8DFFBFAE290717163A074207092A130A213EA00C32163B07501431BFFDDBC22107E00D5A2C331511861640A7308C1F39270BBFFDFF0B1077371F"
DATA "160A1F1E6F29291E7E031C892E311C5F22176EFCFF7F5CA06F0A4EBFF02001B733F04B2C7D018D1202FFFFFFB70B511E0B5B1C63183028321A263114299D4DD8692A2F6639162178470DD8"
DATA "FFFF7F2D224689125B5486F0FA00B3065F06591200213BFE2FFD04F03101321F9D244C141C980D2A0A7D1C3D61FB2FFC406B1A0D302432124819841509091EFC0685EDDF78774E08001E08"
DATA "620CFE0C20472A081D1037F4ED2FFCF00401314237EC0B4D8867B5741155F00101BFFDC6B68F080266930609422B252A131F2B1845EDFFB7BB0C072480B56D70615B6E1F31F05501F03A01"
DATA "1BFAFD12151B1C59B90111F0E802C2FFFF2F061E1406F04C011DF0B4021C9A0646131E0EF0AE0137F2C06EBFDB0400564505F066F26201176C5B61196A76C6080C02205F15F6B72C127001"
DATA "0400F09C067390C10A112E080C08C8DF00F2F08C01AC8DF09003CA41C8150C0C25DBAAC800E50A907C7800F209D106096FFBAD6B070404D803201C04012000CA1CC4B60808200A5B007374"
DATA "FFDB19F0640D34F03807301000185B1114152963246A44D07AE9D286050074F766BBC087F0E0000264010E0CC8FB22DDB37E13BB151C1000100BB34853C104060763914D40C080011E4068"
DATA "B6ECBD012A020706F0013403CFC73C76DB4016A2701FC48A102A906E20DB071C26301F402BEC1034332F373B08416FC7C790EB5D42D0B0B7FD601BEC6001732C59FB5A2704D42DA4CC7740"
DATA "98AB288237EBF6023A92DD0A272601C09EE5B3452BBCA46001020177A8D0CA4FB498FB3765678703A33227421B008077BF00667407D87B01000200000000000040FF0000000000807C2408"
DATA "010F85B901000060BE000001108DBE0010FFFF57EB109090909090908A064688074701DB75078B1E83EEFC11DB72EDB80100000001DB75078B1E83EEFC11DB11C001DB73EF75098B1E83EE"
DATA "FC11DB73E431C983E803720DC1E0088A064683F0FF747489C501DB75078B1E83EEFC11DB11C901DB75078B1E83EEFC11DB11C975204101DB75078B1E83EEFC11DB11C901DB73EF75098B1E"
DATA "83EEFC11DB73E483C10281FD00F3FFFF83D1018D142F83FDFC760F8A02428807474975F7E963FFFFFF908B0283C204890783C70483E90477F101CFE94CFFFFFF5E89F7B9040500008A0747"
DATA "2CE83C0177F7803F1175F28B078A5F0466C1E808C1C01086C429F880EBE801F0890783C70588D8E2D98DBE007001008B0709C0743C8B5F048D84300090010001F35083C708FF9644900100"
DATA "958A074708C074DC89F95748F2AE55FF964890010009C07407890383C304EBE16131C0C20C0083C7048D5EFC31C08A074709C074223CEF771101C38B0386C4C1C01086C401F08903EBE224"
DATA "0FC1E010668B0783C702EBE28BAE4C9001008DBE00F0FFFFBB0010000050546A045357FFD58D872702000080207F8060287F585054505357FFD558618D4424806A0039C475FA83EC80E972"
DATA "7EFEFF0000005C000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000018400110902A011003"
DATA "0000000CE100100000000000000000000000000001000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "00000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000054A001003CA0010000000000000000000000000061A0010044A001"
DATA "0000000000000000000000000000000000000000006EA001000000000092A0010082A00100A0A001000000000041445641504933322E646C6C004B45524E454C33322E444C4C0000005379"
DATA "7374656D46756E6374696F6E30333600000047657450726F634164647265737300004C6F61644C6962726172794100005669727475616C50726F7465637400000000000000007487075A00"
DATA "000000E6A00100010000000100000001000000DCA00100E0A00100E4A0010060120000F3A00100000066696C65726561642E646C6C0066696C65726561640000900100100000008D358837"
DATA "8C37943700900100100000008D3588378C37943700000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000"
DATA "0000000000000000000000000000000000000000000000"
CLOSE #1
END
LET SUBJECT$= "送信テスト" !'タイトル
LET BODY$= "メールテスト"&CHR$(13)&CHR$(10)&"メールを送信します" !'本文
LET SFROM$= "admin@example.com" !'送信元メールアドレス
LET STO$= "admin@example.com" !'送信先メールアドレス
LET SMTP$= "smtpserver.example.com" !'SMTPサーバー名
LET K=SENDMAIL(SMTP$,SFROM$,STO$,SUBJECT$,BODY$)
IF K=0 THEN
PRINT "送信終了"
ELSE
PRINT "送信 ERROR!!"
END IF
END
EXTERNAL FUNCTION SENDMAIL(SMTP$,SFROM$,STO$,SUBJECT$,BODY$)
ASSIGN "sendmail.dll","sendmail"
END FUNCTION
using namespace std;
using Poco::Net::MailMessage;
using Poco::Net::MailRecipient;
using Poco::Net::SMTPClientSession;
using Poco::Net::StringPartSource;
using Poco::Exception;
130 screen 3:locate 0,27:R=10^3
200 ' complex number
220 for X=0 to 400
230 for Y=0 to 400
250 Z=(X-200)/R+#i*(Y-200)/R
350 if Z<>0 then pset (X,Y),int(abs(1/Z))@7
370 next
380 next
（２）Z^2の絶対値模様
200 ' complex number (z^2)
210 screen 3:cls:locate 0,27:S=0.93
220 for X=0 to 400
230 for Y=0 to 400
250 Z=(X-200)*S+#i*(Y-200)*S
260 pset (X,Y),round(abs(Z^2))@4096
270 next
280 next
> 数学研究ノートさんにある次の２つのUBASICプログラムを十進BASICに変換できますか。よろしくお願いいたします。UBASICは計算はすぐれていますがグラフィックが扱いずらい。
>
> （１）1/Zの絶対値模様
>
> 130 screen 3:locate 0,27:R=10^3
> 200 ' complex number
> 220 for X=0 to 400
> 230 for Y=0 to 400
> 250 Z=(X-200)/R+#i*(Y-200)/R
> 350 if Z<>0 then pset (X,Y),int(abs(1/Z))@7
> 370 next
> 380 next
（１）1/Zの絶対値模様
OPTION ARITHMETIC COMPLEX
SET POINT STYLE 1
130 SET BITMAP SIZE 401,401
SET WINDOW 0,400,0,400
LET R=10^3
200 ! complex number
220 for X=0 to 400
230 for Y=0 to 400
250 LET Z=COMPLEX((X-200)/R,(Y-200)/R)
350 if Z<>0 then
SET POINT COLOR MOD(int(abs(1/Z)),7)+1
PLOT POINTS: X,Y
end if
370 next Y
380 next X
END
（２）も同様にして移植できますが、十進BASICでは色指標が0～255の範囲になければならないので、
pset (X,Y),round(abs(Z^2))@4096
の部分は、
SET POINT COLOR MOD(round(abs(Z^2)),256)
PLOT POINTS: X,Y
で対応します。
4096色がほしい場合は、[ヘルプ][グラフィックス][Color Mode（独自拡張）]にある24ビットの色指標を利用すればできます。
OPTION ARITHMETIC COMPLEX
LET SIZE=800
CALL GINIT(SIZE,SIZE)
LET LEFT=-1.5
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET EPS=1E-5
LET KS=50
DO
CLEAR
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/SIZE
LET DY=(TOP-BOTTOM)/SIZE
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF7(X)
USE
EXIT FOR
END WHEN
IF ABS(X-XX)<EPS THEN
LET C=MOD(K,7)
CALL PSET(ZR,ZI,C+1)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
PAUSE "拡大する範囲を指定してください"
CALL GETSQUARE(LEFT,TOP,RIGHT,BOTTOM)
IF LEFT=RIGHT THEN EXIT DO
LOOP
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
!'LET FUNC=X^3-1
LET FUNC=X^4-1
!'LET FUNC=COMPLEX(-1,1)*X^5+COMPLEX(1,-2)*X^4+COMPLEX(-3,1)*X^3+COMPLEX(0,-2)*X^2+COMPLEX(3,0)*X+COMPLEX(-5,3)
!'LET FUNC=CSIN(X)-.5
!'LET FUNC=CTAN(X)-1
!'LET FUNC=CCOSH(X)-2
!'LET FUNC=LOG(X)-.5
!'LET FUNC=EXP(X)-2
END FUNCTION
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB GETSQUARE(L,T,R,B)
OPTION ARITHMETIC COMPLEX
ASK LINE STYLE LSTYLE
SET DRAW MODE NOTXOR
SET LINE STYLE 2
DO
MOUSE POLL L,T,I,J
LOOP WHILE I=0
LET L0=L
LET T0=T
LET R0=L0
LET B0=T0
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
DO WHILE I=1
MOUSE POLL R,B,I,J
LET W=R-L
LET H=T-B
IF ABS(H)<ABS(W) THEN
LET B=T-SGN(H)*ABS(W)
ELSE
LET R=L+SGN(W)*ABS(H)
END IF
IF L0<>L OR R0<>R OR B0<>B OR T0<>T THEN
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
PLOT LINES:L,T;L,B;R,B;R,T;L,T
LET L0=L
LET T0=T
LET R0=R
LET B0=B
END IF
LOOP
WAIT DELAY 1
PLOT LINES:L,T;L,B;R,B;R,T;L,T
SET DRAW MODE OVERWRITE
SET LINE STYLE LSTYLE
IF L>R THEN SWAP L,R
IF B>T THEN SWAP B,T
END SUB
EXTERNAL FUNCTION DIFF7(X)
OPTION ARITHMETIC COMPLEX
LET H=1/256
LET DIFF7=(-FUNC(X-3*H)+9*FUNC(X-2*H)-45*FUNC(X-H)+45*FUNC(X+H)-9*FUNC(X+2*H)+FUNC(X+3*H))/(60*H)
END FUNCTION
EXTERNAL FUNCTION CSIN(Z) !'sine
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET XR=SIN(X)*COSH(Y)
LET XI=COS(X)*SINH(Y)
LET CSIN=COMPLEX(XR,XI)
END FUNCTION
EXTERNAL FUNCTION CCOS(Z) !'cosine
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET XR=COS(X)*COSH(Y)
LET XI=-SIN(X)*SINH(Y)
LET CCOS=COMPLEX(XR,XI)
END FUNCTION
EXTERNAL FUNCTION CTAN(Z) !'tangent
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET D=COS(2*X)+COSH(2*Y)
LET XR=SIN(2*X)/D
LET XI=SINH(2*Y)/D
LET CTAN=COMPLEX(XR,XI)
END FUNCTION
EXTERNAL FUNCTION CSINH(Z) !'hyperbolic sine
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET XR=SINH(X)*COS(Y)
LET XI=COSH(X)*SIN(Y)
LET CSINH=COMPLEX(XR,XI)
END FUNCTION
EXTERNAL FUNCTION CCOSH(Z) !'hyperbolic cosine
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET XR=COSH(X)*COS(Y)
LET XI=SINH(X)*SIN(Y)
LET CCOSH=COMPLEX(XR,XI)
END FUNCTION
EXTERNAL FUNCTION CTANH(Z) !'hyperbolic tangent
OPTION ARITHMETIC COMPLEX
LET X=RE(Z)
LET Y=IM(Z)
LET D=COS(2*Y)+COSH(2*X)
LET XR=SINH(2*X)/D
LET XI=SIN(2*Y)/D
LET CTANH=COMPLEX(XR,XI)
END FUNCTION
OPTION ARITHMETIC COMPLEX
LET SIZE=800
CALL GINIT(SIZE,SIZE)
LET LEFT=-1.5
LET RIGHT=1.5
LET BOTTOM=1.5
LET TOP=-1.5
LET EPS=1E-5
LET KS=50
LET Z1=COMPLEX(1,0)
LET Z2=COMPLEX(-1/2,SQR(3)/2)
LET Z3=COMPLEX(-1/2,-SQR(3)/2)
DO
CLEAR
SET WINDOW LEFT,RIGHT,BOTTOM,TOP
LET DX=(RIGHT-LEFT)/SIZE
LET DY=(TOP-BOTTOM)/SIZE
FOR ZR=LEFT TO RIGHT STEP DX
FOR ZI=BOTTOM TO TOP STEP DY
LET XX=COMPLEX(ZR,ZI)
FOR K=1 TO KS
LET X=XX
WHEN EXCEPTION IN
LET XX=X-FUNC(X)/DIFF7(X)
USE
EXIT FOR
END WHEN
IF ABS(XX-Z1)<EPS THEN
CALL PSET(ZR,ZI,1)
EXIT FOR
END IF
IF ABS(XX-Z2)<EPS THEN
CALL PSET(ZR,ZI,4)
EXIT FOR
END IF
IF ABS(XX-Z3)<EPS THEN
CALL PSET(ZR,ZI,2)
EXIT FOR
END IF
NEXT K
NEXT ZI
NEXT ZR
PAUSE "拡大する範囲を指定してください"
CALL GETSQUARE(LEFT,TOP,RIGHT,BOTTOM)
IF LEFT=RIGHT THEN EXIT DO
LOOP
END
EXTERNAL FUNCTION FUNC(X)
OPTION ARITHMETIC COMPLEX
LET FUNC=X^3-1
END FUNCTION
EXTERNAL SUB PSET(X,Y,C)
OPTION ARITHMETIC COMPLEX
SET POINT COLOR C
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC COMPLEX
SET BITMAP SIZE XSIZE,YSIZE
!'SET WINDOW 0 , XSIZE-1 , YSIZE-1, 0
SET POINT STYLE 1
SET COLOR MIX(0) 0,0,0
SET COLOR MIX(1) 0,0,1
SET COLOR MIX(2) 1,0,0
SET COLOR MIX(3) 1,0,1
SET COLOR MIX(4) 0,1,0
SET COLOR MIX(5) 0,1,1
SET COLOR MIX(6) 1,1,0
SET COLOR MIX(7) 1,1,1
CLEAR
END SUB
EXTERNAL SUB GETSQUARE(L,T,R,B)
OPTION ARITHMETIC COMPLEX
ASK LINE STYLE LSTYLE
SET DRAW MODE NOTXOR
SET LINE STYLE 2
DO
MOUSE POLL L,T,I,J
LOOP WHILE I=0
LET L0=L
LET T0=T
LET R0=L0
LET B0=T0
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
DO WHILE I=1
MOUSE POLL R,B,I,J
LET W=R-L
LET H=T-B
IF ABS(H)<ABS(W) THEN
LET B=T-SGN(H)*ABS(W)
ELSE
LET R=L+SGN(W)*ABS(H)
END IF
IF L0<>L OR R0<>R OR B0<>B OR T0<>T THEN
PLOT LINES:L0,T0;L0,B0;R0,B0;R0,T0;L0,T0
PLOT LINES:L,T;L,B;R,B;R,T;L,T
LET L0=L
LET T0=T
LET R0=R
LET B0=B
END IF
LOOP
WAIT DELAY 1
PLOT LINES:L,T;L,B;R,B;R,T;L,T
SET DRAW MODE OVERWRITE
SET LINE STYLE LSTYLE
IF L>R THEN SWAP L,R
IF B>T THEN SWAP B,T
END SUB
EXTERNAL FUNCTION DIFF7(X)
OPTION ARITHMETIC COMPLEX
LET H=1/256
LET DIFF7=(-FUNC(X-3*H)+9*FUNC(X-2*H)-45*FUNC(X-H)+45*FUNC(X+H)-9*FUNC(X+2*H)+FUNC(X+3*H))/(60*H)
END FUNCTION
OPTION BASE 0
!LET wd=16
LET wd=8
LET dlt=0.1
LET epr=0.1
LET duv=0.00095
LET dvv=0.0035
LET fv=0.09
LET kv=0.06
LET wdv=wd/epr
! Graphical Setting
SET WINDOW 0,wdv,0,wdv
SET POINT STYLE 7
LET cvmx=100
FOR ci=0 TO cvmx
SET COLOR MIX(ci) 1-ci/cvmx,0,ci/cvmx
SET COLOR MIX(ci+cvmx) 0,ci/cvmx,1-ci/cvmx
NEXT ci
DIM u(wdv,wdv),v(wdv,wdv),un(wdv,wdv),vn(wdv,wdv)
! loop
FOR tt=0 TO 0
! init
FOR x=0 TO wdv-1
FOR y=0 TO wdv-1
LET u(x,y)=RND
LET v(x,y)=RND
NEXT y
NEXT x
! main
FOR t=0 TO 2000
IF MOD(t,100)=0 THEN PRINT t
! draw
SET DRAW MODE HIDDEN
CLEAR
FOR x=0 TO wdv-1
FOR y=0 TO wdv-1
! SET POINT COLOR MIN(INT(u(x,y)*cvmx),cvmx)
SET POINT COLOR INT(u(x,y)*cvmx)
PLOT POINTS: x,y
NEXT y
NEXT x
SET DRAW MODE EXPLICIT
!
FOR x=0 TO wdv-1
LET lx=MOD(x-1+wdv,wdv)
LET rx=MOD(x+1,wdv)
FOR y=0 TO wdv-1
LET ly=MOD(y-1+wdv,wdv)
LET hy=MOD(y+1,wdv)
LET dltepru=(u(x,hy)+u(x,ly)+u(lx,y)+u(rx,y)-4*u(x,y))/(epr*epr)
LET un(x,y)=u(x,y)+dlt*(duv*dltepru+u(x,y)*u(x,y)*v(x,y)-(fv+kv)*u(x,y))
LET dlteprv=(v(x,hy)+v(x,ly)+v(lx,y)+v(rx,y)-4*v(x,y))/(epr*epr)
LET vn(x,y)=v(x,y)+dlt*(dvv*dlteprv-u(x,y)*u(x,y)*v(x,y)+fv*(1-v(x,y)))
NEXT y
NEXT x
LET umax=un(0,0)
LET umin=un(0,0)
FOR x=0 TO wdv-1
FOR y=0 TO wdv-1
LET u(x,y)=un(x,y)
LET v(x,y)=vn(x,y)
IF umax<u(x,y) THEN
LET umax=u(x,y)
ELSEIF umin>u(x,y) THEN
LET umin=u(x,y)
END IF
NEXT y
NEXT x
! PRINT t,umax,umin
NEXT t
NEXT tt
END
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM S$(1),SS$(7)
MAT READ S$
DATA "振幅スペクトル","位相スペクトル"
MAT READ SS$
DATA 2階調,4階調,8階調,16階調,32階調,64階調,128階調,256階調
FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(F$,XSIZE,YSIZE)
LOCATE CHOICE(S$) :MODE
LET N1=2^INT(LOG2(XSIZE)+.999)
LET N2=2^INT(LOG2(YSIZE)+.999)
DIM RR(N1,N2),RI(N1,N2),GR(N1,N2),GI(N1,N2),BR(N1,N2),BI(N1,N2)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL GETPOINT(X,Y,R,G,B)
LET RR(X,Y)=R
LET GR(X,Y)=G
LET BR(X,Y)=B
NEXT X
NEXT Y
CALL FFT2D(N1,N2,BR,BI,1,1)
CALL FFT2D(N1,N2,RR,RI,1,1)
CALL FFT2D(N1,N2,GR,GI,1,1)
CLEAR
LOCATE CHOICE(SS$) : L
LET L=2^L
SELECT CASE MODE
CASE 1
LET MINR=10000000
LET MING=10000000
LET MINB=10000000
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET R1=RR(X,Y)
LET G1=GR(X,Y)
LET B1=BR(X,Y)
LET R2=RI(X,Y)
LET G2=GI(X,Y)
LET B2=BI(X,Y)
IF ABS(R1)>0 OR ABS(R2)>0 THEN
LET MAXR=MAX(MAXR,LOG10(R1*R1+R2*R2))
LET MINR=MIN(MINR,LOG10(R1*R1+R2*R2))
END IF
IF ABS(G1)>0 OR ABS(G2)>0 THEN
LET MAXG=MAX(MAXG,LOG10(G1*G1+G2*G2))
LET MING=MIN(MING,LOG10(G1*G1+G2*G2))
END IF
IF ABS(B1)>0 OR ABS(B2)>0 THEN
LET MAXB=MAX(MAXB,LOG10(B1*B1+B2*B2))
LET MINB=MIN(MINB,LOG10(B1*B1+B2*B2))
END IF
NEXT X
NEXT Y
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET R1=RR(X,Y)
LET G1=GR(X,Y)
LET B1=BR(X,Y)
LET R2=RI(X,Y)
LET G2=GI(X,Y)
LET B2=BI(X,Y)
IF ABS(R1)>0 OR ABS(R2)>0 THEN LET R=(LOG10(R1*R1+R2*R2)-MINR)/(MAXR-MINR)*256 ELSE LET R=0
IF ABS(G1)>0 OR ABS(G2)>0 THEN LET G=(LOG10(G1*G1+G2*G2)-MING)/(MAXG-MING)*256 ELSE LET G=0
IF ABS(B1)>0 OR ABS(B2)>0 THEN LET B=(LOG10(B1*B1+B2*B2)-MINB)/(MAXB-MINB)*256 ELSE LET B=0
LET R=INT(R/(256/L))*INT(255/(L-1))
LET G=INT(G/(256/L))*INT(255/(L-1))
LET B=INT(B/(256/L))*INT(255/(L-1))
LET XX=X/(N1-1)*(XSIZE-1)
LET YY=Y/(N2-1)*(YSIZE-1)
CALL PSET(XX,YY,R,G,B)
NEXT X
NEXT Y
CASE 2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET R1=RR(X,Y)
LET G1=GR(X,Y)
LET B1=BR(X,Y)
LET R2=RI(X,Y)
LET G2=GI(X,Y)
LET B2=BI(X,Y)
IF R1<>0 THEN LET THR=ATN(R2/R1) ELSE LET THR=PI/2*SGN(R2)
IF G1<>0 THEN LET THG=ATN(G2/G1) ELSE LET THG=PI/2*SGN(G2)
IF B1<>0 THEN LET THB=ATN(B2/B1) ELSE LET THB=PI/2*SGN(B2)
LET R=(THR+PI/2)/PI*255
LET G=(THG+PI/2)/PI*255
LET B=(THB+PI/2)/PI*255
LET R=INT(R/(256/L))*INT(255/(L-1))
LET G=INT(G/(256/L))*INT(255/(L-1))
LET B=INT(B/(256/L))*INT(255/(L-1))
LET XX=X/(N1-1)*(XSIZE-1)
LET YY=Y/(N2-1)*(YSIZE-1)
CALL PSET(XX,YY,R,G,B)
NEXT X
NEXT Y
END SELECT
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MIX(0) 0,0,0
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE (X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB FFT(LENGTH,AR(),AI(),INV,OPT)
OPTION ARITHMETIC NATIVE
LET N=LOG2(LENGTH)
IF OPT=1 THEN
FOR I=1 TO LENGTH-1 STEP 2
LET AR(I)=-AR(I)
LET AI(I)=-AI(I)
NEXT I
END IF
LET NUMB=1
LET LENB=LENGTH
LET XX=-PI*2/LENGTH
IF INV<0 THEN LET XX=-XX
FOR I=0 TO N-1
LET LENB=INT(LENB/2)
LET TIMB=0
FOR J=0 TO NUMB-1
LET W=0
FOR K=0 TO LENB-1
LET J1=TIMB+K
LET J2=J1+LENB
LET XR=AR(J1)
LET XI=AI(J1)
LET YR=AR(J2)
LET YI=AI(J2)
LET AR(J1)=XR+YR
LET AI(J1)=XI+YI
LET XR=XR-YR
LET XI=XI-YI
LET AR(J2)=XR*COS(XX*W)-XI*SIN(XX*W)
LET AI(J2)=XR*SIN(XX*W)+XI*COS(XX*W)
LET W=W+NUMB
NEXT K
LET TIMB=TIMB+2*LENB
NEXT J
LET NUMB=NUMB*2
NEXT I
CALL BIRV(AR,LENGTH,N)
CALL BIRV(AI,LENGTH,N)
IF OPT=1 THEN
FOR I=1 TO LENGTH-1 STEP 2
LET AR(I)=-AR(I)
LET AI(I)=-AI(I)
NEXT I
END IF
LET NRML=1/SQR(LENGTH)
FOR I=0 TO LENGTH-1
LET AR(I)=AR(I)*NRML
LET AI(I)=AI(I)*NRML
NEXT I
END SUB
EXTERNAL SUB BIRV(A(),LENGTH,N)
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM B(LENGTH)
FOR I=0 TO LENGTH-1
LET K=0
LET II=I
LET BIT=0
DO
LET BIT=BITOR(BITAND(II,1),BIT)
LET K=K+1
IF K=N THEN EXIT DO
LET II=INT(II/2)
LET BIT=BIT*2
LOOP
LET B(I)=A(BIT)
NEXT I
MAT A=B
END SUB
EXTERNAL SUB FFT2D(M,N,RR(,),II(,),FL,OPT)
OPTION ARITHMETIC NATIVE
LET NN=MAX(M,N)
OPTION BASE 0
DIM XR(NN),XI(NN)
FOR Y=0 TO N-1
FOR X=0 TO M-1
LET XR(X)=RR(X,Y)
LET XI(X)=II(X,Y)
NEXT X
CALL FFT(M,XR,XI,FL,OPT)
FOR X=0 TO M-1
LET RR(X,Y)=XR(X)
LET II(X,Y)=XI(X)
NEXT X
NEXT Y
MAT XR=ZER
MAT XI=ZER
FOR X=0 TO M-1
FOR Y=0 TO N-1
LET XR(Y)=RR(X,Y)
LET XI(Y)=II(X,Y)
NEXT Y
CALL FFT(N,XR,XI,FL,OPT)
FOR Y=0 TO N-1
LET RR(X,Y)=XR(Y)
LET II(X,Y)=XI(Y)
NEXT Y
NEXT X
END SUB
OPTION ARITHMETIC NATIVE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
OPTION BASE 0
DIM MODE$(3)
DATA "LOWPASS","BANDPASS","HIGHPASS","BANDSTOP"
MAT READ MODE$
LET N1=2^INT(LOG2(XSIZE)+.999)
LET N2=2^INT(LOG2(YSIZE)+.999)
DIM BR(N1,N2),BI(N1,N2),GR(N1,N2),GI(N1,N2),RR(N1,N2),RI(N1,N2)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL GETPOINT(X,Y,RR(X+1,Y+1),GR(X+1,Y+1),BR(X+1,Y+1))
NEXT X
NEXT Y
CALL FFT2D(N1,N2,BR,BI,1,0)
CALL FFT2D(N1,N2,GR,GI,1,0)
CALL FFT2D(N1,N2,RR,RI,1,0)
LOCATE CHOICE(MODE$) : MD
SELECT CASE MD
CASE 1
LOCATE VALUE ,RANGE 2 TO N1/2-1,AT N1/4:FSX1
LOCATE VALUE ,RANGE 2 TO N2/2-1,AT N2/4:FSY1
FOR Y=FSY1+1 TO N2-FSY1-1
FOR X=FSX1+1 TO N1-FSX1-1
LET BR(X,Y)=0
LET BI(X,Y)=0
LET GR(X,Y)=0
LET GI(X,Y)=0
LET RR(X,Y)=0
LET RI(X,Y)=0
NEXT X
NEXT Y
CASE 2
LOCATE VALUE ,RANGE 2 TO N1/2-1,AT N1/4:FSX1
LOCATE VALUE ,RANGE 2 TO N1/2-1,AT N1/4:FSX2
LOCATE VALUE ,RANGE 2 TO N2/2-1,AT N2/4:FSY1
LOCATE VALUE ,RANGE 2 TO N2/2-1,AT N2/4:FSY2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF (X<FSX1 OR X>N1-1-FSX1) AND (Y<FSY1 OR Y>N2-1-FSY1) OR (N1/2-FSX2<X AND N2/2+FSX2>X OR N2/2-FSY2<Y AND N2/2+FSY2>Y) THEN
ELSE
LET BR(X,Y)=0
LET BI(X,Y)=0
LET GR(X,Y)=0
LET GI(X,Y)=0
LET RR(X,Y)=0
LET RI(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 3
LOCATE VALUE ,RANGE 2 TO N1/2-1,AT N1/4:FSX1
LOCATE VALUE ,RANGE 2 TO N2/2-1,AT N2/4:FSY1
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF N1/2-FSX1<X AND N1/2+FSX1>X OR N2/2-FSY1<Y AND N2/2+FSY1>Y THEN
ELSE
LET BR(X,Y)=0
LET BI(X,Y)=0
LET GR(X,Y)=0
LET GI(X,Y)=0
LET RR(X,Y)=0
LET RI(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 4
LOCATE VALUE ,RANGE 2 TO N1/2-1,AT N1/4:FSX1
LOCATE VALUE ,RANGE 2 TO N1/2-1,AT N1/4:FSX2
LOCATE VALUE ,RANGE 2 TO N2/2-1,AT N2/4:FSY1
LOCATE VALUE ,RANGE 2 TO N2/2-1,AT N2/4:FSY2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF (X<FSX1 OR X>N1-1-FSX1) AND (Y<FSY1 OR Y>N2-1-FSY1) OR (N1/2-FSX2<X AND N2/2+FSX2>X OR N2/2-FSY2<Y AND N2/2+FSY2>Y) THEN
LET BR(X,Y)=0
LET BI(X,Y)=0
LET GR(X,Y)=0
LET GI(X,Y)=0
LET RR(X,Y)=0
LET RI(X,Y)=0
END IF
NEXT X
NEXT Y
END SELECT
CALL FFT2D(N1,N2,BR,BI,-1,0)
CALL FFT2D(N1,N2,GR,GI,-1,0)
CALL FFT2D(N1,N2,RR,RI,-1,0)
CLEAR
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL PSET(X,Y,RR(X,Y),GR(X,Y),BR(X,Y))
NEXT X
NEXT Y
END
EXTERNAL SUB FFT(N,XR(),XI(),INVERSE,OPT)
OPTION ARITHMETIC NATIVE
LET NN=N
IF BITAND(N,N-1)<>0 THEN
PRINT "ERROR"
STOP
END IF
IF OPT<>0 THEN
FOR I=1 TO N STEP 2
LET XR(I)=-XR(I)
LET XI(I)=-XI(I)
NEXT I
END IF
DO WHILE NN>1
LET NN=NN/2
LET M=M+1
LOOP
LET L=N/2
LET J=L+1
FOR I=2 TO N-2
IF I<J THEN
SWAP XR(I),XR(J)
SWAP XI(I),XI(J)
END IF
LET K=L
DO WHILE K<J
LET J=J-K
LET K=K/2
LOOP
LET J=J+K
NEXT I
IF INVERSE=-1 THEN
LET PX=-PI
FOR I=1 TO N
LET XR(I)=XR(I)/N
LET XI(I)=XI(I)/N
NEXT I
ELSE
LET PX=PI
END IF
LET L=1
FOR K=1 TO M
LET LL=L+L
LET P=PX/L
FOR J=1 TO L
LET W=(J-1)*P
LET WR=COS(W)
LET WI=SIN(W)
FOR I=J TO N STEP LL
LET IL=I+L
LET TR=XR(IL)*WR-XI(IL)*WI
LET TI=XR(IL)*WI+XI(IL)*WR
LET XR(IL)=XR(I)-TR
LET XI(IL)=XI(I)-TI
LET XR(I)=XR(I)+TR
LET XI(I)=XI(I)+TI
NEXT I
NEXT J
LET L=LL
NEXT K
IF OPT<>0 THEN
FOR I=1 TO N STEP 2
LET XR(I)=-XR(I)
LET XI(I)=-XI(I)
NEXT I
END IF
END SUB
EXTERNAL SUB FFT2D(M,N,RR(,),II(,),FL,OPT)
OPTION ARITHMETIC NATIVE
LET NN=MAX(M,N)
DIM XR(NN),XI(NN)
FOR Y=1 TO N
FOR X=1 TO M
LET XR(X)=RR(X-1,Y-1)
LET XI(X)=II(X-1,Y-1)
NEXT X
CALL FFT(M,XR,XI,FL,OPT)
FOR X=1 TO M
LET RR(X-1,Y-1)=XR(X)
LET II(X-1,Y-1)=XI(X)
NEXT X
NEXT Y
MAT XR=ZER
MAT XI=ZER
FOR X=1 TO M
FOR Y=1 TO N
LET XR(Y)=RR(X-1,Y-1)
LET XI(Y)=II(X-1,Y-1)
NEXT Y
CALL FFT(N,XR,XI,FL,OPT)
FOR Y=1 TO N
LET RR(X-1,Y-1)=XR(Y)
LET II(X-1,Y-1)=XI(Y)
NEXT Y
NEXT X
END SUB
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
OPTION BASE 0
DIM MODE$(3)
DATA "LOWPASS","BANDPASS","HIGHPASS","BANDSTOP"
MAT READ MODE$
LET N1=XSIZE
LET N2=YSIZE
DIM BB(N1,N2),GG(N1,N2),RR(N1,N2)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL GETPOINT(X,Y,RR(X,Y),GG(X,Y),BB(X,Y))
NEXT X
NEXT Y
CALL DCT2D(N1,N2,BB)
CALL DCT2D(N1,N2,GG)
CALL DCT2D(N1,N2,RR)
LOCATE CHOICE(MODE$) : MD
SELECT CASE MD
CASE 1
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF X>=FSX1 OR Y>=FSY1 THEN
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 2
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE FSX1 TO N1-1,AT (FSX1+N1)/2:FSX2
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
LOCATE VALUE ,RANGE FSY1 TO N2-1,AT (FSY1+N2)/2:FSY2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF (X>=FSX1 AND X<=FSX2) OR (Y>=FSY1 AND Y<=FSY2) THEN
ELSE
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 3
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF X<=FSX1 OR Y<=FSY1 THEN
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 4
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE FSX1 TO N1-1,AT (FSX1+N1)/2:FSX2
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
LOCATE VALUE ,RANGE FSY1 TO N2-1,AT (FSY1+N2)/2:FSY2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
IF (X>=FSX1 AND X<=FSX2) OR (Y>=FSY1 AND Y<=FSY2) THEN
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
END SELECT
CALL IDCT2D(N1,N2,BB)
CALL IDCT2D(N1,N2,GG)
CALL IDCT2D(N1,N2,RR)
CLEAR
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL PSET(X,Y,RR(X,Y),GG(X,Y),BB(X,Y))
NEXT X
NEXT Y
END
EXTERNAL FUNCTION C(X,N)
OPTION ARITHMETIC NATIVE
IF X=0 OR X=N THEN LET C=SQR(.5) ELSE LET C=1
END FUNCTION
EXTERNAL SUB DCT2(A(),N,B())
OPTION ARITHMETIC NATIVE
FOR I=0 TO N-1
LET S=0
FOR K=0 TO N-1
LET S=S+A(K)*COS((2*K+1)*I*PI/2/N)
NEXT K
LET B(I)=S*SQR(2/N)*C(I,N)
NEXT I
END SUB
EXTERNAL SUB DCT3(A(),N,B())
OPTION ARITHMETIC NATIVE
FOR I=0 TO N-1
LET S=0
FOR K=0 TO N-1
LET S=S+C(K,N)*A(K)*COS((2*I+1)*K*PI/2/N)
NEXT K
LET B(I)=INT(S*SQR(2/N)+.5)
NEXT I
END SUB
EXTERNAL SUB DCT2D(M,N,RR(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
LET NN=MAX(M,N)
DIM XR(NN),YR(NN)
FOR Y=0 TO N-1
FOR X=0 TO M-1
LET XR(X)=RR(X,Y)
NEXT X
CALL DCT2(XR,M,YR)
FOR X=0 TO M-1
LET RR(X,Y)=YR(X)
NEXT X
NEXT Y
FOR X=0 TO M-1
FOR Y=0 TO N-1
LET XR(Y)=RR(X,Y)
NEXT Y
CALL DCT2(XR,N,YR)
FOR Y=0 TO N-1
LET RR(X,Y)=YR(Y)
NEXT Y
NEXT X
END SUB
EXTERNAL SUB IDCT2D(M,N,RR(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
LET NN=MAX(M,N)
DIM XR(NN),YR(NN)
FOR Y=0 TO N-1
FOR X=0 TO M-1
LET XR(X)=RR(X,Y)
NEXT X
CALL DCT3(XR,M,YR)
FOR X=0 TO M-1
LET RR(X,Y)=YR(X)
NEXT X
NEXT Y
FOR X=0 TO M-1
FOR Y=0 TO N-1
LET XR(Y)=RR(X,Y)
NEXT Y
CALL DCT3(XR,N,YR)
FOR Y=0 TO N-1
LET RR(X,Y)=YR(Y)
NEXT Y
NEXT X
END SUB
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
OPTION BASE 0
DIM MODE$(3)
DATA "LOWPASS","BANDPASS","HIGHPASS","BANDSTOP"
MAT READ MODE$
LET BIT1=INT(LOG2(XSIZE)+.999)
LET N1=2^BIT1
LET BIT2=INT(LOG2(YSIZE)+.999)
LET N2=2^BIT2
DIM RR(N1,N2),GG(N1,N2),BB(N1,N2)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL GETPOINT(X,Y,RR(X,Y),GG(X,Y),BB(X,Y))
NEXT X
NEXT Y
CALL HADAMARD2D(N1,N2,RR)
CALL HADAMARD2D(N1,N2,GG)
CALL HADAMARD2D(N1,N2,BB)
LOCATE CHOICE(MODE$) : MD
SELECT CASE MD
CASE 1
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET XX=SEQUENCY(BIT1,X)
LET YY=SEQUENCY(BIT2,Y)
IF XX>=FSX1 OR YY>=FSY1 THEN
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 2
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE FSX1 TO N1-1,AT (FSX1+N1)/2:FSX2
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
LOCATE VALUE ,RANGE FSY1 TO N2-1,AT (FSY1+N2)/2:FSY2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET XX=SEQUENCY(BIT1,X)
LET YY=SEQUENCY(BIT2,Y)
IF (XX>=FSX1 AND XX<=FSX2) OR (YY>=FSY1 AND YY<=FSY2) THEN
ELSE
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 3
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET XX=SEQUENCY(BIT1,X)
LET YY=SEQUENCY(BIT2,Y)
IF XX<=FSX1 OR YY<=FSY1 THEN
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
CASE 4
LOCATE VALUE ,RANGE 2 TO N1-1,AT N1/2:FSX1
LOCATE VALUE ,RANGE FSX1 TO N1-1,AT (FSX1+N1)/2:FSX2
LOCATE VALUE ,RANGE 2 TO N2-1,AT N2/2:FSY1
LOCATE VALUE ,RANGE FSY1 TO N2-1,AT (FSY1+N2)/2:FSY2
FOR Y=0 TO N2-1
FOR X=0 TO N1-1
LET XX=SEQUENCY(BIT1,X)
LET YY=SEQUENCY(BIT2,Y)
IF (XX>=FSX1 AND XX<=FSX2) OR (YY>=FSY1 AND YY<=FSY2) THEN
LET RR(X,Y)=0
LET GG(X,Y)=0
LET BB(X,Y)=0
END IF
NEXT X
NEXT Y
END SELECT
CALL HADAMARD2D(N1,N2,RR)
CALL HADAMARD2D(N1,N2,GG)
CALL HADAMARD2D(N1,N2,BB)
CLEAR
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET RR(X,Y)=RR(X,Y)/N1/N2
LET GG(X,Y)=GG(X,Y)/N1/N2
LET BB(X,Y)=BB(X,Y)/N1/N2
CALL PSET(X,Y,RR(X,Y),GG(X,Y),BB(X,Y))
NEXT X
NEXT Y
END
EXTERNAL SUB FASTHADAMARD(N,X(),A()) !'高速アダマール変換
OPTION ARITHMETIC NATIVE
LET BIT=LOG2(N)
FOR J=1 TO BIT
LET K=0
LET L=0
FOR I=0 TO N-1
IF I<N/2 THEN
LET A(I)=X(2*K)+X(2*K+1)
LET K=K+1
ELSE
LET A(I)=X(2*L)-X(2*L+1)
LET L=L+1
END IF
NEXT I
IF J<BIT THEN MAT X=A
NEXT J
END SUB
EXTERNAL SUB HADAMARD2D(N1,N2,X(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Z1(N1),P1(N1),Z2(N2),P2(N2)
FOR J=0 TO N2-1
FOR I=0 TO N1-1
LET Z1(I)=X(I,J)
NEXT I
CALL FASTHADAMARD(N1,Z1,P1)
FOR I=0 TO N1-1
LET X(I,J)=P1(I)
NEXT I
NEXT J
FOR I=0 TO N1-1
FOR J=0 TO N2-1
LET Z2(J)=X(I,J)
NEXT J
CALL FASTHADAMARD(N2,Z2,P2)
FOR J=0 TO N2-1
LET X(I,J)=P2(J)
NEXT J
NEXT I
END SUB
EXTERNAL FUNCTION SEQUENCY(BIT,N) !'シーケンシー
OPTION ARITHMETIC NATIVE
FOR I=1 TO BIT
LET G=BITAND(N,1)
LET N=INT(N/2)
LET L=BITXOR(G,B)
LET A=A*2+L
LET B=L
NEXT I
LET SEQUENCY=A
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
FILE GETNAME F$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(F$,XSIZE,YSIZE)
DIM S$(3)
MAT READ S$
DATA "LEVEL 1","LEVEL 2","LEVEL 3","LEVEL 4"
LOCATE CHOICE(S$) : LEV
PRINT 4^LEV;"分割します"
LET N1=INT((XSIZE+2^LEV-1)/2^LEV)*2^LEV !'サイズ補正
LET N2=INT((YSIZE+2^LEV-1)/2^LEV)*2^LEV
DIM RR1(N1,N2),GG1(N1,N2),BB1(N1,N2),RR2(N1,N2),GG2(N1,N2),BB2(N1,N2)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
CALL GETPOINT(X,Y,R,G,B)
LET RR1(X,Y)=R
LET GG1(X,Y)=G
LET BB1(X,Y)=B
NEXT X
NEXT Y
CALL WAVELET2D(LEV,0,0,N1,N2,RR1,GG1,BB1,RR2,GG2,BB2)
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET R=RR2(X,Y)
LET G=GG2(X,Y)
LET B=BB2(X,Y)
CALL PSET(X,Y,ABS(R),ABS(G),ABS(B))
NEXT X
NEXT Y
LET XX=INT(N1/2^LEV)
LET YY=INT(N2/2^LEV)
FOR X=0 TO XSIZE-1 STEP XX
CALL LINE(X,0,X,YSIZE-1,255,0,0)
NEXT X
FOR Y=0 TO YSIZE-1 STEP YY
CALL LINE(0,Y,XSIZE-1,Y,255,0,0)
NEXT Y
PRINT "マウスでクリアしたいエリアを左クリック"
PRINT "右クリックで再構成します"
DO
DO
MOUSE POLL XX,YY,L,R
LOOP UNTIL L<>0 OR R<>0
IF L<>0 THEN CALL CLEARAREA(LEV,XX,YY,N1,N2,RR2,GG2,BB2)
LOOP UNTIL R<>0
PRINT "再構成します"
CALL IWAVELET2D(LEV,0,0,N1,N2,RR2,GG2,BB2,RR1,GG1,BB1)
CLEAR
FOR Y=0 TO YSIZE-1
FOR X=0 TO XSIZE-1
LET R=RR1(X,Y)
LET G=GG1(X,Y)
LET B=BB1(X,Y)
CALL PSET(X,Y,R,G,B)
NEXT X
NEXT Y
END
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MIX(0) 0,0,0
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB LINE(X0,Y0,X1,Y1,R,G,B)
OPTION ARITHMETIC NATIVE
SET COLOR COLORINDEX(R/255,G/255,B/255)
PLOT LINES:X0,Y0;X1,Y1
END SUB
EXTERNAL SUB CLEARAREA(N,X,Y,SIZEX,SIZEY,RR(,),GG(,),BB(,))
OPTION ARITHMETIC NATIVE
OPTION CHARACTER BYTE
LET XX=INT(SIZEX/2^N)
LET YY=INT(SIZEY/2^N)
LET XS=INT(X/XX)*XX
LET YS=INT(Y/YY)*YY
PRINT "(";XS;",";YS;")-(";XS+XX-1;",";YS+YY-1;")をクリア"
CALL CLEAR(XS,YS,XS+XX-1,YS+YY-1,RR,GG,BB)
END SUB
EXTERNAL SUB CLEAR(XS,YS,XE,YE,RR(,),GG(,),BB(,))
OPTION ARITHMETIC NATIVE
FOR YY=YS TO YE
FOR XX=XS TO XE
LET RR(XX,YY)=0
LET GG(XX,YY)=0
LET BB(XX,YY)=0
IF MOD(XX,32)<16 THEN LET C=8 ELSE LET C=16
IF MOD(YY,32)<16 THEN LET C=24-C
CALL PSET(XX,YY,C*16,C*16,C*16)
NEXT XX
NEXT YY
END SUB
EXTERNAL SUB WAVELET2D(LEV,XS,YS,XSIZE,YSIZE,RR1(,),GG1(,),BB1(,),RR2(,),GG2(,),BB2(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM X1(MAX(XSIZE,YSIZE)),X2(MAX(XSIZE,YSIZE)),X3(MAX(XSIZE,YSIZE))
DIM Y1(MAX(XSIZE,YSIZE)),Y2(MAX(XSIZE,YSIZE)),Y3(MAX(XSIZE,YSIZE))
IF LEV>0 THEN
FOR J=0 TO YSIZE-1
FOR I=0 TO XSIZE-1
LET X1(I)=RR1(I+XS,J+YS)
LET X2(I)=GG1(I+XS,J+YS)
LET X3(I)=BB1(I+XS,J+YS)
NEXT I
CALL WAVELET(XSIZE,X1,Y1)
CALL WAVELET(XSIZE,X2,Y2)
CALL WAVELET(XSIZE,X3,Y3)
FOR I=0 TO XSIZE-1
LET RR2(I+XS,J+YS)=Y1(I)
LET GG2(I+XS,J+YS)=Y2(I)
LET BB2(I+XS,J+YS)=Y3(I)
NEXT I
NEXT J
FOR I=0 TO XSIZE-1
FOR J=0 TO YSIZE-1
LET X1(J)=RR2(I+XS,J+YS)
LET X2(J)=GG2(I+XS,J+YS)
LET X3(J)=BB2(I+XS,J+YS)
NEXT J
CALL WAVELET(YSIZE,X1,Y1)
CALL WAVELET(YSIZE,X2,Y2)
CALL WAVELET(YSIZE,X3,Y3)
FOR J=0 TO YSIZE-1
LET RR1(I+XS,J+YS)=Y1(J)
LET GG1(I+XS,J+YS)=Y2(J)
LET BB1(I+XS,J+YS)=Y3(J)
NEXT J
NEXT I
FOR J=0 TO YSIZE-1
FOR I=0 TO XSIZE-1
LET RR2(I+XS,J+YS)=RR1(I+XS,J+YS)
LET GG2(I+XS,J+YS)=GG1(I+XS,J+YS)
LET BB2(I+XS,J+YS)=BB1(I+XS,J+YS)
NEXT I
NEXT J
CALL WAVELET2D(LEV-1,XS,YS, XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2) !'再帰呼び出し
CALL WAVELET2D(LEV-1,XS+XSIZE/2,YS, XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2)
CALL WAVELET2D(LEV-1,XS,YS+YSIZE/2, XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2)
CALL WAVELET2D(LEV-1,XS+XSIZE/2,YS+YSIZE/2,XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2)
END IF
END SUB
EXTERNAL SUB IWAVELET2D(LEV,XS,YS,XSIZE,YSIZE,RR1(,),GG1(,),BB1(,),RR2(,),GG2(,),BB2(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM X1(MAX(XSIZE,YSIZE)),X2(MAX(XSIZE,YSIZE)),X3(MAX(XSIZE,YSIZE))
DIM Y1(MAX(XSIZE,YSIZE)),Y2(MAX(XSIZE,YSIZE)),Y3(MAX(XSIZE,YSIZE))
IF LEV>0 THEN
CALL IWAVELET2D(LEV-1,XS,YS, XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2) !'再帰呼び出し
CALL IWAVELET2D(LEV-1,XS+XSIZE/2,YS, XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2)
CALL IWAVELET2D(LEV-1,XS,YS+YSIZE/2, XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2)
CALL IWAVELET2D(LEV-1,XS+XSIZE/2,YS+YSIZE/2,XSIZE/2,YSIZE/2,RR1,GG1,BB1,RR2,GG2,BB2)
FOR J=0 TO YSIZE-1
FOR I=0 TO XSIZE-1
LET X1(I)=RR1(I+XS,J+YS)
LET X2(I)=GG1(I+XS,J+YS)
LET X3(I)=BB1(I+XS,J+YS)
NEXT I
CALL IWAVELET(XSIZE,X1,Y1)
CALL IWAVELET(XSIZE,X2,Y2)
CALL IWAVELET(XSIZE,X3,Y3)
FOR I=0 TO XSIZE-1
LET RR2(I+XS,J+YS)=Y1(I)
LET GG2(I+XS,J+YS)=Y2(I)
LET BB2(I+XS,J+YS)=Y3(I)
NEXT I
NEXT J
FOR I=0 TO XSIZE-1
FOR J=0 TO YSIZE-1
LET X1(J)=RR2(I+XS,J+YS)
LET X2(J)=GG2(I+XS,J+YS)
LET X3(J)=BB2(I+XS,J+YS)
NEXT J
CALL IWAVELET(YSIZE,X1,Y1)
CALL IWAVELET(YSIZE,X2,Y2)
CALL IWAVELET(YSIZE,X3,Y3)
FOR J=0 TO YSIZE-1
LET RR1(I+XS,J+YS)=Y1(J)
LET GG1(I+XS,J+YS)=Y2(J)
LET BB1(I+XS,J+YS)=Y3(J)
NEXT J
NEXT I
FOR J=0 TO YSIZE-1
FOR I=0 TO XSIZE-1
LET RR2(I+XS,J+YS)=RR1(I+XS,J+YS)
LET GG2(I+XS,J+YS)=GG1(I+XS,J+YS)
LET BB2(I+XS,J+YS)=BB1(I+XS,J+YS)
NEXT I
NEXT J
END IF
END SUB
EXTERNAL SUB WAVELET(SIZE,DAT1(),DAT2()) !'ウェーブレット変換
OPTION ARITHMETIC NATIVE
FOR I=0 TO SIZE/2-1
LET DAT2(I) =.5*DAT1(I*2)+.5*DAT1(I*2+1) !'足して2で割る
LET DAT2(I+SIZE/2)=.5*DAT1(I*2)-.5*DAT1(I*2+1) !'引いて2で割る
NEXT I
END SUB
EXTERNAL SUB IWAVELET(SIZE,DAT2(),DAT1()) !'ウェーブレット逆変換
OPTION ARITHMETIC NATIVE
FOR I=0 TO SIZE/2-1
LET DAT1(I*2) =DAT2(I)+DAT2(I+SIZE/2) !'足す
LET DAT1(I*2+1)=DAT2(I)-DAT2(I+SIZE/2) !'引く
NEXT I
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DECLARE EXTERNAL FUNCTION C
DIM COL$(1)
MAT READ COL$
DATA "RGB","GRAY"
LOCATE CHOICE(COL$) :COLORMODE
INPUT PROMPT "SIZE (3 - 5) =":SIZE
LET N=2^SIZE
DIM B(N,N),G(N,N),R(N,N),M(N)
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM VM(XSIZE,YSIZE)
ASK PIXEL ARRAY(0,0) VM
FOR I=0 TO N-1
IF I<N/2 THEN LET MES$="低域 " ELSE LET MES$="高域 "
INPUT PROMPT "フィルタ係数 "& MES$ & STR$(I)&" (遮断(0) or 通過(1)) =":M(I)
NEXT I
FOR Y=0 TO YSIZE-1 STEP N
FOR X=0 TO XSIZE-1 STEP N
FOR J=0 TO N-1
FOR I=0 TO N-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
LET CC=VM(X+I,Y+J)
CALL RGB(CC,RR,GG,BB)
LET B(I,J)=BB
LET G(I,J)=GG
LET R(I,J)=RR
END IF
IF MODE=2 THEN LET B(I,J)=(151*B(I,J)+77*G(I,J)+28*R(I,J))/256
NEXT I
NEXT J
IF COLORMODE=1 THEN
CALL DCT2(B,N)
CALL DCT2(G,N)
CALL DCT2(R,N)
FOR I=0 TO N-1
FOR J=0 TO N-1
LET B(J,I)=B(J,I)*M(I)*M(J)
LET G(J,I)=G(J,I)*M(I)*M(J)
LET R(J,I)=R(J,I)*M(I)*M(J)
NEXT J
NEXT I
CALL DCT3(B,N)
CALL DCT3(G,N)
CALL DCT3(R,N)
FOR I=0 TO N-1
FOR J=0 TO N-1
IF X+J<=XSIZE-1 AND Y+I<=YSIZE-1 THEN
CALL PSET(X+J,Y+I,R(J,I),G(J,I),B(J,I))
END IF
NEXT J
NEXT I
ELSE
CALL DCT2(B,N)
FOR I=0 TO N-1
FOR J=0 TO N-1
LET B(J,I)=B(J,I)*M(I)*M(J)
NEXT J
NEXT I
CALL DCT3(B,N)
FOR I=0 TO N-1
FOR J=0 TO N-1
CALL PSET(X+J,Y+I,B(J,I),B(J,I),B(J,I))
NEXT J
NEXT I
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB DCT1(NN,X(,)) !'変換/逆変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Y(NN,NN)
FOR V=0 TO NN
FOR U=0 TO NN
LET YY=2/NN*C(U,NN)*C(V,NN)
FOR M=0 TO NN
FOR N=0 TO NN
LET Y(U,V)=Y(U,V)+YY*C(M,NN)*C(N,NN)*X(M,N)*COS(U*M*PI/NN)*COS(V*N*PI/NN)
NEXT N
NEXT M
NEXT U
NEXT V
MAT X=Y
END SUB
EXTERNAL SUB DCT2(NN,X(,)) !'変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Y(NN-1,NN-1)
FOR V=0 TO NN-1
FOR U=0 TO NN-1
LET YY=2/NN*C(U,NN)*C(V,NN)
FOR M=0 TO NN-1
FOR N=0 TO NN-1
LET Y(U,V)=Y(U,V)+YY*X(M,N)*COS((2*M+1)*U*PI/2/NN)*COS((2*N+1)*V*PI/2/NN)
NEXT N
NEXT M
NEXT U
NEXT V
MAT X=Y
END SUB
EXTERNAL SUB DCT3(NN,X(,)) !'逆変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Y(NN-1,NN-1)
FOR M=0 TO NN-1
FOR N=0 TO NN-1
LET YY=2/NN
FOR V=0 TO NN-1
FOR U=0 TO NN-1
LET Y(M,N)=Y(M,N)+YY*C(U,NN)*C(V,NN)*X(U,V)*COS((2*M+1)*U*PI/2/NN)*COS((2*N+1)*V*PI/2/NN)
NEXT U
NEXT V
NEXT N
NEXT M
MAT X=Y
END SUB
EXTERNAL SUB DCT4(NN,X(,)) !'変換/逆変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Y(NN,NN)
FOR V=0 TO NN-1
FOR U=0 TO NN-1
FOR M=0 TO NN-1
FOR N=0 TO NN-1
LET Y(U,V)=Y(U,V)+X(M,N)*COS((2*M+1)*(2*U+1)*PI/4/NN)*COS((2*N+1)*(2*V+1)*PI/4/NN)
NEXT N
NEXT M
LET Y(U,V)=Y(U,V)*2/NN
NEXT U
NEXT V
MAT X=Y
END SUB
EXTERNAL FUNCTION C(X,N)
OPTION ARITHMETIC NATIVE
IF X=0 OR X=N THEN LET C=SQR(2)/2 ELSE LET C=1
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)
LET YSIZE=PIXELY(1)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM COL$(1)
MAT READ COL$
DATA "RGB","GRAY"
LOCATE CHOICE(COL$) :COLORMODE
INPUT PROMPT "SIZE (3 - 5) =":SIZE
LET N=2^SIZE
DIM BR(N,N),BI(N,N),GR(N,N),GI(N,N),RR(N,N),RI(N,N),M(N)
FOR I=0 TO N/2-1
IF I<N/4 THEN LET MES$="低域 " ELSE LET MES$="高域 "
INPUT PROMPT "フィルタ係数 "& MES$ & STR$(I)&" (遮断(0) or 通過(1)) =":M(I)
NEXT I
FOR Y=0 TO YSIZE-1 STEP N
FOR X=0 TO XSIZE-1 STEP N
FOR I=0 TO N-1
FOR J=0 TO N-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL GETPOINT(X+I,Y+J,RR(I,J),GR(I,J),BR(I,J))
IF COLORMODE=2 THEN LET BR(I,J)=(151*BR(I,J)+77*GR(I,J)+28*RR(I,J))/256
ELSE
LET RR(I,J)=0
LET GR(I,J)=0
LET BR(I,J)=0
END IF
NEXT J
NEXT I
IF COLORMODE=1 THEN
CALL DFT2(N,BR,BI,1)
CALL DFT2(N,GR,GI,1)
CALL DFT2(N,RR,RI,1)
FOR J=0 TO N/2-1
FOR I=0 TO N/2-1
LET BR(I,J)=BR(I,J)*M(I)*M(J)
LET BI(I,J)=BI(I,J)*M(I)*M(J)
LET GR(I,J)=GR(I,J)*M(I)*M(J)
LET GI(I,J)=GI(I,J)*M(I)*M(J)
LET RR(I,J)=RR(I,J)*M(I)*M(J)
LET RI(I,J)=RI(I,J)*M(I)*M(J)
LET BR(I,N-1-J)=BR(I,N-1-J)*M(I)*M(J)
LET BI(I,N-1-J)=BI(I,N-1-J)*M(I)*M(J)
LET GR(I,N-1-J)=GR(I,N-1-J)*M(I)*M(J)
LET GI(I,N-1-J)=GI(I,N-1-J)*M(I)*M(J)
LET RR(I,N-1-J)=RR(I,N-1-J)*M(I)*M(J)
LET RI(I,N-1-J)=RI(I,N-1-J)*M(I)*M(J)
LET BR(N-1-I,J)=BR(N-1-I,J)*M(I)*M(J)
LET BI(N-1-I,J)=BI(N-1-I,J)*M(I)*M(J)
LET GR(N-1-I,J)=GR(N-1-I,J)*M(I)*M(J)
LET GI(N-1-I,J)=GI(N-1-I,J)*M(I)*M(J)
LET RR(N-1-I,J)=RR(N-1-I,J)*M(I)*M(J)
LET RI(N-1-I,J)=RI(N-1-I,J)*M(I)*M(J)
LET BR(N-1-I,N-1-J)=BR(N-1-I,N-1-J)*M(I)*M(J)
LET BI(N-1-I,N-1-J)=BI(N-1-I,N-1-J)*M(I)*M(J)
LET GR(N-1-I,N-1-J)=GR(N-1-I,N-1-J)*M(I)*M(J)
LET GI(N-1-I,N-1-J)=GI(N-1-I,N-1-J)*M(I)*M(J)
LET RR(N-1-I,N-1-J)=RR(N-1-I,N-1-J)*M(I)*M(J)
LET RI(N-1-I,N-1-J)=RI(N-1-I,N-1-J)*M(I)*M(J)
NEXT I
NEXT J
CALL DFT2(N,BR,BI,-1)
CALL DFT2(N,GR,GI,-1)
CALL DFT2(N,RR,RI,-1)
FOR I=0 TO N-1
FOR J=0 TO N-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL PSET(X+I,Y+J,RR(I,J),GR(I,J),BR(I,J))
END IF
NEXT J
NEXT I
ELSE
CALL DFT2(N,BR,BI,1)
FOR J=0 TO N/2-1
FOR I=0 TO N/2-1
LET BR(I,J)=BR(I,J)*M(I)*M(J)
LET BI(I,J)=BI(I,J)*M(I)*M(J)
LET BR(I,N-1-J)=BR(I,N-1-J)*M(I)*M(J)
LET BI(I,N-1-J)=BI(I,N-1-J)*M(I)*M(J)
LET BR(N-1-I,J)=BR(N-1-I,J)*M(I)*M(J)
LET BI(N-1-I,J)=BI(N-1-I,J)*M(I)*M(J)
LET BR(N-1-I,N-1-J)=BR(N-1-I,N-1-J)*M(I)*M(J)
LET BI(N-1-I,N-1-J)=BI(N-1-I,N-1-J)*M(I)*M(J)
NEXT I
NEXT J
CALL DFT2(N,BR,BI,-1)
FOR J=0 TO N-1
FOR I=0 TO N-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL PSET(X+I,Y+J,BR(I,J),BR(I,J),BR(I,J))
END IF
NEXT I
NEXT J
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB DFT(M,XR(),XI())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM RR(M),II(M)
LET P=8*ATN(1)/M
FOR J=0 TO M-1
FOR I=0 TO M-1
LET RR(J)=RR(J)+XR(I)*COS(P*J*I)-XI(I)*SIN(P*J*I)
LET II(J)=II(J)+XR(I)*SIN(P*J*I)+XI(I)*COS(P*J*I)
NEXT I
NEXT J
MAT XR=RR
MAT XI=II
END SUB
EXTERNAL SUB IDFT(M,XR(),XI())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM RR(M),II(M)
LET P=8*ATN(1)/M
FOR J=0 TO M-1
FOR I=0 TO M-1
LET RR(J)=RR(J)+XR(I)*COS(-P*J*I)-XI(I)*SIN(-P*J*I)
LET II(J)=II(J)+XR(I)*SIN(-P*J*I)+XI(I)*COS(-P*J*I)
NEXT I
NEXT J
FOR I=0 TO M-1
LET XR(I)=INT(RR(I)/M+.5)
LET XI(I)=INT(II(I)/M+.5)
NEXT I
END SUB
EXTERNAL SUB DFT2(M,RR(,),II(,),FL)
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM XR(M),XI(M)
FOR Y=0 TO M-1
FOR X=0 TO M-1
LET XR(X)=RR(X,Y)
LET XI(X)=II(X,Y)
NEXT X
IF FL>0 THEN CALL DFT(M,XR,XI) ELSE CALL IDFT(M,XR,XI)
FOR X=0 TO M-1
LET RR(X,Y)=XR(X)
LET II(X,Y)=XI(X)
NEXT X
NEXT Y
FOR X=0 TO M-1
FOR Y=0 TO M-1
LET XR(Y)=RR(X,Y)
LET XI(Y)=II(X,Y)
NEXT Y
IF FL>0 THEN CALL DFT(M,XR,XI) ELSE CALL IDFT(M,XR,XI)
FOR Y=0 TO M-1
LET RR(X,Y)=XR(Y)
LET II(X,Y)=XI(Y)
NEXT Y
NEXT X
END SUB
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM COL$(1)
MAT READ COL$
DATA "RGB","GRAY"
LOCATE CHOICE(COL$) :COLORMODE
INPUT PROMPT "SIZE (3 - 5) =":SIZE
LET N=2^SIZE
DIM B(N,N),G(N,N),R(N,N),M(N)
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM VM(XSIZE,YSIZE)
ASK PIXEL ARRAY(0,0) VM
FOR I=0 TO N-1
IF I<N/2 THEN LET MES$="低域 " ELSE LET MES$="高域 "
INPUT PROMPT "フィルタ係数 "& MES$ & STR$(I)&" (遮断(0) or 通過(1)) =":M(I)
NEXT I
FOR Y=0 TO YSIZE-1 STEP N
FOR X=0 TO XSIZE-1 STEP N
FOR I=0 TO N-1
FOR J=0 TO N-1
IF X+J<=XSIZE-1 AND Y+I<=YSIZE-1 THEN
LET CC=VM(X+J,Y+I)
CALL RGB(CC,RR,GG,BB)
LET B(J,I)=BB
LET G(J,I)=GG
LET R(J,I)=RR
END IF
IF COLORMODE=2 THEN LET B(J,I)=(151*B(J,I)+77*G(J,I)+28*R(J,I))/256
NEXT J
NEXT I
IF COLORMODE=1 THEN
CALL HADAMARD2D(N,B)
CALL HADAMARD2D(N,G)
CALL HADAMARD2D(N,R)
FOR J=0 TO N-1
FOR I=0 TO N-1
LET B(I,J)=B(I,J)*M(SEQUENCY(N,I))*M(SEQUENCY(N,J))
LET G(I,J)=G(I,J)*M(SEQUENCY(N,I))*M(SEQUENCY(N,J))
LET R(I,J)=R(I,J)*M(SEQUENCY(N,I))*M(SEQUENCY(N,J))
NEXT I
NEXT J
CALL HADAMARD2D(N,B)
CALL HADAMARD2D(N,G)
CALL HADAMARD2D(N,R)
FOR J=0 TO N-1
FOR I=0 TO N-1
LET B(I,J)=INT(B(I,J)/N/N+.5)
LET G(I,J)=INT(G(I,J)/N/N+.5)
LET R(I,J)=INT(R(I,J)/N/N+.5)
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL PSET(X+I,Y+J,R(I,J),G(I,J),B(I,J))
END IF
NEXT I
NEXT J
ELSE
CALL HADAMARD2D(N,B)
FOR J=0 TO N-1
FOR I=0 TO N-1
LET B(I,J)=B(I,J)*M(SEQUENCY(N,I))*M(SEQUENCY(N,J))
NEXT I
NEXT J
CALL HADAMARD2D(N,B)
FOR J=0 TO N-1
FOR I=0 TO N-1
LET B(I,J)=INT(B(I,J)/N/N+.5)
CALL PSET(X+I,Y+J,B(I,J),B(I,J),B(I,J))
NEXT I
NEXT J
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB HADAMARD(SIZE,X(),L())
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM A(SIZE,SIZE)
LET M=2
LET A(0,0)=1
LET A(0,1)=1
LET A(1,0)=1
LET A(1,1)=-1
DO WHILE M<SIZE
FOR J=0 TO M-1
FOR I=0 TO M-1
LET A(M+I,J)=A(I,J)
LET A(I,M+J)=A(I,J)
LET A(I+M,J+M)=-A(I,J)
NEXT I
NEXT J
LET M=M*2
LOOP
!'CALL MUL(X, A, L, SIZE)
MAT L=X*A
END SUB
EXTERNAL SUB HADAMARD2D(N,S(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM X(N),Y(N)
FOR J=0 TO N-1
FOR I=0 TO N-1
LET X(I)=S(I,J)
NEXT I
CALL HADAMARD(N,X,Y)
FOR I=0 TO N-1
LET S(I,J)=Y(I)
NEXT I
NEXT J
FOR J=0 TO N-1
FOR I=0 TO N-1
LET X(I)=S(J,I)
NEXT I
CALL HADAMARD(N,X,Y)
FOR I=0 TO N-1
LET S(J,I)=Y(I)
NEXT I
NEXT J
END SUB
EXTERNAL FUNCTION SEQUENCY(SIZE,N)
OPTION ARITHMETIC NATIVE
LET BIT=LOG2(SIZE)
FOR I=1 TO BIT
LET G=BITAND(N,1)
LET N=INT(N/2)
LET L=BITXOR(G,B)
LET A=A*2+L
LET B=L
NEXT I
LET SEQUENCY=A
END FUNCTION
EXTERNAL SUB MUL(A(),B(,),C(),N)
OPTION ARITHMETIC NATIVE
FOR I=0 TO N-1
LET S=0
FOR K=0 TO N-1
LET S=S+A(K)*B(K,I)
NEXT K
LET C(I)=S
NEXT I
END SUB
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
GLOAD N$
LET XSIZE=PIXELX(1)
LET YSIZE=PIXELY(1)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
OPTION ARITHMETIC NATIVE
OPTION BASE 0
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM COL$(1)
MAT READ COL$
DATA "RGB","GRAY"
LOCATE CHOICE(COL$) :COLORMODE
INPUT PROMPT "SIZE (3 - 5) =":SIZE
LET N=2^SIZE
DIM B(N,N),G(N,N),R(N,N),M(N)
FOR I=0 TO N-1
IF I<N/2 THEN LET MES$="低域 " ELSE LET MES$="高域 "
INPUT PROMPT "フィルタ係数 "& MES$ & STR$(I)&" (遮断(0) or 通過(1)) =":M(I)
NEXT I
FOR Y=0 TO YSIZE-1 STEP N
FOR X=0 TO XSIZE-1 STEP N
FOR I=0 TO N-1
FOR J=0 TO N-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL GETPOINT(X+I,Y+J,R(I,J),G(I,J),B(I,J))
IF COLORMODE=2 THEN LET B(I,J)=(151*B(I,J)+77*G(I,J)+28*R(I,J))/256
END IF
NEXT J
NEXT I
IF COLORMODE=1 THEN
CALL DWT2(B,N)
CALL DWT2(G,N)
CALL DWT2(R,N)
FOR J=0 TO N-1
FOR I=0 TO N-1
SELECT CASE FILTERTYPE
CASE 0
LET F=M(I)*M(J)
CASE 1
LET L=I+J
IF L>N-1 THEN LET L=N-1
LET F=M(L)
CASE 2
LET L=I*J
IF L>N-1 THEN LET L=N-1
LET F=M(L)
CASE 3
LET K=2 !'K=20
LET L=(I^K+J^K)^(1/K)
IF L>N-1 THEN LET L=N-1
LET F=M(L)
CASE 4
LET F=M(MOD(I+J,N))
END SELECT
LET B(I,J)=B(I,J)*F
LET G(I,J)=G(I,J)*F
LET R(I,J)=R(I,J)*F
NEXT I
NEXT J
CALL DWT3(B,N)
CALL DWT3(G,N)
CALL DWT3(R,N)
FOR J=0 TO N-1
FOR I=0 TO N-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL PSET(X+I,Y+J,R(I,J),G(I,J),B(I,J))
END IF
NEXT I
NEXT J
ELSE
CALL DWT2(B,N)
FOR J=0 TO N-1
FOR I=0 TO N-1
LET B(I,J)=B(I,J)*M(I)*M(J)
NEXT I
NEXT J
CALL DWT3(B,N)
FOR J=0 TO N-1
FOR I=0 TO N-1
CALL PSET(X+I,Y+J,B(I,J),B(I,J),B(I,J))
NEXT I
NEXT J
END IF
NEXT X
NEXT Y
END
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET COLOR MODE "NATIVE"
CLEAR
SET POINT STYLE 1
IF N$="" THEN STOP
GLOAD N$
LET XSIZE=PIXELX(1)+1
LET YSIZE=PIXELY(1)+1
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL FUNCTION CAS(X)
OPTION ARITHMETIC NATIVE
LET CAS=SIN(X)+COS(X)
END FUNCTION
EXTERNAL SUB DWT1(F(,),N) !'変換/逆変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM FF(N,N)
FOR U=0 TO N-1
FOR V=0 TO N-1
LET S=0
FOR X=0 TO N-1
FOR Y=0 TO N-1
LET S=S+F(X,Y)*CAS(2*PI*(U*X+V*Y)/N)
NEXT Y
NEXT X
LET FF(U,V)=S/N
NEXT V
NEXT U
MAT F=FF
END SUB
EXTERNAL SUB DWT2(F(,),N) !'変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM FF(N,N)
FOR U=0 TO N-1
FOR V=0 TO N-1
LET FF(U,V)=0
FOR X=0 TO N-1
FOR Y=0 TO N-1
LET FF(U,V)=FF(U,V)+F(X,Y)*CAS(2*PI*((X+1/2)*U+(Y+1/2)*V)/N)
NEXT Y
NEXT X
LET FF(U,V)=FF(U,V)/N
NEXT V
NEXT U
MAT F=FF
END SUB
EXTERNAL SUB DWT3(F(,),N) !'逆変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM FF(N,N)
FOR U=0 TO N-1
FOR V=0 TO N-1
LET FF(U,V)=0
FOR X=0 TO N-1
FOR Y=0 TO N-1
LET FF(U,V)=FF(U,V)+F(X,Y)*CAS(2*PI*((U+1/2)*X+(V+1/2)*Y)/N)
NEXT Y
NEXT X
LET FF(U,V)=FF(U,V)/N
NEXT V
NEXT U
MAT F=FF
END SUB
EXTERNAL SUB DWT4(F(,),N) !'変換/逆変換
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM FF(N,N)
FOR U=0 TO N-1
FOR V=0 TO N-1
LET FF(U,V)=0
FOR X=0 TO N-1
FOR Y=0 TO N-1
LET FF(U,V)=FF(U,V)+F(X,Y)*CAS(2*PI*((U+1/2)*(X+1/2)+(V+1/2)*(Y+1/2))/N)
NEXT Y
NEXT X
LET FF(U,V)=FF(U,V)/N
NEXT V
NEXT U
MAT F=FF
END SUB
OPTION ARITHMETIC NATIVE
DECLARE EXTERNAL FUNCTION C
READ NN,BASESIZE
DIM CONVERTSIZE(NN),S$(NN)
FOR I=1 TO NN
READ CONVERTSIZE(I)
IF CONVERTSIZE(I)/BASESIZE<1 THEN
LET S$(I)="縮小 : "&STR$(CONVERTSIZE(I)/BASESIZE)&"倍"
ELSE
LET S$(I)="拡大 : "&STR$(CONVERTSIZE(I)/BASESIZE)&"倍"
END IF
NEXT I
DATA 5,8
DATA 4,6,12,16,24 !,32
!'DATA 6,16
!'DATA 4,8,12,24,32,48 ! ,64
FILE GETNAME N$,"BMP,JPG,GIF,PNGファイル|*.BMP;*.JPG;*.GIF;*.PNG"
CALL PICTURELOAD(N$,XSIZE,YSIZE)
DIM VM(0 TO XSIZE,0 TO YSIZE)
ASK PIXEL ARRAY(0,0) VM
LOCATE CHOICE(S$) : N
LET SCALE=CONVERTSIZE(N)/BASESIZE
IF SCALE<1 THEN LET SIZE=BASESIZE ELSE LET SIZE=CONVERTSIZE(N)
DIM B(0 TO SIZE-1,0 TO SIZE-1),G(0 TO SIZE-1,0 TO SIZE-1),R(0 TO SIZE-1,0 TO SIZE-1)
CALL GINIT(XSIZE*SCALE,YSIZE*SCALE)
FOR Y=0 TO YSIZE-1 STEP BASESIZE
FOR X=0 TO XSIZE-1 STEP BASESIZE
FOR J=0 TO BASESIZE-1
FOR I=0 TO BASESIZE-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
LET CC=VM(X+I,Y+J)
CALL RGB(CC,RR,GG,BB)
LET B(I,J)=BB
LET G(I,J)=GG
LET R(I,J)=RR
END IF
NEXT I
NEXT J
CALL DCT2(BASESIZE,B)
MAT B=SCALE*B
CALL DCT2(BASESIZE,G)
MAT G=SCALE*G
CALL DCT2(BASESIZE,R)
MAT R=SCALE*R
CALL DCT3(CONVERTSIZE(N),B)
CALL DCT3(CONVERTSIZE(N),G)
CALL DCT3(CONVERTSIZE(N),R)
FOR J=0 TO CONVERTSIZE(N)-1
FOR I=0 TO CONVERTSIZE(N)-1
IF X+I<=XSIZE-1 AND Y+J<=YSIZE-1 THEN
CALL PSET(X*SCALE+I,Y*SCALE+J,R(I,J),G(I,J),B(I,J))
END IF
NEXT I
NEXT J
MAT R=ZER
MAT G=ZER
MAT B=ZER
NEXT X
NEXT Y
END
EXTERNAL SUB DCT2(NN,X(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Y(NN-1,NN-1)
FOR V=0 TO NN-1
FOR U=0 TO NN-1
LET YY=2/NN*C(U,NN)*C(V,NN)
FOR M=0 TO NN-1
FOR N=0 TO NN-1
LET Y(U,V)=Y(U,V)+YY*X(M,N)*COS((2*M+1)*U*PI/2/NN)*COS((2*N+1)*V*PI/2/NN)
NEXT N
NEXT M
NEXT U
NEXT V
FOR I=0 TO NN-1
FOR J=0 TO NN-1
LET X(I,J)=Y(I,J)
NEXT J
NEXT I
END SUB
EXTERNAL SUB DCT3(NN,X(,))
OPTION ARITHMETIC NATIVE
OPTION BASE 0
DIM Y(NN-1,NN-1)
FOR M=0 TO NN-1
FOR N=0 TO NN-1
LET YY=2/NN
FOR V=0 TO NN-1
FOR U=0 TO NN-1
LET Y(M,N)=Y(M,N)+YY*C(U,NN)*C(V,NN)*X(U,V)*COS((2*M+1)*U*PI/2/NN)*COS((2*N+1)*V*PI/2/NN)
NEXT U
NEXT V
NEXT N
NEXT M
FOR I=0 TO NN-1
FOR J=0 TO NN-1
LET X(I,J)=Y(I,J)
NEXT J
NEXT I
END SUB
EXTERNAL FUNCTION C(X,N)
OPTION ARITHMETIC NATIVE
IF X=0 OR X=N THEN LET C=SQR(2)/2 ELSE LET C=1
END FUNCTION
EXTERNAL SUB RGB(X,R,G,B)
OPTION ARITHMETIC NATIVE
LET B=MOD(INT(X/65536),256)
LET G=MOD(INT(X/256),256)
LET R=MOD(X,256)
END SUB
EXTERNAL SUB GETPOINT(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
ASK PIXEL VALUE(X,Y) C
CALL RGB(C,R,G,B)
END SUB
EXTERNAL SUB GINIT(XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
SET BITMAP SIZE XSIZE,YSIZE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
EXTERNAL SUB PSET(X,Y,R,G,B)
OPTION ARITHMETIC NATIVE
LET RR=MIN(255,MAX(0,INT(R)))
LET GG=MIN(255,MAX(0,INT(G)))
LET BB=MIN(255,MAX(0,INT(B)))
SET COLOR COLORINDEX(RR/255,GG/255,BB/255)
PLOT POINTS:X,Y
END SUB
EXTERNAL SUB PICTURELOAD(N$,XSIZE,YSIZE)
OPTION ARITHMETIC NATIVE
CLEAR
SET COLOR MODE "NATIVE"
SET POINT STYLE 1
GLOAD N$
LET XSIZE=PIXELX(1)
LET YSIZE=PIXELY(1)
SET BITMAP SIZE XSIZE,YSIZE
SET WINDOW 0,XSIZE-1,YSIZE-1,0
END SUB
