├── 04.Polynomial Approximation and Interpolation ├── clean.bat ├── Lagrange-interpolation-1D.F90 ├── interpolation-1D.lay └── Lagrange-interpolation-2D.F90 ├── 07.Initial-Value Ordinary Differential Equations ├── clean.bat ├── doubleGyre.m ├── ODEsovler.lay ├── ODEsovler.F90 ├── ODEsovler-compare.lay └── doubleGyre.F90 ├── .gitignore ├── 00.Numerical Methods for Hyperbolic Equation ├── 00.Upwind Scheme - Godunov Scheme │ ├── DATA-Godunov.txt │ ├── DATA-Upwind.txt │ ├── Upwind.f90 │ └── Godunov.f90 ├── 01.3rd-order Finite Volume Scheme │ ├── DATA.txt │ └── FVM.f90 ├── 02.TVDLimiter - TVBLimiter │ ├── DATA-TVB.txt │ ├── DATA-TVD.txt │ ├── TVD-limiter.f90 │ └── TVB-limiter.f90 ├── 03.ENO Scheme │ ├── DATA.txt │ └── ENO.f90 └── 04.WENO Scheme │ ├── test.txt │ ├── WENO_3.f90 │ ├── WENO_2.f90 │ └── WENO_1.f90 ├── 03.Nonlinear Equations ├── Newton.f90 ├── Secant.f90 └── Bisection.f90 ├── README.md ├── 02.Eigenproblems ├── power.f90 ├── Rayleigh.f90 ├── inverse_power.f90 └── Jacobi.f90 ├── 01.Systems of Linear Algebraic Equations ├── Thomas_2.f90 ├── Thomas_1.f90 └── Gauss.f90 └── 06.Numerical Integration ├── Simpson.f90 ├── GLI.f90 └── Romberg.f90 /04.Polynomial Approximation and Interpolation/clean.bat: -------------------------------------------------------------------------------- 1 | del *.dat -------------------------------------------------------------------------------- /07.Initial-Value Ordinary Differential Equations/clean.bat: -------------------------------------------------------------------------------- 1 | del *.dat -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /bin/* 2 | /obj/* 3 | *.sln 4 | *.suo 5 | *.exe 6 | *.o 7 | *.save 8 | *.dat -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/00.Upwind Scheme - Godunov Scheme/DATA-Godunov.txt: -------------------------------------------------------------------------------- 1 | Godunov Method: 2 | Number of points LInfinity Normal Order 3 | 40 6.51216507E-03 1.04127 4 | 80 3.16426158E-03 1.0201 5 | 160 1.56024098E-03 1.00971 6 | 320 7.74890184E-04 1.00495 7 | 640 3.86118889E-04 ------- -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/01.3rd-order Finite Volume Scheme/DATA.txt: -------------------------------------------------------------------------------- 1 | 3rd-FVM Method: 2 | Number of points L1 Normal Order 3 | 40 3.36245527687565305E-005 2.95909103119678961 4 | 80 4.32395689946873454E-006 2.97144041267568827 5 | 160 5.51300849620283209E-007 2.97324815961992062 6 | 320 7.02023711670940221E-008 2.85555821592767950 7 | 640 9.69936055794735245E-009 ------------------- -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/00.Upwind Scheme - Godunov Scheme/DATA-Upwind.txt: -------------------------------------------------------------------------------- 1 | UPWIND SCHEME: 2 | Number of points L1 Normal Order 3 | 40 6.20635410768204804E-003 0.98631083586761186 4 | 80 3.13276201481390432E-003 0.9928648526729261 5 | 160 1.57414705779173420E-003 0.9963555720642534 6 | 320 7.89064288368396998E-004 0.99815799485908474 7 | 640 3.95036196913503925E-004 ------------------- -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/02.TVDLimiter - TVBLimiter/DATA-TVB.txt: -------------------------------------------------------------------------------- 1 | 3rd-FVM Method(TVB Limiter): 2 | Number of points L1 Normal Order 3 | 40 2.51501001336378645E-003 0.9839517646948878 4 | 80 1.27157131740280737E-003 0.9880021818947912 5 | 160 6.41095060161960971E-004 0.99268551245286188 6 | 320 3.22176838141243122E-004 0.9968115878374611 7 | 640 1.61444824433049127E-004 ------------------ -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/02.TVDLimiter - TVBLimiter/DATA-TVD.txt: -------------------------------------------------------------------------------- 1 | 3rd-FVM Method(TVD Limiter): 2 | Number of points L1 Normal Order 3 | 40 2.77522953464775807E-003 1.0623888658228235 4 | 80 1.32888681685562962E-003 1.0213773020194047 5 | 160 6.54670524966419068E-004 1.01031675417179720 6 | 320 3.25002828099179143E-004 1.0047456299369609 7 | 640 1.61967756838981138E-004 ------------------ -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/03.ENO Scheme/DATA.txt: -------------------------------------------------------------------------------- 1 | ENO Scheme(FVM): 2 | alpha = dt/dx = 0.5 3 | Number of points L1 Normal Order 4 | 40 4.50672568110942889E-005 2.66841488974372634 5 | 80 7.08905263965586043E-006 2.2604047593582114 6 | 160 1.47958038882520914E-006 1.3978165296397097 7 | 320 5.61505303311726453E-007 1.51294327494013891 8 | 640 1.96749009634838876E-007 -------------------- 9 | 10 | 11 | alpha = dt/dx = 0.1 12 | Number of points L1 Normal Order 13 | 40 4.75290119692824836E-005 2.64341482968652364 14 | 80 7.60696874008209515E-006 2.2666266342828856 15 | 160 1.58084403806214220E-006 1.5946522610690892 16 | 320 5.23420662073898890E-007 1.4634304500088832 17 | 640 1.89807950777076025E-007 --------------------- 18 | 19 | 20 | alpha = dt/dx = 0.01 21 | Number of points L1 Normal Order 22 | 40 4.74348443735387267E-005 2.63967350349050210 23 | 80 7.61161085425887517E-006 2.2681706165336814 24 | 160 1.58011678297204656E-006 1.7155840153349968 25 | 320 4.81112828517038744E-007 1.4336538020948010 26 | 640 1.78104191134698087E-007 -------------------- 27 | -------------------------------------------------------------------------------- /03.Nonlinear Equations/Newton.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds all the roots of nonlinear equation by using Newton's interation Method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | real :: x0 9 | 10 | write(*,*) 'Newton`s interation Method:' 11 | write(*,*) 'Eq: 2*exp(-x)-sin(x)=0' 12 | x0=6.0 13 | write(*,*) 'Root close near point x=',x0 14 | call Newton(x0) 15 | 16 | stop 17 | end program main 18 | 19 | 20 | 21 | subroutine Newton(x0) 22 | implicit none 23 | real :: x,x0,f,df 24 | 25 | x=x0 26 | x0=x-f(x)/df(x) 27 | do while(ABS(1-x/x0).GT.0.001) 28 | x=x0 29 | x0=x-f(x)/df(x) 30 | enddo 31 | write(*,*) 'x=',x0 32 | 33 | return 34 | end subroutine Newton 35 | 36 | 37 | 38 | function f(x) 39 | f=2*exp(-x)-sin(x) 40 | end function f 41 | 42 | function df(x) 43 | df=-2*exp(-x)-cos(x) 44 | end function df 45 | -------------------------------------------------------------------------------- /03.Nonlinear Equations/Secant.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds all the roots of nonlinear equation by using Secant Method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | real :: a, b, root, eps 9 | 10 | write(*,*) 'Secant Method:' 11 | write(*,*) 'Eq: 2*exp(-x)-sin(x)=0' 12 | a=2.0 13 | b=4.0 14 | eps = 1.0e-5 15 | write(*,*) 'Root closely near interval[',a,b,']' 16 | call Secant(a,b,root,eps) 17 | write(*,*) 'x=',root 18 | 19 | stop 20 | end program main 21 | 22 | 23 | 24 | subroutine Secant(x1,x2,root,eps) 25 | implicit none 26 | integer, parameter:: itc=200 27 | integer :: i 28 | real :: x1, x2, x3, df, root, eps,f 29 | 30 | !!! Iterative refining the solution 31 | do i=1,itc 32 | df = (x2-x1)/(f(x2)-f(x1)) 33 | x3 = x2 - f(x2)*df 34 | !!! check the step. if it is improbably large - use bisection 35 | if(abs(x3) > 100.0*abs(x2)) x3 = (x2+x1)/2.0 36 | !!! condition to stop iterations 37 | if(abs(f(x3))<= eps) exit 38 | x1 = x2; 39 | x2 = x3; 40 | end do 41 | root=x3 42 | 43 | return 44 | end subroutine Secant 45 | 46 | 47 | 48 | function f(x) 49 | f=2*exp(-x)-sin(x) 50 | end 51 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Numerical Methods 2 | 3 | ## Code List 4 | 5 | ### Hyperbolic Equations 6 | 7 | * Upwind Scheme / Godunov Scheme 8 | * 3rd-order Finite Volume Scheme 9 | * TVD Limiter / TVB Limiter 10 | * 3rd-order ENO Scheme(FVM) 11 | * 5th-order WENO Scheme(FVM) 12 | * 5th-order WENO Scheme(FDM) 13 | 14 | ###Systems of Linear Algebraic Equations 15 | 16 | * Gauss Elimination Method 17 | * Thomas Method for Tridiagonal Systems of Equations 18 | 19 | ###Eigenproblems 20 | 21 | * Jacobi Method 22 | * Rayleigh Method 23 | * The Power Method 24 | * Inverse Power Method 25 | 26 | ###Nonlinear Equations 27 | 28 | * Bisection Methods 29 | * Newton Methods 30 | * Secant Methods 31 | * Polynomial Approximation and Interpolation 32 | * Lagrange interpolation Methods 33 | 34 | ###Numerical Differentiation 35 | 36 | ###Numerical Integration 37 | 38 | * Gauss-Legendre Integration Method 39 | * Romberg Integration Method 40 | * Simpson Integration Method 41 | 42 | ###One-Dimensional Initial-Value Ordinary Differential Equations 43 | 44 | * Euler Method 45 | * 4th-order Runge-Kutta Method 46 | * One-Dimensional Boundary-Value Ordinary Differential Equations 47 | 48 | ## Licence 49 | 50 | These Numerical Methods programs use very basic algorithms. They are intended only for an educational use. 51 | 52 | Copyright (C) 2012-2013 Ao Xu 53 | 54 | This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. To view a copy of this license, visit http://creativecommons.org/licenses/by-nc/3.0/ or send a letter to Creative Commons, 444 Castro Street, Suite 900, Mountain View, California, 94041, USA. 55 | 56 | Ao Xu, Profiles: -------------------------------------------------------------------------------- /03.Nonlinear Equations/Bisection.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds all the roots of nonlinear equation by using Bisection Method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter ::dp=kind(0.d0) 9 | real(dp) :: a0,b0,h 10 | 11 | write(*,*) 'Bisection Method:' 12 | write(*,*) 'Eq: 2*exp(-x)-sin(x)=0' 13 | a0 = 0.0_dp 14 | b0 = 10.0_dp 15 | h = 0.02_dp 16 | write(*,*) 'Roots in interval[',a0,b0,'] step h=',h 17 | call Bisection(a0,b0,h) 18 | 19 | stop 20 | end program main 21 | 22 | 23 | 24 | subroutine Bisection(a0,b0,h) 25 | implicit none 26 | integer, parameter ::dp=kind(0.d0) 27 | real(dp) :: a0,b0,h,z,a,b,c,f 28 | 29 | z = a0 30 | do while(z.LT.b0) 31 | if(ABS(f(z)).LT.0.01_dp) then 32 | write(*,*) 'x=',z 33 | else 34 | if(f(z)*f(z+h).LT.0.0_dp) then 35 | a = z 36 | b = z+h 37 | c = (a+b)/2.0_dp 38 | if(ABS(f(c)).LT.0.01_dp) then 39 | write(*,*) 'x=',c 40 | else 41 | if(f(a)*f(c).LT.0.0_dp) b = c 42 | if(f(b)*f(c).LT.0.0_dp) a = c 43 | endif 44 | else 45 | continue 46 | endif 47 | endif 48 | z=z+h 49 | enddo 50 | 51 | return 52 | end subroutine Bisection 53 | 54 | 55 | 56 | function f(x) 57 | implicit none 58 | integer, parameter ::dp=kind(0.d0) 59 | real(dp) :: f, x 60 | f = 2.0_dp*exp(-x)-sin(x) 61 | end function f 62 | -------------------------------------------------------------------------------- /02.Eigenproblems/power.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds the maximum eigenvalue of a matrix and its eigenvector for a given initial eigenvector by using power method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: n=3 9 | integer i,j 10 | real egv 11 | real :: a(n,n), b(n), c(n) 12 | a(1,:)=(/2, 3, 2/) 13 | a(2,:)=(/10, 3, 4/) 14 | a(3,:)=(/3, 6, 1/) 15 | b = (/0.0, 0.0, 1.0/) 16 | 17 | write(*,*) 'Power Method:' 18 | write(*,*) 'All the elements of matrix A:' 19 | write(*,'(3f9.4)') ((a(i,j),j=1,n),i=1,n) 20 | write(*,*) 'Initial eigenvector:' 21 | write(*,15) b 22 | call power(a,b,c,egv,n) 23 | write(*,*) '***********************************' 24 | write(*,*) 'Maximum eigenvalue:' 25 | write(*,*) egv 26 | write(*,*) 'Eigenvector:' 27 | write(*,15) b 28 | 15 format(1x,'[',f9.6,',',f9.6,',',f9.6,']') 29 | 30 | 31 | stop 32 | end program main 33 | 34 | 35 | 36 | subroutine power(a,b,c,egv,n) 37 | implicit none 38 | integer n,itc,i,j 39 | real :: a(n,n),b(n),c(n) 40 | real :: e,e1,egv 41 | 42 | do itc=1,50 43 | e=0.0 44 | do i=1,n 45 | c(i)=0.0 46 | do j=1,n 47 | c(i)=c(i)+a(i,j)*b(j) 48 | end do 49 | end do 50 | do i=1,n 51 | if(ABS(c(i)).LT.e) cycle 52 | e=ABS(c(i)) 53 | e1=c(i) 54 | end do 55 | do i=1,n 56 | b(i)=c(i)/e1 57 | end do 58 | end do 59 | egv=e1 60 | 61 | return 62 | end subroutine power 63 | -------------------------------------------------------------------------------- /01.Systems of Linear Algebraic Equations/Thomas_2.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program sloves tridiagonal linear equation A*x=b 3 | !!! Diagonally dominant matrix(sparse matrix) coefficient is stored in n*3 matrix 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | program main 8 | implicit none 9 | 10 | integer, parameter :: n=7 !!! n is number of equations 11 | integer :: i,j 12 | real :: a(n,3), b(n), x(n) !!! x(i) is solution vector 13 | data (a(1,j), j=1,3) / 0.0, -2.25, 1.0/ !!! a is coefficient matrix A(i,3) 14 | data (a(2,j), j=1,3) / 1.0, -2.25, 1.0/ 15 | data (a(3,j), j=1,3) / 1.0, -2.25, 1.0/ 16 | data (a(4,j), j=1,3) / 1.0, -2.25, 1.0/ 17 | data (a(5,j), j=1,3) / 1.0, -2.25, 1.0/ 18 | data (a(6,j), j=1,3) / 1.0, -2.25, 1.0/ 19 | data (a(7,j), j=1,3) / 1.0, -2.25, 0.0/ 20 | data (b(i),i=1,n) / 0.0, 0.0, 0.0, 0.0, 0.0, 0.0, -100.0 / !!! b(i) is right hand side vector 21 | 22 | write(*,*) 'Thomas Method:' 23 | write(*,*) 'All the elements of matrix A:' 24 | write(*,'(3f11.5)') ((a(i,j),j=1,3),i=1,n) 25 | write(*,*) 26 | write(*,*) 'Vector b:' 27 | write(*,'(f11.5)') (b(i),i=1,n) 28 | call Thomas(a,b,x,n) 29 | write(*,*) 30 | write(*,*) 'Solution x:' 31 | write(*,'(f11.5)') (x(i),i=1,n) 32 | 33 | stop 34 | end program main 35 | 36 | 37 | 38 | subroutine Thomas(a,b,x,n) 39 | implicit none 40 | 41 | integer :: n, i 42 | real :: em 43 | real :: a(n,3), b(n), x(n) 44 | !!! forward elimination 45 | do i=2,n 46 | em=a(i,1)/a(i-1,2) 47 | a(i,1)=em 48 | a(i,2)=a(i,2)-em*a(i-1,3) 49 | b(i)=b(i)-a(i,1)*b(i-1) 50 | enddo 51 | !!! back substitution 52 | x(n)=b(n)/a(n,2) 53 | do i=n-1,1,-1 54 | x(i)=(b(i)-a(i,3)*x(i+1))/a(i,2) 55 | enddo 56 | 57 | return 58 | end subroutine Thomas 59 | -------------------------------------------------------------------------------- /01.Systems of Linear Algebraic Equations/Thomas_1.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program sloves tridiagonal linear equation A*x=b 3 | !!! Sparse matrix A is Tridiagonal Matrix 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | ! Example refer to : 8 | ! 9 | ! | 4 1 0 0 0 | |x1| | 1.0 | 10 | ! | 1 4 1 0 0 | |x2| | 0.5 | 11 | ! | 0 1 4 1 0 | |x3| = | -1.0 | 12 | ! | 0 0 1 4 1 | |x4| | 3.0 | 13 | ! | 0 0 0 1 4 | |x5| | 2.0 | 14 | ! 15 | ! Solution is : 16 | ! x1=0.2 x2=0.2 x3=-0.5 x4=0.8 x5=0.3 17 | 18 | program main 19 | integer, parameter :: n=5 20 | real(8) :: A(n), B(n), C(n), F(n) 21 | real(8) :: X(n) 22 | 23 | data (A(i), i=1,n) /0.0d0, 1.0d0, 1.0d0, 1.0d0, 1.0d0/ 24 | data (B(i), i=1,n) /4.0d0, 4.0d0, 4.0d0, 4.0d0, 4.0d0/ 25 | data (C(i), i=1,n) /1.0d0, 1.0d0, 1.0d0, 1.0d0, 0.0d0/ 26 | data (F(i), i=1,n) /1.0d0, 0.5d0, -1.0d0, 3.0d0, 2.0d0/ 27 | X = 0.0d0 28 | 29 | write(*,*) 'Thomas Method:' 30 | write(*,*) "ax=b" 31 | write(*,*) "Coefficient for a(n*n) and b(n*1)" 32 | write(*,*) 33 | do i=1,n 34 | write(*,100) A(i),B(i),C(i),F(i) 35 | enddo 36 | call Thomas(A,B,C,F,X,n) 37 | 38 | write(*,*) 39 | write(*,*) 'Solution x:' 40 | write(*,'(f11.5)') (X(i),i=1,n) 41 | 42 | 100 format(2x,f7.3,f7.3,f7.3,f18.3) 43 | stop 44 | end program main 45 | 46 | 47 | 48 | subroutine Thomas(coeffA,coeffB,coeffC,coeffF,X,n) 49 | implicit none 50 | integer :: n, k 51 | real(8) :: coeffA(n), coeffB(n), coeffC(n), coeffF(n), X(n) 52 | real(8) :: A(n), B(n), C(n), F(n) 53 | real(8) :: t 54 | 55 | A = coeffA 56 | B = coeffB 57 | C = coeffC 58 | F = coeffF 59 | 60 | C(1) = C(1)/B(1) 61 | F(1) = F(1)/B(1) 62 | do k=2,n 63 | t = B(k)-C(k-1)*A(k) 64 | C(k)=C(k)/t 65 | F(k)=( F(k)-F(k-1)*A(k) )/t 66 | enddo 67 | do k=n-1,1,-1 68 | F(k)=F(k)-C(k)*F(k+1) 69 | enddo 70 | 71 | X = F 72 | 73 | return 74 | end subroutine Thomas 75 | -------------------------------------------------------------------------------- /06.Numerical Integration/Simpson.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program integrates function f(x) by using Simpson rule with doubling number of intervals. 3 | !!! The result is modified by Cotes Method. 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | program main 8 | implicit none 9 | real(8) :: a, b, f, integral, eps 10 | external f 11 | 12 | a = 0.0 13 | b = 2.0 14 | eps = 1.0e-6 15 | write(*,*) 'Simpson Method(result modified by Cotes Method):' 16 | write(*,*) 'f(x) = sin(0.5*Pi*x^2)' 17 | write(*,*) 'Integration on [',a,b,']' 18 | call Simpson(f,a,b,eps,integral) 19 | write(*,*) 'Result:',integral 20 | 21 | stop 22 | end program main 23 | 24 | 25 | 26 | subroutine Simpson(f,a,b,eps,integral) 27 | implicit none 28 | real(8) :: f, a, b, eps, integral 29 | real(8) :: sn, s2n, h, x 30 | real(8), parameter :: coeff = 1.0/15.0 ! error estimate coeff 31 | integer, parameter :: nmax=1048576 ! max number of intervals 32 | integer n, i 33 | 34 | ! evaluate integral for 2 intervals (three points) 35 | h = (b-a)/2.0 36 | sn = (1.0/3.0)*h*(f(a)+4.0*f(a+h)+f(b)) 37 | ! loop over number of intervals (starting from 4 intervals) 38 | n=4 39 | do while (n <= nmax) 40 | s2n = 0.0 41 | h = (b-a)/dfloat(n) 42 | do i=2, n-2, 2 43 | x = a+dfloat(i)*h 44 | s2n = s2n + 2.0*f(x) + 4.0*f(x+h) 45 | enddo 46 | s2n = (s2n + f(a) + f(b) + 4.0*f(a+h))*h/3.0 47 | !!! Similar as Cotes Method 48 | if(coeff*ABS(s2n-sn) <= eps) then 49 | integral = s2n + coeff*(s2n-sn) 50 | exit 51 | end if 52 | sn = s2n 53 | n = n*2 54 | enddo 55 | 56 | return 57 | end subroutine Simpson 58 | 59 | 60 | 61 | function f(x) 62 | implicit none 63 | real(8), parameter :: Pi=3.141592653589793 64 | real(8) :: f, x 65 | 66 | f=SIN(Pi*x*x/2.0) 67 | 68 | return 69 | end function f 70 | 71 | 72 | -------------------------------------------------------------------------------- /02.Eigenproblems/Rayleigh.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds eigenvalues and eigenvectors of a real symmetric matrix by using Rayleigh Method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: n=3 9 | integer i, j 10 | real egv 11 | real :: a(n,n),b(n) 12 | a(1,:)=(/2, 3, 2/) 13 | a(2,:)=(/10, 3, 4/) 14 | a(3,:)=(/3, 6, 1/) 15 | b =(/0.0, 0.0, 1.0/) 16 | 17 | write(*,*) 'Rayleigh Method:' 18 | write(*,*) 'All the elements of matrix A:' 19 | write(*,'(3f9.4)') ((a(i,j),j=1,n),i=1,n) 20 | write(*,*) 'Initial eigenvector:' 21 | write(*,15) b 22 | call Rayleigh(a,b,egv,n) 23 | write(*,*) '***********************************' 24 | write(*,*) 'Maximum eigenvalue:' 25 | write(*,*) egv 26 | write(*,*) 'Eigenvector:' 27 | write(*,15) b 28 | 15 format(1x,'[',f9.6,',',f9.6,',',f9.6,']') 29 | 30 | stop 31 | end program main 32 | 33 | 34 | 35 | subroutine Rayleigh(a,b,egv,n) 36 | implicit none 37 | integer i, j, n, itc 38 | real, parameter:: eps=1.0e-06 39 | real :: a(n,n), b(n), c(n), egv 40 | real :: e, e1, r0, r, fm, fz 41 | 42 | r0=0 43 | do itc=1,50 44 | e=0.0 45 | do i=1,n 46 | c(i)=0.0 47 | do j=1,n 48 | c(i)=c(i)+a(i,j)*b(j) 49 | enddo 50 | enddo !!! c=ax 51 | do i=1,n 52 | if(ABS(c(i)).LT.e) exit 53 | e=ABS(c(i)) 54 | e1=c(i) !find the maximum value of c(i) 55 | enddo 56 | fm=0.0 57 | fz=0.0 58 | do i=1,n 59 | fz=fz+b(i)*c(i) !!!fz = x'ax 60 | fm=fm+b(i)*b(i) !!!fm = x'x 61 | enddo 62 | do i=1,n 63 | b(i)=c(i)/e1 !!!normalization 64 | enddo 65 | r=fz/fm !!! Rayleigh = x'ax / x'x 66 | if(ABS(r-r0)/ABS(r).LT.eps) exit 67 | r0=r 68 | enddo 69 | egv = r 70 | 71 | return 72 | end 73 | -------------------------------------------------------------------------------- /02.Eigenproblems/inverse_power.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds eigenvalues of a matrix and its eigenvector for a given initial eigenvalue by using inverse power method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: n=4 9 | integer i,j 10 | real egv 11 | real :: a(n,n),x(n) 12 | real :: y(n)=(/9.7, 0.6, -0.6, -1.7/) 13 | a(1,:)=(/3.0, 2.0, 3.0, 4.0/) 14 | a(2,:)=(/2.0, 1.0, 1.0, 1.0/) 15 | a(3,:)=(/3.0, 1.0, 2.0, 3.0/) 16 | a(4,:)=(/4.0, 1.0, 3.0, 2.0/) 17 | 18 | write(*,*) 'Inverse power Method:' 19 | write(*,*) 'All the elements of matrix A:' 20 | write(*,'(3f9.4)') ((a(i,j),j=1,n),i=1,n) 21 | write(*,*) 'Initial eigenvalue:' 22 | write(*,'(f9.4)') y 23 | 24 | do i=1,n 25 | write(*,*) '*************************************' 26 | write(*,*) 27 | egv=y(i) 28 | call ipmcv(a,x,egv,n) 29 | write(*,*) 'Eigenvalue:',egv 30 | write(*,*) 'Eigenvector:' 31 | write(*,15) x 32 | 15 format(1x,'[',f9.6,',',f9.6,',',f9.6,',',f9.6,']') 33 | write(*,*) 34 | enddo 35 | 36 | stop 37 | end program main 38 | 39 | subroutine ipmcv(a,x,egv,n) 40 | implicit none 41 | integer n, i, j, k, itc 42 | real :: e, e0, e1, egv 43 | real :: a(n,n), b(n,n), x(n) 44 | 45 | b=a 46 | do i=1,n 47 | b(i,i)=b(i,i)-egv 48 | end do 49 | do j=1,n-1 50 | do k=j+1,n 51 | b(j,k)=b(j,k)/b(j,j) 52 | do i=j+1,n 53 | b(i,k)=b(i,k)-b(i,j)*b(j,k) 54 | end do 55 | end do 56 | end do 57 | do i=1,n 58 | x(i)=1.0 59 | end do 60 | do itc=1,50 61 | do i=n-1,1,-1 62 | do j=n,i+1,-1 63 | x(i)=x(i)-b(i,j)*x(j) 64 | enddo 65 | enddo 66 | e=0.0 67 | do i=1,n 68 | if(ABS(x(i)).LT.e) cycle 69 | e=ABS(x(i)) 70 | e1=x(i) 71 | enddo 72 | do i=1,n 73 | x(i)=x(i)/e1 74 | enddo 75 | if(ABS(e-e0).LT.5.0E-7*ABS(e)) exit 76 | e0=e 77 | x(1)=x(1)/b(1,1) 78 | do i=2,n 79 | do j=1,i-1 80 | x(i)=x(i)-b(i,j)*x(j) 81 | end do 82 | x(i)=x(i)/b(i,i) 83 | enddo 84 | enddo 85 | egv=egv+1.0/e1 86 | 87 | return 88 | end subroutine ipmcv 89 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/04.WENO Scheme/test.txt: -------------------------------------------------------------------------------- 1 | ==================================================================================================================== 2 | WENO Scheme in Finite Volume Formulation 3 | with Godunov Flux 4 | ******************************************************************************************************************** 5 | N LInfinity error LInfinity order L1 error L1 order 6 | 10 2.91942894664620756E-003 ------------------- 1.57162800627973372E-003 ------------------- 7 | 20 1.54900743484120973E-004 4.2362702252758964 6.16579279835078903E-005 4.6718295631678933 8 | 40 9.28710306791202811E-006 4.0599716125071584 2.19765139594056033E-006 4.81025194745735472 9 | 80 8.08041267563730514E-007 3.52272776597339959 8.28220596028444404E-008 4.72980366584180734 10 | 160 6.08509738153628632E-008 3.73107671880082398 3.11817810272332497E-009 4.73123984109152125 11 | 320 1.26835253411172744E-009 5.5842526526571650 7.83657528033282523E-011 5.31433621413714722 12 | ==================================================================================================================== 13 | WENO Scheme in Finite Volume Formulation 14 | with Lax-Friedrichs Flux 15 | ******************************************************************************************************************** 16 | N LInfinity error LInfinity order L1 error L1 order 17 | 10 4.69388050488184216E-003 ------------------- 2.77647722480637042E-003 ------------------- 18 | 20 3.78564197313413509E-004 3.63217123491052958 1.10980298074014593E-004 4.6448800736296145 19 | 40 1.20921886813674107E-005 4.9683906741288920 3.85645030011432401E-006 4.8468862543884676 20 | 80 9.47969754305777457E-007 3.6730905556502151 1.48657683308698559E-007 4.6972075829636309 21 | 160 6.50044617023226579E-008 3.86623038086417563 6.30811551763357381E-009 4.5586411402380343 22 | 320 7.41568639828216192E-009 3.13188660331818166 1.45383382863781451E-009 2.1173466993168542 23 | ==================================================================================================================== 24 | WENO Scheme in Finite Difference Formulation 25 | with Lax-Friedrichs Flux 26 | ******************************************************************************************************************** 27 | N LInfinity error LInfinity order L1 error L1 order 28 | 10 1.27642651379151761E-002 ------------------- 5.46568857792504009E-003 ------------------- 29 | 20 9.28434634305252970E-004 3.7811663293685260 3.11445490065452937E-004 4.13335167431418936 30 | 40 5.30733304826558339E-005 4.12874135256820677 9.83827910552102120E-006 4.98442988722860778 31 | 80 2.02101541268984164E-006 4.71483485510064767 2.93214216413742782E-007 5.06837902498554805 32 | 160 6.14184944014439793E-008 5.04026336697138064 7.96597369569023338E-009 5.20196052781919395 33 | 320 3.71548525279763453E-009 4.04705059865821790 1.33895472214263120E-009 2.5727435402452384 34 | ==================================================================================================================== -------------------------------------------------------------------------------- /06.Numerical Integration/GLI.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program integrates function f(x) with respect to x from a to b 3 | !!! by using Gauss-Legendre numerical integration method(n=20) 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | program main 8 | implicit none 9 | real(8) :: f, gl, a, b 10 | external f 11 | 12 | a = 0.0d0 13 | b = 1.0d0 14 | write(*,*) 'Gauss-Legendre Method(N=20):' 15 | write(*,*) 'f(x) = 1.0/(1.0+x)' 16 | write(*,*) 'Integration on [',a,b,']' 17 | call GLI(a,b,gl) 18 | write(*,*) 'Result:',gl 19 | 20 | stop 21 | end program main 22 | 23 | 24 | subroutine GLI(a,b,gl) 25 | implicit none 26 | integer, parameter :: k=10 27 | integer :: i 28 | real(8) :: x_k(k),A_k(k) 29 | real(8) :: a, b, c0, c1, c2, t1, t2, f, f1, f2, gl 30 | 31 | !!! n = 20, k =10 32 | data x_k/0.9931285991850949d0,0.9639719272779138d0,0.9122344282513259d0,0.8391169718222188d0,0.7463319064601508d0, & 33 | 0.6360536807265150d0,0.5108670019508271d0,0.3737060887154196d0,0.2277858511416451d0,0.07652652113349734d0/ 34 | data A_k/0.01761400713915212d0,0.04060142980038694d0,0.06267204833410906d0,0.08327674157670475d0,0.1019301198172404d0, & 35 | 0.1181945319615184d0,0.1316886384491766d0,0.1420961093183821d0,0.1491729864726037d0,0.1527533871307259d0/ 36 | 37 | !!! n = 10, k=5 38 | !!! data x_k/0.9739065285171717d0,0.8650633666889845d0,0.6794095682990244d0,0.4333953941292472d0,0.1488743389816312d0/ 39 | !!! data A_k/0.06667134430868814d0,0.1494513491505806d0,0.2190863625159820d0,0.2692667193099964d0,0.2955242247147529d0/ 40 | 41 | !!! n = 5, k = 3 42 | !!! data x_k/0.000000000000000d0,0.538469310105683d0,0.906179845938664d0/ 43 | !!! data A_k/0.568888888888889d0,0.478628670499366d0,0.236926885056189d0/ 44 | 45 | !!! n = 4, k = 2 46 | !!! data x_k/0.339981043584856d0,0.861136311594053d0/ 47 | !!! data A_k/0.347854845137454d0,0.652145154862546d0/ 48 | 49 | !!! n = 3, k = 2 50 | !!! data x_k/0.000000000000000d0,0.774596669241483d0/ 51 | !!! data A_k/0.888888888888889d0,0.555555555555556d0/ 52 | 53 | !!! n = 2, k = 1 54 | !!! data x_k/0.577350269189626d0/ 55 | !!! data A_k/1.000000000000000d0/ 56 | 57 | c1=(b-a)/2.0d0 58 | c2=c1+a 59 | gl=0.0d0 60 | do i=1,k 61 | c0=c1*x_k(i) 62 | t1=c2+c0 63 | t2=c2-c0 64 | f1=f(t1) 65 | f2=f(t2) 66 | gl=gl+A_k(i)*(f1+f2) 67 | end do 68 | gl=c1*gl 69 | 70 | return 71 | end subroutine GLI 72 | 73 | 74 | 75 | function f(x) 76 | implicit none 77 | real(8) :: f, x 78 | 79 | f = 1.0d0/(1.0d0+x) !!! Function for integration 80 | 81 | return 82 | end function f 83 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/00.Upwind Scheme - Godunov Scheme/Upwind.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves Burgers Equation using 1st-order Upwind Scheme. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: N=640 9 | real(8), parameter :: Pi=3.14159265358979d0 10 | integer :: i, nt 11 | real(8) :: alpha, dx, dt, t, u_error 12 | real(8) :: u(0:N), X(0:N), u_exact(0:N) 13 | 14 | alpha = 0.5d0 15 | dx = Pi/DBLE(N) 16 | dt = alpha*dx 17 | t = 0.1d0*Pi 18 | nt = NINT(t/dt) 19 | 20 | do i=0,N 21 | X(i) = i*dx 22 | enddo 23 | 24 | write(*,*) '' 25 | write(*,*) 'UPWIND SCHEME:' 26 | write(*,*) '****************************************' 27 | 28 | call exact(N,X,t,u_exact) 29 | 30 | call FTBS(nt,N,alpha,u,X) 31 | 32 | !!! calculate error 33 | u_error = 0.0d0 34 | do i=0,N-1 35 | u_error = ABS(u_exact(i)-u(i))+u_error 36 | enddo 37 | u_error = u_error/DBLE(N) 38 | 39 | write(*,*) 'Number of points is:',N 40 | write(*,*) 'L1 Normal is:', u_error 41 | 42 | open(unit=01,file='./result.dat',status='unknown') 43 | write(01,101) 44 | write(01,102) 45 | write(01,103) N+1 46 | 47 | do i = 0,N 48 | write(01,100) X(i), u(i),u_exact(i) 49 | enddo 50 | 51 | close(01) 52 | print*,'****************************************' 53 | 54 | 55 | 100 format(2x,10(e12.6,' ')) 56 | 101 format('Title="Burgers Equation"') 57 | 102 format('Variables=x,u_num,u_exact') 58 | 103 format('zone',1x'i=',1x,i5,2x,'f=point') 59 | stop 60 | end program main 61 | 62 | 63 | 64 | subroutine exact(N,X,t,u_exact) 65 | implicit none 66 | integer :: i, N 67 | real(8) :: x0, temp, t 68 | real(8) :: X(0:N), u_exact(0:N) 69 | 70 | do i=0,N 71 | x0 = X(i) 72 | do 73 | temp = x0 74 | x0 = x0-(x0+t*SIN(x0)-X(i))/(1.0d0+t*COS(x0)) 75 | if(ABS(temp-x0).GT.1e-5) then 76 | cycle 77 | else 78 | exit 79 | endif 80 | enddo 81 | u_exact(i) = SIN(x0) 82 | !write(*,*) 'x0=',X(i),'u_exact=',u_exact(i) 83 | enddo 84 | 85 | return 86 | end subroutine exact 87 | 88 | 89 | 90 | subroutine FTBS(nt,N,alpha,u,X) 91 | implicit none 92 | integer :: i, j, nt, N 93 | real(8) :: alpha 94 | real(8) :: un(0:N), u(0:N), X(0:N) 95 | 96 | do i=0,N 97 | un(i) = SIN(X(i)) 98 | enddo 99 | 100 | do j=1,nt 101 | u(0) = un(0)-alpha*un(0)*(un(0)-un(N-1)) 102 | do i=1,N 103 | u(i) = un(i)-alpha*un(i)*(un(i)-un(i-1)) 104 | enddo 105 | un = u 106 | enddo 107 | 108 | ! do i=1,N 109 | ! write(*,*) 'x=',X(i),'u=',u(i) 110 | ! enddo 111 | 112 | return 113 | end subroutine FTBS 114 | -------------------------------------------------------------------------------- /06.Numerical Integration/Romberg.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program integrates function f(x) by using Romberg Method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | real(8) :: f, a, b, eps, x, ri 9 | external f 10 | 11 | a = 0.0 12 | b = 5.0 13 | eps = 1.0e-6 14 | write(*,*) 'Romberg Method:' 15 | write(*,*) 'f(x) = cos(0.5*Pi*x*x)' 16 | write(*,*) 'Integration on [',a,b,']' 17 | call Romberg(a,b,eps,x,ri) 18 | write(*,*) 'Result:',ri 19 | 20 | stop 21 | end program main 22 | 23 | 24 | 25 | subroutine Romberg(a,b,eps,x,ri) 26 | implicit none 27 | integer :: k 28 | real(8) :: a, b, eps, x, ri, ri0, f, h, fa, fb, t1, t2, s, s1, s2, c1, c2, ff 29 | 30 | h = b-a 31 | fa = f(a) 32 | fb = f(b) 33 | t1 = h*(fa+fb)/2.0 34 | k = 1 35 | do 36 | s = 0.0 37 | x = a+0.5*h 38 | do while(x.LT.b) 39 | ff = f(x) 40 | s = s+ff 41 | x = x+h 42 | enddo 43 | t2 = (t1+h*s)/2.0 44 | s2 = t2+(t2-t1)/3.0 45 | if(k.NE.1) then 46 | c2 = s2+(s2-s1)/15.0 47 | if(k.NE.2) then 48 | ri = c2+(c2-c1)/63.0 49 | if(k.NE.3) then 50 | if(ABS(ri-ri0).GT.ABS(ri)*eps) then 51 | ri0 = ri 52 | c1 = c2 53 | k = k+1 54 | h = 0.5*h 55 | t1 = t2 56 | s1 = s2 57 | cycle 58 | else 59 | exit 60 | endif 61 | else 62 | ri0 = ri 63 | c1 = c2 64 | k = k+1 65 | h = 0.5*h 66 | t1 = t2 67 | s1 = s2 68 | cycle 69 | endif 70 | 71 | else 72 | c1 = c2 73 | k = k+1 74 | h = 0.5*h 75 | t1 = t2 76 | s1 = s2 77 | cycle 78 | endif 79 | 80 | else 81 | k = k+1 82 | h = h/2.0 83 | t1 = t2 84 | s1 = s2 85 | cycle 86 | endif 87 | enddo 88 | 89 | 90 | return 91 | end subroutine Romberg 92 | 93 | 94 | 95 | function f(x) 96 | implicit none 97 | real(8), parameter :: Pi=3.141592653589793 98 | real(8) :: f, x 99 | 100 | f=COS(0.5*Pi*x*x) !!! Function for integration 101 | 102 | return 103 | end function f 104 | -------------------------------------------------------------------------------- /01.Systems of Linear Algebraic Equations/Gauss.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves a system of linear equation A*x=b by using Gauss elimination(with scaled pivoting) 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: N=4 9 | integer, parameter :: dp=kind(0.d0) 10 | real(dp) :: a(N,N), b(N), x(N) 11 | integer i,j 12 | ! matrix A 13 | data (a(1,i), i=1,N) / 2.0_dp, 0.0_dp, 0.0_dp, 6.0_dp / 14 | data (a(2,i), i=1,N) / 3.0_dp, 7.0_dp, 0.0_dp, 0.0_dp / 15 | data (a(3,i), i=1,N) / 0.0_dp, 0.0_dp, 1.5_dp, 0.0_dp / 16 | data (a(4,i), i=1,N) / 0.0_dp, 10.0_dp, 0.0_dp, 8.0_dp / 17 | !matrix b 18 | data (b(i), i=1,N) / 13.0_dp, 8.5_dp, 2.25_dp, 26.0_dp / 19 | 20 | write(*,*) 'Gauss elimination with scaling and pivoting method:' 21 | write(*,*) 'All the elements of matrix A:' 22 | write(*,'(4f9.4)') ((a(i,j),j=1,N),i=1,N) 23 | write(*,*) 24 | write(*,*) 'Vector b:' 25 | write(*,'(f9.4)') (b(i),i=1,N) 26 | 27 | call Gauss(a,b,x,N) 28 | 29 | write(*,*) 30 | write(*,*) 'Solution x:' 31 | write(*,'(f9.4)') (x(i),i=1,N) 32 | 33 | stop 34 | end program main 35 | 36 | 37 | 38 | subroutine Gauss(a,b,x,N) 39 | implicit none 40 | integer N 41 | integer, parameter :: dp=kind(0.d0) 42 | real(dp) :: a(N,N), b(N), x(N) 43 | real(dp) :: s(N) 44 | real(dp) :: c, pivot, store 45 | integer i, j, k, l 46 | !!! begin forward elimination 47 | do k=1, N-1 48 | !!! scaling 49 | !!! s(i) will have the largest element from row i 50 | do i=k,N !!! loop over rows 51 | s(i) = 0.0_dp 52 | do j=k,N !!! loop over elements of row i 53 | s(i) = MAX(s(i),ABS(a(i,j))) 54 | end do 55 | end do 56 | !!! pivoting 1 57 | !!! find a row with the largest pivoting element 58 | pivot = ABS(a(k,k)/s(k)) 59 | l = k 60 | do j=k+1,N 61 | if(ABS(a(j,k)/s(j)).GT.pivot) then 62 | pivot = abs(a(j,k)/s(j)) 63 | l = j 64 | end if 65 | end do 66 | 67 | !!! Check if the system has a sigular matrix 68 | if(pivot.EQ.0.0_dp) then 69 | write(*,*) ' The matrix is sigular ' 70 | return 71 | end if 72 | 73 | !!! pivoting 2 interchange rows k and l (if needed) 74 | if (l /= k) then 75 | do j=k,n 76 | store = a(k,j) 77 | a(k,j) = a(l,j) 78 | a(l,j) = store 79 | end do 80 | store = b(k) 81 | b(k) = b(l) 82 | b(l) = store 83 | end if 84 | 85 | !!! the elimination (after scaling and pivoting) 86 | do i=k+1,n 87 | c = a(i,k)/a(k,k) 88 | a(i,k) = 0.0_dp 89 | b(i) = b(i)-c*b(k) 90 | do j=k+1,n 91 | a(i,j) = a(i,j)-c*a(k,j) 92 | enddo 93 | enddo 94 | enddo 95 | !!! back substiturion 96 | x(n) = b(n)/a(n,n) 97 | do i=n-1,1,-1 98 | c = 0.0_dp 99 | do j=i+1,n 100 | c = c+a(i,j)*x(j) 101 | enddo 102 | x(i) = (b(i)- c)/a(i,i) 103 | enddo 104 | 105 | return 106 | end subroutine Gauss 107 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/00.Upwind Scheme - Godunov Scheme/Godunov.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves Burgers Equation using Godunov Scheme. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: N=21 9 | real, parameter :: Pi=3.1415926535 10 | integer :: i, nt 11 | real :: alpha, dx, dt, t, u_error, error_0 12 | real :: u(N), X(N), u_exact(N) 13 | 14 | alpha = 0.5 15 | dx = 2*Pi/(N-1) 16 | dt = alpha*dx 17 | t = 0.1*Pi 18 | nt = NINT(t/dt) 19 | 20 | do i=1,N 21 | X(i) = (i-1)*dx 22 | enddo 23 | 24 | write(*,*) '' 25 | write(*,*) 'GODUNOV SCHEME:' 26 | write(*,*) '****************************************' 27 | 28 | call exact(N,X,t,u_exact) 29 | 30 | call Godunov(nt,alpha,N,X,u) 31 | 32 | !!!calculate error 33 | u_error = 0.0 34 | do i=1,N 35 | u_error = ABS(u(i)-u_exact(i)) 36 | if(u_error.GT.error_0) error_0 = u_error 37 | enddo 38 | 39 | write(*,*) 'Number of points is:',N 40 | write(*,*) 'Infinity Normal is:', u_error 41 | 42 | open(unit=01,file='./result.dat',status='unknown') 43 | write(01,101) 44 | write(01,102) 45 | write(01,103) N 46 | 47 | do i = 1,N 48 | write(01,100) X(i), u(i),u_exact(i) 49 | enddo 50 | 51 | close(01) 52 | print*,'****************************************' 53 | 54 | 55 | 100 format(2x,10(e12.6,' ')) 56 | 101 format('Title="Burgers Equation(Godunov Scheme)"') 57 | 102 format('Variables=x,u_num,u_exact') 58 | 103 format('zone',1x'i=',1x,i5,2x,'f=point') 59 | stop 60 | end program main 61 | 62 | 63 | 64 | subroutine exact(N,X,t,u_exact) 65 | implicit none 66 | integer :: i, N 67 | real :: x0, temp, t 68 | real :: X(N), u_exact(N) 69 | 70 | do i=1,N 71 | x0 = X(i) 72 | do 73 | temp = x0 74 | x0 = x0-(x0+t*(1.0/3.0+2.0/3.0*SIN(x0))-X(i))/(1.0+t*2.0/3.0*COS(x0)) 75 | if(ABS(temp-x0).GT.1e-5) then 76 | cycle 77 | else 78 | exit 79 | endif 80 | enddo 81 | u_exact(i) = 1.0/3.0+2.0/3.0*SIN(x0) 82 | !write(*,*) 'x0=',X(i),'u_exact=',u_exact(i) 83 | enddo 84 | 85 | return 86 | end subroutine exact 87 | 88 | 89 | subroutine Godunov(nt,alpha,N,X,u) 90 | implicit none 91 | integer :: N, i, j, nt 92 | real :: alpha 93 | real :: un(N), u(N), f(0:N), X(N) 94 | 95 | do i=1,N 96 | un(i) = 1.0/3.0+2.0/3.0*SIN(X(i)) 97 | enddo 98 | 99 | do j=1,nt 100 | do i=1,N-1 101 | if(un(i).LE.un(i+1)) then 102 | f(i) = MIN(0.5*un(i)*un(i),0.5*un(i+1)*un(i+1)) 103 | if(un(i)*un(i+1).LT.0.0) f(i) = 0.0 104 | else 105 | f(i) = MAX(0.5*un(i)*un(i),0.5*un(i+1)*un(i+1)) 106 | endif 107 | enddo 108 | 109 | f(0) = f(N-1) 110 | f(N) = f(1) 111 | 112 | do i =1,N 113 | u(i) = un(i)-alpha*(f(i)-f(i-1)) 114 | enddo 115 | 116 | un = u 117 | enddo 118 | 119 | ! do i=1,N 120 | ! write(*,*) 'x=',X(i),'u=',u(i) 121 | ! enddo 122 | 123 | return 124 | end subroutine Godunov 125 | -------------------------------------------------------------------------------- /07.Initial-Value Ordinary Differential Equations/doubleGyre.m: -------------------------------------------------------------------------------- 1 | clc; close all; clear all 2 | graphicsON = 1; % flag for graphics 3 | outputDatFile = 1; 4 | tstart = tic; 5 | A = 0.1; % parameters from Shadden 2005 Physica D 6 | eps = 0.1; 7 | omega = 2.0*pi/10.0; % frequency of gyre oscillations 8 | 9 | %% Part 1 - Initialize grid of particles through vector field 10 | dx = 0.05; 11 | xvec = 0:dx:2; 12 | yvec = 0:dx:1; 13 | [x0,y0] = meshgrid(xvec,yvec); % grid of particles 14 | yIC(1,:,:) = x0'; 15 | yIC(2,:,:) = y0'; 16 | 17 | if(graphicsON) 18 | subplot(2,1,1) 19 | dy = doublegyreVEC(0,yIC,A,eps,omega); 20 | quiver(yIC(1,1:4:end,1:4:end),yIC(2,1:4:end,1:4:end),dy(1,1:4:end,1:4:end),dy(2,1:4:end,1:4:end)); 21 | axis([0 2 0 1]), drawnow 22 | subplot(2,1,2) 23 | % plot initial conditions 24 | plot(yIC(1,:),yIC(2,:),'r.','LineWidth',2,'MarkerSize',4) 25 | axis([0 2 0 1]), drawnow 26 | end 27 | 28 | 29 | %% Part 2 - Compute trajectory 30 | dt =1e-1; % timestep 31 | T = 10.0; % duration of integration 32 | 33 | yin(1,:,:) = x0'; % 0.5; 34 | yin(2,:,:) = y0'; % 0.25; 35 | fileID = fopen('final.dat','wt+'); 36 | for i=1:T/dt 37 | time = i*dt; 38 | 39 | if(outputDatFile) 40 | fprintf(fileID, '%18.15f %18.15f %18.15f\n',yin, time); 41 | end 42 | if(graphicsON) 43 | subplot(2,1,1) 44 | dy = doublegyreVEC(time,yIC,A,eps,omega); 45 | quiver(yIC(1,1:4:end,1:4:end),yIC(2,1:4:end,1:4:end),dy(1,1:4:end,1:4:end),dy(2,1:4:end,1:4:end)); 46 | axis([0 2 0 1]) 47 | drawnow 48 | end 49 | 50 | yout = rk4singlestep(@(t,y)doublegyreVEC(t,y,A,eps,omega),dt,time,yin); 51 | yin = yout; 52 | if(graphicsON) 53 | subplot(2,1,2) 54 | plot(yout(1,:),yout(2,:),'r.','LineWidth',2,'MarkerSize',4) 55 | axis([0 2 0 1]) 56 | hold on; %drawnow 57 | end 58 | 59 | end 60 | fclose(fileID); 61 | 62 | % %% Part 3 - Compute the finite-time Lyapunov exponent (sigma) 63 | % myBlack = [0 0 0]; 64 | % myGray = [192 192 192]; 65 | % myWhite = [255 255 255]; 66 | % myRed = [255 0 0]; 67 | % myGold = [255 215 0]; 68 | % myBlue = [0 0 200]; 69 | % myTangerine = [255 69 0]; 70 | % mycolorpoint=[myWhite 71 | % myWhite 72 | % myWhite 73 | % myBlue 74 | % myBlue]; 75 | % mycolorposition=[1 17 33 49 64]; 76 | % mycolormap_r=interp1(mycolorposition,mycolorpoint(:,1),1:64,'linear','extrap'); 77 | % mycolormap_g=interp1(mycolorposition,mycolorpoint(:,2),1:64,'linear','extrap'); 78 | % mycolormap_b=interp1(mycolorposition,mycolorpoint(:,3),1:64,'linear','extrap'); 79 | % mycolor=[mycolormap_r',mycolormap_g',mycolormap_b']/256.0; 80 | 81 | % reshape 3-dim array into 2-dim array 82 | xT = reshape(yout(1,:,:),length(xvec),length(yvec)); 83 | yT = reshape(yout(2,:,:),length(xvec),length(yvec)); 84 | 85 | % Finite difference to compute the gradient 86 | [dxTdx0,dxTdy0] = gradient(xT,dx,dx); 87 | [dyTdx0,dyTdy0] = gradient(yT,dx,dx); 88 | 89 | % compute sigma: large sigma indicates large mixing! 90 | for i=1:length(xvec) 91 | for j=1:length(yvec) 92 | D(1,1) = dxTdx0(i,j); 93 | D(1,2) = dxTdy0(i,j); 94 | D(2,1) = dyTdx0(i,j); 95 | D(2,2) = dyTdy0(i,j); 96 | sigma(i,j) = (0.5/time)*log(max(eig(D'*D))); 97 | % sigma(i,j) = (1/T)*sqrt(max(eig(D'*D))); 98 | end 99 | end 100 | 101 | if(graphicsON) 102 | %figure 103 | contourf(x0',y0',sigma,'LineColor','none') 104 | set(gcf,'Position',[700 300 600 300]) 105 | colorbar 106 | % caxis([0, 500]); 107 | %colormap(mycolor); 108 | drawnow; 109 | end 110 | 111 | %% 112 | telapsed = toc(tstart); 113 | disp(['Successfully: simulation completed! ',num2str(telapsed),' seconds']) 114 | 115 | %% 116 | function yout = rk4singlestep(fun,dt,t0,y0) 117 | 118 | f1 = fun(t0,y0); 119 | f2 = fun(t0+dt/2,y0+(dt/2)*f1); 120 | f3 = fun(t0+dt/2,y0+(dt/2)*f2); 121 | f4 = fun(t0+dt,y0+dt*f3); 122 | yout = y0+(dt/6)*(f1+2*f2+2*f3+f4); 123 | end 124 | 125 | %% 126 | function [dy] = doublegyreVEC(t,yin,A,eps,om) 127 | x = yin(1,:,:); 128 | y = yin(2,:,:); 129 | % A = 0.1; eps = 0.25; om = 2*pi/10; % from Shadden 2005 Physica D 130 | 131 | u = zeros(size(x)); v = u; 132 | 133 | a = eps * sin(om * t); 134 | b = 1.0 - 2.0 * a; 135 | 136 | f = a * x.^2.0 + b * x; 137 | df = 2.0 * a * x + b; 138 | 139 | u = -pi * A * sin(pi * f) .* cos(pi * y); 140 | v = pi * A * cos(pi * f) .* sin(pi * y) .* df; 141 | 142 | dy = [u;v]; 143 | end -------------------------------------------------------------------------------- /07.Initial-Value Ordinary Differential Equations/ODEsovler.lay: -------------------------------------------------------------------------------- 1 | #!MC 1410 2 | $!VarSet |LFDSFN1| = '"analytical.dat"' 3 | $!VarSet |LFDSVL1| = '"V1" "V2"' 4 | $!VarSet |LFDSFN2| = '"numerical.dat"' 5 | $!VarSet |LFDSVL2| = '"V1" "V2"' 6 | $!SetStyleBase Factory 7 | $!GlobalPaper 8 | PaperSizeInfo 9 | { 10 | Letter 11 | { 12 | Width = 8.5 13 | Height = 11 14 | LeftHardClipOffset = 0.125 15 | RightHardClipOffset = 0.125 16 | TopHardClipOffset = 0.125 17 | BottomHardClipOffset = 0.125 18 | } 19 | } 20 | $!Page 21 | Name = '' 22 | PaperAttributes 23 | { 24 | BackgroundColor = White 25 | IsTransparent = Yes 26 | OrientPortrait = No 27 | ShowGrid = Yes 28 | ShowRuler = No 29 | ShowPaper = No 30 | PaperSize = Letter 31 | RulerSpacing = OneInch 32 | PaperGridSpacing = HalfInch 33 | RegionInWorkArea 34 | { 35 | X1 = 1 36 | Y1 = 0.25 37 | X2 = 10 38 | Y2 = 8.25 39 | } 40 | } 41 | ### Frame Number 1 ### 42 | $!ReadDataSet '|LFDSFN1|' 43 | InitialPlotType = XYLine 44 | IncludeText = No 45 | IncludeGeom = No 46 | AssignStrandIDs = Yes 47 | VarLoadMode = ByName 48 | VarNameList = '|LFDSVL1|' 49 | $!RemoveVar |LFDSVL1| 50 | $!RemoveVar |LFDSFN1| 51 | $!ReadDataSet '|LFDSFN2|' 52 | InitialPlotType = XYLine 53 | IncludeText = No 54 | IncludeGeom = No 55 | ReadDataOption = Append 56 | ResetStyle = No 57 | AssignStrandIDs = Yes 58 | VarLoadMode = ByName 59 | VarNameList = '|LFDSVL2|' 60 | $!RemoveVar |LFDSVL2| 61 | $!RemoveVar |LFDSFN2| 62 | $!FrameLayout 63 | ShowBorder = No 64 | ShowHeader = No 65 | HeaderColor = Red 66 | XYPos 67 | { 68 | X = 1 69 | Y = 0.25 70 | } 71 | Width = 9 72 | Height = 8 73 | $!ThreeDAxis 74 | AspectRatioLimit = 25 75 | BoxAspectRatioLimit = 25 76 | $!PlotType = XYLine 77 | $!FrameName = 'Frame 001' 78 | $!GlobalTime 79 | SolutionTime = 0 80 | $!DeleteLineMaps 81 | $!ActiveLineMaps = [1-2] 82 | $!GlobalLinePlot 83 | DataLabels 84 | { 85 | DistanceSkip = 5 86 | } 87 | Legend 88 | { 89 | Show = Yes 90 | TextShape 91 | { 92 | FontFamily = 'Times New Roman' 93 | IsBold = No 94 | SizeUnits = Point 95 | Height = 24 96 | } 97 | Box 98 | { 99 | BoxType = None 100 | Margin = 5 101 | } 102 | XYPos 103 | { 104 | X = 94.926 105 | Y = 95.28 106 | } 107 | } 108 | $!LineMap [1] 109 | Name = 'Analytical' 110 | Assign 111 | { 112 | Zone = 1 113 | XAxisVar = 1 114 | YAxisVar = 2 115 | } 116 | Lines 117 | { 118 | Color = Red 119 | LineThickness = 0.4 120 | } 121 | Symbols 122 | { 123 | Color = Red 124 | FillMode = UseSpecificColor 125 | FillColor = White 126 | LineThickness = 0.4 127 | } 128 | BarCharts 129 | { 130 | Color = Red 131 | FillColor = Red 132 | } 133 | ErrorBars 134 | { 135 | Color = Red 136 | } 137 | $!LineMap [2] 138 | Name = 'Numerical' 139 | Assign 140 | { 141 | Zone = 2 142 | XAxisVar = 1 143 | YAxisVar = 2 144 | } 145 | Lines 146 | { 147 | Color = Blue 148 | LinePattern = DashDot 149 | LineThickness = 0.4 150 | } 151 | Symbols 152 | { 153 | Color = Blue 154 | FillMode = UseSpecificColor 155 | FillColor = White 156 | LineThickness = 0.4 157 | } 158 | BarCharts 159 | { 160 | Color = Green 161 | FillColor = Green 162 | } 163 | ErrorBars 164 | { 165 | Color = Green 166 | } 167 | $!XYLineAxis 168 | DepXToYRatio = 1 169 | GridArea 170 | { 171 | DrawBorder = Yes 172 | } 173 | ViewportPosition 174 | { 175 | X1 = 15 176 | Y1 = 15 177 | X2 = 95 178 | Y2 = 95 179 | } 180 | ViewportTopSnapTarget = 95 181 | $!XYLineAxis 182 | XDetail 1 183 | { 184 | RangeMin = 0 185 | RangeMax = 1.0001 186 | GRSpacing = 0.2 187 | TickLabel 188 | { 189 | TextShape 190 | { 191 | FontFamily = 'Times New Roman' 192 | SizeUnits = Point 193 | Height = 28 194 | } 195 | Offset = 3 196 | } 197 | Title 198 | { 199 | TitleMode = UseText 200 | Text = 'time' 201 | TextShape 202 | { 203 | FontFamily = 'Times New Roman' 204 | IsBold = No 205 | SizeUnits = Point 206 | Height = 50 207 | } 208 | Offset = 7 209 | } 210 | } 211 | $!XYLineAxis 212 | YDetail 1 213 | { 214 | RangeMin = -0.16052007675170898 215 | RangeMax = 0.15918690417259931 216 | GRSpacing = 0.05 217 | TickLabel 218 | { 219 | TextShape 220 | { 221 | FontFamily = 'Times New Roman' 222 | SizeUnits = Point 223 | Height = 28 224 | } 225 | } 226 | Title 227 | { 228 | TitleMode = UseText 229 | Text = 'velocity' 230 | TextShape 231 | { 232 | FontFamily = 'Times New Roman' 233 | IsBold = No 234 | SizeUnits = Point 235 | Height = 50 236 | } 237 | Offset = 8 238 | } 239 | } 240 | $!LinePlotLayers 241 | ShowSymbols = Yes 242 | $!FrameControl ActivateByNumber 243 | Frame = 1 244 | $!SetStyleBase Config 245 | -------------------------------------------------------------------------------- /02.Eigenproblems/Jacobi.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program finds eigenvalues and eigenvectors of a real symmetric matrix by using Jacobi Method. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: n=4 9 | integer i, j 10 | integer :: nRot ! the numer of Jacobi rotations that were required 11 | real, parameter:: eps=1.0e-09 12 | real(8) :: a(n,n) ! a is a real symmetric matrix 13 | real(8) :: v(n,n) ! v's colums contain the normalized eigenvectors of a 14 | real(8) :: d(n) ! eigenvalues of a in its first n elements 15 | 16 | a(1,:)=(/1.0, 2.0, 1.0, 2.0/) 17 | a(2,:)=(/2.0, 2.0, -1.0, 1.0/) 18 | a(3,:)=(/1.0, -1.0, 1.0, 1.0/) 19 | a(4,:)=(/2.0, 1.0, 1.0, 1.0/) 20 | 21 | write(*,*) 'Jacobi Method:' 22 | write(*,*) 'All the elements of matrix A:' 23 | write(*,'(4f9.4)') ((a(i,j),j=1,n),i=1,n) 24 | call Jacobi(a,4,d,v,nRot) 25 | write(*,*) "nRot=", nRot 26 | 27 | do i=1,n 28 | write(*,*) '*************************************' 29 | write(*,*) 30 | write (*,*) 'Eigenvalues:' 31 | write (*,'(4f9.4)') d(i) 32 | write(*,*) 'Eigenvector:' 33 | write(*,15) (v(j,i),j=1,n) 34 | 15 format(1x,'[',f9.6,',',f9.6,',',f9.6,',',f9.6,']') 35 | enddo 36 | 37 | stop 38 | end program main 39 | 40 | 41 | 42 | subroutine Jacobi(a,n,d,v,nRot) 43 | implicit none 44 | integer :: n, nRot 45 | real(8) :: a(n,n), d(n), v(n,n) 46 | integer :: i, ip, iq, j 47 | real(8) :: c, g, h, s, sm, t, tau, theta, tresh 48 | real(8) :: b(n), z(n) 49 | 50 | ! initialize v to the identity matrix 51 | do ip=1,n 52 | do iq=1,n 53 | v(ip,iq) = 0.0d0 54 | enddo 55 | v(ip,ip) = 1.0d0 56 | enddo 57 | 58 | ! initizlize b and d to the diagonal of a 59 | do ip=1,n 60 | b(ip) = a(ip,ip) 61 | d(ip) = b(ip) 62 | z(ip) = 0.0d0 63 | enddo 64 | 65 | nRot = 0 66 | 67 | do i=1,50 68 | ! sum off-diagonal elements 69 | sm = 0.0d0 70 | do ip=1,n-1 71 | do iq=ip+1,n 72 | sm = sm+DABS(a(ip,iq)) 73 | enddo 74 | enddo 75 | ! Normal return ... 76 | if(sm.EQ.0.0d0) return 77 | ! On the first three sweeps, rotate only if tresh exceeded. 78 | if(i.LT.4) then 79 | tresh = 0.2d0*sm/n**2 80 | else 81 | tresh = 0.0d0 82 | endif 83 | 84 | do ip=1,n-1 85 | do iq=ip+1,n 86 | g = 100.0d0*DABS(a(ip,iq)) 87 | ! After four sweeps, skip the rotation if the off-diagnoal element is small 88 | if( (i.GT.4).AND.(ABS(d(ip))+g.EQ.ABS(d(ip))).AND.(ABS(d(iq))+g.eq.ABS(d(iq))) ) then 89 | a(ip,iq) = 0.0d0 90 | elseif(ABS(a(ip,iq)).GT.tresh) then 91 | h = d(iq)-d(ip) 92 | if(ABS(h)+g.EQ.ABS(h)) then 93 | t = a(ip,iq)/h ! t=1/(2theta) 94 | else 95 | theta = 0.5d0*h/a(ip,iq) 96 | t = 1.0d0/(ABS(theta)+SQRT(1.0d0+theta**2)) 97 | if(theta.LT.0.0d0) t = -t 98 | endif 99 | c = 1.0d0/SQRT(1.0d0+t**2) 100 | s = t*c 101 | tau = s/(1.0d0+c) 102 | h = t*a(ip,iq) 103 | z(ip) = z(ip)-h 104 | z(iq) = z(iq)+h 105 | d(ip) = d(ip)-h 106 | d(iq) = d(iq)+h 107 | a(ip,iq) = 0.0d0 108 | 109 | ! case of ratations 1 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: N=20 9 | real(8), parameter :: Pi=3.1415926536d0 10 | integer :: i, nt 11 | real(8) :: alpha, dx, dt, t, u_error 12 | real(8) :: u_avg(0:N-1) 13 | real(8) :: u_exact(0:N), X(0:N) 14 | 15 | alpha = 0.5d0 16 | dx = 2.0d0*Pi/N 17 | dt = alpha*dx 18 | t = 0.1d0*Pi 19 | nt = NINT(t/dt) 20 | 21 | do i=0,N 22 | X(i) = i*dx 23 | enddo 24 | 25 | 26 | write(*,*) '' 27 | write(*,*) '3rd-order FVM SCHEME:' 28 | write(*,*) '****************************************' 29 | 30 | 31 | call exact(N,dx,X,t,u_exact) 32 | 33 | call FVM(N,dx,X,dt,nt,u_avg) 34 | 35 | !!! calculate error 36 | u_error = 0.0d0 37 | do i=0,N-1 38 | u_error = ABS(u_exact(i)-u_avg(i))+u_error 39 | enddo 40 | u_error = u_error/N 41 | 42 | write(*,*) 'Number of points is:',N 43 | write(*,*) 'L1 Normal is:', u_error 44 | 45 | open(unit=01,file='./result.dat',status='unknown') 46 | write(01,101) 47 | write(01,102) 48 | write(01,103) N 49 | 50 | do i = 0,N-1 51 | write(01,100) X(i)+dx, u_avg(i),u_exact(i) 52 | enddo 53 | 54 | 55 | close(01) 56 | write(*,*) '****************************************' 57 | 58 | 59 | 100 format(2x,10(e12.6,' ')) 60 | 101 format('Title="Burgers Equation"') 61 | 102 format('Variables=x,u_num,u_exact') 62 | 103 format('zone',1x'i=',1x,i5,2x,'f=point') 63 | stop 64 | end program main 65 | 66 | 67 | 68 | subroutine exact(N,dx,X,t,u_exact) 69 | implicit none 70 | integer :: i, N, j 71 | real(8) :: dx, x0, temp, t 72 | real(8) :: X(0:N) 73 | real(8) :: u_exact(0:N), u_t(3), u_x(3), weight(3) 74 | 75 | u_t(1) = -0.774596669241483d0 76 | u_t(2) = 0.0d0 77 | u_t(3) = 0.774596669241483d0 78 | 79 | weight(1) = 0.5555555555556d0 80 | weight(2) = 0.8888888888889d0 81 | weight(3) = 0.5555555555556d0 82 | 83 | do i=0,N 84 | do j=1,3 85 | u_x(j) = X(i)-dx*0.5d0+dx*(1.0d0+u_t(j))/2.d0 86 | enddo 87 | u_exact(i)=0.d0 88 | do j=1,3 89 | x0 = u_x(j) 90 | do 91 | temp = x0 92 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-u_x(j))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 93 | if(ABS(temp-x0).GT.1e-13) then 94 | cycle 95 | else 96 | exit 97 | endif 98 | enddo 99 | u_exact(i) = u_exact(i)+weight(j)*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))*0.5d0 100 | enddo 101 | 102 | !write(*,*) 'x0=',X(i),'u_exact=',u_exact(i) 103 | enddo 104 | 105 | 106 | 107 | return 108 | end subroutine exact 109 | 110 | 111 | 112 | subroutine FVM(N,dx,X,dt,nt,u_avg) 113 | implicit none 114 | integer :: N, i, j, nt 115 | real(8) :: dx, dt, ul, ur 116 | real(8) :: X(0:N), u_avg(0:N-1), du_avg(0:N-1), f(N), u1(0:N-1), u2(0:N-1) 117 | 118 | do i=1,N-1 119 | u_avg(i) = 1.0d0/3.0d0+4.0d0/3.0d0/dx*SIN(X(i))*SIN(0.5d0*dx) 120 | enddo 121 | 122 | u_avg(0) = 1.0d0/3.0d0 123 | 124 | do j=1,nt 125 | call Godunov(u_avg,du_avg,dx,N) 126 | do i=0,N-1 127 | u1(i) = u_avg(i)+dt*du_avg(i) 128 | enddo 129 | 130 | call Godunov(u1,du_avg,dx,N) 131 | do i=0,N-1 132 | u2(i) = 3.0d0/4.0d0*u_avg(i)+1.0d0/4.0d0*(u1(i)+dt*du_avg(i)) 133 | enddo 134 | 135 | call Godunov(u2,du_avg,dx,N) 136 | do i=0,N-1 137 | u_avg(i) = 1.0d0/3.0d0*u_avg(i)+2.0d0/3.0d0*(u2(i)+dt*du_avg(i)) 138 | enddo 139 | enddo 140 | 141 | 142 | ! do i=0,N-1 143 | ! write(*,*) 'x0=',X(i),'u(i)=',u_avg(i) 144 | ! enddo 145 | ! write(*,*) 'x0=',X(N),'u(i)=',u_avg(0) 146 | 147 | return 148 | end subroutine FVM 149 | 150 | 151 | 152 | subroutine Godunov(u_avg, du_avg, dx, N) 153 | implicit none 154 | integer :: i, N 155 | real(8) :: u_avg(0:N-1), du_avg(0:N-1), ul, ur, f(N), dx 156 | 157 | do i=0,N-1 158 | ul = -1.0d0/6.0d0*u_avg(MOD(i-1+N,N))+5.0/6.0*u_avg(i)+1.0d0/3.0d0*u_avg(MOD(i+1,N)) 159 | ur = 1.0d0/3.0d0*u_avg(i)+5.0d0/6.0d0*u_avg(MOD(i+1,N))-1.0d0/6.0d0*u_avg(MOD(i+2,N)) 160 | if(ul.LE.ur) then 161 | f(i+1) = MIN(0.5d0*ul*ul,0.5d0*ur*ur) 162 | if(ul*ur.LT.0.0d0) f(i+1) = 0.0d0 163 | else 164 | f(i+1) = MAX(0.5d0*ul*ul,0.5d0*ur*ur) 165 | endif 166 | enddo 167 | 168 | do i=1,N-1 169 | du_avg(i) = -(f(i+1)-f(i))/dx 170 | enddo 171 | du_avg(0) = -(f(1)-f(N))/dx 172 | end subroutine Godunov 173 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/02.TVDLimiter - TVBLimiter/TVD-limiter.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves Burgers Equation using 3rd-order finite volume method 3 | !!! Using Godunov numerical flux, with TVD Limiter 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | program main 8 | implicit none 9 | integer, parameter :: N=320 10 | real(8), parameter :: Pi=3.1415926535d0 11 | integer :: i, nt 12 | real(8) :: alpha, dx, dt, t, u_error 13 | real(8) :: u_avg(0:N-1), X(0:N), u_exact(0:N) 14 | 15 | alpha = 0.01d0 16 | dx = 2.0d0*Pi/N 17 | dt = alpha*dx 18 | t = 0.1d0*Pi 19 | nt = NINT(t/dt) 20 | 21 | do i=0,N 22 | X(i) = i*dx 23 | enddo 24 | 25 | write(*,*) 26 | write(*,*) '3rd FVM SCHEME(TVD Limiter):' 27 | write(*,*) '****************************************' 28 | 29 | 30 | call exact(N,dx,X,t,u_exact) 31 | 32 | call FVM(N,dx,X,dt,nt,u_avg) 33 | 34 | !!! calculate error, L1 normal 35 | u_error = 0.0d0 36 | do i=0,N-1 37 | u_error = ABS(u_exact(i)-u_avg(i))+u_error 38 | enddo 39 | u_error = u_error/N 40 | 41 | write(*,*) 'Number of points is:',N 42 | write(*,*) 'alpha =', alpha 43 | write(*,*) 'L1 Normal is:', u_error 44 | 45 | open(unit=01,file='./results.dat',status='unknown') 46 | write(01,101) 47 | write(01,102) 48 | write(01,103) N 49 | 50 | do i = 0,N-1 51 | write(01,100) X(i), u_avg(i),u_exact(i) 52 | enddo 53 | 54 | close(01) 55 | write(*,*) '****************************************' 56 | 57 | 100 format(2x,10(e12.6,' ')) 58 | 101 format('Title="Burgers Equation(TVD Limiter)"') 59 | 102 format('Variables=x,u_num,u_exact') 60 | 103 format('zone',1x,'i=',1x,i5,2x,'f=point') 61 | stop 62 | end program main 63 | 64 | 65 | 66 | subroutine exact(N,dx,X,t,u_exact) 67 | implicit none 68 | integer :: i, N, j 69 | real(8) :: dx, x0, temp, t 70 | real(8) :: X(0:N) 71 | real(8) :: u_exact(0:N), u_t(3), u_x(3), weight(3) 72 | 73 | u_t(1) = -0.774596669241483d0 74 | u_t(2) = 0.0d0 75 | u_t(3) = 0.774596669241483d0 76 | 77 | weight(1) = 0.5555555555556d0 78 | weight(2) = 0.8888888888889d0 79 | weight(3) = 0.5555555555556d0 80 | 81 | do i=0,N 82 | do j=1,3 83 | u_x(j) = X(i)-dx*0.5d0+dx*(1.0d0+u_t(j))/2.d0 84 | enddo 85 | u_exact(i)=0.d0 86 | do j=1,3 87 | x0 = u_x(j) 88 | do 89 | temp = x0 90 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-u_x(j))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 91 | if(ABS(temp-x0).GT.1e-13) then 92 | cycle 93 | else 94 | exit 95 | endif 96 | enddo 97 | u_exact(i) = u_exact(i)+weight(j)*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))*0.5d0 98 | enddo 99 | 100 | !write(*,*) 'x0=',X(i),'u_exact=',u_exact(i) 101 | enddo 102 | 103 | 104 | 105 | return 106 | end subroutine exact 107 | 108 | 109 | 110 | 111 | subroutine FVM(N,dx,X,dt,nt,u_avg) 112 | implicit none 113 | integer :: N, i, j, nt 114 | real(8) :: dx, dt, ul, ur 115 | real(8) :: X(0:N), u_avg(0:N-1), du_avg(0:N), f(N), u1(0:N-1), u2(0:N-1) 116 | 117 | do i=1,N-1 118 | u_avg(i) = 1.0d0/3.0d0+4.0d0/3.0d0/dx*SIN(X(i))*SIN(0.5d0*dx) 119 | enddo 120 | 121 | u_avg(0) = 1.0/3.0 122 | 123 | do j=1,nt 124 | call Godunov(u_avg,du_avg,dx,N) 125 | do i=0,N-1 126 | u1(i) = u_avg(i)+dt*du_avg(i) 127 | enddo 128 | 129 | call Godunov(u1,du_avg,dx,N) 130 | do i=0,N-1 131 | u2(i) = 3.0d0/4.0d0*u_avg(i)+1.0d0/4.0d0*(u1(i)+dt*du_avg(i)) 132 | enddo 133 | 134 | call Godunov(u2,du_avg,dx,N) 135 | do i=0,N-1 136 | u_avg(i) = 1.0d0/3.0d0*u_avg(i)+2.0d0/3.0d0*(u2(i)+dt*du_avg(i)) 137 | enddo 138 | enddo 139 | 140 | 141 | ! do i=0,N-1 142 | ! write(*,*) 'x0=',X(i),'u(i)=',u_avg(i) 143 | ! enddo 144 | ! write(*,*) 'x0=',X(N),'u(i)=',u_avg(0) 145 | 146 | return 147 | end subroutine FVM 148 | 149 | 150 | subroutine Godunov(u_avg, du_avg, dx, N) 151 | implicit none 152 | integer :: i, N 153 | real(8) :: u_avg(0:N-1), du_avg(0:N-1), ul, ur, f(N), dx 154 | 155 | do i=0,N-1 156 | ul = -1.0d0/6.0d0*u_avg(MOD(i-1+N,N))+5.0/6.0*u_avg(i)+1.0d0/3.0d0*u_avg(MOD(i+1,N)) 157 | ur = 1.0d0/3.0d0*u_avg(i)+5.0d0/6.0d0*u_avg(MOD(i+1,N))-1.0d0/6.0d0*u_avg(MOD(i+2,N)) 158 | 159 | call TVD_Limiter(ul,ur,u_avg(MOD(i-1+N,N)),u_avg(i),u_avg(MOD(i+1,N)),u_avg(MOD(i+2,N))) 160 | 161 | if(ul.LE.ur) then 162 | f(i+1) = MIN(0.5d0*ul*ul,0.5d0*ur*ur) 163 | if(ul*ur.LT.0.0d0) f(i+1) = 0.0d0 164 | else 165 | f(i+1) = MAX(0.5d0*ul*ul,0.5d0*ur*ur) 166 | endif 167 | enddo 168 | 169 | do i=1,N-1 170 | du_avg(i) = -(f(i+1)-f(i))/dx 171 | enddo 172 | du_avg(0) = -(f(1)-f(N))/dx 173 | 174 | return 175 | end subroutine Godunov 176 | 177 | 178 | 179 | subroutine TVD_Limiter(ul,ur,u_avg_j0,u_avg_j1,u_avg_j2,u_avg_j3) 180 | implicit none 181 | real(8) :: ul, ur, u_avg_j0, u_avg_j1, u_avg_j2, u_avg_j3, u_tilde, u_dtilde 182 | 183 | u_tilde = ul-u_avg_j1 184 | u_dtilde = u_avg_j2-ur 185 | 186 | !if((u_tilde*(u_avg_j2-u_avg_j1).GT.0.0).AND.(u_tilde*(u_avg_j1-u_avg_j0).GT.0.0)) then 187 | if ((SIGN(1.0d0,u_tilde).EQ.SIGN(1.0d0,u_avg_j2-u_avg_j1)).AND.(SIGN(1.0d0,u_tilde).EQ.SIGN(1.0d0,u_avg_j1-u_avg_j0))) then 188 | u_tilde = MIN(ABS(u_tilde),ABS(u_avg_j2-u_avg_j1),ABS(u_avg_j1-u_avg_j0))*SIGN(1.0d0,u_tilde) 189 | else 190 | u_tilde = 0.0d0 191 | endif 192 | 193 | !if((u_dtilde*(u_avg_j3-u_avg_j2).GT.0.0).AND.(u_dtilde*(u_avg_j2-u_avg_j1).GT.0.0)) then 194 | if ((SIGN(1.0d0,u_dtilde).EQ.SIGN(1.0d0,u_avg_j3-u_avg_j2)).AND.(SIGN(1.0d0,u_dtilde).EQ.SIGN(1.0d0,u_avg_j2-u_avg_j1))) then 195 | u_dtilde = MIN(ABS(u_dtilde),ABS(u_avg_j3-u_avg_j2),ABS(u_avg_j2-u_avg_j1))*SIGN(1.0d0,u_dtilde) 196 | else 197 | u_dtilde = 0.0d0 198 | endif 199 | 200 | ul = u_tilde+u_avg_j1 201 | ur = u_dtilde+u_avg_j2 202 | 203 | return 204 | end subroutine TVD_Limiter 205 | 206 | 207 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/02.TVDLimiter - TVBLimiter/TVB-limiter.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves Burgers Equation using 3rd-order finite volume method 3 | !!! Using Godunov numerical flux, with TVB Limiter 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | program main 8 | implicit none 9 | integer, parameter :: N=640 10 | real(8), parameter :: Pi=3.1415926535d0 11 | integer :: i, nt 12 | real(8) :: alpha, dx, dt, t, u_error 13 | real(8) :: u_avg(0:N-1), X(0:N), u_exact(0:N) 14 | 15 | 16 | alpha = 0.5d0 17 | dx = 2.0d0*Pi/N 18 | dt = alpha*dx 19 | t = 0.1d0*Pi 20 | nt = NINT(t/dt) 21 | 22 | do i=0,N 23 | X(i) = i*dx 24 | enddo 25 | 26 | 27 | print*, '' 28 | print*,'3rd FVM SCHEME(with TVB Limiter):' 29 | print*,'****************************************' 30 | 31 | 32 | call exact(N,dx,X,t,u_exact) 33 | 34 | call ENO(N,dx,X,dt,nt,u_avg) 35 | 36 | !!! calculate error 37 | u_error = 0.0d0 38 | do i=0,N-1 39 | u_error = ABS(u_exact(i)-u_avg(i))+u_error 40 | enddo 41 | u_error = u_error/N 42 | 43 | write(*,*) 'Number of points is:',N 44 | write(*,*) 'L1 Normal is:', u_error 45 | 46 | open(unit=01,file='./results.dat',status='unknown') 47 | write(01,101) 48 | write(01,102) 49 | write(01,103) N+1 50 | 51 | do i = 0,N-1 52 | write(01,100) X(i), u_avg(i),u_exact(i) 53 | enddo 54 | write(01,100) X(N), u_avg(0),u_exact(N) 55 | 56 | 57 | close(01) 58 | print*,'****************************************' 59 | 60 | 61 | 100 format(2x,10(e12.6,' ')) 62 | 101 format('Title="Burgers Equation"') 63 | 102 format('Variables=x,u_num,u_exact') 64 | 103 format('zone',1x'i=',1x,i5,2x,'f=point') 65 | stop 66 | end program main 67 | 68 | 69 | 70 | subroutine exact(N,dx,X,t,u_exact) 71 | implicit none 72 | integer :: i, N, j 73 | real(8) :: dx, x0, temp, t 74 | real(8) :: X(0:N) 75 | real(8) :: u_exact(0:N), u_t(3), u_x(3), weight(3) 76 | 77 | u_t(1) = -0.774596669241483d0 78 | u_t(2) = 0.0d0 79 | u_t(3) = 0.774596669241483d0 80 | 81 | weight(1) = 0.5555555555556d0 82 | weight(2) = 0.8888888888889d0 83 | weight(3) = 0.5555555555556d0 84 | 85 | do i=0,N 86 | do j=1,3 87 | u_x(j) = X(i)-dx*0.5d0+dx*(1.0d0+u_t(j))/2.d0 88 | enddo 89 | u_exact(i)=0.d0 90 | do j=1,3 91 | x0 = u_x(j) 92 | do 93 | temp = x0 94 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-u_x(j))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 95 | if(ABS(temp-x0).GT.1e-13) then 96 | cycle 97 | else 98 | exit 99 | endif 100 | enddo 101 | u_exact(i) = u_exact(i)+weight(j)*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))*0.5d0 102 | enddo 103 | 104 | !print*,'x0=',X(i),'u_exact=',u_exact(i) 105 | enddo 106 | 107 | 108 | 109 | return 110 | end subroutine exact 111 | 112 | 113 | 114 | 115 | subroutine ENO(N,dx,X,dt,nt,u_avg) 116 | implicit none 117 | integer :: N, i, j, nt 118 | real(8) :: dx, dt, ul, ur 119 | real(8) :: X(0:N), u_avg(0:N-1), du_avg(0:N), f(N), u1(0:N-1), u2(0:N-1) 120 | 121 | do i=1,N-1 122 | u_avg(i) = 1.0d0/3.0d0+4.0d0/3.0d0/dx*SIN(X(i))*SIN(0.5d0*dx) 123 | enddo 124 | 125 | u_avg(0) = 1.0/3.0 126 | 127 | do j=1,nt 128 | 129 | call Godunov(u_avg,du_avg,dx,N) 130 | do i=0,N-1 131 | u1(i) = u_avg(i)+dt*du_avg(i) 132 | enddo 133 | 134 | call Godunov(u1,du_avg,dx,N) 135 | do i=0,N-1 136 | u2(i) = 3.0d0/4.0d0*u_avg(i)+1.0d0/4.0d0*(u1(i)+dt*du_avg(i)) 137 | enddo 138 | 139 | call Godunov(u2,du_avg,dx,N) 140 | do i=0,N-1 141 | u_avg(i) = 1.0d0/3.0d0*u_avg(i)+2.0d0/3.0d0*(u2(i)+dt*du_avg(i)) 142 | enddo 143 | enddo 144 | 145 | 146 | ! do i=0,N-1 147 | ! print*,'x0=',X(i),'u(i)=',u_avg(i) 148 | ! enddo 149 | ! print*,'x0=',X(N),'u(i)=',u_avg(0) 150 | 151 | return 152 | end subroutine ENO 153 | 154 | 155 | subroutine Godunov(u_avg, du_avg, dx, N) 156 | implicit none 157 | integer :: i, N 158 | real(8) :: u_avg(0:N-1), du_avg(0:N-1), ul, ur, f(N), dx 159 | 160 | do i=0,N-1 161 | ul = -1.0d0/6.0d0*u_avg(MOD(i-1+N,N))+5.0/6.0*u_avg(i)+1.0d0/3.0d0*u_avg(MOD(i+1,N)) 162 | ur = 1.0d0/3.0d0*u_avg(i)+5.0d0/6.0d0*u_avg(MOD(i+1,N))-1.0d0/6.0d0*u_avg(MOD(i+2,N)) 163 | 164 | call TVB_Limiter(ul,ur,u_avg(MOD(i-1+N,N)),u_avg(i),u_avg(MOD(i+1,N)),u_avg(MOD(i+2,N)),dx) 165 | 166 | if(ul.LE.ur) then 167 | f(i+1) = MIN(0.5d0*ul*ul,0.5d0*ur*ur) 168 | if(ul*ur.LT.0.0d0) f(i+1) = 0.0d0 169 | else 170 | f(i+1) = MAX(0.5d0*ul*ul,0.5d0*ur*ur) 171 | endif 172 | enddo 173 | 174 | do i=1,N-1 175 | du_avg(i) = -(f(i+1)-f(i))/dx 176 | enddo 177 | du_avg(0) = -(f(1)-f(N))/dx 178 | end subroutine Godunov 179 | 180 | 181 | 182 | subroutine TVB_Limiter(ul,ur,u_avg_j0,u_avg_j1,u_avg_j2,u_avg_j3,dx) 183 | implicit none 184 | real(8) :: ul, ur, u_avg_j0, u_avg_j1, u_avg_j2, u_avg_j3, u_tilde, u_dtilde, dx, M 185 | 186 | M = 5.0d0 187 | 188 | u_tilde = ul-u_avg_j1 189 | u_dtilde = u_avg_j2-ur 190 | 191 | if (ABS(u_tilde).GT.M*dx*dx) then 192 | if ((SIGN(1.0d0,u_tilde).EQ.SIGN(1.0d0,u_avg_j2-u_avg_j1)).AND. & 193 | &(SIGN(1.0d0,u_tilde).EQ.SIGN(1.0d0,u_avg_j1-u_avg_j0))) then 194 | u_tilde = MIN(ABS(u_tilde),ABS(u_avg_j2-u_avg_j1),ABS(u_avg_j1-u_avg_j0))*SIGN(1.0d0,u_tilde) 195 | else 196 | u_tilde = 0.0d0 197 | endif 198 | endif 199 | 200 | if (ABS(u_dtilde).GT.M*dx*dx) then 201 | if ((SIGN(1.0d0,u_dtilde).EQ.SIGN(1.0d0,u_avg_j3-u_avg_j2)).AND. & 202 | &(SIGN(1.0d0,u_tilde).EQ.SIGN(1.0d0,u_avg_j2-u_avg_j1))) then 203 | u_dtilde = MIN(ABS(u_dtilde),ABS(u_avg_j3-u_avg_j2),ABS(u_avg_j2-u_avg_j1))*SIGN(1.0d0,u_dtilde) 204 | else 205 | u_dtilde = 0.0d0 206 | endif 207 | endif 208 | 209 | ul = u_avg_j1+u_tilde 210 | ur = u_avg_j2+u_dtilde 211 | 212 | return 213 | end subroutine TVB_Limiter 214 | 215 | 216 | 217 | -------------------------------------------------------------------------------- /07.Initial-Value Ordinary Differential Equations/ODEsovler.F90: -------------------------------------------------------------------------------- 1 | #define outputData 2 | !~#define firstEuler 3 | !~#define secondEuler 4 | #define RK4 5 | 6 | #define rhsFt 7 | !~#define rhsFty 8 | 9 | #define calPosition 10 | 11 | program main 12 | implicit none 13 | real(8), parameter :: Pi=4.0d0*datan(1.0d0) 14 | character*24 ctime, string 15 | INTEGER*4 time 16 | real(kind=8) :: start, finish 17 | integer, parameter :: maxTimeStep=11 18 | real(8) :: dt 19 | real(8) :: t(1:maxTimeStep), timeIndex(1:maxTimeStep) 20 | real(8) :: velocityNumerical(1:maxTimeStep), velocityAnalytical(1:maxTimeStep) 21 | real(8) :: positionNumerical(1:maxTimeStep), positionAnalytical(1:maxTimeStep) 22 | real(8) :: acceleration(1:maxTimeStep) 23 | real(8) :: k1, k2, k3, k4 24 | integer :: i, interpolationOrder 25 | integer :: errorNum 26 | real(8) :: errorL1_1, errorL2_1, errorL1_2, errorL2_2 27 | 28 | !~ write(*,*) "Pi=",Pi 29 | !~ write(*,*) "nint(Pi+0.5)=", nint(Pi+0.5) 30 | !~ write(*,*) "int(Pi+0.5)=", int(Pi+0.5) 31 | 32 | string = ctime( time() ) 33 | write(*,*) 'Start: ', string 34 | call CPU_TIME(start) 35 | 36 | #ifdef rhsFt 37 | write(*,*) "RHS: 2*Pi*cos(2*Pi*t(i))" 38 | #endif 39 | #ifdef rhsFty 40 | write(*,*) "RHS: -2*t(i)*u(i)" 41 | #endif 42 | 43 | #ifdef calPosition 44 | write(*,*) "I am calPosition" 45 | #endif 46 | 47 | dt = 1.0d0/dble(maxTimeStep-1) 48 | write(*,*) "dt=", real(dt) 49 | do i=1,maxTimeStep 50 | t(i) = (i-1)*dt 51 | timeIndex(i) = dble(i) 52 | #ifdef rhsFt 53 | positionAnalytical(i) = -1.0d0/2.0d0/Pi*dcos(2.0d0*Pi*t(i)) 54 | velocityAnalytical(i) = dsin(2.0d0*Pi*t(i)) 55 | acceleration(i) = 2.0d0*Pi*dcos(2.0d0*Pi*t(i)) 56 | #endif 57 | #ifdef rhsFty 58 | velocityAnalytical(i) = dexp(-t(i)**2.0d0) 59 | acceleration(i) = -2.0d0*t(i)*velocityAnalytical(i) 60 | #endif 61 | enddo 62 | #ifdef outputData 63 | open(unit=01,file="analytical.dat",status="unknown") 64 | do i=1,maxTimeStep 65 | #ifndef calPosition 66 | write(01,*) t(i), velocityAnalytical(i) 67 | #endif 68 | #ifdef calPosition 69 | write(01,*) t(i), positionAnalytical(i) 70 | #endif 71 | enddo 72 | close(01) 73 | #endif 74 | 75 | positionNumerical = 0.0d0 76 | velocityNumerical = 0.0d0 77 | !---Initial condition 78 | #ifdef rhsFt 79 | velocityNumerical(1) = 0.0d0 80 | positionNumerical(1) = -1.0d0/2.0d0/Pi 81 | #endif 82 | #ifdef rhsFty 83 | velocityNumerical(1) = 1.0d0 84 | #endif 85 | !---Initial condition 86 | 87 | #ifdef firstEuler 88 | write(*,*) "I am firstEuler" 89 | do i=1,maxTimeStep-1 90 | #ifdef rhsFt 91 | k1 = 2.0d0*Pi*dcos(2.0d0*Pi*t(i)) 92 | #endif 93 | #ifdef rhsFty 94 | k1 = -2.0d0*t(i)*velocityNumerical(i) 95 | #endif 96 | velocityNumerical(i+1) = velocityNumerical(i)+dt*k1 97 | #ifdef calPosition 98 | positionNumerical(i+1) = positionNumerical(i)+velocityNumerical(i)*dt !~!~+0.5d0*dt*dt*k1 99 | #endif 100 | enddo 101 | #endif 102 | 103 | #ifdef secondEuler 104 | write(*,*) "I am secondEuler" 105 | do i=1,maxTimeStep-1 106 | #ifdef rhsFt 107 | k1 = 2.0d0*Pi*dcos(2.0d0*Pi*t(i)) 108 | k2 = 2.0d0*Pi*dcos(2.0d0*Pi*t(i+1)) 109 | #endif 110 | #ifdef rhsFty 111 | k1 = -2.0d0*t(i)*velocityNumerical(i) 112 | k2 = -2.0d0*t(i+1)*(velocityNumerical(i)+dt*k1) 113 | #endif 114 | velocityNumerical(i+1) = velocityNumerical(i)+dt*(k1+k2)/2.0d0 115 | #ifdef calPosition 116 | k1 = velocityNumerical(i) 117 | k2 = velocityNumerical(i+1) 118 | positionNumerical(i+1) = positionNumerical(i)+dt*(k1+k2)/2.0d0 119 | #endif 120 | enddo 121 | #endif 122 | 123 | #ifdef RK4 124 | write(*,*) "I am RK4" 125 | !------------------------------------------------------------------ 126 | do i=1,maxTimeStep-1 127 | interpolationOrder = 5 128 | if(i.LE.4) interpolationOrder = i 129 | #ifdef rhsFt 130 | k1 = 2.0d0*Pi*dcos(2.0d0*Pi*t(i)) !~!~2.0d0*Pi*dcos(2.0d0*Pi*t(i)) !~!~t(i)=(i-1)*dt 131 | k2 = 2.0d0*Pi*dcos(2.0d0*Pi*(t(i)+0.5d0*dt)) 132 | k3 = k2 133 | k4 = 2.0d0*Pi*dcos(2.0d0*Pi*t(i+1)) 134 | #endif 135 | #ifdef rhsFty 136 | k1 = -2.0d0*t(i)*velocityNumerical(i) 137 | k2 = -2.0d0*(t(i)+0.5d0*dt)*(velocityNumerical(i)+0.5d0*dt*k1) 138 | k3 = -2.0d0*(t(i)+0.5d0*dt)*(velocityNumerical(i)+0.5d0*dt*k2) 139 | k4 = -2.0d0*t(i+1)*(velocityNumerical(i)+dt*k3) 140 | #endif 141 | velocityNumerical(i+1) = velocityNumerical(i)+dt*(k1+2.0d0*k2+2.0d0*k3+k4)/6.0d0 142 | #ifdef calPosition 143 | k1 = velocityNumerical(i) 144 | call LagrangeInterpolation(timeIndex(i-(interpolationOrder-1):i+1), velocityNumerical(i-(interpolationOrder-1):i+1), dble(i)+0.5d0, k2, interpolationOrder) 145 | k3 = k2 146 | k4 = velocityNumerical(i+1) 147 | positionNumerical(i+1) = positionNumerical(i)+dt*(k1+2.0d0*k2+2.0d0*k3+k4)/6.0d0 148 | #endif 149 | enddo 150 | #endif 151 | 152 | call CPU_TIME(finish) 153 | 154 | #ifdef outputData 155 | open(unit=03,file="numerical.dat",status="unknown") 156 | do i=1,maxTimeStep 157 | #ifndef calPosition 158 | write(03,*) t(i), velocityNumerical(i) 159 | #endif 160 | #ifdef calPosition 161 | write(03,*) t(i), positionNumerical(i) 162 | #endif 163 | enddo 164 | close(03) 165 | #endif 166 | 167 | errorL1_1 = 0.0d0 168 | errorL2_1 = 0.0d0 169 | errorL1_2 = 0.0d0 170 | errorL2_2 = 0.0d0 171 | errorNum = 0 172 | do i=1,maxTimeStep-1 173 | errorL1_1 = errorL1_1+dabs(velocityNumerical(i+1)-velocityAnalytical(i+1)) 174 | errorL2_1 = errorL2_1+(velocityNumerical(i+1)-velocityAnalytical(i+1))**2.0d0 175 | #ifdef calPosition 176 | errorL1_2 = errorL1_2+dabs(positionNumerical(i+1)-positionAnalytical(i+1)) 177 | errorL2_2 = errorL2_2+(positionNumerical(i+1)-positionAnalytical(i+1))**2.0d0 178 | #endif 179 | errorNum = errorNum+1 180 | enddo 181 | 182 | write(*,*) "Time (CPU) = ", real(finish-start), "s" 183 | write(*,*) "L1 error (velocity)=", errorL1_1/dble(errorNum) 184 | write(*,*) "L2 error (velocity)=", dsqrt(errorL2_1/dble(errorNum)) 185 | #ifdef calPosition 186 | write(*,*) "L1 error (position)=", errorL1_2/dble(errorNum) 187 | write(*,*) "L2 error (position)=", dsqrt(errorL2_2/dble(errorNum)) 188 | #endif 189 | 190 | string = ctime( time() ) 191 | write(*,*) 'End: ', string 192 | 193 | stop 194 | end program main 195 | 196 | 197 | subroutine LagrangeInterpolation(pointX, pointU, point0X, point0U, order) 198 | implicit none 199 | integer :: order 200 | real(8) :: pointX(1:order+1), pointU(1:order+1) 201 | real(8) :: point0X, point0U 202 | REAL(8) :: TEMP 203 | integer :: j, k 204 | 205 | point0U = 0.0d0 206 | do k=1,order+1 207 | temp = 1.0d0 208 | do j=1,order+1 209 | if(j.NE.K) temp=temp*(point0X-pointX(j))/(pointX(k)-pointX(j)) 210 | enddo 211 | point0U= point0U+temp*pointU(k) 212 | enddO 213 | 214 | return 215 | end subroutine LagrangeInterpolation -------------------------------------------------------------------------------- /07.Initial-Value Ordinary Differential Equations/ODEsovler-compare.lay: -------------------------------------------------------------------------------- 1 | #!MC 1410 2 | $!VarSet |LFDSFN1| = '"analytical.dat"' 3 | $!VarSet |LFDSVL1| = '"V1" "V2"' 4 | $!VarSet |LFDSFN2| = '"numerical-1st.dat"' 5 | $!VarSet |LFDSVL2| = '"V1" "V2"' 6 | $!VarSet |LFDSFN3| = '"numerical-2nd.dat"' 7 | $!VarSet |LFDSVL3| = '"V1" "V2"' 8 | $!VarSet |LFDSFN4| = '"numerical-4th.dat"' 9 | $!VarSet |LFDSVL4| = '"V1" "V2"' 10 | $!SetStyleBase Factory 11 | $!GlobalPaper 12 | PaperSizeInfo 13 | { 14 | Letter 15 | { 16 | Width = 8.5 17 | Height = 11 18 | LeftHardClipOffset = 0.125 19 | RightHardClipOffset = 0.125 20 | TopHardClipOffset = 0.125 21 | BottomHardClipOffset = 0.125 22 | } 23 | } 24 | $!Page 25 | Name = '' 26 | PaperAttributes 27 | { 28 | BackgroundColor = White 29 | IsTransparent = Yes 30 | OrientPortrait = No 31 | ShowGrid = Yes 32 | ShowRuler = No 33 | ShowPaper = No 34 | PaperSize = Letter 35 | RulerSpacing = OneInch 36 | PaperGridSpacing = HalfInch 37 | RegionInWorkArea 38 | { 39 | X1 = 1 40 | Y1 = 0.25 41 | X2 = 10 42 | Y2 = 8.25 43 | } 44 | } 45 | ### Frame Number 1 ### 46 | $!ReadDataSet '|LFDSFN1|' 47 | InitialPlotType = XYLine 48 | IncludeText = No 49 | IncludeGeom = No 50 | AssignStrandIDs = Yes 51 | VarLoadMode = ByName 52 | VarNameList = '|LFDSVL1|' 53 | $!RemoveVar |LFDSVL1| 54 | $!RemoveVar |LFDSFN1| 55 | $!ReadDataSet '|LFDSFN2|' 56 | InitialPlotType = XYLine 57 | IncludeText = No 58 | IncludeGeom = No 59 | ReadDataOption = Append 60 | ResetStyle = No 61 | AssignStrandIDs = Yes 62 | VarLoadMode = ByName 63 | VarNameList = '|LFDSVL2|' 64 | $!RemoveVar |LFDSVL2| 65 | $!RemoveVar |LFDSFN2| 66 | $!ReadDataSet '|LFDSFN3|' 67 | InitialPlotType = XYLine 68 | IncludeText = No 69 | IncludeGeom = No 70 | ReadDataOption = Append 71 | ResetStyle = No 72 | AssignStrandIDs = Yes 73 | VarLoadMode = ByName 74 | VarNameList = '|LFDSVL3|' 75 | $!RemoveVar |LFDSVL3| 76 | $!RemoveVar |LFDSFN3| 77 | $!ReadDataSet '|LFDSFN4|' 78 | InitialPlotType = XYLine 79 | IncludeText = No 80 | IncludeGeom = No 81 | ReadDataOption = Append 82 | ResetStyle = No 83 | AssignStrandIDs = Yes 84 | VarLoadMode = ByName 85 | VarNameList = '|LFDSVL4|' 86 | $!RemoveVar |LFDSVL4| 87 | $!RemoveVar |LFDSFN4| 88 | $!FrameLayout 89 | ShowBorder = No 90 | ShowHeader = No 91 | HeaderColor = Red 92 | XYPos 93 | { 94 | X = 1 95 | Y = 0.25 96 | } 97 | Width = 9 98 | Height = 8 99 | $!ThreeDAxis 100 | AspectRatioLimit = 25 101 | BoxAspectRatioLimit = 25 102 | $!PlotType = XYLine 103 | $!FrameName = 'Frame 001' 104 | $!GlobalTime 105 | SolutionTime = 0 106 | $!DeleteLineMaps 107 | $!ActiveLineMaps = [1-4] 108 | $!GlobalLinePlot 109 | DataLabels 110 | { 111 | DistanceSkip = 5 112 | } 113 | Legend 114 | { 115 | Show = Yes 116 | TextShape 117 | { 118 | FontFamily = 'Times New Roman' 119 | IsBold = No 120 | SizeUnits = Point 121 | Height = 22 122 | } 123 | Box 124 | { 125 | BoxType = None 126 | Margin = 5 127 | } 128 | XYPos 129 | { 130 | X = 57.284 131 | Y = 40.274 132 | } 133 | } 134 | $!LineMap [1] 135 | Name = 'Analytical' 136 | Assign 137 | { 138 | Zone = 1 139 | XAxisVar = 1 140 | YAxisVar = 2 141 | } 142 | Lines 143 | { 144 | Color = Red 145 | LineThickness = 0.4 146 | } 147 | Symbols 148 | { 149 | SymbolShape 150 | { 151 | GeomShape = Circle 152 | } 153 | Color = Red 154 | FillMode = UseSpecificColor 155 | FillColor = White 156 | LineThickness = 0.4 157 | } 158 | BarCharts 159 | { 160 | Color = Red 161 | FillColor = Red 162 | } 163 | ErrorBars 164 | { 165 | Color = Red 166 | } 167 | $!LineMap [2] 168 | Name = 'Numerical-1st' 169 | Assign 170 | { 171 | Zone = 2 172 | XAxisVar = 1 173 | YAxisVar = 2 174 | } 175 | Lines 176 | { 177 | Color = Purple 178 | LinePattern = DashDot 179 | LineThickness = 0.4 180 | } 181 | Symbols 182 | { 183 | Color = Purple 184 | FillMode = UseSpecificColor 185 | FillColor = White 186 | LineThickness = 0.4 187 | } 188 | BarCharts 189 | { 190 | Color = Green 191 | FillColor = Green 192 | } 193 | ErrorBars 194 | { 195 | Color = Green 196 | } 197 | $!LineMap [3] 198 | Name = 'Numerical-2nd' 199 | Assign 200 | { 201 | Zone = 3 202 | XAxisVar = 1 203 | YAxisVar = 2 204 | } 205 | Lines 206 | { 207 | Color = Blue 208 | LineThickness = 0.4 209 | } 210 | Symbols 211 | { 212 | Color = Blue 213 | FillMode = UseSpecificColor 214 | FillColor = White 215 | LineThickness = 0.4 216 | } 217 | BarCharts 218 | { 219 | Color = Blue 220 | FillColor = Blue 221 | } 222 | ErrorBars 223 | { 224 | Color = Blue 225 | } 226 | $!LineMap [4] 227 | Name = 'Numerical-4th' 228 | Assign 229 | { 230 | Zone = 4 231 | XAxisVar = 1 232 | YAxisVar = 2 233 | } 234 | Lines 235 | { 236 | Color = Black 237 | LineThickness = 0.4 238 | } 239 | Symbols 240 | { 241 | Color = Black 242 | FillMode = UseSpecificColor 243 | FillColor = White 244 | LineThickness = 0.4 245 | } 246 | BarCharts 247 | { 248 | Color = Custom1 249 | FillColor = Custom1 250 | } 251 | ErrorBars 252 | { 253 | Color = Custom1 254 | } 255 | $!XYLineAxis 256 | DepXToYRatio = 1 257 | GridArea 258 | { 259 | DrawBorder = Yes 260 | } 261 | ViewportPosition 262 | { 263 | X1 = 15 264 | Y1 = 15 265 | X2 = 95 266 | Y2 = 95 267 | } 268 | ViewportTopSnapTarget = 95 269 | $!XYLineAxis 270 | XDetail 1 271 | { 272 | RangeMin = 0 273 | RangeMax = 1.0001 274 | GRSpacing = 0.2 275 | TickLabel 276 | { 277 | TextShape 278 | { 279 | FontFamily = 'Times New Roman' 280 | SizeUnits = Point 281 | Height = 28 282 | } 283 | Offset = 3 284 | } 285 | Title 286 | { 287 | TitleMode = UseText 288 | Text = 'time' 289 | TextShape 290 | { 291 | FontFamily = 'Times New Roman' 292 | IsBold = No 293 | SizeUnits = Point 294 | Height = 50 295 | } 296 | Offset = 7 297 | } 298 | } 299 | $!XYLineAxis 300 | YDetail 1 301 | { 302 | RangeMin = -1.1000000000000001 303 | RangeMax = 1.3999999999999999 304 | GRSpacing = 1 305 | TickLabel 306 | { 307 | TextShape 308 | { 309 | FontFamily = 'Times New Roman' 310 | SizeUnits = Point 311 | Height = 28 312 | } 313 | } 314 | Title 315 | { 316 | TitleMode = UseText 317 | Text = 'velocity' 318 | TextShape 319 | { 320 | FontFamily = 'Times New Roman' 321 | IsBold = No 322 | SizeUnits = Point 323 | Height = 50 324 | } 325 | Offset = 8 326 | } 327 | } 328 | $!LinePlotLayers 329 | ShowSymbols = Yes 330 | $!FrameControl ActivateByNumber 331 | Frame = 1 332 | $!SetStyleBase Config 333 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/04.WENO Scheme/WENO_3.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves Burgers Equation using WENO Scheme in Finite Difference Formulation. 3 | !!! with Lax-Friedrichs Flux 4 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 5 | !!! Ao Xu, Profiles: 6 | 7 | program main 8 | implicit none 9 | integer, parameter :: N=320 10 | real(8), parameter :: Pi=3.1415926535898d0 11 | integer :: i, nt 12 | real(8) :: dx, dt, t 13 | real(8) :: error_0, error_1 14 | real(8) :: X(N), u(-1:N+3), u_exact(N) 15 | 16 | dx = 2.0d0*Pi/float(N-1) 17 | dt = 0.01*dx 18 | t = 0.1d0*Pi 19 | nt = NINT(t/dt) 20 | do i=1,N 21 | X(i) = (i-1)*dx 22 | enddo 23 | 24 | write(*,*) 25 | write(*,*) 'WENO Scheme in Finite Difference Formulation:' 26 | write(*,*) 'with Lax-Friedrichs Flux' 27 | write(*,*) '*********************************************' 28 | 29 | call exact(N,dx,X,t,u_exact) 30 | 31 | call WENO(N,dx,X,dt,nt,u) 32 | 33 | !!! calculate error 34 | error_0 = 0.0d0 35 | error_1 = 0.0d0 36 | do i=1,N 37 | error_0 = MAX(error_0, ABS(u_exact(i)-u(i))) 38 | error_1 = ABS(u_exact(i)-u(i))+error_1 39 | enddo 40 | error_1 = error_1/float(N) 41 | 42 | write(*,*) 'N =',N 43 | write(*,*) 't =',t 44 | write(*,*) 'dx =',dx 45 | write(*,*) 'dt =',dt 46 | write(*,*) 'LInfinity Normal is:', error_0 47 | write(*,*) 'L1 Normal is:', error_1 48 | 49 | open(unit=01,file='./result.dat',status='unknown') 50 | write(01,101) 51 | write(01,102) 52 | write(01,103) N 53 | 54 | do i=1,N 55 | write(01,100) X(i), u(i), u_exact(i) 56 | enddo 57 | 58 | close(01) 59 | 60 | 100 format(2x,10(e12.6,' ')) 61 | 101 format('Title="Burgers Equation(WENO Scheme)"') 62 | 102 format('Variables=x,u_num,u_exact') 63 | 103 format('zone',1x,'i=',1x,i5,2x,'f=point') 64 | 65 | stop 66 | end program main 67 | 68 | 69 | subroutine exact(N,dx,X,t,u_exact) 70 | implicit none 71 | integer :: i, N, j, k 72 | real(8) :: dx, x0, temp, t 73 | real(8) :: X(N), u_exact(N) 74 | 75 | do i=1,N 76 | x0 = X(i) 77 | do 78 | temp = x0 79 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-X(i))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 80 | if(ABS(temp-x0).GT.1e-15) then 81 | cycle 82 | else 83 | exit 84 | endif 85 | enddo 86 | u_exact(i) = 1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0) 87 | enddo 88 | 89 | return 90 | end subroutine exact 91 | 92 | 93 | subroutine WENO(N,dx,X,dt,nt,u) 94 | implicit none 95 | integer :: N, i, j, nt 96 | real(8) :: dx, dt 97 | real(8) :: X(N), u(-1:N+3), du(N), u1(-1:N+3), u2(-1:N+3) 98 | 99 | do i=1,N 100 | u(i) = 1.0d0/3.0d0+2.0d0/3.0d0*SIN(X(i)) 101 | enddo 102 | u(N+1) = u(2) 103 | u(N+2) = u(3) 104 | u(N+3) = u(4) 105 | u(0) = u(N-1) 106 | u(-1) = u(N-2) 107 | 108 | do j=1,nt 109 | 110 | call Lax(dx,N,u,du) 111 | do i=1,N 112 | u1(i) = u(i)+dt*du(i) 113 | enddo 114 | u1(N+1) = u1(2) 115 | u1(N+2) = u1(3) 116 | u1(N+3) = u1(4) 117 | u1(0) = u1(N-1) 118 | u1(-1) = u1(N-2) 119 | 120 | call Lax(dx,N,u1,du) 121 | do i=1,N 122 | u2(i) = 3.0d0/4.0d0*u(i)+1.0d0/4.0d0*(u1(i)+dt*du(i)) 123 | enddo 124 | u2(N+1) = u2(2) 125 | u2(N+2) = u2(3) 126 | u2(N+3) = u2(4) 127 | u2(0) = u2(N-1) 128 | u2(-1) = u2(N-2) 129 | 130 | call Lax(dx,N,u2,du) 131 | do i=1,N 132 | u(i) = 1.0d0/3.0d0*u(i)+2.0d0/3.0d0*(u2(i)+dt*du(i)) 133 | enddo 134 | 135 | u(N+1) = u(2) 136 | u(N+2) = u(3) 137 | u(N+3) = u(4) 138 | u(0) = u(N-1) 139 | u(-1) = u(N-2) 140 | 141 | enddo 142 | 143 | return 144 | end subroutine WENO 145 | 146 | 147 | subroutine Lax(dx,N,u,du) 148 | implicit none 149 | integer :: i, N 150 | real(8) :: u(-1:N+3), du(N), dx 151 | real(8) :: f_positive(-1:N+3), f_negative(-1:N+3) 152 | real(8) :: f_l(N+1), f_r(N+1), f(0:N) 153 | real(8) :: alpha 154 | 155 | alpha=0.0d0 156 | do i=1,N 157 | alpha = MAX(alpha, ABS(u(i))) 158 | enddo 159 | 160 | do i=-1,N+3 161 | f_positive(i) = 0.5d0*(0.5d0*u(i)*u(i)+alpha*u(i)) 162 | enddo 163 | call Recon(dx,N,f_positive,f,f_r) 164 | 165 | do i=-1,N+3 166 | f_negative(i) = 0.5d0*(0.5d0*u(i)*u(i)-alpha*u(i)) 167 | enddo 168 | 169 | call Recon(dx,N,f_negative,f_l,f) 170 | 171 | do i=1,N 172 | f(i) = f_l(i+1)+f_r(i) 173 | enddo 174 | f(0) = f(N-1) 175 | 176 | do i=1,N 177 | du(i) = -(f(i)-f(i-1))/dx 178 | enddo 179 | 180 | return 181 | end subroutine Lax 182 | 183 | 184 | 185 | subroutine Recon(dx,N,u,u_l,u_r) 186 | implicit none 187 | integer :: i, N, j 188 | real(8) :: u(-1:N+3), u_l(N+1), u_r(N+1), dx 189 | real(8) :: beta(0:2) 190 | real(8) :: alphal(0:2), alphar(0:2), omgl(0:2), omgr(0:2), ul(0:2), ur(0:2) 191 | real(8) :: epsilon 192 | 193 | epsilon = 1e-6 194 | 195 | do i=1,N+1 196 | 197 | ur(0) = 1.0d0/3.0d0*u(i)+5.0d0/6.0d0*u(i+1)-1.0d0/6.0d0*u(i+2) 198 | ur(1) = -1.0d0/6.0d0*u(i-1)+5.0d0/6.0d0*u(i)+1.0d0/3.0d0*u(i+1) 199 | ur(2) = 1.0d0/3.0d0*u(i-2)-7.0d0/6.0d0*u(i-1)+11.0d0/6.0d0*u(i) 200 | 201 | ul(0) = 11.0d0/6.0d0*u(i)-7.0d0/6.0d0*u(i+1)+1.0d0/3.0d0*u(i+2) 202 | ul(1) = 1.0d0/3.0d0*u(i-1)+5.0d0/6.0d0*u(i)-1.0d0/6.0d0*u(i+1) 203 | ul(2) = -1.0d0/6.0d0*u(i-2)+5.0d0/6.0d0*u(i-1)+1.0d0/3.0d0*u(i) 204 | 205 | !compute weights 206 | beta(0) = 13.d0/12.d0*(u(i)-2.0d0*u(i+1)+u(i+2))**2 & 207 | +0.25d0*(3.d0*u(i)-4.d0*u(i+1)+u(i+2))**2 208 | beta(1) = 13.d0/12.d0*(u(i-1)-2.0d0*u(i)+u(i+1))**2 & 209 | +0.25d0*(u(i-1)-u(i+1))**2 210 | beta(2) = 13.0d0/12.0d0*(u(i-2)-2.d0*u(i-1)+u(i))**2 & 211 | +0.25d0*(u(i-2)-4.0d0*u(i-1)+3.0d0*u(i))**2 212 | 213 | alphar(0) = 0.3d0/(beta(0)+epsilon)/(beta(0)+epsilon) 214 | alphar(1) = 0.6d0/(beta(1)+epsilon)/(beta(1)+epsilon) 215 | alphar(2) = 0.1d0/(beta(2)+epsilon)/(beta(2)+epsilon) 216 | 217 | alphal(0) = 0.1d0/(beta(0)+epsilon)/(beta(0)+epsilon) 218 | alphal(1) = 0.6d0/(beta(1)+epsilon)/(beta(1)+epsilon) 219 | alphal(2) = 0.3d0/(beta(2)+epsilon)/(beta(2)+epsilon) 220 | 221 | do j=0, 2 222 | omgr(j) = alphar(j)/(alphar(0)+alphar(1)+alphar(2)) 223 | omgl(j) = alphal(j)/(alphal(0)+alphal(1)+alphal(2)) 224 | enddo 225 | 226 | u_r(i) = omgr(0)*ur(0)+omgr(1)*ur(1)+omgr(2)*ur(2) 227 | u_l(i) = omgl(0)*ul(0)+omgl(1)*ul(1)+omgl(2)*ul(2) 228 | 229 | enddo 230 | 231 | return 232 | end subroutine Recon 233 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/03.ENO Scheme/ENO.f90: -------------------------------------------------------------------------------- 1 | 2 | !!! This program solves Burgers Equation using ENO Scheme. 3 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 4 | !!! Ao Xu, Profiles: 5 | 6 | program main 7 | implicit none 8 | integer, parameter :: N=160 9 | real(8), parameter :: Pi=3.1415926535897932385d0 10 | integer :: i, nt 11 | real(8) :: alpha, dx, dt, t, u_error, error_0 12 | real(8) :: u_avg(0:N-1) 13 | real(8) :: u_exact(0:N), X(0:N) 14 | 15 | alpha = 0.5d0 16 | dx = 2.0d0*Pi/float(N) 17 | dt = alpha*dx 18 | t = 0.1d0*Pi 19 | nt = NINT(t/dt) 20 | 21 | do i=0,N 22 | X(i) = DBLE(i)*dx 23 | enddo 24 | 25 | 26 | write(*,*) '' 27 | write(*,*) 'ENO SCHEME:' 28 | write(*,*) '****************************************' 29 | 30 | 31 | call exact(N,dx,X,t,u_exact) 32 | 33 | call ENO(N,dx,X,dt,nt,u_avg) 34 | 35 | !!! calculate error 36 | u_error = 0.0d0 37 | error_0 = 0.0d0 38 | do i=0,N-1 39 | u_error = ABS(u_exact(i)-u_avg(i))+u_error 40 | error_0 = MAX(error_0, ABS(u_exact(i)-u_avg(i))) 41 | enddo 42 | u_error = u_error/DBLE(N) 43 | 44 | write(*,*) 'Number of points is:',N 45 | write(*,*) 'alpha =',alpha 46 | write(*,*) 'L1 Normal is:', u_error 47 | !write(*,*) 'L Infinity Normal is:', error_0 48 | 49 | open(unit=01,file='./result.dat',status='unknown') 50 | write(01,101) 51 | write(01,102) 52 | write(01,103) N 53 | 54 | do i = 0,N-1 55 | write(01,100) X(i), u_avg(i),u_exact(i) 56 | enddo 57 | 58 | 59 | close(01) 60 | print*,'****************************************' 61 | 62 | 63 | 100 format(2x,10(e12.6,' ')) 64 | 101 format('Title="Burgers Equation(ENO Scheme)"') 65 | 102 format('Variables=x,u_num,u_exact') 66 | 103 format('zone',1x,'i=',1x,i5,2x,'f=point') 67 | stop 68 | end program main 69 | 70 | 71 | 72 | subroutine exact(N,dx,X,t,u_exact) 73 | implicit none 74 | integer :: i, N, j, k 75 | real(8) :: dx, x0, temp, t 76 | real(8) :: X(0:N) 77 | real(8) :: u_exact(0:N), u_t(10), u_x(10), weight(10) 78 | data u_t/0.9931285991850949d0,0.9639719272779138d0,0.9122344282513259d0,0.8391169718222188d0,0.7463319064601508d0, & 79 | 0.6360536807265150d0,0.5108670019508271d0,0.3737060887154196d0,0.2277858511416451d0,0.07652652113349734d0/ !!! x_k 80 | data weight/0.01761400713915212d0,0.04060142980038694d0,0.06267204833410906d0,0.08327674157670475d0,0.1019301198172404d0, & 81 | 0.1181945319615184d0,0.1316886384491766d0,0.1420961093183821d0,0.1491729864726037d0,0.1527533871307259d0/ !!! weight coefficient A_k 82 | 83 | do i=0,N 84 | u_exact(i)=0.d0 85 | do k=-1,1,2 86 | do j=1,10 87 | u_x(j) = X(i)-dx*0.5d0+dx*(1.0d0+DBLE(k)*u_t(j))/2.d0 88 | enddo 89 | do j=1,10 90 | x0 = u_x(j) 91 | do 92 | temp = x0 93 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-u_x(j))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 94 | if(ABS(temp-x0).GT.1d-14) then 95 | cycle 96 | else 97 | exit 98 | endif 99 | enddo 100 | u_exact(i) = u_exact(i)+weight(j)*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))*0.5d0 101 | enddo 102 | enddo 103 | 104 | !write(*,*) 'x0=',X(i),'u_exact=',u_exact(i) 105 | enddo 106 | 107 | 108 | 109 | return 110 | end subroutine exact 111 | 112 | 113 | 114 | subroutine ENO(N,dx,X,dt,nt,u_avg) 115 | implicit none 116 | integer :: N, i, j, nt 117 | real(8) :: dx, dt, ul, ur 118 | real(8) :: X(0:N), u_avg(0:N-1), du_avg(0:N-1), f(N), u1(0:N-1), u2(0:N-1) 119 | 120 | do i=1,N-1 121 | u_avg(i) = 1.0d0/3.0d0+4.0d0/3.0d0/dx*SIN(X(i))*SIN(0.5d0*dx) 122 | enddo 123 | u_avg(0) = 1.0d0/3.0d0 124 | 125 | do j=1,nt 126 | call Godunov(u_avg,du_avg,dx,N) 127 | do i=0,N-1 128 | u1(i) = u_avg(i)+dt*du_avg(i) 129 | enddo 130 | 131 | call Godunov(u1,du_avg,dx,N) 132 | do i=0,N-1 133 | u2(i) = 3.0d0/4.0d0*u_avg(i)+1.0d0/4.0d0*(u1(i)+dt*du_avg(i)) 134 | enddo 135 | 136 | call Godunov(u2,du_avg,dx,N) 137 | do i=0,N-1 138 | u_avg(i) = 1.0d0/3.0d0*u_avg(i)+2.0d0/3.0d0*(u2(i)+dt*du_avg(i)) 139 | enddo 140 | enddo 141 | 142 | return 143 | end subroutine ENO 144 | 145 | 146 | subroutine Godunov(u_avg, du_avg, dx, N) 147 | implicit none 148 | integer :: i, N, s 149 | real(8) :: u_avg(0:N-1), du_avg(0:N-1), dx 150 | real(8) :: u_reconl(0:N-1), u_reconr(0:N-1), f(0:N-1) 151 | 152 | call Recon(u_avg,u_reconl,u_reconr,dx,N) 153 | do i=0, N-1 154 | if(u_reconl(i).LE.u_reconr(i)) then 155 | f(i) = MIN(0.5d0*u_reconl(i)*u_reconl(i),0.5d0*u_reconr(i)*u_reconr(i)) 156 | if(u_reconl(i)*u_reconr(i).LT.0.0d0) f(i) = 0.0d0 157 | else 158 | f(i) = MAX(0.5d0*u_reconl(i)*u_reconl(i),0.5d0*u_reconr(i)*u_reconr(i)) 159 | endif 160 | enddo 161 | 162 | do i=0,N-1 163 | du_avg(i) = -(f(i)-f(MOD(i-1+N, N)))/dx 164 | enddo 165 | 166 | return 167 | endsubroutine Godunov 168 | 169 | 170 | subroutine Recon(u_avg, u_reconl, u_reconr, dx, N) 171 | implicit none 172 | integer :: i, N, s 173 | real(8) :: u_avg(0:N-1), u_reconl(0:N-1), u_reconr(0:N-1), dx 174 | 175 | do i=0,N-1 176 | call stencil(u_avg,3,i,N,s) 177 | select case (s) 178 | case (-2) 179 | u_reconl(i) = 1.0d0/3.0d0*u_avg(MOD(i-2+N,N))-7.0d0/6.0d0*u_avg(MOD(i-1+N,N))+11.0d0/6.0d0*u_avg(i) 180 | u_reconr(MOD(i-1+N, N)) = -1.0d0/6.0d0*u_avg(MOD(i-2+N,N))+5.0d0/6.0d0*u_avg(MOD(i-1+N,N))+1.0d0/3.0d0*u_avg(i) 181 | case (0) 182 | u_reconl(i) = -1.0d0/6.0d0*u_avg(MOD(i-1+N,N))+5.0d0/6.0d0*u_avg(i)+1.0d0/3.0d0*u_avg(MOD(i+1,N)) 183 | u_reconr(MOD(i-1+N, N)) = -1.0d0/6.0d0*u_avg(MOD(i+1,N))+5.0d0/6.0d0*u_avg(i)+1.0d0/3.0d0*u_avg(MOD(i-1+N,N)) 184 | case (2) 185 | u_reconl(i) = 1.0d0/3.0d0*u_avg(i)+5.0d0/6.0d0*u_avg(MOD(i+1,N))-1.0d0/6.0d0*u_avg(MOD(i+2,N)) 186 | u_reconr(MOD(i-1+N, N)) = 1.0d0/3.0d0*u_avg(MOD(i+2,N))-7.0d0/6.0d0*u_avg(MOD(i+1,N))+11.0d0/6.0d0*u_avg(i) 187 | end select 188 | enddo 189 | 190 | return 191 | end subroutine Recon 192 | 193 | 194 | subroutine stencil(u, m, k, N, s) 195 | implicit none 196 | integer :: i, j, m, s, k, N, k_temp 197 | real(8) :: u(0:N-1), u_differ(0:N-1) 198 | 199 | do j=0, N-1 200 | u_differ(j) = u(MOD(j+1,N))-u(j) 201 | enddo 202 | 203 | k_temp = k; 204 | s = 0 205 | 206 | do i=2, m 207 | 208 | if(u_differ(MOD(k_temp-1+N,N)).LE.u_differ(MOD(k_temp+N,N))) then 209 | s = s-1 210 | k_temp = k_temp-1 211 | else 212 | s = s+1 213 | endif 214 | 215 | do j=0, N-1 216 | u_differ(j) = u_differ(MOD(j+1,N))-u_differ(j) 217 | enddo 218 | 219 | enddo 220 | 221 | return 222 | end subroutine stencil 223 | 224 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/04.WENO Scheme/WENO_2.f90: -------------------------------------------------------------------------------- 1 | 2 | 3 | !!! This program solves Burgers Equation using WENO Scheme in Finite Volume Formulation. 4 | !!! with Lax-Friedrichs Flux 5 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 6 | !!! Ao Xu, Profiles: 7 | 8 | program main 9 | implicit none 10 | integer, parameter :: N=320 11 | real(8), parameter :: Pi=3.1415926535898d0 12 | integer :: i, nt 13 | real(8) :: dx, dt, t, error_0, error_1 14 | real(8) :: X(N), u_avg(-1:N+3), u_exact(N) 15 | 16 | dx = 2.0d0*Pi/float(N-1) 17 | dt = 0.01d0*dx 18 | t = 0.1d0*Pi 19 | nt = NINT(t/dt) 20 | do i=1,N 21 | X(i) = (i-1)*dx 22 | enddo 23 | 24 | write(*,*) 25 | write(*,*) 'WENO Scheme in Finite Volume Formulation:' 26 | write(*,*) 'with Lax-Friedrichs Flux' 27 | write(*,*) '*********************************************' 28 | 29 | call exact(N,dx,X,t,u_exact) 30 | 31 | call WENO(N,dx,X,dt,nt,u_avg) 32 | 33 | !!! calculate error 34 | error_0 = 0.0d0 35 | error_1 = 0.0d0 36 | do i=1,N-1 37 | error_0 = MAX(error_0, ABS(u_exact(i)-u_avg(i))) 38 | error_1 = ABS(u_exact(i)-u_avg(i))+error_1 39 | enddo 40 | error_1 = error_1/float(N-1) 41 | 42 | write(*,*) 'N =',N 43 | write(*,*) 't =',t 44 | write(*,*) 'dx =',dx 45 | write(*,*) 'dt =',dt 46 | write(*,*) 'LInfinity Normal is:', error_0 47 | write(*,*) 'L1 Normal is:', error_1 48 | 49 | open(unit=01,file='./result.dat',status='unknown') 50 | write(01,101) 51 | write(01,102) 52 | write(01,103) N-1 53 | 54 | do i = 1,N-1 55 | write(01,100) X(i)+0.5d0*dx, u_avg(i),u_exact(i) 56 | enddo 57 | 58 | close(01) 59 | 60 | 100 format(2x,10(e12.6,' ')) 61 | 101 format('Title="Burgers Equation(WENO Scheme)"') 62 | 102 format('Variables=x,u_num,u_exact') 63 | 103 format('zone',1x,'i=',1x,i5,2x,'f=point') 64 | 65 | stop 66 | end program main 67 | 68 | 69 | 70 | subroutine exact(N,dx,X,t,u_exact) 71 | implicit none 72 | integer :: i, N, j, k 73 | real(8) :: dx, x0, temp, t 74 | real(8) :: X(N) 75 | real(8) :: u_exact(N), u_t(10), u_x(10), weight(10) 76 | data u_t/0.9931285991850949d0,0.9639719272779138d0,0.9122344282513259d0,0.8391169718222188d0,0.7463319064601508d0, & 77 | 0.6360536807265150d0,0.5108670019508271d0,0.3737060887154196d0,0.2277858511416451d0,0.07652652113349734d0/ !!! x_k 78 | data weight/0.01761400713915212d0,0.04060142980038694d0,0.06267204833410906d0,0.08327674157670475d0,0.1019301198172404d0, & 79 | 0.1181945319615184d0,0.1316886384491766d0,0.1420961093183821d0,0.1491729864726037d0,0.1527533871307259d0/ !!! weight coefficient A_k 80 | 81 | do i=1,N 82 | u_exact(i)=0.d0 83 | do k=-1,1,2 84 | 85 | do j=1,10 86 | u_x(j) = X(i)+0.5d0*dx*float(k)*u_t(j) 87 | enddo 88 | 89 | do j=1,10 90 | x0 = u_x(j) 91 | do 92 | temp = x0 93 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-u_x(j))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 94 | if(ABS(temp-x0).GT.1e-15) then 95 | cycle 96 | else 97 | exit 98 | endif 99 | enddo 100 | u_exact(i) = u_exact(i)+weight(j)*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0)) *0.5d0 101 | enddo 102 | 103 | enddo 104 | enddo 105 | 106 | return 107 | end subroutine exact 108 | 109 | 110 | subroutine WENO(N,dx,X,dt,nt,u_avg) 111 | implicit none 112 | integer :: N, i, j, nt 113 | real(8) :: dx, dt 114 | real(8) :: X(N), u_avg(-1:N+3), u1(-1:N+3), u2(-1:N+3), du_avg(N) 115 | 116 | do i=1,N 117 | u_avg(i) = 1.0d0/3.0d0+4.0d0/3.0d0/dx*SIN(X(i))*SIN(0.5d0*dx) 118 | enddo 119 | u_avg(N+1) = u_avg(2) 120 | u_avg(N+2) = u_avg(3) 121 | u_avg(N+3) = u_avg(4) 122 | u_avg(0) = u_avg(N-1) 123 | u_avg(-1) = u_avg(N-2) 124 | 125 | do j=1,nt 126 | 127 | call Lax(dx,N,u_avg,du_avg) 128 | do i=1,N 129 | u1(i) = u_avg(i)+dt*du_avg(i) 130 | enddo 131 | u1(N+1) = u1(2) 132 | u1(N+2) = u1(3) 133 | u1(N+3) = u1(4) 134 | u1(0) = u1(N-1) 135 | u1(-1) = u1(N-2) 136 | 137 | call Lax(dx,N,u1,du_avg) 138 | do i=1,N 139 | u2(i) = 3.0d0/4.0d0*u_avg(i)+1.0d0/4.0d0*(u1(i)+dt*du_avg(i)) 140 | enddo 141 | u2(N+1) = u2(2) 142 | u2(N+2) = u2(3) 143 | u2(N+3) = u2(4) 144 | u2(0) = u2(N-1) 145 | u2(-1) = u2(N-2) 146 | 147 | call Lax(dx,N,u2,du_avg) 148 | do i=1,N 149 | u_avg(i) = 1.0d0/3.0d0*u_avg(i)+2.0d0/3.0d0*(u2(i)+dt*du_avg(i)) 150 | enddo 151 | u_avg(N+1) = u_avg(2) 152 | u_avg(N+2) = u_avg(3) 153 | u_avg(N+3) = u_avg(4) 154 | u_avg(0) = u_avg(N-1) 155 | u_avg(-1) = u_avg(N-2) 156 | 157 | enddo 158 | 159 | return 160 | end subroutine WENO 161 | 162 | 163 | subroutine Lax(dx,N,u_avg,du_avg) 164 | implicit none 165 | integer :: i, N 166 | real(8) :: u_avg(-1:N+3), du_avg(N), dx 167 | real(8) :: flux_P(0:N-1), flux_N(0:N-1) 168 | real(8) :: u_l(N+1), u_r(N+1), f(0:N) 169 | real(8) :: alpha 170 | 171 | alpha=0.0d0 172 | do i=1,N 173 | alpha = MAX(alpha, ABS(u_avg(i))) 174 | enddo 175 | 176 | call Recon(dx,N,u_avg,u_l,u_r) 177 | 178 | do i=1,N 179 | f(i) = 0.5d0*(0.5d0*u_l(i+1)*u_l(i+1)+0.5d0*u_r(i)*u_r(i)-alpha*(u_r(i)-u_l(i+1))) 180 | enddo 181 | f(0) = f(N-1) 182 | 183 | do i=1,N 184 | du_avg(i) = -(f(i)-f(i-1))/dx 185 | enddo 186 | 187 | return 188 | end subroutine Lax 189 | 190 | 191 | subroutine Recon(dx,N,u_avg,u_l,u_r) 192 | implicit none 193 | integer :: i, N, j 194 | real(8) :: u_avg(-1:N+3), u_l(N+1), u_r(N+1), dx 195 | real(8) :: beta(0:2) 196 | real(8) :: alphal(0:2), alphar(0:2), omgl(0:2), omgr(0:2), ul(0:2), ur(0:2) 197 | real(8) :: epsilon 198 | 199 | epsilon = 1e-6 200 | 201 | do i=1,N+1 202 | 203 | ur(0) = 1.0d0/3.0d0*u_avg(i)+5.0d0/6.0d0*u_avg(i+1)-1.0d0/6.0d0*u_avg(i+2) 204 | ur(1) = -1.0d0/6.0d0*u_avg(i-1)+5.0d0/6.0d0*u_avg(i)+1.0d0/3.0d0*u_avg(i+1) 205 | ur(2) = 1.0d0/3.0d0*u_avg(i-2)-7.0d0/6.0d0*u_avg(i-1)+11.0d0/6.0d0*u_avg(i) 206 | 207 | ul(0) = 11.0d0/6.0d0*u_avg(i)-7.0d0/6.0d0*u_avg(i+1)+1.0d0/3.0d0*u_avg(i+2) 208 | ul(1) = 1.0d0/3.0d0*u_avg(i-1)+5.0d0/6.0d0*u_avg(i)-1.0d0/6.0d0*u_avg(i+1) 209 | ul(2) = -1.0d0/6.0d0*u_avg(i-2)+5.0d0/6.0d0*u_avg(i-1)+1.0d0/3.0d0*u_avg(i) 210 | 211 | !compute weights 212 | beta(0) = 13.d0/12.d0*(u_avg(i)-2.0d0*u_avg(i+1)+u_avg(i+2))**2+ & 213 | 0.25d0*(3.d0*u_avg(i)-4.d0*u_avg(i+1)+u_avg(i+2))**2 214 | beta(1) = 13.d0/12.d0*(u_avg(i-1)-2.d0*u_avg(i)+u_avg(i+1))**2+ & 215 | 0.25d0*(u_avg(i-1)-u_avg(i+1))**2 216 | beta(2) = 13.0d0/12.0d0*(u_avg(i-2)-2.d0*u_avg(i-1)+u_avg(i))**2 & 217 | +0.25d0*(u_avg(i-2)-4.0d0*u_avg(i-1)+3.d0*u_avg(i))**2 218 | 219 | alphar(0) = 0.3d0/(beta(0)+epsilon)/(beta(0)+epsilon) 220 | alphar(1) = 0.6d0/(beta(1)+epsilon)/(beta(1)+epsilon) 221 | alphar(2) = 0.1d0/(beta(2)+epsilon)/(beta(2)+epsilon) 222 | 223 | alphal(0) = 0.1d0/(beta(0)+epsilon)/(beta(0)+epsilon) 224 | alphal(1) = 0.6d0/(beta(1)+epsilon)/(beta(1)+epsilon) 225 | alphal(2) = 0.3d0/(beta(2)+epsilon)/(beta(2)+epsilon) 226 | 227 | do j=0, 2 228 | omgr(j) = alphar(j)/(alphar(0)+alphar(1)+alphar(2)) 229 | omgl(j) = alphal(j)/(alphal(0)+alphal(1)+alphal(2)) 230 | enddo 231 | 232 | u_r(i) = omgr(0)*ur(0)+omgr(1)*ur(1)+omgr(2)*ur(2) 233 | u_l(i) = omgl(0)*ul(0)+omgl(1)*ul(1)+omgl(2)*ul(2) 234 | 235 | enddo 236 | 237 | return 238 | end subroutine Recon 239 | 240 | -------------------------------------------------------------------------------- /00.Numerical Methods for Hyperbolic Equation/04.WENO Scheme/WENO_1.f90: -------------------------------------------------------------------------------- 1 | 2 | 3 | !!! This program solves Burgers Equation using WENO Scheme in Finite Volume Formulation. 4 | !!! with Godunov Flux 5 | !!! This work is licensed under the Creative Commons Attribution-NonCommercial 3.0 Unported License. 6 | !!! Ao Xu, Profiles: 7 | 8 | program main 9 | implicit none 10 | integer, parameter :: N=20 11 | real(8), parameter :: Pi=3.1415926535898d0 12 | integer :: i, nt 13 | real(8) :: dx, dt, t, error_0, error_1 14 | real(8) :: X(N), u_avg(-1:N+3), u_exact(N) 15 | 16 | dx = 2.0d0*Pi/float(N-1) 17 | dt = 0.01d0*dx 18 | t = 0.1d0*Pi 19 | nt = NINT(t/dt) 20 | do i=1,N 21 | X(i) = (i-1)*dx 22 | enddo 23 | 24 | write(*,*) 25 | write(*,*) 'WENO Scheme in Finite Volume Formulation:' 26 | write(*,*) 'with Godunov Flux' 27 | write(*,*) '*********************************************' 28 | 29 | call exact(N,dx,X,t,u_exact) 30 | 31 | call WENO(N,dx,X,dt,nt,u_avg) 32 | 33 | !!! calculate error 34 | error_0 = 0.0d0 35 | error_1 = 0.0d0 36 | do i=1,N-1 37 | error_0 = MAX(error_0, ABS(u_exact(i)-u_avg(i))) 38 | error_1 = ABS(u_exact(i)-u_avg(i))+error_1 39 | enddo 40 | error_1 = error_1/float(N-1) 41 | 42 | write(*,*) 'N =',N 43 | write(*,*) 't =',t 44 | write(*,*) 'dx =',dx 45 | write(*,*) 'dt =',dt 46 | write(*,*) 'LInfinity Normal is:', error_0 47 | write(*,*) 'L1 Normal is:', error_1 48 | 49 | open(unit=01,file='./result.dat',status='unknown') 50 | write(01,101) 51 | write(01,102) 52 | write(01,103) N-1 53 | 54 | do i = 1,N-1 55 | write(01,100) X(i)+0.5d0*dx, u_avg(i),u_exact(i) 56 | enddo 57 | 58 | close(01) 59 | 60 | print*,'****************************************' 61 | 62 | 100 format(2x,10(e12.6,' ')) 63 | 101 format('Title="Burgers Equation(WENO Scheme)"') 64 | 102 format('Variables=x,u_num,u_exact') 65 | 103 format('zone',1x,'i=',1x,i5,2x,'f=point') 66 | 67 | stop 68 | end program main 69 | 70 | 71 | subroutine exact(N,dx,X,t,u_exact) 72 | implicit none 73 | integer :: i, N, j, k 74 | real(8) :: dx, x0, temp, t 75 | real(8) :: X(N) 76 | real(8) :: u_exact(N), u_t(10), u_x(10), weight(10) 77 | data u_t/0.9931285991850949d0,0.9639719272779138d0,0.9122344282513259d0,0.8391169718222188d0,0.7463319064601508d0, & 78 | 0.6360536807265150d0,0.5108670019508271d0,0.3737060887154196d0,0.2277858511416451d0,0.07652652113349734d0/ !!! x_k 79 | data weight/0.01761400713915212d0,0.04060142980038694d0,0.06267204833410906d0,0.08327674157670475d0,0.1019301198172404d0, & 80 | 0.1181945319615184d0,0.1316886384491766d0,0.1420961093183821d0,0.1491729864726037d0,0.1527533871307259d0/ !!! weight coefficient A_k 81 | 82 | do i=1,N 83 | u_exact(i)=0.d0 84 | do k=-1,1,2 85 | 86 | do j=1,10 87 | u_x(j) = X(i)+0.5d0*dx*float(k)*u_t(j) 88 | enddo 89 | 90 | do j=1,10 91 | x0 = u_x(j) 92 | do 93 | temp = x0 94 | x0 = x0-(x0+t*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0))-u_x(j))/(1.0d0+t*2.0d0/3.0d0*COS(x0)) 95 | if(ABS(temp-x0).GT.1e-15) then 96 | cycle 97 | else 98 | exit 99 | endif 100 | enddo 101 | u_exact(i) = u_exact(i)+weight(j)*(1.0d0/3.0d0+2.0d0/3.0d0*SIN(x0)) *0.5d0 102 | enddo 103 | 104 | enddo 105 | enddo 106 | 107 | 108 | return 109 | end subroutine exact 110 | 111 | 112 | subroutine WENO(N,dx,X,dt,nt,u_avg) 113 | implicit none 114 | integer :: N, i, j, nt 115 | real(8) :: dx, dt 116 | real(8) :: X(N), u_avg(-1:N+3), u1(-1:N+3), u2(-1:N+3), du_avg(N) 117 | 118 | do i=1,N 119 | u_avg(i) = 1.0d0/3.0d0+4.0d0/3.0d0/dx*SIN(X(i))*SIN(0.5d0*dx) 120 | enddo 121 | u_avg(N+1) = u_avg(2) 122 | u_avg(N+2) = u_avg(3) 123 | u_avg(N+3) = u_avg(4) 124 | u_avg(0) = u_avg(N-1) 125 | u_avg(-1) = u_avg(N-2) 126 | 127 | do j=1,nt 128 | 129 | call Godunov(dx,N,u_avg,du_avg) 130 | do i=1,N 131 | u1(i) = u_avg(i)+dt*du_avg(i) 132 | enddo 133 | u1(N+1) = u1(2) 134 | u1(N+2) = u1(3) 135 | u1(N+3) = u1(4) 136 | u1(0) = u1(N-1) 137 | u1(-1) = u1(N-2) 138 | 139 | call Godunov(dx,N,u1,du_avg) 140 | do i=1,N 141 | u2(i) = 3.0d0/4.0d0*u_avg(i)+1.0d0/4.0d0*(u1(i)+dt*du_avg(i)) 142 | enddo 143 | u2(N+1) = u2(2) 144 | u2(N+2) = u2(3) 145 | u2(N+3) = u2(4) 146 | u2(0) = u2(N-1) 147 | u2(-1) = u2(N-2) 148 | 149 | call Godunov(dx,N,u2,du_avg) 150 | do i=1,N 151 | u_avg(i) = 1.0d0/3.0d0*u_avg(i)+2.0d0/3.0d0*(u2(i)+dt*du_avg(i)) 152 | enddo 153 | u_avg(N+1) = u_avg(2) 154 | u_avg(N+2) = u_avg(3) 155 | u_avg(N+3) = u_avg(4) 156 | u_avg(0) = u_avg(N-1) 157 | u_avg(-1) = u_avg(N-2) 158 | 159 | enddo 160 | 161 | return 162 | end subroutine WENO 163 | 164 | 165 | subroutine Godunov(dx,N,u_avg,du_avg) 166 | implicit none 167 | integer :: i, N 168 | real(8) :: u_avg(-1:N+3), du_avg(N), dx 169 | real(8) :: u_l(N+1), u_r(N+1), f(0:N) 170 | 171 | call Recon(dx,N,u_avg,u_l,u_r) 172 | 173 | do i=1,N 174 | if(u_r(i).LE.u_l(i+1)) then 175 | f(i) = MIN(0.5d0*u_r(i)*u_r(i),0.5d0*u_l(i+1)*u_l(i+1)) 176 | if(u_l(i+1)*u_r(i).LT.0.0d0) f(i) = 0.0d0 177 | else 178 | f(i) = MAX(0.5d0*u_l(i+1)*u_l(i+1),0.5d0*u_r(i)*u_r(i)) 179 | endif 180 | enddo 181 | f(0) = f(N-1) 182 | 183 | do i=1,N 184 | du_avg(i) = -(f(i)-f(i-1))/dx 185 | enddo 186 | 187 | return 188 | endsubroutine Godunov 189 | 190 | 191 | subroutine Recon(dx,N,u_avg,u_l,u_r) 192 | implicit none 193 | integer :: i, N, j 194 | real(8) :: u_avg(-1:N+3), u_l(N+1), u_r(N+1), dx 195 | real(8) :: beta(0:2) 196 | real(8) :: alphal(0:2), alphar(0:2), omgl(0:2), omgr(0:2), ul(0:2), ur(0:2) 197 | real(8) :: epsilon 198 | 199 | epsilon = 1e-6 200 | 201 | do i=1,N+1 202 | 203 | ur(0) = 1.0d0/3.0d0*u_avg(i)+5.0d0/6.0d0*u_avg(i+1)-1.0d0/6.0d0*u_avg(i+2) 204 | ur(1) = -1.0d0/6.0d0*u_avg(i-1)+5.0d0/6.0d0*u_avg(i)+1.0d0/3.0d0*u_avg(i+1) 205 | ur(2) = 1.0d0/3.0d0*u_avg(i-2)-7.0d0/6.0d0*u_avg(i-1)+11.0d0/6.0d0*u_avg(i) 206 | 207 | ul(0) = 11.0d0/6.0d0*u_avg(i)-7.0d0/6.0d0*u_avg(i+1)+1.0d0/3.0d0*u_avg(i+2) 208 | ul(1) = 1.0d0/3.0d0*u_avg(i-1)+5.0d0/6.0d0*u_avg(i)-1.0d0/6.0d0*u_avg(i+1) 209 | ul(2) = -1.0d0/6.0d0*u_avg(i-2)+5.0d0/6.0d0*u_avg(i-1)+1.0d0/3.0d0*u_avg(i) 210 | 211 | !compute weights 212 | beta(0) = 13.d0/12.d0*(u_avg(i)-2.0d0*u_avg(i+1)+u_avg(i+2))**2+ & 213 | 0.25d0*(3.d0*u_avg(i)-4.d0*u_avg(i+1)+u_avg(i+2))**2 214 | beta(1) = 13.d0/12.d0*(u_avg(i-1)-2.d0*u_avg(i)+u_avg(i+1))**2+ & 215 | 0.25d0*(u_avg(i-1)-u_avg(i+1))**2 216 | beta(2) = 13.0d0/12.0d0*(u_avg(i-2)-2.d0*u_avg(i-1)+u_avg(i))**2 & 217 | +0.25d0*(u_avg(i-2)-4.0d0*u_avg(i-1)+3.d0*u_avg(i))**2 218 | 219 | alphar(0) = 0.3d0/(beta(0)+epsilon)/(beta(0)+epsilon) 220 | alphar(1) = 0.6d0/(beta(1)+epsilon)/(beta(1)+epsilon) 221 | alphar(2) = 0.1d0/(beta(2)+epsilon)/(beta(2)+epsilon) 222 | 223 | alphal(0) = 0.1d0/(beta(0)+epsilon)/(beta(0)+epsilon) 224 | alphal(1) = 0.6d0/(beta(1)+epsilon)/(beta(1)+epsilon) 225 | alphal(2) = 0.3d0/(beta(2)+epsilon)/(beta(2)+epsilon) 226 | 227 | do j=0, 2 228 | omgr(j) = alphar(j)/(alphar(0)+alphar(1)+alphar(2)) 229 | omgl(j) = alphal(j)/(alphal(0)+alphal(1)+alphal(2)) 230 | enddo 231 | 232 | u_r(i) = omgr(0)*ur(0)+omgr(1)*ur(1)+omgr(2)*ur(2) 233 | u_l(i) = omgl(0)*ul(0)+omgl(1)*ul(1)+omgl(2)*ul(2) 234 | 235 | enddo 236 | 237 | return 238 | end subroutine Recon 239 | -------------------------------------------------------------------------------- /04.Polynomial Approximation and Interpolation/Lagrange-interpolation-1D.F90: -------------------------------------------------------------------------------- 1 | !~#define linear_interpolation 2 | !~#define quadratic_interpolation 3 | !~#define cubic_interpolation 4 | #define fifth_interpolation 5 | 6 | #define outputData 7 | 8 | program main 9 | implicit none 10 | real(8), parameter :: Pi=4.0d0*datan(1.0d0) 11 | integer, parameter :: nx=101 12 | real(8) :: xExact(nx), uExact(nx) 13 | 14 | #ifdef linear_interpolation 15 | integer, parameter :: order=1 16 | #endif 17 | #ifdef quadratic_interpolation 18 | integer, parameter :: order=2 19 | #endif 20 | #ifdef cubic_interpolation 21 | integer, parameter :: order=3 22 | #endif 23 | #ifdef fifth_interpolation 24 | integer, parameter :: order=5 25 | #endif 26 | 27 | integer, parameter :: meshX=10 28 | real(8) :: xMesh(meshX), uMesh(meshX) 29 | 30 | integer, parameter :: particleX=100 31 | real(8) :: xInterpolated(particleX), uInterpolated(particleX) 32 | 33 | integer :: iLoc 34 | integer :: i, j 35 | real(8) :: dx, dx2 36 | integer :: findLoc 37 | integer :: locate 38 | real(8) :: errorL1, errorL2 39 | integer :: errorNum 40 | character*24 ctime, string 41 | INTEGER*4 time 42 | real(kind=8) :: start, finish 43 | 44 | !~ write(*,*) "Pi=",Pi 45 | !~ write(*,*) "nint(Pi+0.5)=", nint(Pi+0.5) 46 | !~ write(*,*) "int(Pi+0.5)=", int(Pi+0.5) 47 | 48 | string = ctime( time() ) 49 | write(*,*) 'Start: ', string 50 | call CPU_TIME(start) 51 | 52 | #ifdef linear_interpolation 53 | write(*,*) "I am linear interpolation!" 54 | #endif 55 | #ifdef quadratic_interpolation 56 | write(*,*) "I am quadratic interpolation!" 57 | #endif 58 | #ifdef cubic_interpolation 59 | write(*,*) "I am cubic interpolation!" 60 | #endif 61 | #ifdef fifth_interpolation 62 | write(*,*) "I am fifth interpolation!" 63 | #endif 64 | write(*,*) " " 65 | 66 | !--exact solution 67 | do i=1,nx 68 | xExact(i) = dble(i-1)/dble(nx-1)*2.0d0*Pi 69 | uExact(i) = dsin(xExact(i)) 70 | enddo 71 | #ifdef outputData 72 | open(unit=01,file="exact.dat",status="unknown") 73 | do i=1,nx 74 | write(01,*) xExact(i), uExact(i) 75 | enddo 76 | close(01) 77 | #endif 78 | 79 | write(*,*) "meshX:", meshX 80 | !--raw data points 81 | dx = 2.0d0*Pi/dble(meshX) 82 | do i=1,meshX 83 | xMesh(i) = dx/2.0d0+dble(i-1)*dx 84 | uMesh(i) = dsin(xMesh(i)) 85 | enddo 86 | #ifdef outputData 87 | open(unit=02,file="raw.dat",status="unknown") 88 | do i=1,meshX 89 | write(02,*) xMesh(i), uMesh(i) 90 | enddo 91 | close(02) 92 | #endif 93 | 94 | write(*,*) "particleX:", particleX 95 | !--interpolated data points 96 | dx2 = 2.0d0*Pi/dble(particleX-1) 97 | errorL1 = 0.0d0 98 | errorL2 = 0.0d0 99 | errorNum = 0 100 | do i=1,particleX 101 | xInterpolated(i) = dble(i-1)*dx2 102 | if( (xInterpolated(i).LT.xMesh(1)).OR.(xInterpolated(i).GT.xMesh(meshX)) ) then 103 | !~ write(*,*) "xInterpolated(i) is out of the range of X1" 104 | !~ write(*,*) "i =", i 105 | !~ write(*,*) "xInterpolated(i) =", xInterpolated(i) 106 | !~ write(*,*) "xMesh_min =", xMesh(1)," , xMesh_mmeshX = ", xMesh(meshX) 107 | !~ write(*,*) " " 108 | uInterpolated(i) = 0.0d0 109 | ELSE 110 | #ifdef linear_interpolation 111 | iLoc = locate(xMesh, xInterpolated(i), meshX) 112 | if( (iLoc.GE.1).AND.(iLoc.LE.meshX-1) ) then 113 | call LagrangeInterpolation(xMesh(iLoc:iLoc+1), uMesh(iLoc:iLoc+1), xInterpolated(i), uInterpolated(i), order) 114 | else 115 | write(*,*) "check boundary, iLoc=", iLoc 116 | stop 117 | endif 118 | #endif 119 | 120 | #ifdef quadratic_interpolation 121 | iLoc = locate(xMesh, xInterpolated(i), meshX) 122 | if( (iLoc.GE.2).AND.(iLoc.LE.meshX-1) ) then 123 | call LagrangeInterpolation(xMesh(iLoc-1:iLoc+1), uMesh(iLoc-1:iLoc+1), xInterpolated(i), uInterpolated(i), order) 124 | elseif( (iLoc.LT.2) ) then 125 | if(iLoc.LE.0) then 126 | write(*,*) "check boundary, iLoc=", iLoc 127 | stop 128 | endif 129 | call LagrangeInterpolation(xMesh(iLoc:iLoc+2), uMesh(iLoc:iLoc+2), xInterpolated(i), uInterpolated(i), order) 130 | else 131 | write(*,*) "check boundary, iLoc=", iLoc 132 | stop 133 | endif 134 | #endif 135 | 136 | #ifdef cubic_interpolation 137 | iLoc = locate(xMesh, xInterpolated(i), meshX) 138 | if( (iLoc.GE.2).AND.(iLoc.LE.meshX-2) ) then 139 | call LagrangeInterpolation(xMesh(iLoc-1:iLoc+2), uMesh(iLoc-1:iLoc+2), xInterpolated(i), uInterpolated(i), order) 140 | elseif( (iLoc.LT.2) ) then 141 | if(iLoc.LE.0) then 142 | write(*,*) "check boundary, iLoc=", iLoc 143 | stop 144 | endif 145 | call LagrangeInterpolation(xMesh(iLoc:iLoc+3), uMesh(iLoc:iLoc+3), xInterpolated(i), uInterpolated(i), order) 146 | elseif( (iLoc.GT.meshX-2) ) then 147 | if(iLoc.GE.meshX) then 148 | write(*,*) "check boundary, iLoc=", iLoc 149 | stop 150 | endif 151 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+1), uMesh(iLoc-2:iLoc+1), xInterpolated(i), uInterpolated(i), order) 152 | else 153 | write(*,*) "check boundary, iLoc=", iLoc 154 | stop 155 | endif 156 | #endif 157 | 158 | #ifdef fifth_interpolation 159 | iLoc = locate(xMesh, xInterpolated(i), meshX) 160 | if( (iLoc.GE.3).AND.(iLoc.LE.meshX-3) ) then 161 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+3), uMesh(iLoc-2:iLoc+3), xInterpolated(i), uInterpolated(i), order) 162 | elseif( (iLoc.LT.3) ) then 163 | if(iLoc.LE.0) then 164 | write(*,*) "check boundary, iLoc=", iLoc 165 | stop 166 | endif 167 | call LagrangeInterpolation(xMesh(iLoc:iLoc+5), uMesh(iLoc:iLoc+5), xInterpolated(i), uInterpolated(i), order) 168 | elseif( (iLoc.GT.meshX-3) ) then 169 | if(iLoc.GE.meshX) then 170 | write(*,*) "check boundary, iLoc=", iLoc 171 | stop 172 | endif 173 | call LagrangeInterpolation(xMesh(iLoc-4:iLoc+1), uMesh(iLoc-4:iLoc+1), xInterpolated(i), uInterpolated(i), order) 174 | else 175 | write(*,*) "check boundary, iLoc=", iLoc 176 | stop 177 | endif 178 | #endif 179 | 180 | errorL1= errorL1+dabs(uInterpolated(i)-dsin(xInterpolated(i))) 181 | errorL2 = errorL2+(uInterpolated(i)-dsin(xInterpolated(i)))**2.0d0 182 | errorNum = errorNum+1 183 | 184 | endif 185 | enddo 186 | 187 | #ifdef outputData 188 | open(unit=03,file="interpolated.dat",status="unknown") 189 | do i=1,particleX 190 | write(03,*) xInterpolated(i), uInterpolated(i) 191 | enddo 192 | close(03) 193 | #endif 194 | 195 | call CPU_TIME(finish) 196 | write(*,*) "Time (CPU) = ", real(finish-start), "s" 197 | write(*,*) "L1 error=", errorL1/dble(errorNum) 198 | write(*,*) "L2 error=", dsqrt(errorL2/dble(errorNum)) 199 | 200 | string = ctime( time() ) 201 | write(*,*) 'End: ', string 202 | 203 | stop 204 | end program main 205 | 206 | !--Given an array xx(1:N), and given a value x, returns a value j 207 | !----such that x is between xx(j) and xx(j+1). 208 | !----N = size(xx) 209 | !----xx must be monotonic, either increasing or decreasing. 210 | !----j=0 or j=N is returned to indicate that x is out of range 211 | function locate(xx, x, N) 212 | implicit none 213 | real(8) :: xx(1:N) 214 | real(8) :: x 215 | integer :: locate 216 | integer :: N, jLower, jMedium, jUpper 217 | logical :: ascnd 218 | 219 | ascnd = (xx(n).GE.xx(1)) 220 | jLower = 0 221 | jUpper = N+1 222 | do 223 | if((jUpper-jLower).LE.1) exit 224 | jMedium = (jUpper+jLower)/2 225 | if( ascnd.EQV.(x.GE.xx(jMedium)) ) then 226 | jLower = jMedium 227 | else 228 | jUpper = jMedium 229 | endif 230 | enddo 231 | if (x==xx(1)) then 232 | locate = 1 233 | elseif (x == xx(N)) then 234 | locate = N-1 235 | else 236 | locate = jLower 237 | endif 238 | 239 | end function locate 240 | 241 | 242 | subroutine LagrangeInterpolation(pointX, pointU, point0X, point0U, order) 243 | implicit none 244 | integer :: order 245 | real(8) :: pointX(1:order+1), pointU(1:order+1) 246 | real(8) :: point0X, point0U 247 | REAL(8) :: TEMP 248 | integer :: j, k 249 | 250 | point0U = 0.0d0 251 | do k=1,order+1 252 | temp = 1.0d0 253 | do j=1,order+1 254 | if(j.NE.K) temp=temp*(point0X-pointX(j))/(pointX(k)-pointX(j)) 255 | enddo 256 | point0U= point0U+temp*pointU(k) 257 | enddO 258 | 259 | return 260 | end subroutine LagrangeInterpolation 261 | 262 | -------------------------------------------------------------------------------- /07.Initial-Value Ordinary Differential Equations/doubleGyre.F90: -------------------------------------------------------------------------------- 1 | module commondata 2 | implicit none 3 | real(8), parameter :: Pi=4.0d0*datan(1.0d0) 4 | integer(8), parameter :: nx=201, ny=101 5 | real(8), parameter :: tMax=100.0d0 6 | real(8), parameter :: dt = 0.001d0 7 | integer(8), parameter :: maxTimeStep=tMax/dt 8 | real(8), allocatable :: xGrid(:), yGrid(:) 9 | real(8), allocatable :: u(:,:), v(:,:), timeLocal(:) 10 | real(8), allocatable :: uParticle(:), vParticle(:) 11 | real(8), allocatable :: xParticle(:), yParticle(:) 12 | real(8), parameter :: omega=2.0d0*Pi/10.0d0, myEpsilon=0.1d0, A=0.1d0 13 | integer(8), parameter :: calRelError=1 14 | end module commondata 15 | 16 | !~#define firstEuler 17 | !~#define secondEuler 18 | #define RK4 19 | 20 | program main 21 | use commondata 22 | implicit none 23 | integer(8) :: i, j, k 24 | real(8) :: f, dfdx 25 | character(len=100) :: filename 26 | real(8) :: errorL1, errorL2, errorTime 27 | integer(8) :: scaleFactor 28 | integer(8),parameter :: tempMax=tMax/0.00001d0 29 | real(8), allocatable :: testX(:), testY(:), testTime(:) 30 | 31 | allocate (xGrid(nx)) 32 | allocate (yGrid(ny)) 33 | allocate (u(nx,ny)) 34 | allocate (v(nx,ny)) 35 | allocate (timeLocal(0:maxTimeStep)) 36 | allocate (uParticle(0:maxTimeStep)) 37 | allocate (vParticle(0:maxTimeStep)) 38 | allocate (xParticle(0:maxTimeStep)) 39 | allocate (yParticle(0:maxTimeStep)) 40 | allocate (testX(0:tempMax)) 41 | allocate (testY(0:tempMax)) 42 | allocate (testTime(0:tempMax)) 43 | 44 | write(*,*) "Pi=", Pi 45 | 46 | xGrid = 0.0d0 47 | yGrid = 0.0d0 48 | do i=1,nx 49 | xGrid(i) = 2.0d0/(nx-1)*(i-1) 50 | enddo 51 | do j=1,ny 52 | yGrid(j) = 1.0d0/(ny-1)*(j-1) 53 | enddo 54 | 55 | write(*,*) "dt=", dt 56 | write(*,*) "tMax=", tMax 57 | write(filename,*) real(dt) 58 | filename = adjustl(filename) 59 | write(*,*) "maxTimeStep=tMax/dt", maxTimeStep 60 | write(*,*) " " 61 | 62 | !~!~pause 63 | 64 | #ifdef firstEuler 65 | write(*,*) "I am firstEuler" 66 | #endif 67 | 68 | #ifdef secondEuler 69 | write(*,*) "I am secondEuler" 70 | #endif 71 | 72 | #ifdef RK4 73 | write(*,*) "I am RK4" 74 | #endif 75 | 76 | timeLocal = 0.0d0 77 | do k=1,maxTimeStep 78 | timeLocal(k) = dble(k)*dt 79 | enddo 80 | 81 | xParticle = 0.0d0 82 | yParticle = 0.0d0 83 | uParticle = 0.0d0 84 | vParticle = 0.0d0 85 | xParticle(0) = 0.5d0 86 | yParticle(0) = 0.25d0 87 | do k=0, maxTimeStep-1 88 | if(MOD(k,2000).EQ.0) write(*,*) "k=",k, "; maxTimeStep=",maxTimeStep, real(real(k)/real(maxTimeStep)*100.0),"%" 89 | 90 | !~ do j=1,ny 91 | !~ do i=1,nx 92 | !~ u(i,j) = -Pi*A*dsin(Pi*f(xGrid(i), time(k)))*dcos(Pi*yGrid(j)) 93 | !~ v(i,j) = Pi*A*dcos(Pi*f(xGrid(i), time(k)))*dsin(Pi*yGrid(j))*dfdx(xGrid(i), time(k)) 94 | !~ enddo 95 | !~ enddo 96 | 97 | #ifdef firstEuler 98 | call firstEulerUpdate(k) 99 | #endif 100 | 101 | #ifdef secondEuler 102 | call secondEulerUpdate(k) 103 | #endif 104 | 105 | #ifdef RK4 106 | call RK4Update(k) 107 | #endif 108 | ENDDO 109 | 110 | DO K=0,maxTimeStep 111 | open(unit=02,file='particle'//trim(filename)//'.dat', status="unknown", position="append") 112 | write(02,*) xParticle(k), yParticle(k), timeLocal(k) 113 | close(02) 114 | enddo 115 | 116 | !~!~write(*,*) "timeLocal(1)", timeLocal(1) 117 | 118 | if(calRelError.EQ.1) then 119 | scaleFactor = tempMax/maxTimeStep 120 | write(*,*) " " 121 | write(*,*) "tempMax", tempMax 122 | write(*,*) "scaleFactor=tempMax/timeStepMax", scaleFactor 123 | !-------------calculate error---------------------- 124 | testX = 0.0d0 125 | testY = 0.0d0 126 | testTime = 0.0d0 127 | open(unit=01, file='benchmark.dat',status="old") 128 | do i=0,tempMax 129 | read(01,*) testX(i), testY(i), testTime(i) 130 | enddo 131 | close(01) 132 | 133 | errorTime = 0.0d0 134 | errorL1 = 0.0d0 135 | errorL2 = 0.0d0 136 | do k=0,maxTimeStep 137 | errorTime = errorTime+dabs(timeLocal(k)-testTime(k*scaleFactor)) 138 | errorL1 = errorL1+dabs(xParticle(k)-testX(k*scaleFactor))+dabs(yParticle(k)-testY(k*scaleFactor)) 139 | errorL2 = errorL2+(xParticle(k)-testX(k*scaleFactor))**2.0d0 & 140 | +(yParticle(k)-testY(k*scaleFactor))**2.0d0 141 | !~ write(*,*) "k",k,"; k*scaleFactor",k*scaleFactor,"; errorTime", errorTime 142 | !~ write(*,*) "timeLocal(k)", timeLocal(k), "; testTime(k*scaleFactor)",testTime(k*scaleFactor) 143 | !~ write(*,*) " " 144 | enddo 145 | errorTime = errorTime/maxTimeStep 146 | errorL1 = errorL1/maxTimeStep 147 | errorL2 = dsqrt(errorL2/maxTimeStep) 148 | write(*,*) "errorTime", errorTime 149 | write(*,*) "errorL1=", errorL1 150 | write(*,*) "errorL2=", errorL2 151 | endif 152 | 153 | !~!~call output_ASCII() 154 | 155 | stop 156 | end program 157 | 158 | 159 | subroutine firstEulerUpdate(k) 160 | use commondata 161 | implicit none 162 | integer(8) :: k 163 | real(8) :: f, dfdx 164 | 165 | uParticle(k) = -Pi*A*dsin(Pi*f(xParticle(k), timeLocal(k)))*dcos(Pi*yParticle(k)) 166 | vParticle(k) = Pi*A*dcos(Pi*f(xParticle(k), timeLocal(k)))*dsin(Pi*yParticle(k))*dfdx(xParticle(k), timeLocal(k)) 167 | 168 | xParticle(k+1) = xParticle(k)+uParticle(k)*dt 169 | yParticle(k+1) = yParticle(k)+vParticle(k)*dt 170 | 171 | return 172 | end subroutine firstEulerUpdate 173 | 174 | 175 | subroutine secondEulerUpdate(k) 176 | use commondata 177 | implicit none 178 | integer(8) :: k 179 | real(8) :: f, dfdx 180 | real(8) :: k1x, k1y, k2x, k2y 181 | 182 | k1x = -Pi*A*dsin(Pi*f(xParticle(k), timeLocal(k)))*dcos(Pi*yParticle(k)) 183 | k1y = Pi*A*dcos(Pi*f(xParticle(k), timeLocal(k)))*dsin(Pi*yParticle(k))*dfdx(xParticle(k), timeLocal(k)) 184 | 185 | k2x = -Pi*A*dsin(Pi*f(xParticle(k)+dt*k1x, timeLocal(k)+dt))*dcos(Pi*(yParticle(k)+dt*k1y)) 186 | k2y = Pi*A*dcos(Pi*f(xParticle(k)+dt*k1x, timeLocal(k)+dt))*dsin(Pi*(yParticle(k)+dt*k1y))*dfdx(xParticle(k)+dt*k1x, timeLocal(k)+dt) 187 | 188 | xParticle(k+1) = xParticle(k)+(k1x+k2x)*dt/2.0d0 189 | yParticle(k+1) = yParticle(k)+(k1y+k2y)*dt/2.0d0 190 | 191 | return 192 | end subroutine secondEulerUpdate 193 | 194 | 195 | subroutine RK4Update(k) 196 | use commondata 197 | implicit none 198 | integer(8) :: k 199 | real(8) :: f, dfdx 200 | real(8) :: k1x, k1y, k2x, k2y, k3x, k3y, k4x, k4y 201 | 202 | k1x = -Pi*A*dsin(Pi*f(xParticle(k), timeLocal(k)))*dcos(Pi*yParticle(k)) 203 | k1y = Pi*A*dcos(Pi*f(xParticle(k), timeLocal(k)))*dsin(Pi*yParticle(k))*dfdx(xParticle(k), timeLocal(k)) 204 | 205 | k2x = -Pi*A*dsin(Pi*f(xParticle(k)+0.5d0*dt*k1x, timeLocal(k)+0.5d0*dt))*dcos(Pi*(yParticle(k)+0.5d0*dt*k1y)) 206 | k2y = Pi*A*dcos(Pi*f(xParticle(k)+0.5d0*dt*k1x, timeLocal(k)+0.5d0*dt))*dsin(Pi*(yParticle(k)+0.5d0*dt*k1y))*dfdx(xParticle(k)+0.5d0*dt*k1x, timeLocal(k)+0.5d0*dt) 207 | 208 | k3x = -Pi*A*dsin(Pi*f(xParticle(k)+0.5d0*dt*k2x, timeLocal(k)+0.5d0*dt))*dcos(Pi*(yParticle(k)+0.5d0*dt*k2y)) 209 | k3y = Pi*A*dcos(Pi*f(xParticle(k)+0.5d0*dt*k2x, timeLocal(k)+0.5d0*dt))*dsin(Pi*(yParticle(k)+0.5d0*dt*k2y))*dfdx(xParticle(k)+0.5d0*dt*k2x, timeLocal(k)+0.5d0*dt) 210 | 211 | k4x = -Pi*A*dsin(Pi*f(xParticle(k)+dt*k3x, timeLocal(k)+dt))*dcos(Pi*(yParticle(k)+dt*k3y)) 212 | k4y = Pi*A*dcos(Pi*f(xParticle(k)+dt*k3x, timeLocal(k)+dt))*dsin(Pi*(yParticle(k)+dt*k3y))*dfdx(xParticle(k)+dt*k3x, timeLocal(k)+dt) 213 | 214 | xParticle(k+1) = xParticle(k)+(k1x+2.0d0*k2x+2.0d0*k3x+k4x)*dt/6.0d0 215 | yParticle(k+1) = yParticle(k)+(k1y+2.0d0*k2y+2.0d0*k3y+k4y)*dt/6.0d0 216 | 217 | return 218 | end subroutine RK4Update 219 | 220 | 221 | function f(x,t) 222 | use commondata 223 | implicit none 224 | real(8) :: f, x, t 225 | f = myEpsilon*dsin(omega*t)*x**2.0d0+x-2.0d0*myEpsilon*dsin(omega*t)*x 226 | 227 | end function f 228 | 229 | 230 | function dfdx(x,t) 231 | use commondata 232 | implicit none 233 | real(8) :: dfdx, x, t 234 | dfdx = myEpsilon*dsin(omega*t)*2.0d0*x+1.0d0-2.0d0*myEpsilon*dsin(omega*t) 235 | 236 | end function dfdx 237 | 238 | 239 | subroutine output_ASCII() 240 | use commondata 241 | implicit none 242 | integer(8) :: i, j 243 | character(len=100) :: filename 244 | 245 | write(filename,*) maxTimeStep 246 | filename = adjustl(filename) 247 | 248 | open(unit=02,file='doubleGyre-'//trim(filename)//'.dat',status='unknown') 249 | write(02,*) 'TITLE="Lid Driven Cavity"' 250 | write(02,*) 'VARIABLES="X" "Y" "U" "V" ' 251 | write(02,101) nx, ny 252 | do j=1,ny 253 | do i=1,nx 254 | write(02,100) xGrid(i), yGrid(j), u(i,j), v(i,j) 255 | enddo 256 | enddo 257 | 100 format(1x,2(e11.4,' '),10(e13.6,' ')) 258 | 101 format('ZONE',1x,'I=',1x,i5,2x,'J=',1x,i5,1x,'F=POINT') 259 | close(02) 260 | 261 | return 262 | end subroutine output_ASCII 263 | 264 | 265 | subroutine LagrangeInterpolation(pointX, pointU, point0X, point0U, order) 266 | implicit none 267 | integer(8) :: order 268 | real(8) :: pointX(1:order+1), pointU(1:order+1) 269 | real(8) :: point0X, point0U 270 | real(8) :: TEMP 271 | integer(8) :: j, k 272 | 273 | point0U = 0.0d0 274 | do k=1,order+1 275 | temp = 1.0d0 276 | do j=1,order+1 277 | if(j.NE.K) temp=temp*(point0X-pointX(j))/(pointX(k)-pointX(j)) 278 | enddo 279 | point0U= point0U+temp*pointU(k) 280 | enddO 281 | 282 | return 283 | end subroutine LagrangeInterpolation 284 | 285 | 286 | -------------------------------------------------------------------------------- /04.Polynomial Approximation and Interpolation/interpolation-1D.lay: -------------------------------------------------------------------------------- 1 | #!MC 1300 2 | # Created by Tecplot 360 build 13.1.0.15185 3 | $!VarSet |LFDSFN1| = '"exact.dat"' 4 | $!VarSet |LFDSVL1| = '"V1" "V2"' 5 | $!VarSet |LFDSFN2| = '"raw.dat"' 6 | $!VarSet |LFDSVL2| = '"V1" "V2"' 7 | $!VarSet |LFDSFN3| = '"interpolated.dat"' 8 | $!VarSet |LFDSVL3| = '"V1" "V2"' 9 | $!SETSTYLEBASE FACTORY 10 | $!GLOBALLINKING 11 | LINKCOLORMAPS = YES 12 | $!GLOBALCOLORMAP 1 13 | CONTOURCOLORMAP = SMRAINBOW 14 | $!COLORMAPCONTROL 1 RESETTOFACTORY 15 | $!GLOBALCOLORMAP 1 16 | SMRAINBOW 17 | { 18 | CONTROLPOINT 1 19 | { 20 | COLORMAPFRACTION = 0 21 | LEADRGB 22 | { 23 | R = 0 24 | G = 0 25 | B = 255 26 | } 27 | TRAILRGB 28 | { 29 | R = 0 30 | G = 0 31 | B = 255 32 | } 33 | } 34 | CONTROLPOINT 2 35 | { 36 | COLORMAPFRACTION = 0.25 37 | LEADRGB 38 | { 39 | R = 0 40 | G = 255 41 | B = 255 42 | } 43 | TRAILRGB 44 | { 45 | R = 0 46 | G = 255 47 | B = 255 48 | } 49 | } 50 | CONTROLPOINT 3 51 | { 52 | COLORMAPFRACTION = 0.5 53 | LEADRGB 54 | { 55 | R = 0 56 | G = 255 57 | B = 0 58 | } 59 | TRAILRGB 60 | { 61 | R = 0 62 | G = 255 63 | B = 0 64 | } 65 | } 66 | CONTROLPOINT 4 67 | { 68 | COLORMAPFRACTION = 0.75 69 | LEADRGB 70 | { 71 | R = 255 72 | G = 255 73 | B = 0 74 | } 75 | TRAILRGB 76 | { 77 | R = 255 78 | G = 255 79 | B = 0 80 | } 81 | } 82 | CONTROLPOINT 5 83 | { 84 | COLORMAPFRACTION = 1 85 | LEADRGB 86 | { 87 | R = 255 88 | G = 0 89 | B = 0 90 | } 91 | TRAILRGB 92 | { 93 | R = 255 94 | G = 0 95 | B = 0 96 | } 97 | } 98 | } 99 | $!GLOBALCOLORMAP 2 100 | CONTOURCOLORMAP = LGRAINBOW 101 | $!COLORMAPCONTROL 2 RESETTOFACTORY 102 | $!GLOBALCOLORMAP 2 103 | LGRAINBOW 104 | { 105 | CONTROLPOINT 1 106 | { 107 | COLORMAPFRACTION = 0 108 | LEADRGB 109 | { 110 | R = 0 111 | G = 0 112 | B = 255 113 | } 114 | TRAILRGB 115 | { 116 | R = 0 117 | G = 0 118 | B = 255 119 | } 120 | } 121 | CONTROLPOINT 2 122 | { 123 | COLORMAPFRACTION = 0.1667 124 | LEADRGB 125 | { 126 | R = 0 127 | G = 255 128 | B = 255 129 | } 130 | TRAILRGB 131 | { 132 | R = 0 133 | G = 255 134 | B = 255 135 | } 136 | } 137 | CONTROLPOINT 3 138 | { 139 | COLORMAPFRACTION = 0.3333 140 | LEADRGB 141 | { 142 | R = 0 143 | G = 255 144 | B = 0 145 | } 146 | TRAILRGB 147 | { 148 | R = 0 149 | G = 255 150 | B = 0 151 | } 152 | } 153 | CONTROLPOINT 4 154 | { 155 | COLORMAPFRACTION = 0.5 156 | LEADRGB 157 | { 158 | R = 255 159 | G = 255 160 | B = 0 161 | } 162 | TRAILRGB 163 | { 164 | R = 255 165 | G = 255 166 | B = 0 167 | } 168 | } 169 | CONTROLPOINT 5 170 | { 171 | COLORMAPFRACTION = 0.6667 172 | LEADRGB 173 | { 174 | R = 255 175 | G = 0 176 | B = 0 177 | } 178 | TRAILRGB 179 | { 180 | R = 255 181 | G = 0 182 | B = 0 183 | } 184 | } 185 | CONTROLPOINT 6 186 | { 187 | COLORMAPFRACTION = 0.8333 188 | LEADRGB 189 | { 190 | R = 255 191 | G = 0 192 | B = 255 193 | } 194 | TRAILRGB 195 | { 196 | R = 255 197 | G = 0 198 | B = 255 199 | } 200 | } 201 | CONTROLPOINT 7 202 | { 203 | COLORMAPFRACTION = 1 204 | LEADRGB 205 | { 206 | R = 255 207 | G = 255 208 | B = 255 209 | } 210 | TRAILRGB 211 | { 212 | R = 255 213 | G = 255 214 | B = 255 215 | } 216 | } 217 | } 218 | $!GLOBALCOLORMAP 3 219 | CONTOURCOLORMAP = MODERN 220 | $!COLORMAPCONTROL 3 RESETTOFACTORY 221 | $!GLOBALCOLORMAP 3 222 | MODERN 223 | { 224 | CONTROLPOINT 1 225 | { 226 | COLORMAPFRACTION = 0 227 | LEADRGB 228 | { 229 | R = 100 230 | G = 35 231 | B = 100 232 | } 233 | TRAILRGB 234 | { 235 | R = 100 236 | G = 35 237 | B = 100 238 | } 239 | } 240 | CONTROLPOINT 2 241 | { 242 | COLORMAPFRACTION = 0.1429 243 | LEADRGB 244 | { 245 | R = 35 246 | G = 35 247 | B = 100 248 | } 249 | TRAILRGB 250 | { 251 | R = 255 252 | G = 0 253 | B = 255 254 | } 255 | } 256 | CONTROLPOINT 3 257 | { 258 | COLORMAPFRACTION = 0.2857 259 | LEADRGB 260 | { 261 | R = 35 262 | G = 100 263 | B = 100 264 | } 265 | TRAILRGB 266 | { 267 | R = 0 268 | G = 0 269 | B = 255 270 | } 271 | } 272 | CONTROLPOINT 4 273 | { 274 | COLORMAPFRACTION = 0.4286 275 | LEADRGB 276 | { 277 | R = 35 278 | G = 100 279 | B = 35 280 | } 281 | TRAILRGB 282 | { 283 | R = 0 284 | G = 255 285 | B = 255 286 | } 287 | } 288 | CONTROLPOINT 5 289 | { 290 | COLORMAPFRACTION = 0.5714 291 | LEADRGB 292 | { 293 | R = 100 294 | G = 100 295 | B = 35 296 | } 297 | TRAILRGB 298 | { 299 | R = 0 300 | G = 255 301 | B = 0 302 | } 303 | } 304 | CONTROLPOINT 6 305 | { 306 | COLORMAPFRACTION = 0.7143 307 | LEADRGB 308 | { 309 | R = 85 310 | G = 46 311 | B = 10 312 | } 313 | TRAILRGB 314 | { 315 | R = 255 316 | G = 255 317 | B = 0 318 | } 319 | } 320 | CONTROLPOINT 7 321 | { 322 | COLORMAPFRACTION = 0.8571 323 | LEADRGB 324 | { 325 | R = 100 326 | G = 35 327 | B = 35 328 | } 329 | TRAILRGB 330 | { 331 | R = 217 332 | G = 117 333 | B = 26 334 | } 335 | } 336 | CONTROLPOINT 8 337 | { 338 | COLORMAPFRACTION = 1 339 | LEADRGB 340 | { 341 | R = 255 342 | G = 0 343 | B = 0 344 | } 345 | TRAILRGB 346 | { 347 | R = 255 348 | G = 0 349 | B = 0 350 | } 351 | } 352 | } 353 | $!GLOBALCOLORMAP 4 354 | CONTOURCOLORMAP = GRAYSCALE 355 | $!COLORMAPCONTROL 4 RESETTOFACTORY 356 | $!GLOBALCOLORMAP 4 357 | GRAYSCALE 358 | { 359 | CONTROLPOINT 1 360 | { 361 | COLORMAPFRACTION = 0 362 | LEADRGB 363 | { 364 | R = 0 365 | G = 0 366 | B = 0 367 | } 368 | TRAILRGB 369 | { 370 | R = 0 371 | G = 0 372 | B = 0 373 | } 374 | } 375 | CONTROLPOINT 2 376 | { 377 | COLORMAPFRACTION = 0.125 378 | LEADRGB 379 | { 380 | R = 32 381 | G = 32 382 | B = 32 383 | } 384 | TRAILRGB 385 | { 386 | R = 32 387 | G = 32 388 | B = 32 389 | } 390 | } 391 | CONTROLPOINT 3 392 | { 393 | COLORMAPFRACTION = 0.25 394 | LEADRGB 395 | { 396 | R = 64 397 | G = 64 398 | B = 64 399 | } 400 | TRAILRGB 401 | { 402 | R = 64 403 | G = 64 404 | B = 64 405 | } 406 | } 407 | CONTROLPOINT 4 408 | { 409 | COLORMAPFRACTION = 0.375 410 | LEADRGB 411 | { 412 | R = 96 413 | G = 96 414 | B = 96 415 | } 416 | TRAILRGB 417 | { 418 | R = 96 419 | G = 96 420 | B = 96 421 | } 422 | } 423 | CONTROLPOINT 5 424 | { 425 | COLORMAPFRACTION = 0.5 426 | LEADRGB 427 | { 428 | R = 128 429 | G = 128 430 | B = 128 431 | } 432 | TRAILRGB 433 | { 434 | R = 128 435 | G = 128 436 | B = 128 437 | } 438 | } 439 | CONTROLPOINT 6 440 | { 441 | COLORMAPFRACTION = 0.625 442 | LEADRGB 443 | { 444 | R = 160 445 | G = 160 446 | B = 160 447 | } 448 | TRAILRGB 449 | { 450 | R = 160 451 | G = 160 452 | B = 160 453 | } 454 | } 455 | CONTROLPOINT 7 456 | { 457 | COLORMAPFRACTION = 0.75 458 | LEADRGB 459 | { 460 | R = 192 461 | G = 192 462 | B = 192 463 | } 464 | TRAILRGB 465 | { 466 | R = 192 467 | G = 192 468 | B = 192 469 | } 470 | } 471 | CONTROLPOINT 8 472 | { 473 | COLORMAPFRACTION = 0.875 474 | LEADRGB 475 | { 476 | R = 224 477 | G = 224 478 | B = 224 479 | } 480 | TRAILRGB 481 | { 482 | R = 224 483 | G = 224 484 | B = 224 485 | } 486 | } 487 | CONTROLPOINT 9 488 | { 489 | COLORMAPFRACTION = 1 490 | LEADRGB 491 | { 492 | R = 255 493 | G = 255 494 | B = 255 495 | } 496 | TRAILRGB 497 | { 498 | R = 255 499 | G = 255 500 | B = 255 501 | } 502 | } 503 | } 504 | $!GLOBALCOLORMAP 5 505 | CONTOURCOLORMAP = SMRAINBOW 506 | $!COLORMAPCONTROL 5 RESETTOFACTORY 507 | $!GLOBALCOLORMAP 5 508 | SMRAINBOW 509 | { 510 | CONTROLPOINT 1 511 | { 512 | COLORMAPFRACTION = 0 513 | LEADRGB 514 | { 515 | R = 0 516 | G = 0 517 | B = 255 518 | } 519 | TRAILRGB 520 | { 521 | R = 0 522 | G = 0 523 | B = 255 524 | } 525 | } 526 | CONTROLPOINT 2 527 | { 528 | COLORMAPFRACTION = 0.25 529 | LEADRGB 530 | { 531 | R = 0 532 | G = 255 533 | B = 255 534 | } 535 | TRAILRGB 536 | { 537 | R = 0 538 | G = 255 539 | B = 255 540 | } 541 | } 542 | CONTROLPOINT 3 543 | { 544 | COLORMAPFRACTION = 0.5 545 | LEADRGB 546 | { 547 | R = 0 548 | G = 255 549 | B = 0 550 | } 551 | TRAILRGB 552 | { 553 | R = 0 554 | G = 255 555 | B = 0 556 | } 557 | } 558 | CONTROLPOINT 4 559 | { 560 | COLORMAPFRACTION = 0.75 561 | LEADRGB 562 | { 563 | R = 255 564 | G = 255 565 | B = 0 566 | } 567 | TRAILRGB 568 | { 569 | R = 255 570 | G = 255 571 | B = 0 572 | } 573 | } 574 | CONTROLPOINT 5 575 | { 576 | COLORMAPFRACTION = 1 577 | LEADRGB 578 | { 579 | R = 255 580 | G = 0 581 | B = 0 582 | } 583 | TRAILRGB 584 | { 585 | R = 255 586 | G = 0 587 | B = 0 588 | } 589 | } 590 | } 591 | $!GLOBALCOLORMAP 6 592 | CONTOURCOLORMAP = SMRAINBOW 593 | $!COLORMAPCONTROL 6 RESETTOFACTORY 594 | $!GLOBALCOLORMAP 6 595 | SMRAINBOW 596 | { 597 | CONTROLPOINT 1 598 | { 599 | COLORMAPFRACTION = 0 600 | LEADRGB 601 | { 602 | R = 0 603 | G = 0 604 | B = 255 605 | } 606 | TRAILRGB 607 | { 608 | R = 0 609 | G = 0 610 | B = 255 611 | } 612 | } 613 | CONTROLPOINT 2 614 | { 615 | COLORMAPFRACTION = 0.25 616 | LEADRGB 617 | { 618 | R = 0 619 | G = 255 620 | B = 255 621 | } 622 | TRAILRGB 623 | { 624 | R = 0 625 | G = 255 626 | B = 255 627 | } 628 | } 629 | CONTROLPOINT 3 630 | { 631 | COLORMAPFRACTION = 0.5 632 | LEADRGB 633 | { 634 | R = 0 635 | G = 255 636 | B = 0 637 | } 638 | TRAILRGB 639 | { 640 | R = 0 641 | G = 255 642 | B = 0 643 | } 644 | } 645 | CONTROLPOINT 4 646 | { 647 | COLORMAPFRACTION = 0.75 648 | LEADRGB 649 | { 650 | R = 255 651 | G = 255 652 | B = 0 653 | } 654 | TRAILRGB 655 | { 656 | R = 255 657 | G = 255 658 | B = 0 659 | } 660 | } 661 | CONTROLPOINT 5 662 | { 663 | COLORMAPFRACTION = 1 664 | LEADRGB 665 | { 666 | R = 255 667 | G = 0 668 | B = 0 669 | } 670 | TRAILRGB 671 | { 672 | R = 255 673 | G = 0 674 | B = 0 675 | } 676 | } 677 | } 678 | $!GLOBALCOLORMAP 7 679 | CONTOURCOLORMAP = SMRAINBOW 680 | $!COLORMAPCONTROL 7 RESETTOFACTORY 681 | $!GLOBALCOLORMAP 7 682 | SMRAINBOW 683 | { 684 | CONTROLPOINT 1 685 | { 686 | COLORMAPFRACTION = 0 687 | LEADRGB 688 | { 689 | R = 0 690 | G = 0 691 | B = 255 692 | } 693 | TRAILRGB 694 | { 695 | R = 0 696 | G = 0 697 | B = 255 698 | } 699 | } 700 | CONTROLPOINT 2 701 | { 702 | COLORMAPFRACTION = 0.25 703 | LEADRGB 704 | { 705 | R = 0 706 | G = 255 707 | B = 255 708 | } 709 | TRAILRGB 710 | { 711 | R = 0 712 | G = 255 713 | B = 255 714 | } 715 | } 716 | CONTROLPOINT 3 717 | { 718 | COLORMAPFRACTION = 0.5 719 | LEADRGB 720 | { 721 | R = 0 722 | G = 255 723 | B = 0 724 | } 725 | TRAILRGB 726 | { 727 | R = 0 728 | G = 255 729 | B = 0 730 | } 731 | } 732 | CONTROLPOINT 4 733 | { 734 | COLORMAPFRACTION = 0.75 735 | LEADRGB 736 | { 737 | R = 255 738 | G = 255 739 | B = 0 740 | } 741 | TRAILRGB 742 | { 743 | R = 255 744 | G = 255 745 | B = 0 746 | } 747 | } 748 | CONTROLPOINT 5 749 | { 750 | COLORMAPFRACTION = 1 751 | LEADRGB 752 | { 753 | R = 255 754 | G = 0 755 | B = 0 756 | } 757 | TRAILRGB 758 | { 759 | R = 255 760 | G = 0 761 | B = 0 762 | } 763 | } 764 | } 765 | $!GLOBALCOLORMAP 8 766 | CONTOURCOLORMAP = SMRAINBOW 767 | $!COLORMAPCONTROL 8 RESETTOFACTORY 768 | $!GLOBALCOLORMAP 8 769 | SMRAINBOW 770 | { 771 | CONTROLPOINT 1 772 | { 773 | COLORMAPFRACTION = 0 774 | LEADRGB 775 | { 776 | R = 0 777 | G = 0 778 | B = 255 779 | } 780 | TRAILRGB 781 | { 782 | R = 0 783 | G = 0 784 | B = 255 785 | } 786 | } 787 | CONTROLPOINT 2 788 | { 789 | COLORMAPFRACTION = 0.25 790 | LEADRGB 791 | { 792 | R = 0 793 | G = 255 794 | B = 255 795 | } 796 | TRAILRGB 797 | { 798 | R = 0 799 | G = 255 800 | B = 255 801 | } 802 | } 803 | CONTROLPOINT 3 804 | { 805 | COLORMAPFRACTION = 0.5 806 | LEADRGB 807 | { 808 | R = 0 809 | G = 255 810 | B = 0 811 | } 812 | TRAILRGB 813 | { 814 | R = 0 815 | G = 255 816 | B = 0 817 | } 818 | } 819 | CONTROLPOINT 4 820 | { 821 | COLORMAPFRACTION = 0.75 822 | LEADRGB 823 | { 824 | R = 255 825 | G = 255 826 | B = 0 827 | } 828 | TRAILRGB 829 | { 830 | R = 255 831 | G = 255 832 | B = 0 833 | } 834 | } 835 | CONTROLPOINT 5 836 | { 837 | COLORMAPFRACTION = 1 838 | LEADRGB 839 | { 840 | R = 255 841 | G = 0 842 | B = 0 843 | } 844 | TRAILRGB 845 | { 846 | R = 255 847 | G = 0 848 | B = 0 849 | } 850 | } 851 | } 852 | $!PLOTOPTIONS 853 | SUBDIVIDEALLCELLS = NO 854 | $!GLOBALPAPER 855 | PAPERSIZEINFO 856 | { 857 | LETTER 858 | { 859 | WIDTH = 8.5 860 | HEIGHT = 11 861 | LEFTHARDCLIPOFFSET = 0.125 862 | RIGHTHARDCLIPOFFSET = 0.125 863 | TOPHARDCLIPOFFSET = 0.125 864 | BOTTOMHARDCLIPOFFSET = 0.125 865 | } 866 | } 867 | $!PAGE 868 | NAME = '' 869 | PAPERATTRIBUTES 870 | { 871 | BACKGROUNDCOLOR = WHITE 872 | ISTRANSPARENT = YES 873 | ORIENTPORTRAIT = NO 874 | SHOWGRID = YES 875 | SHOWRULER = NO 876 | SHOWPAPER = NO 877 | PAPERSIZE = LETTER 878 | RULERSPACING = ONEINCH 879 | PAPERGRIDSPACING = HALFINCH 880 | REGIONINWORKAREA 881 | { 882 | X1 = 1 883 | Y1 = 0.25 884 | X2 = 10 885 | Y2 = 8.25 886 | } 887 | } 888 | ### Frame Number 1 ### 889 | $!READDATASET '|LFDSFN1|' 890 | INITIALPLOTTYPE = XYLINE 891 | INCLUDETEXT = NO 892 | INCLUDEGEOM = NO 893 | ASSIGNSTRANDIDS = YES 894 | VARLOADMODE = BYNAME 895 | VARNAMELIST = '|LFDSVL1|' 896 | $!REMOVEVAR |LFDSVL1| 897 | $!REMOVEVAR |LFDSFN1| 898 | $!READDATASET '|LFDSFN2|' 899 | INITIALPLOTTYPE = XYLINE 900 | INCLUDETEXT = NO 901 | INCLUDEGEOM = NO 902 | READDATAOPTION = APPEND 903 | RESETSTYLE = NO 904 | ASSIGNSTRANDIDS = YES 905 | VARLOADMODE = BYNAME 906 | VARNAMELIST = '|LFDSVL2|' 907 | $!REMOVEVAR |LFDSVL2| 908 | $!REMOVEVAR |LFDSFN2| 909 | $!READDATASET '|LFDSFN3|' 910 | INITIALPLOTTYPE = XYLINE 911 | INCLUDETEXT = NO 912 | INCLUDEGEOM = NO 913 | READDATAOPTION = APPEND 914 | RESETSTYLE = NO 915 | ASSIGNSTRANDIDS = YES 916 | VARLOADMODE = BYNAME 917 | VARNAMELIST = '|LFDSVL3|' 918 | $!REMOVEVAR |LFDSVL3| 919 | $!REMOVEVAR |LFDSFN3| 920 | $!FRAMELAYOUT 921 | SHOWBORDER = NO 922 | SHOWHEADER = NO 923 | HEADERCOLOR = RED 924 | XYPOS 925 | { 926 | X = 1 927 | Y = 0.25 928 | } 929 | WIDTH = 9 930 | HEIGHT = 8 931 | $!THREEDAXIS 932 | ASPECTRATIOLIMIT = 25 933 | BOXASPECTRATIOLIMIT = 25 934 | $!PLOTTYPE = XYLINE 935 | $!FRAMENAME = 'Frame 001' 936 | $!GLOBALTIME 937 | SOLUTIONTIME = 0 938 | $!DELETELINEMAPS 939 | $!ACTIVELINEMAPS = [1-3] 940 | $!GLOBALLINEPLOT 941 | DATALABELS 942 | { 943 | DISTANCESKIP = 5 944 | } 945 | LEGEND 946 | { 947 | SHOW = YES 948 | TEXTSHAPE 949 | { 950 | FONTFAMILY = 'Times' 951 | ISBOLD = NO 952 | SIZEUNITS = POINT 953 | HEIGHT = 28 954 | } 955 | BOX 956 | { 957 | BOXTYPE = NONE 958 | MARGIN = 2 959 | } 960 | XYPOS 961 | { 962 | X = 95 963 | Y = 95 964 | } 965 | } 966 | $!LINEMAP [1] 967 | NAME = 'Exact' 968 | ASSIGN 969 | { 970 | ZONE = 1 971 | XAXISVAR = 1 972 | YAXISVAR = 2 973 | } 974 | LINES 975 | { 976 | COLOR = BLACK 977 | LINETHICKNESS = 0.4 978 | } 979 | SYMBOLS 980 | { 981 | SHOW = NO 982 | COLOR = RED 983 | FILLCOLOR = RED 984 | } 985 | BARCHARTS 986 | { 987 | COLOR = RED 988 | FILLCOLOR = RED 989 | } 990 | ERRORBARS 991 | { 992 | COLOR = RED 993 | } 994 | $!LINEMAP [2] 995 | NAME = 'Raw' 996 | ASSIGN 997 | { 998 | ZONE = 2 999 | XAXISVAR = 1 1000 | YAXISVAR = 2 1001 | } 1002 | LINES 1003 | { 1004 | COLOR = BLUE 1005 | LINETHICKNESS = 0.4 1006 | } 1007 | SYMBOLS 1008 | { 1009 | COLOR = BLUE 1010 | FILLCOLOR = GREEN 1011 | LINETHICKNESS = 0.4 1012 | } 1013 | BARCHARTS 1014 | { 1015 | COLOR = GREEN 1016 | FILLCOLOR = GREEN 1017 | } 1018 | ERRORBARS 1019 | { 1020 | COLOR = GREEN 1021 | } 1022 | $!LINEMAP [3] 1023 | NAME = 'Interpolated' 1024 | ASSIGN 1025 | { 1026 | ZONE = 3 1027 | XAXISVAR = 1 1028 | YAXISVAR = 2 1029 | } 1030 | LINES 1031 | { 1032 | SHOW = NO 1033 | COLOR = RED 1034 | LINETHICKNESS = 0.4 1035 | } 1036 | SYMBOLS 1037 | { 1038 | SYMBOLSHAPE 1039 | { 1040 | GEOMSHAPE = CIRCLE 1041 | } 1042 | COLOR = RED 1043 | FILLCOLOR = BLUE 1044 | SIZE = 2.2 1045 | LINETHICKNESS = 0.4 1046 | } 1047 | BARCHARTS 1048 | { 1049 | COLOR = BLUE 1050 | FILLCOLOR = BLUE 1051 | } 1052 | ERRORBARS 1053 | { 1054 | COLOR = BLUE 1055 | } 1056 | $!XYLINEAXIS 1057 | DEPXTOYRATIO = 1 1058 | GRIDAREA 1059 | { 1060 | DRAWBORDER = YES 1061 | } 1062 | VIEWPORTPOSITION 1063 | { 1064 | X2 = 95 1065 | Y2 = 95 1066 | } 1067 | VIEWPORTTOPSNAPTARGET = 95 1068 | $!XYLINEAXIS 1069 | XDETAIL 1 1070 | { 1071 | RANGEMIN = -0.5 1072 | RANGEMAX = 6.5 1073 | GRSPACING = 1 1074 | TITLE 1075 | { 1076 | TITLEMODE = USETEXT 1077 | TEXT = 'x' 1078 | } 1079 | } 1080 | $!XYLINEAXIS 1081 | YDETAIL 1 1082 | { 1083 | RANGEMIN = -1.5 1084 | RANGEMAX = 1.5 1085 | GRSPACING = 0.5 1086 | TITLE 1087 | { 1088 | TITLEMODE = USETEXT 1089 | TEXT = 'y' 1090 | } 1091 | } 1092 | $!LINEPLOTLAYERS 1093 | SHOWSYMBOLS = YES 1094 | $!FRAMECONTROL ACTIVATEBYNUMBER 1095 | FRAME = 1 1096 | $!SETSTYLEBASE CONFIG 1097 | -------------------------------------------------------------------------------- /04.Polynomial Approximation and Interpolation/Lagrange-interpolation-2D.F90: -------------------------------------------------------------------------------- 1 | !~#define linear_interpolation 2 | !~#define cubic_interpolation 3 | #define fifth_interpolation 4 | 5 | #define outputData 6 | 7 | program main 8 | implicit none 9 | real(8), parameter :: Pi=4.0d0*datan(1.0d0) 10 | integer, parameter :: nx=101, ny=81 11 | real(8) :: xExact(nx), yExact(ny), uExact(nx,ny) 12 | 13 | #ifdef linear_interpolation 14 | integer, parameter :: order=1 15 | #endif 16 | #ifdef cubic_interpolation 17 | integer, parameter :: order=3 18 | #endif 19 | #ifdef fifth_interpolation 20 | integer, parameter :: order=5 21 | #endif 22 | 23 | integer, parameter :: meshX=10*1, meshY=8*1 24 | real(8) :: xMesh(meshX), yMesh(meshY), uMesh(meshX,meshY) 25 | 26 | integer, parameter :: particleX=100, particleY=80 27 | real(8) :: xInterpolated(particleX), yInterpolated(particleY), uInterpolated(particleX,particleY) 28 | 29 | integer :: i, j 30 | integer :: iLoc, jLoc 31 | real(8) :: dx, dy, dx2, dy2 32 | integer :: findLoc 33 | integer :: locate 34 | real(8) :: errorL1, errorL2 35 | integer :: errorNum 36 | character*24 ctime, string 37 | INTEGER*4 time 38 | real(kind=8) :: start, finish 39 | real(8) :: tempU(1:order+1) 40 | 41 | !~ write(*,*) "Pi=",Pi 42 | !~ write(*,*) "nint(Pi+0.5)=", nint(Pi+0.5) 43 | !~ write(*,*) "int(Pi+0.5)=", int(Pi+0.5) 44 | 45 | string = ctime( time() ) 46 | write(*,*) 'Start: ', string 47 | call CPU_TIME(start) 48 | 49 | #ifdef linear_interpolation 50 | write(*,*) "I am linear interpolation!" 51 | #endif 52 | #ifdef quadratic_interpolation 53 | write(*,*) "I am quadratic interpolation!" 54 | #endif 55 | #ifdef cubic_interpolation 56 | write(*,*) "I am cubic interpolation!" 57 | #endif 58 | write(*,*) " " 59 | 60 | !--exact solution 61 | do i=1,nx 62 | xExact(i) = dble(i-1)/dble(nx-1)*2.0d0*Pi 63 | enddo 64 | do j=1,ny 65 | yExact(j) = dble(j-1)/dble(ny-1)*2.0d0*Pi 66 | enddo 67 | do j=1,ny 68 | do i=1,nx 69 | uExact(i,j) = dsin(xExact(i))*dcos(yExact(j)) 70 | enddo 71 | enddo 72 | #ifdef outputData 73 | open(unit=01,file="exact.dat",status="unknown") 74 | write(01,*) 'TITLE="Lid Driven Cavity"' 75 | write(01,*) 'VARIABLES="X" "Y" "U" ' 76 | write(01,101) nx, ny 77 | do j=1,ny 78 | do i=1,nx 79 | write(01,100) xExact(i), yExact(j), uExact(i,j) 80 | enddo 81 | enddo 82 | 100 format(1x,2(e11.4,' '),10(e13.6,' ')) 83 | 101 format(' ZONE',1x,'I=',1x,i5,2x,'J=',1x,i5,1x,'F=POINT') 84 | close(01) 85 | #endif 86 | 87 | write(*,*) "meshX:", meshX, ", meshY:", meshY 88 | !--raw data points 89 | dx = 2.0d0*Pi/dble(meshX) 90 | dy = 2.0d0*Pi/dble(meshY) 91 | do i=1,meshX 92 | xMesh(i) = dx/2.0d0+dble(i-1)*dx 93 | enddo 94 | do j=1,meshY 95 | yMesh(j) = dy/2.0d0+dble(j-1)*dy 96 | enddo 97 | do j=1,meshY 98 | do i=1,meshX 99 | uMesh(i,j) = dsin(xMesh(i))*dcos(yMesh(j)) 100 | enddo 101 | enddo 102 | #ifdef outputData 103 | open(unit=02,file="raw.dat",status="unknown") 104 | write(02,*) 'TITLE="Lid Driven Cavity"' 105 | write(02,*) 'VARIABLES="X" "Y" "uMesh" ' 106 | write(02,101) meshX, meshY 107 | do j=1,meshY 108 | do i=1,meshX 109 | write(02,100) xMesh(i), yMesh(j), uMesh(i,j) 110 | enddo 111 | enddo 112 | close(02) 113 | #endif 114 | 115 | write(*,*) "particleX:", particleX, ", particleY:", particleY 116 | !--interpolated data points 117 | dx2 = 2.0d0*Pi/dble(particleX-1) 118 | dy2 = 2.0d0*Pi/dble(particleY-1) 119 | errorL1 = 0.0d0 120 | errorL2 = 0.0d0 121 | errorNum = 0 122 | do i=1,particleX 123 | xInterpolated(i) = dble(i-1)*dx2 124 | enddo 125 | do j=1,particleY 126 | yInterpolated(j)= dble(j-1)*dy2 127 | enddo 128 | do j=1,particleY 129 | do i=1,particleX 130 | if( (xInterpolated(i).LT.xMesh(1)).OR.(xInterpolated(i).GT.xMesh(meshX)).OR.(yInterpolated(j).LT.yMesh(1)).OR.(yInterpolated(j).GT.yMesh(meshY)) ) then 131 | !~ write(*,*) "xInterpolated(i) is out of the range of X1" 132 | !~ write(*,*) "i =", i 133 | !~ write(*,*) "xInterpolated(i) =", xInterpolated(i) 134 | !~ write(*,*) "xMesh_min =", xMesh(1)," , xMesh_mmeshX = ", xMesh(meshX) 135 | !~ write(*,*) " " 136 | !~uInterpolated(i,j) = 0.0d0 137 | !~write(*,*) "i,j=", i, j 138 | ELSE 139 | #ifdef linear_interpolation 140 | iLoc = locate(xMesh, xInterpolated(i), meshX) 141 | jLoc = locate(yMesh, yInterpolated(j), meshY) 142 | if( (iLoc.GE.1).AND.(jLoc.GE.1).AND.(iLoc.LE.meshX-1).AND.(jLoc.LE.meshY-1) ) then 143 | !--Bulk 144 | call LagrangeInterpolation(yMesh(jLoc:jLoc+1), uMesh(iLoc, jLoc:jLoc+1), yInterpolated(j), tempU(1), order) 145 | call LagrangeInterpolation(yMesh(jLoc:jLoc+1), uMesh(iLoc+1, jLoc:jLoc+1), yInterpolated(j), tempU(2), order) 146 | 147 | call LagrangeInterpolation(xMesh(iLoc:iLoc+1), tempU(1:2), xInterpolated(i), uInterpolated(i,j), order) 148 | else 149 | write(*,*) "check boundary, iLoc=", iLoc 150 | stop 151 | endif 152 | #endif 153 | 154 | #ifdef cubic_interpolation 155 | iLoc = locate(xMesh, xInterpolated(i), meshX) 156 | jLoc = locate(yMesh, yInterpolated(j), meshY) 157 | if( (iLoc.GE.2).AND.(jLoc.GE.2).AND.(iLoc.LE.meshX-2).AND.(jLoc.LE.meshY-2) ) then 158 | !--Bulk 159 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc-1, jLoc-1:jLoc+2), yInterpolated(j), tempU(1), order) 160 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc, jLoc-1:jLoc+2), yInterpolated(j), tempU(2), order) 161 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc+1,jLoc-1:jLoc+2), yInterpolated(j), tempU(3), order) 162 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc+2,jLoc-1:jLoc+2), yInterpolated(j), tempU(4), order) 163 | 164 | call LagrangeInterpolation(xMesh(iLoc-1:iLoc+2), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 165 | 166 | elseif( (iLoc.LT.2).AND.(jLoc.GE.2).AND.(jLoc.LE.meshY-2) ) then 167 | !----Left wall 168 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc, jLoc-1:jLoc+2), yInterpolated(j), tempU(1), order) 169 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc+1,jLoc-1:jLoc+2), yInterpolated(j), tempU(2), order) 170 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc+2,jLoc-1:jLoc+2), yInterpolated(j), tempU(3), order) 171 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc+3,jLoc-1:jLoc+2), yInterpolated(j), tempU(4), order) 172 | 173 | call LagrangeInterpolation(xMesh(iLoc:iLoc+3), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 174 | 175 | elseif( (iLoc.GE.2).AND.(jLoc.LT.2).AND.(iLoc.LE.meshX-2) ) then 176 | !----Bottom wall 177 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc-1, jLoc:jLoc+3), yInterpolated(j), tempU(1), order) 178 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc, jLoc:jLoc+3), yInterpolated(j), tempU(2), order) 179 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc+1,jLoc:jLoc+3), yInterpolated(j), tempU(3), order) 180 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc+2,jLoc:jLoc+3), yInterpolated(j), tempU(4), order) 181 | 182 | call LagrangeInterpolation(xMesh(iLoc-1:iLoc+2), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 183 | 184 | elseif( (jLoc.GE.2).AND.(iLoc.GT.meshX-2).AND.(jLoc.LE.meshY-2) ) then 185 | !----Right wall 186 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc-2, jLoc-1:jLoc+2), yInterpolated(j), tempU(1), order) 187 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc-1, jLoc-1:jLoc+2), yInterpolated(j), tempU(2), order) 188 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc, jLoc-1:jLoc+2), yInterpolated(j), tempU(3), order) 189 | call LagrangeInterpolation(yMesh(jLoc-1:jLoc+2), uMesh(iLoc+1,jLoc-1:jLoc+2), yInterpolated(j), tempU(4), order) 190 | 191 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+1), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 192 | 193 | elseif( (iLoc.GE.2).AND.(iLoc.LE.meshX-2).AND.(jLoc.GT.meshY-2) ) then 194 | !----Top wall 195 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc-1, jLoc-2:jLoc+1), yInterpolated(j), tempU(1), order) 196 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc, jLoc-2:jLoc+1), yInterpolated(j), tempU(2), order) 197 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc+1,jLoc-2:jLoc+1), yInterpolated(j), tempU(3), order) 198 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc+2,jLoc-2:jLoc+1), yInterpolated(j), tempU(4), order) 199 | 200 | call LagrangeInterpolation(xMesh(iLoc-1:iLoc+2), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 201 | 202 | elseif( (iLoc.LT.2).AND.(jLoc.LT.2) ) then 203 | !------Left&Bottom corner 204 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc, jLoc:jLoc+3), yInterpolated(j), tempU(1), order) 205 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc+1,jLoc:jLoc+3), yInterpolated(j), tempU(2), order) 206 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc+2,jLoc:jLoc+3), yInterpolated(j), tempU(3), order) 207 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc+3,jLoc:jLoc+3), yInterpolated(j), tempU(4), order) 208 | 209 | call LagrangeInterpolation(xMesh(iLoc:iLoc+3), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 210 | 211 | elseif( (iLoc.LT.2).AND.(jLoc.GT.meshY-2) ) then 212 | !------Left&Top corner 213 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc, jLoc-2:jLoc+1), yInterpolated(j), tempU(1), order) 214 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc+1,jLoc-2:jLoc+1), yInterpolated(j), tempU(2), order) 215 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc+2,jLoc-2:jLoc+1), yInterpolated(j), tempU(3), order) 216 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc+3,jLoc-2:jLoc+1), yInterpolated(j), tempU(4), order) 217 | 218 | call LagrangeInterpolation(xMesh(iLoc:iLoc+3), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 219 | 220 | elseif( (jLoc.LT.2).AND.(iLoc.GT.meshX-2) ) then 221 | !------Right&Bottom corner 222 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc-2, jLoc:jLoc+3), yInterpolated(j), tempU(1), order) 223 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc-1, jLoc:jLoc+3), yInterpolated(j), tempU(2), order) 224 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc, jLoc:jLoc+3), yInterpolated(j), tempU(3), order) 225 | call LagrangeInterpolation(yMesh(jLoc:jLoc+3), uMesh(iLoc+1,jLoc:jLoc+3), yInterpolated(j), tempU(4), order) 226 | 227 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+1), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 228 | 229 | elseif( (iLoc.GT.meshX-2).AND.(jLoc.GT.meshY-2) ) then 230 | !------Right&Top corner 231 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc-2, jLoc-2:jLoc+1), yInterpolated(j), tempU(1), order) 232 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc-1, jLoc-2:jLoc+1), yInterpolated(j), tempU(2), order) 233 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc, jLoc-2:jLoc+1), yInterpolated(j), tempU(3), order) 234 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+1), uMesh(iLoc+1,jLoc-2:jLoc+1), yInterpolated(j), tempU(4), order) 235 | 236 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+1), tempU(1:4), xInterpolated(i), uInterpolated(i,j), order) 237 | 238 | else 239 | write(*,*) "Check boundary..." 240 | write(*,*) "iLoc=,", iLoc, ", jLoc=", jLoc 241 | stop 242 | endif 243 | #endif 244 | 245 | #ifdef fifth_interpolation 246 | iLoc = locate(xMesh, xInterpolated(i), meshX) 247 | jLoc = locate(yMesh, yInterpolated(j), meshY) 248 | if( (iLoc.GE.3).AND.(jLoc.GE.3).AND.(iLoc.LE.meshX-3).AND.(jLoc.LE.meshY-3) ) then 249 | !--Bulk 250 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc-2, jLoc-2:jLoc+3), yInterpolated(j), tempU(1), order) 251 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc-1, jLoc-2:jLoc+3), yInterpolated(j), tempU(2), order) 252 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc, jLoc-2:jLoc+3), yInterpolated(j), tempU(3), order) 253 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+1,jLoc-2:jLoc+3), yInterpolated(j), tempU(4), order) 254 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+2,jLoc-2:jLoc+3), yInterpolated(j), tempU(5), order) 255 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+3,jLoc-2:jLoc+3), yInterpolated(j), tempU(6), order) 256 | 257 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+3), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 258 | 259 | elseif( (iLoc.LT.3).AND.(jLoc.GE.3).AND.(jLoc.LE.meshY-3) ) then 260 | !----Left wall 261 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc, jLoc-2:jLoc+3), yInterpolated(j), tempU(1), order) 262 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+1,jLoc-2:jLoc+3), yInterpolated(j), tempU(2), order) 263 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+2,jLoc-2:jLoc+3), yInterpolated(j), tempU(3), order) 264 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+3,jLoc-2:jLoc+3), yInterpolated(j), tempU(4), order) 265 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+4,jLoc-2:jLoc+3), yInterpolated(j), tempU(5), order) 266 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+5,jLoc-2:jLoc+3), yInterpolated(j), tempU(6), order) 267 | 268 | call LagrangeInterpolation(xMesh(iLoc:iLoc+5), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 269 | 270 | elseif( (iLoc.GE.3).AND.(jLoc.LT.3).AND.(iLoc.LE.meshX-3) ) then 271 | !----Bottom wall 272 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc-2, jLoc:jLoc+5), yInterpolated(j), tempU(1), order) 273 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc-1, jLoc:jLoc+5), yInterpolated(j), tempU(2), order) 274 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc, jLoc:jLoc+5), yInterpolated(j), tempU(3), order) 275 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+1,jLoc:jLoc+5), yInterpolated(j), tempU(4), order) 276 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+2,jLoc:jLoc+5), yInterpolated(j), tempU(5), order) 277 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+3,jLoc:jLoc+5), yInterpolated(j), tempU(6), order) 278 | 279 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+3), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 280 | 281 | elseif( (jLoc.GE.3).AND.(iLoc.GT.meshX-3).AND.(jLoc.LE.meshY-3) ) then 282 | !----Right wall 283 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc-4, jLoc-2:jLoc+3), yInterpolated(j), tempU(1), order) 284 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc-3, jLoc-2:jLoc+3), yInterpolated(j), tempU(2), order) 285 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc-2, jLoc-2:jLoc+3), yInterpolated(j), tempU(3), order) 286 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc-1, jLoc-2:jLoc+3), yInterpolated(j), tempU(4), order) 287 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc, jLoc-2:jLoc+3), yInterpolated(j), tempU(5), order) 288 | call LagrangeInterpolation(yMesh(jLoc-2:jLoc+3), uMesh(iLoc+1,jLoc-2:jLoc+3), yInterpolated(j), tempU(6), order) 289 | 290 | call LagrangeInterpolation(xMesh(iLoc-4:iLoc+1), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 291 | 292 | elseif( (iLoc.GE.3).AND.(iLoc.LE.meshX-3).AND.(jLoc.GT.meshY-3) ) then 293 | !----Top wall 294 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc-2, jLoc-4:jLoc+1), yInterpolated(j), tempU(1), order) 295 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc-1, jLoc-4:jLoc+1), yInterpolated(j), tempU(2), order) 296 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc, jLoc-4:jLoc+1), yInterpolated(j), tempU(3), order) 297 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+1,jLoc-4:jLoc+1), yInterpolated(j), tempU(4), order) 298 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+2,jLoc-4:jLoc+1), yInterpolated(j), tempU(5), order) 299 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+3,jLoc-4:jLoc+1), yInterpolated(j), tempU(6), order) 300 | 301 | call LagrangeInterpolation(xMesh(iLoc-2:iLoc+3), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 302 | 303 | elseif( (iLoc.LT.3).AND.(jLoc.LT.3) ) then 304 | !------Left&Bottom corner 305 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc, jLoc:jLoc+5), yInterpolated(j), tempU(1), order) 306 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+1,jLoc:jLoc+5), yInterpolated(j), tempU(2), order) 307 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+2,jLoc:jLoc+5), yInterpolated(j), tempU(3), order) 308 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+3,jLoc:jLoc+5), yInterpolated(j), tempU(4), order) 309 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+4,jLoc:jLoc+5), yInterpolated(j), tempU(5), order) 310 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+5,jLoc:jLoc+5), yInterpolated(j), tempU(6), order) 311 | 312 | call LagrangeInterpolation(xMesh(iLoc:iLoc+5), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 313 | 314 | elseif( (iLoc.LT.3).AND.(jLoc.GT.meshY-3) ) then 315 | !------Left&Top corner 316 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc, jLoc-4:jLoc+1), yInterpolated(j), tempU(1), order) 317 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+1,jLoc-4:jLoc+1), yInterpolated(j), tempU(2), order) 318 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+2,jLoc-4:jLoc+1), yInterpolated(j), tempU(3), order) 319 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+3,jLoc-4:jLoc+1), yInterpolated(j), tempU(4), order) 320 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+4,jLoc-4:jLoc+1), yInterpolated(j), tempU(5), order) 321 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+5,jLoc-4:jLoc+1), yInterpolated(j), tempU(6), order) 322 | 323 | call LagrangeInterpolation(xMesh(iLoc:iLoc+5), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 324 | 325 | elseif( (jLoc.LT.3).AND.(iLoc.GT.meshX-3) ) then 326 | !------Right&Bottom corner 327 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc-4, jLoc:jLoc+5), yInterpolated(j), tempU(1), order) 328 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc-3, jLoc:jLoc+5), yInterpolated(j), tempU(2), order) 329 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc-2, jLoc:jLoc+5), yInterpolated(j), tempU(3), order) 330 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc-1, jLoc:jLoc+5), yInterpolated(j), tempU(4), order) 331 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc, jLoc:jLoc+5), yInterpolated(j), tempU(5), order) 332 | call LagrangeInterpolation(yMesh(jLoc:jLoc+5), uMesh(iLoc+1,jLoc:jLoc+5), yInterpolated(j), tempU(6), order) 333 | 334 | call LagrangeInterpolation(xMesh(iLoc-4:iLoc+1), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 335 | 336 | elseif( (iLoc.GT.meshX-3).AND.(jLoc.GT.meshY-3) ) then 337 | !------Right&Top corner 338 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc-4, jLoc-4:jLoc+1), yInterpolated(j), tempU(1), order) 339 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc-3, jLoc-4:jLoc+1), yInterpolated(j), tempU(2), order) 340 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc-2, jLoc-4:jLoc+1), yInterpolated(j), tempU(3), order) 341 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc-1, jLoc-4:jLoc+1), yInterpolated(j), tempU(4), order) 342 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc, jLoc-4:jLoc+1), yInterpolated(j), tempU(5), order) 343 | call LagrangeInterpolation(yMesh(jLoc-4:jLoc+1), uMesh(iLoc+1,jLoc-4:jLoc+1), yInterpolated(j), tempU(6), order) 344 | 345 | call LagrangeInterpolation(xMesh(iLoc-4:iLoc+1), tempU(1:6), xInterpolated(i), uInterpolated(i,j), order) 346 | 347 | else 348 | write(*,*) "Check boundary..." 349 | write(*,*) "iLoc=,", iLoc, ", jLoc=", jLoc 350 | stop 351 | endif 352 | #endif 353 | 354 | errorL1= errorL1+dabs(uInterpolated(i,j)-dsin(xInterpolated(i))*dcos(yInterpolated(j))) 355 | errorL2 = errorL2+(uInterpolated(i,j)-dsin(xInterpolated(i))*dcos(yInterpolated(j)))**2.0d0 356 | errorNum = errorNum+1 357 | 358 | endif 359 | enddo 360 | enddo 361 | 362 | #ifdef outputData 363 | open(unit=03,file="interpolated.dat",status="unknown") 364 | write(03,*) 'TITLE="Lid Driven Cavity"' 365 | write(03,*) 'VARIABLES="X" "Y" "uInterpolated" ' 366 | write(03,101) particleX, particleY 367 | do j=1,particleY 368 | do i=1,particleX 369 | write(03,100) xInterpolated(i), yInterpolated(j), uInterpolated(i,j) 370 | enddo 371 | enddo 372 | close(03) 373 | #endif 374 | 375 | call CPU_TIME(finish) 376 | write(*,*) "Time (CPU) = ", real(finish-start), "s" 377 | write(*,*) "L1 error=", errorL1/dble(errorNum) 378 | write(*,*) "L2 error=", dsqrt(errorL2/dble(errorNum)) 379 | 380 | string = ctime( time() ) 381 | write(*,*) 'End: ', string 382 | 383 | stop 384 | end program main 385 | 386 | !--Given an array xx(1:N), and given a value x, returns a value j 387 | !----such that x is between xx(j) and xx(j+1). 388 | !----N = size(xx) 389 | !----xx must be monotonic, either increasing or decreasing. 390 | !----j=0 or j=N is returned to indicate that x is out of range 391 | function locate(xx, x, N) 392 | implicit none 393 | real(8) :: xx(1:N) 394 | real(8) :: x 395 | integer :: locate 396 | integer :: N, jLower, jMedium, jUpper 397 | logical :: ascnd 398 | 399 | ascnd = (xx(n).GE.xx(1)) 400 | jLower = 0 401 | jUpper = N+1 402 | do 403 | if((jUpper-jLower).LE.1) exit 404 | jMedium = (jUpper+jLower)/2 405 | if( ascnd.EQV.(x.GE.xx(jMedium)) ) then 406 | jLower = jMedium 407 | else 408 | jUpper = jMedium 409 | endif 410 | enddo 411 | if (x==xx(1)) then 412 | locate = 1 413 | elseif (x == xx(N)) then 414 | locate = N-1 415 | else 416 | locate = jLower 417 | endif 418 | 419 | end function locate 420 | 421 | 422 | subroutine LagrangeInterpolation(pointX, pointU, point0X, point0U, order) 423 | implicit none 424 | integer :: order 425 | real(8) :: pointX(1:order+1), pointU(1:order+1) 426 | real(8) :: point0X, point0U 427 | REAL(8) :: TEMP 428 | integer :: j, k 429 | 430 | point0U = 0.0d0 431 | do k=1,order+1 432 | temp = 1.0d0 433 | do j=1,order+1 434 | if(j.NE.K) temp=temp*(point0X-pointX(j))/(pointX(k)-pointX(j)) 435 | enddo 436 | point0U= point0U+temp*pointU(k) 437 | enddO 438 | 439 | return 440 | end subroutine LagrangeInterpolation 441 | 442 | --------------------------------------------------------------------------------