Добавил:

Upload Опубликованный материал нарушает ваши авторские права? Сообщите нам.

Вуз:

Санкт-Петербургский государственный морской технический университет

Предмет:

[НЕСОРТИРОВАННОЕ]

Файл:

Числ моделир в гидромехе.docx

Скачиваний:

Добавлен:

01.03.2025

Размер:

117.51 Кб

Скачать

☆

<<< < Предыдущая 1 23 / 53 4 5 > Следующая >>>

Программный код

Program Doska

use msimsl

real Lx,Ly,dx,dy, xIt,yIt,&

&G,aP,aW,aE,aN,aS,b0,&

&d,eps,keps,pi,t,alfa

real,allocatable:: x(:),y(:),F(:,:),A(:,:),B(:),&

&Ftdma(:,:),Fg(:,:),Fgs(:,:),Ftr(:,:),& &ItFtdma(:),ItFgs(:),ItFtr(:),&

&A1(:,:),B1(:,:),Feps(:),P(:),Q(:)

integer uzlx,uzly, Na,n,Neps,Nb, iIt,jIt,It1,It2

write(*,*) 'Oblast (Lx, Ly)'

read(*,*) Lx, Ly

write(*,*) 'Reshotka (po x, po y)'

read(*,*) uzlx, uzly

write(*,*) 'Tochka sravneniya skorosti iteracii (xIt, yIt)'

read(*,*) xIt, yIt

Na=(uzlx-2)*(uzly-2)

allocate(x(uzlx),y(uzly),F(uzly,uzlx),A(Na,Na),B(Na))

eps=0.001

dx=Lx/(uzlx-1.)

dy=Ly/(uzly-1.)

do i=1,uzlx,1

x(i)=(i-1.)*dx

end do

do j=1,uzly,1

y(j)=(j-1.)*dy

end do

do i=2,uzlx-1,1 !Tochka sravneniya skorosti iteracii

if (Abs(xIt-x(i))<=dx/2.) then

iIt=i

end if

end do

do j=2,uzly-1,1

if (Abs(yIt-y(j))<=dy/2.) then

jIt=j

end if

end do !Tochka sravneniya skorosti iteracii end

G=1.

aW=G*(dy/dx)

aE=G*(dy/dx)

aN=G*(dx/dy)

aS=G*(dx/dy)

aP=aW+aE+aN+aS

b0=0.

open(1,file='C:\123456789\Fortran\Doska(17x17).txt')

write(1,'(3x,a,1x,a,f7.3)') 'Rabochaya oblast:','Lx =',Lx

write(1,'(21x,a,f7.3)') 'Ly =',Ly

write(1,*)

write(1,'(3x,a,1x,a,1x,i4)') 'Reshotka:','uzlov po x =',uzlx

write(1,'(13x,a,1x,i4)') 'uzlov po y =',uzly

F(:,:)=0. !Boundary condition F

do i=1,uzlx,1

F(1,i)=100.*(x(i)**2.+0.4)

F(uzly,i)=100.*(x(i)**2.+0.4)

end do

do j=1,uzly,1

F(j,1)=100.*(0.4-y(j)**2.+y(j))

F(j,uzlx)=100.*(1.4-y(j)**2.+y(j))

end do !Boundary condition F end

A(:,:)=0. !Matrix A

do j=2,uzly-1,1

do i=2,uzlx-1,1

n=(i-1)+(j-2)*(uzlx-2)

A(n,n)=aP

if (i/=2) then

A(n,n-1)=-aW

end if

if (i/=(uzlx-1)) then

A(n,n+1)=-aE

end if

if (j/=(uzly-1)) then

A(n,n+(uzlx-2))=-aN

end if

if (j/=2) then

A(n,n-(uzlx-2))=-aS

end if

end do

B(:)=b0 !Matrix B

do j=2,uzly-1,1

do i=2,uzlx-1,1

n=(i-1)+(j-2)*(uzlx-2)

if (i==2) then

B(n)=B(n)+aW*F(j,1)

end if

if (i==(uzlx-1)) then

B(n)=B(n)+aE*F(j,uzlx)

end if

if (j==2) then

B(n)=B(n)+aS*F(1,i)

end if

if (j==(uzly-1)) then

B(n)=B(n)+aN*F(uzly,i)

end if

end do

allocate(Ftdma(uzly,uzlx),Feps(uzlx),P(uzlx-2),Q(uzlx-2)) !TDMA

allocate(ItFtdma(0:5000))

Ftdma(:,:)=F(:,:)

ItFtdma(:)=0.

It1=0

do while (Neps<Na)

Neps=0

ItFtdma(It1)=Ftdma(jIt,iIt)

do j=2,uzly-1,1

Feps(:)=Ftdma(j,:)

do i=2,uzlx-1,1

n=(i-1)+(j-2)*(uzlx-2)

if (j>2.and.j<(uzly-1)) then

d=B(n)-A(n,n+(uzlx-2))*Ftdma(j+1,i)-A(n,n-(uzlx-2))*Ftdma(j-1,i)

else

if (j==2) then

d=B(n)-A(n,n+(uzlx-2))*Ftdma(j+1,i)

else

d=B(n)-A(n,n-(uzlx-2))*Ftdma(j-1,i)

end if

if (i>2) then

if (i/=(uzlx-1)) then

P(i-1)=-A(n,n+1)/(A(n,n)+A(n,n-1)*P(i-2))

end if

Q(i-1)=(d-A(n,n-1)*Q(i-2))/(A(n,n)+A(n,n-1)*P(i-2))

else

P(i-1)=-A(n,n+1)/A(n,n)

Q(i-1)=d/A(n,n)

end if

end do

Ftdma(j,uzlx-1)=Q(uzlx-2)

do i=uzlx-2,2,-1

Ftdma(j,i)=P(i-1)*Ftdma(j,i+1)+Q(i-1)

end do

do i=2,uzly-1,1

if (Abs(Ftdma(j,i)-Feps(i))<=eps) then

Neps=Neps+1

end if

end do

It1=It1+1

ItFtdma(It1)=Ftdma(jIt,iIt)

end do

deallocate(Feps, P, Q) !TDMA end

Nb=1 !Gauss metod

allocate(Fg(uzly,uzlx),A1(Na,Na),B1(Na,Nb))

A1(:,:)=A(:,:)

B1(:,Nb)=B(:)

Fg(:,:)=F(:,:)

call GELA(A1,B1,Na,Nb,ier)

do j=2,uzly-1,1

do i=2,uzlx-1,1

n=(i-1)+(j-2)*(uzlx-2)

Fg(j,i)=B1(n,Nb)

end do

deallocate(A1, B1) !Gauss metod end

allocate(Fgs(uzly,uzlx)) !Gauss-Seidel metod

allocate(ItFgs(0:5000))

Fgs(:,:)=F(:,:)

ItFgs(:)=0.

Neps=0

It2=0

do while (Neps<Na)

Neps=0

ItFgs(It2)=Fgs(jIt,iIt)

do j=2,uzly-1,1

do i=2,uzlx-1,1

n=(i-1)+(j-2)*(uzlx-2)

keps=Fgs(j,i)

if (j>2.and.j<(uzly-1)) then

if (i>2.and.i<(uzlx-1)) then

Fgs(j,i)=(-A(n,n-1)*Fgs(j,i-1)-A(n,n+1)*Fgs(j,i+1)-A(n,n+(uzlx-2))*Fgs(j+1,i)-A(n,n-(uzlx-2))*Fgs(j-1,i)+B(n))/A(n,n)

else

if (i==2) then

Fgs(j,i)=(-A(n,n+1)*Fgs(j,i+1)-A(n,n+(uzlx-2))*Fgs(j+1,i)-A(n,n-(uzlx-2))*Fgs(j-1,i)+B(n))/A(n,n)

end if

if (i==(uzlx-1)) then

Fgs(j,i)=(-A(n,n-1)*Fgs(j,i-1)-A(n,n+(uzlx-2))*Fgs(j+1,i)-A(n,n-(uzlx-2))*Fgs(j-1,i)+B(n))/A(n,n)

end if

else

if (j==2) then

if (i>2.and.i<(uzlx-1)) then

Fgs(j,i)=(-A(n,n-1)*Fgs(j,i-1)-A(n,n+1)*Fgs(j,i+1)-A(n,n+(uzlx-2))*Fgs(j+1,i)+B(n))/A(n,n)

else

if (i==2) then

Fgs(j,i)=(-A(n,n+1)*Fgs(j,i+1)-A(n,n+(uzlx-2))*Fgs(j+1,i)+B(n))/A(n,n)

end if

if (i==(uzlx-1)) then

Fgs(j,i)=(-A(n,n-1)*Fgs(j,i-1)-A(n,n+(uzlx-2))*Fgs(j+1,i)+B(n))/A(n,n)

end if

if (j==(uzly-1)) then

if (i>2.and.i<(uzlx-1)) then

Fgs(j,i)=(-A(n,n-1)*Fgs(j,i-1)-A(n,n+1)*Fgs(j,i+1)-A(n,n-(uzlx-2))*Fgs(j-1,i)+B(n))/A(n,n)

else

if (i==2) then

Fgs(j,i)=(-A(n,n+1)*Fgs(j,i+1)-A(n,n-(uzlx-2))*Fgs(j-1,i)+B(n))/A(n,n)

end if

if (i==(uzlx-1)) then

Fgs(j,i)=(-A(n,n-1)*Fgs(j,i-1)-A(n,n-(uzlx-2))*Fgs(j-1,i)+B(n))/A(n,n)

end if

if (Abs(Fgs(j,i)-keps)<=eps) then

Neps=Neps+1

end if

end do

It2=It2+1

end do !Gauss-Seidel metod end

if (It2>It1) then

It1=It2

end if

allocate(Ftr(uzly,uzlx)) !Top relaxation metod

allocate(ItFtr(0:5000))

Ftr(:,:)=F(:,:)

ItFtr(:)=0.

pi=CONST('Pi')

t=cos(pi/(uzlx-1.))+cos(pi/(uzly-1.))

alfa=(8.+4.*sqrt(4.-t**2.))/t**2.

if (alfa<=0.or.alfa>2.) then

alfa=(8.-4.*sqrt(4.-t**2.))/t**2.

end if

Neps=0

It2=0

do while (Neps<Na)

Neps=0

ItFtr(It2)=Ftr(jIt,iIt)

do j=2,uzly-1,1

do i=2,uzlx-1,1

keps=Ftr(j,i)

n=(i-1)+(j-2)*(uzlx-2)

if (j>2.and.j<(uzly-1)) then

if (i>2.and.i<(uzlx-1)) then

Ftr(j,i)=alfa*(-A(n,n-1)*Ftr(j,i-1)-A(n,n+1)*Ftr(j,i+1)-A(n,n+(uzlx-2))*Ftr(j+1,i)-A(n,n-(uzlx-2))*Ftr(j-1,i)+B(n))/A(n,n)+(1.-alfa)*keps

else

if (i==2) then

Ftr(j,i)=alfa*(-A(n,n+1)*Ftr(j,i+1)-A(n,n+(uzlx-2))*Ftr(j+1,i)-A(n,n-(uzlx-2))*Ftr(j-1,i)+B(n))/A(n,n)+(1.-alfa)*keps

end if

if (i==(uzlx-1)) then

Ftr(j,i)=alfa*(-A(n,n-1)*Ftr(j,i-1)-A(n,n+(uzlx-2))*Ftr(j+1,i)-A(n,n-(uzlx-2))*Ftr(j-1,i)+B(n))/A(n,n)+(1.-alfa)*keps

end if

else

if (j==2) then

if (i>2.and.i<(uzlx-1)) then

Ftr(j,i)=alfa*(-A(n,n-1)*Ftr(j,i-1)-A(n,n+1)*Ftr(j,i+1)-A(n,n+(uzlx-2))*Ftr(j+1,i)+B(n))/A(n,n)+(1.-alfa)*keps

else

if (i==2) then

Ftr(j,i)=alfa*(-A(n,n+1)*Ftr(j,i+1)-A(n,n+(uzlx-2))*Ftr(j+1,i)+B(n))/A(n,n)+(1.-alfa)*keps

end if

if (i==(uzlx-1)) then

Ftr(j,i)=alfa*(-A(n,n-1)*Ftr(j,i-1)-A(n,n+(uzlx-2))*Ftr(j+1,i)+B(n))/A(n,n)+(1.-alfa)*keps

end if

if (j==(uzly-1)) then

if (i>2.and.i<(uzlx-1)) then

Ftr(j,i)=alfa*(-A(n,n-1)*Ftr(j,i-1)-A(n,n+1)*Ftr(j,i+1)-A(n,n-(uzlx-2))*Ftr(j-1,i)+B(n))/A(n,n)+(1.-alfa)*keps

else

if (i==2) then

Ftr(j,i)=alfa*(-A(n,n+1)*Ftr(j,i+1)-A(n,n-(uzlx-2))*Ftr(j-1,i)+B(n))/A(n,n)+(1.-alfa)*keps

end if

if (i==(uzlx-1)) then

Ftr(j,i)=alfa*(-A(n,n-1)*Ftr(j,i-1)-A(n,n-(uzlx-2))*Ftr(j-1,i)+B(n))/A(n,n)+(1.-alfa)*keps

end if

if (Abs(Ftr(j,i)-keps)<=eps) then

Neps=Neps+1

end if

end do

It2=It2+1

end do !Top relaxation metod end

if (It2>It1) then

It1=It2

end if

write(1,*)

write(1,'(1x,100a1)') ('-',k=1,77)

write(1,'(2x,a)') 'Value F TDMA Gauss Gauss-Seidel Top relaxation'

write(1,'(1x,100a1)') ('-',k=1,77)

write(1,'(3x,a)')' (x,y) F F F F'

do j=1,uzly,1

write(1,*)

do i=1,uzlx,1

write(1,1) '(',x(i),',',y(j),')', Ftdma(j,i),Fg(j,i),Fgs(j,i),Ftr(j,i)

end do

write(1,'(1x,100a1)') ('-',k=1,77)

1 format(2x,a,f8.5,a,f8.5,a,3x,f8.3,5x,f8.3,5x,f8.3,5x,f8.3)

write(1,*)

write(1,'(2x,a,f8.5,a,f8.5,a)') 'Sravnenie skorosti iteracii (',x(iIt),',',y(jIt),')'

write(1,'(1x,100a1)') ('-',k=1,77)

write(1,'(2x,a)') 'Iteracii TDMA Gauss-Seidel Top relaxation'

write(1,'(1x,100a1)') ('-',k=1,77)

write(1,'(2x,a)')'Iteration F F F'

write(1,*)

do i=0,It1,1

write(1,2) i, ItFtdma(i),ItFgs(i),ItFtr(i)

end do

write(1,'(1x,100a1)') ('-',k=1,77)

2 format(2x,i5,5x,f8.3)!,5x,f8.3,5x,f8.3)

end !Konec :)

SUBROUTINE GELA( a, b, N, NB, ier )

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

* Programm for solution system algebric equations, using *

* Gauss method with some right parts by A.Kudriavzev *

* b --- massiv right parts and results *

* a --- matric of koefficients *

* n --- number equations *

* nb -- number different right parts *

* ier - users error *

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

DIMENSION A(n,n),B(n,nb)

IER=0

DO 10 K=1,N

IF(K.EQ.N)GO TO 210

K1=K+1

IM=K

AM=ABS(A(K,K))

DO 220 I=K1,N

AIK=ABS(A(I,K))

IF(AIK.LE.AM)GO TO 220

IM=I

AM=AIK

220 CONTINUE

DO 230 J=K,N

AM=A(K,J)

A(K,J)=A(IM,J)

230 A(IM,J)=AM

DO 231 JB=1,NB

AM=B(K,JB)

B(K,JB)=B(IM,JB)

231 B(IM,JB)=AM

210 AK1=AKK

AKK=A(K,K)

IF(AKK.NE.0.)GO TO 240

IER=2

RETURN

240 CONTINUE

AKI=1./AKK

DO 101 JB=1,NB

101 B(K,JB)=B(K,JB)*AKI

IF(K.EQ.N)GO TO 100

DO 20 J=K1,N

A(K,J)=A(K,J)*AKI

AKJ=A(K,J)

DO 30 I=K1,N

30 A(I,J)=A(I,J)-A(I,K)*AKJ

AJK=A(J,K)

DO 201 JB=1,NB

201 B(J,JB)=B(J,JB)-AJK*B(K,JB)

20 CONTINUE

10 CONTINUE

100 K1=K

K=K-1

IF(K.EQ.0)RETURN

DO 401 JB=1,NB

BKB=B(K,JB)

DO 40 J=K1,N

40 BKB=BKB-A(K,J)*B(J,JB)

401 B(K,JB)=BKB

GO TO 100

END

<<< < Предыдущая 1 23 / 53 4 5 > Следующая >>>

Соседние файлы в предмете [НЕСОРТИРОВАННОЕ]

#
01.04.2025292.86 Кб0часть2_А5.doc
#
01.04.2025516.1 Кб1часть3_А5.doc
#
01.04.2025716.29 Кб0часть4_А5.doc
#
24.08.20191.1 Mб114Чернов, 62. Диплом.docx
#
01.05.20251.24 Mб0Четвертое пособие КРИТЕРИИ.doc
#
01.03.2025117.51 Кб0Числ моделир в гидромехе.docx
#
18.04.201541.47 Кб19Численные методы_1(вопросы)_.doc
#
18.04.2015727.51 Кб40Числовые ряды..pdf
#
01.05.2025764.8 Кб0Чудо печка на отработке масла.docx
#
11.07.20191.37 Mб5Шаблон АХД.rtf
#
14.07.20191.36 Mб11Шаблон КР.rtf