I'm using a Fortran 90 script below to solve a partial differential equation using iterative method, but I have one issue about the structure of the program. If I use a subroutine called by the program the solution converge properly, but if I just put the calculations inside of the iterations the solution does not converge.
Here is the program that does not work:
...
DO IT = 2,ITMAX
DO I = 1,IMAX
PHIN(IT-1,I,1) = PHIN(IT-1,I,2) - (Y(2) - Y(1))*UINF*PHIY(I)
END DO
PHIN(IT,I,1) = PHIN(IT-1,I,1)
DO J = 2,JMAX-1
DO I = 2,IMAX-1
LPHI(I,J) = AX(I)*PHIN(IT-1,I-1,J) - &
BX(I)*PHIN(IT-1,I,J) + &
CX(I)*PHIN(IT-1,I+1,J) + &
AY(J)*PHIN(IT-1,I,J-1) - &
BY(J)*PHIN(IT-1,I,J) + &
CY(J)*PHIN(IT-1,I,J+1)
ENDDO
ENDDO
!
! SELECT CASE(SOL)
! CASE(1)
! CALL NPJ()
! CASE(2)
! CALL NPGS()
! CASE(3)
! CALL NSOR()
! END SELECT
DO J = 2,JMAX-1
DO I = 2,IMAX-1
C(I,J) = 1/(2*(DELTAX(I)**2 + DELTAY(J)**2))* &
(((DELTAX(I)*DELTAY(J))**2)*LPHI(I,J) + &
(PHIN(IT,I-1,J) - PHIN(IT-1,I-1,J))*DELTAY(J) + &
(PHIN(IT,I,J-1) - PHIN(IT-1,I,J-1))*DELTAX(I))
END DO
END DO
PHIN(IT,:,:) = PHIN(IT-1,:,:) + C(:,:)
RESI(IT) = MAXVAL(ABS(LPHI(:,:)))
IF (RESI(IT)<EPS) THEN
ITVALUE = IT
EXIT
ENDIF
LPHI(:,:) = 0
WRITE(*,*) IT,RESI(IT)
ENDDO
...
and the solution that works fine,
...
DO IT = 2,ITMAX
DO I = 1,IMAX
PHIN(IT-1,I,1) = PHIN(IT-1,I,2) - (Y(2) - Y(1))*UINF*PHIY(I)
END DO
PHIN(IT,I,1) = PHIN(IT-1,I,1)
DO J = 2,JMAX-1
DO I = 2,IMAX-1
LPHI(I,J) = AX(I)*PHIN(IT-1,I-1,J) - &
BX(I)*PHIN(IT-1,I,J) + &
CX(I)*PHIN(IT-1,I+1,J) + &
AY(J)*PHIN(IT-1,I,J-1) - &
BY(J)*PHIN(IT-1,I,J) + &
CY(J)*PHIN(IT-1,I,J+1)
ENDDO
ENDDO
SELECT CASE(SOL)
CASE(1)
CALL NPJ()
CASE(2)
CALL NPGS()
CASE(3)
CALL NSOR()
END SELECT
PHIN(IT,:,:) = PHIN(IT-1,:,:) + C(:,:)
RESI(IT) = MAXVAL(ABS(LPHI(:,:)))
IF (RESI(IT)<EPS) THEN
ITVALUE = IT
EXIT
ENDIF
LPHI(:,:) = 0
WRITE(*,*) IT,RESI(IT)
ENDDO
...
subroutIne NPGS()
use var_mesh
use var_solve
C(:,:) = 0
DO J = 2,JMAX-1
DO I = 2,IMAX-1
C(I,J) = 1/(2*(DELTAX(I)**2 + DELTAY(J)**2))* &
(((DELTAX(I)*DELTAY(J))**2)*LPHI(I,J) + &
(PHIN(IT,I-1,J) - PHIN(IT-1,I-1,J))*DELTAY(J) + &
(PHIN(IT,I,J-1) - PHIN(IT-1,I,J-1))*DELTAX(I))
END DO
END DO
RETURN
END SUBROUTINE NPGS
Can someone explain what is the main difference and why both programs are different?
Assigning C = 0 helps the script in the convergence, but I found what was the error, I assign just one part of the boundary condition in the program in this line:
PHIN(IT,I,1) = PHIN(IT-1,I,1)
but the correct way is to the entirely matrix and:
PHIN(IT,:,:) = PHIN(IT-1,:,:)
Related
Recently I want to reproduce the Fig.1(a) of Edge States and Topological Invariants of Non-Hermitian Systems.I used cgeev to solve eigenvalue of non-Hermitian Hamiltonian matrices，I found the solution become wired.
Here is my Fortran code,the result to Fig1.(a) correspond the abs.dat.
module pub
implicit none
complex,parameter::im = (0.0,1.0)
real,parameter::pi = 3.1415926535
integer xn,N,en,kn
parameter(xn = 100,N = xn*2,en = 100)
complex Ham(N,N)
real t1,t2,t3,gam
!-----------------
integer::lda = N
integer,parameter::lwmax=2*N + N**2
complex,allocatable::w(:) ! store eigenvalues
complex,allocatable::work(:)
real,allocatable::rwork(:)
integer lwork
integer info
integer LDVL, LDVR
parameter(LDVL = N, LDVR = N )
complex VL( LDVL, N ), VR( LDVR, N )
end module pub
!=====================================================
program sol
use pub
! Physics memory allocate
allocate(w(N))
allocate(work(lwmax))
allocate(rwork(2*N))
!-----------------
t2 = 1.0
t3 = 0.0
gam = 3.0/4.0
call band()
end program sol
!======================================================
subroutine band()
use pub
integer m1,i
open(11,file="real.dat")
open(12,file="imag.dat")
open(13,file="abs.dat")
do m1 = -en,en
t1 = 3.0*m1/en
call matset()
call eigsol()
write(11,999)t1,(real(w(i)),i = 1,N)
write(12,999)t1,(aimag(w(i)),i = 1,N)
write(13,999)t1,(abs(w(i)),i = 1,N)
end do
close(11)
close(12)
close(13)
999 format(201f11.6)
end subroutine band
!======================================================
subroutine matset()
use pub
real kx
complex sx(2,2),sy(2,2),sz(2,2)
integer k,m1,m2
sx(1,2) = 1.0
sx(2,1) = 1.0
sy(1,2) = -im
sy(2,1) = im
sz(1,1) = 1.0
sz(2,2) = -1.0
!--------
Ham = 0.0
do k = 0,xn-1
if(k == 0)then
do m1 = 1,2
do m2 = 1,2
ham(m1,m2) = t1*sx(m1,m2) + im*gam/2.0*sy(m1,m2)
ham(m1,m2 + 2) = (t2 + t3)/2.0*sx(m1,m2) - im*(t2 - t3)/2.0*sy(m1,m2)
end do
end do
elseif(k == xn-1)then
do m1 = 1,2
do m2 = 1,2
ham(k*2 + m1,k*2 + m2) = t1*sx(m1,m2) + im*gam/2.0*sy(m1,m2)
ham(k*2 + m1,k*2 + m2 - 2) = (t2 + t3)/2.0*sx(m1,m2) + im*(t2 - t3)/2.0*sy(m1,m2)
end do
end do
else
do m1 = 1,2
do m2 = 1,2
ham(k*2 + m1,k*2 + m2) = t1*sx(m1,m2) + im*gam/2.0*sy(m1,m2)
! right hopping
ham(k*2 + m1,k*2 + m2 + 2) = (t2 + t3)/2.0*sx(m1,m2) - im*(t2 - t3)/2.0*sy(m1,m2)
! left hopping
ham(k*2 + m1,k*2 + m2 - 2) = (t2 + t3)/2.0*sx(m1,m2) + im*(t2 - t3)/2.0*sy(m1,m2)
end do
end do
end if
end do
return
end subroutine matset
!==============================================================================
subroutine eigsol()
use pub
! Query the optimal workspace.
LWORK = -1
CALL cgeev( 'Vectors', 'Vectors', N, Ham, LDA, W, VL, LDVL, VR, LDVR, WORK, LWORK, RWORK, INFO)
LWORK = MIN( LWMAX, INT( WORK( 1 ) ) )
! Solve eigenproblem.
CALL cgeev( 'Vectors', 'Vectors', N, Ham, LDA, W, VL, LDVL,VR, LDVR, WORK, LWORK, RWORK, INFO)
! Check for convergence.
IF( INFO.GT.0 ) THEN
WRITE(*,*)'The algorithm failed to compute eigenvalues.'
STOP
END IF
! open(120,file="eigval.dat")
! do m = 1,N
! write(120,*)m,w(m)
! end do
! close(120)
return
end subroutine eigsol
If I used wrong function from Lapack or my code isn't correct.
I use intel fortran,complie command is
*ifort -mkl file.f90 -o a.out
Run program ./a.out&*
I have a fortran code that computes the solution vector using the thomas algorithm subroutine.
I want the solution vector to run in a loop for a certain number of time.
How do i call this subroutine in the loop?
my subroutine is the thomas algorithm subroutine.
It returns the solution vector u but I want it to use the vectors NN times in a loop. So the old u becomes the new u to use in the subroutine.
How do I do this?
Below is the what i tried
program thomasalg2
implicit double precision(A-H,O-Z)
real*8, dimension(9,1) :: a,b,c,r,u,uold!the dimension is subject to change depending on the size of the new matrix
!real*8, dimension(9,50) :: W
real*8 :: pi
real*8 :: h,k,lm,l,T
integer :: i,j,al,NN,n
l = 1!right endpoint on the X-axis
n = 9 !number of rols/cols of the coefficient matrix with boundaries included
T = 0.5 !maximum number of the time variable
NN = 50!number of time steps
np = n
h = l/n
k = T/NN
al = 1.0D0 !alpha
pi = dacos(-1.0D0)
lm = (al**2)*(k/(h**2)) !lambda
do i = 1,n
r(i,1) = sin(pi*i*h) !this is W_0
end do
a(1,1) = 0.0D0
do i = 2,n
a(i,1) = -lm
end do
do i = 1,n
b(i,1) = 1 + (2*lm)
end do
c(9,1) = 0.0D0
do i = 1,n-1
c(i,1) = -lm
end do
!the 3 diagonals are stored in the 1st, 2nd, 3rd & 4th files respectively.
open(10, file = 'thom1.txt')
open(11, file = 'thom2.txt')
open(12, file = 'thom3.txt')
open(13, file = 'thom4.txt')
write(10,*)
do i = 1,n
write(10,*) a(i,1)
end do
write(11,*)
do i = 1,n
write(11,*) b(i,1)
end do
write(12,*)
do i = 1,n
write(12,*) c(i,1)
end do
write(13,*)
do i = 1,n
write(13,*) r(i,1)
end do
open(14, file = 'tridag2.txt')
write(14,*)
n = 9
do i = 1,n
write(14,*) a(i,1),b(i,1),c(i,1),r(i,1) !write the given vectors in the file in the form of a column vector
end do
call tridag(a,b,c,r,u,n)
!solve the given system and return the solution vector u
do i = 1,NN
call tridag(a,b,c,r,u,n)
!write(15,*) u
r = u
end do
open(15, file = 'tridag2u.txt')
write(15,*)
!write the solution vector in the form of a column vector
do i = 1,n
write(15,*) u(i,1)
end do
!print *, "Your data has been written in 'tridag2.txt'"
end program thomasalg2
subroutine tridag(a,b,c,r,u,n)
implicit double precision (A-H, O-Z)
integer n, NMAX
real*8 a(n), b(n), c(n), r(n), u(n)
parameter (NMAX = 500)
integer j
real*8 bet, gam(NMAX)
if(b(1).eq.0.) stop "tridag: rewrite equations"
bet = b(1)
u(1)=r(1)/bet
do j = 2,n
gam(j) = c(j-1)/bet
bet = b(j)-a(j)*gam(j)
if (bet.eq.0.) stop "tridag failed"
u(j) = (r(j)-a(j)*u(j-1))/bet
end do
do j = n-1,1,-1
u(j) = u(j)-gam(j+1)*u(j+1)
end do
!print *, "The solution is", u
return
end subroutine
I am trying to increase the number of possible steps in the following Fortran self avoiding random walk program.
Increasing the number of steps would result in more accuracy regarding the square mean distance
I would appropriate your solutions and suggestions.
PROGRAM Two_dimensional_Self_Avoiding__Random_Walks
implicit none
integer, dimension(:,:), allocatable :: lattice
integer, dimension(1:46):: na
integer :: i,x,y,xt,yt,id,step,xx, ns,n,ii,III,choice
real :: r,dis,dis2,square,d,d2
Logical :: terminate,newsite
CALL RANDOM_SEED()
! intial values for end to end distance
read(*,*) choice
if (choice == 1) then
print*, ' Enter ns and n '
read(*,*) ns
na = (/(III, III=5, 50, 1)/)
do ii= 1, 46
dis = 0.0; dis2 = 0.0
n = na(ii)
allocate(lattice(-n:n,-n:n))
CALL walks() ! self avoiding walks
IF (ALLOCATED (lattice)) DEALLOCATE (lattice)
enddo
elseif (choice == 2) then
print*, ' Enter ns and n '
read(*,*) ns , n
dis = 0.0; dis2 = 0.0
allocate(lattice(-n:n,-n:n))
CALL walks()
endif
CONTAINS
SUBROUTINE walks
DO i = 1,ns
lattice = 0; x = 0; y = 0
step = 0; terminate = .FALSE.
DO WHILE ((.NOT. terminate) .AND. (step <= n))
xt = x; yt = y
xx = lattice(x+1,y)+lattice(x-1,y) &
+lattice(x,y+1)+lattice(x,y-1)
IF (xx == 4) THEN
terminate = .TRUE.
ELSE
newsite = .FALSE.
DO WHILE (.NOT. newsite)
CALL RANDOM_NUMBER(r)
id = INT(r*4.0)
IF (id == 0) THEN
x = xt + 1; y = yt
ELSEIF (id == 1) THEN
x = xt - 1; y = yt
ELSEIF (id == 2) THEN
x = xt; y = yt + 1
ELSEIF (id == 3) THEN
x = xt; y = yt - 1
ENDIF
IF (lattice(x,y) == 0) newsite = .TRUE.
ENDDO
step = step + 1; lattice(x,y) = 1
ENDIF
write(7,*) x,y
ENDDO
write(10,*),step
square = float(x**2+y**2)
dis = dis + sqrt(square); dis2 = dis2 + square
d = dis/ns; d2=dis2/ns
ENDDO
write(11,*), ns,n, d, d2
print*, ns,n, d, d2
END SUBROUTINE walks
END PROGRAM Two_dimensional_Self_Avoiding__Random_Walks
The following is a program for self avoiding random walk. The program works fine but I need to make a minor modification but I do not know how.
Currently the program receives n and ns as inputs and then calculates a distance (dis). I want the program to receive more than one n and calculate the distance for each n.
Example of current output
n = 100 ns = 100 dis = 10.8
I want the program to output
n = 100 ns = 100 dis = 10.8
n = 200 ns = 100 dis = 11.6
and go on for all input vales of n.
This can be done by running the program every time with different n but I need to do it with one run.
PROGRAM Two_dimensional_Self_Avoiding__Random_Walks
implicit none
integer, dimension(:,:), allocatable :: lattice
integer :: i,x,y,xt,yt,id,step,xx, ns,n
real :: r,dis,dis2,square,d,d2
Logical :: terminate,newsite
print*, ' Enter ns and n '
read(*,*) ns,n
allocate(lattice(-n:n,-n:n))
CALL RANDOM_SEED()
dis = 0.0; dis2 = 0.0 ! intial values for end to end distance
CALL walks() ! self avoiding walks
dis = dis/float(ns); dis2 = dis2/float(ns)
print*,ns,n,dis,dis2
CONTAINS
SUBROUTINE walks
DO i = 1,ns
lattice = 0; x = 0; y = 0
step = 0; terminate = .FALSE.
!do ii = 1, n
DO WHILE ((.NOT. terminate) .AND. (step <= n))
xt = x; yt = y
xx = lattice(x+1,y)+lattice(x-1,y) &
+lattice(x,y+1)+lattice(x,y-1)
IF (xx == 4) THEN
terminate = .TRUE.
ELSE
newsite = .FALSE.
DO WHILE (.NOT. newsite)
CALL RANDOM_NUMBER(r)
id = INT(r*4.0)
IF (id == 0) THEN
x = xt + 1; y = yt
ELSEIF (id == 1) THEN
x = xt - 1; y = yt
ELSEIF (id == 2) THEN
x = xt; y = yt + 1
ELSEIF (id == 3) THEN
x = xt; y = yt - 1
ENDIF
IF (lattice(x,y) == 0) newsite = .TRUE.
ENDDO
step = step + 1; lattice(x,y) = 1
ENDIF
write(10,*),step
!print*, x,y
write(7,*) x,y
ENDDO
square = float(x**2+y**2)
dis = dis + sqrt(square); dis2 = dis2 + square
d = dis/ns; d2=dis2/ns
write(8,*) step, d, d2
!enddo
ENDDO
END SUBROUTINE walks
END PROGRAM Two_dimensional_Self_Avoiding__Random_Walks
I was writing code to use Fortran Eispack routines (compute eigenvalues and eigenvectors, just to check if the values would be different from the ones I got from Matlab), but every time it calls the qzhes subroutine the program hangs.
I load matrixes from files.
Tried commenting the call, and it works without an issue.
I just learned Fortran, and with the help of the internet I wrote this code (which compiles and run):
program qz
IMPLICIT NONE
INTEGER:: divm, i, divg
INTEGER(kind=4) :: dimen
LOGICAL :: matz
REAL(kind = 8), DIMENSION(:,:), ALLOCATABLE:: ma
REAL(kind = 8), DIMENSION(:), ALLOCATABLE:: tabm
REAL(kind = 8), DIMENSION(:,:), ALLOCATABLE:: ga
REAL(kind = 8), DIMENSION(:), ALLOCATABLE:: tabg
REAL(kind = 8), DIMENSION(:,:), ALLOCATABLE:: zet
divm = 1
divg = 2
dimen = 20
matz = .TRUE.
ALLOCATE(ma(1:dimen,1:dimen))
ALLOCATE(tabm(1:dimen))
ALLOCATE(ga(1:dimen,1:dimen))
ALLOCATE(tabg(1:dimen))
OPEN(divm, FILE='Em.txt')
DO i=1,dimen
READ (divm,*) tabm
ma(1:dimen,i)=tabm
END DO
CLOSE(divm)
OPEN(divg, FILE='Gje.txt')
DO i=1,dimen
READ (divg,*) tabg
ga(1:dimen,i)=tabg
END DO
CLOSE(divg)
call qzhes(dimen, ma, ga, matz, zet)
OPEN(divm, FILE='Em2.txt')
DO i=1,dimen
tabm = ma(1:dimen,i)
WRITE (divm,*) tabm
END DO
CLOSE(divm)
OPEN(divg, FILE='Gje2.txt')
DO i=1,dimen
tabg = ga(1:dimen,i)
WRITE (divg,*) tabg
END DO
CLOSE(divg)
end program qz
...//EISPACK subrotines//...
Matrixes:
Gje.txt:https://drive.google.com/file/d/0BxH3QOkswLy_c2hmTGpGVUI3NzQ/view?usp=sharing
Em.txt:https://drive.google.com/file/d/0BxH3QOkswLy_OEtJUGQwN3ZXX2M/view?usp=sharing
Edit:
subroutine qzhes ( n, a, b, matz, z )
!*****************************************************************************80
!
!! QZHES carries out transformations for a generalized eigenvalue problem.
!
! Discussion:
!
! This subroutine is the first step of the QZ algorithm
! for solving generalized matrix eigenvalue problems.
!
! This subroutine accepts a pair of real general matrices and
! reduces one of them to upper Hessenberg form and the other
! to upper triangular form using orthogonal transformations.
! it is usually followed by QZIT, QZVAL and, possibly, QZVEC.
!
! Licensing:
!
! This code is distributed under the GNU LGPL license.
!
! Modified:
!
! 18 October 2009
!
! Author:
!
! Original FORTRAN77 version by Smith, Boyle, Dongarra, Garbow, Ikebe,
! Klema, Moler.
! FORTRAN90 version by John Burkardt.
!
! Reference:
!
! James Wilkinson, Christian Reinsch,
! Handbook for Automatic Computation,
! Volume II, Linear Algebra, Part 2,
! Springer, 1971,
! ISBN: 0387054146,
! LC: QA251.W67.
!
! Brian Smith, James Boyle, Jack Dongarra, Burton Garbow,
! Yasuhiko Ikebe, Virginia Klema, Cleve Moler,
! Matrix Eigensystem Routines, EISPACK Guide,
! Lecture Notes in Computer Science, Volume 6,
! Springer Verlag, 1976,
! ISBN13: 978-3540075462,
! LC: QA193.M37.
!
! Parameters:
!
! Input, integer ( kind = 4 ) N, the order of the matrices.
!
! Input/output, real ( kind = 8 ) A(N,N). On input, the first real general
! matrix. On output, A has been reduced to upper Hessenberg form. The
! elements below the first subdiagonal have been set to zero.
!
! Input/output, real ( kind = 8 ) B(N,N). On input, a real general matrix.
! On output, B has been reduced to upper triangular form. The elements
! below the main diagonal have been set to zero.
!
! Input, logical MATZ, should be TRUE if the right hand transformations
! are to be accumulated for later use in computing eigenvectors.
!
! Output, real ( kind = 8 ) Z(N,N), contains the product of the right hand
! transformations if MATZ is TRUE.
!
implicit none
integer ( kind = 4 ) n
real ( kind = 8 ) a(n,n)
real ( kind = 8 ) b(n,n)
integer ( kind = 4 ) i
integer ( kind = 4 ) j
integer ( kind = 4 ) k
integer ( kind = 4 ) l
integer ( kind = 4 ) l1
integer ( kind = 4 ) lb
logical matz
integer ( kind = 4 ) nk1
integer ( kind = 4 ) nm1
real ( kind = 8 ) r
real ( kind = 8 ) rho
real ( kind = 8 ) s
real ( kind = 8 ) t
real ( kind = 8 ) u1
real ( kind = 8 ) u2
real ( kind = 8 ) v1
real ( kind = 8 ) v2
real ( kind = 8 ) z(n,n)
!
! Set Z to the identity matrix.
!
if ( matz ) then
z(1:n,1:n) = 0.0D+00
do i = 1, n
z(i,i) = 1.0D+00
end do
end if
!
! Reduce B to upper triangular form.
!
if ( n <= 1 ) then
return
end if
nm1 = n - 1
do l = 1, n - 1
l1 = l + 1
s = sum ( abs ( b(l+1:n,l) ) )
if ( s /= 0.0D+00 ) then
s = s + abs ( b(l,l) )
b(l:n,l) = b(l:n,l) / s
r = sqrt ( sum ( b(l:n,l)**2 ) )
r = sign ( r, b(l,l) )
b(l,l) = b(l,l) + r
rho = r * b(l,l)
do j = l + 1, n
t = dot_product ( b(l:n,l), b(l:n,j) )
b(l:n,j) = b(l:n,j) - t * b(l:n,l) / rho
end do
do j = 1, n
t = dot_product ( b(l:n,l), a(l:n,j) )
a(l:n,j) = a(l:n,j) - t * b(l:n,l) / rho
end do
b(l,l) = - s * r
b(l+1:n,l) = 0.0D+00
end if
end do
!
! Reduce A to upper Hessenberg form, while keeping B triangular.
!
if ( n == 2 ) then
return
end if
do k = 1, n - 2
nk1 = nm1 - k
do lb = 1, nk1
l = n - lb
l1 = l + 1
!
! Zero A(l+1,k).
!
s = abs ( a(l,k) ) + abs ( a(l1,k) )
if ( s /= 0.0D+00 ) then
u1 = a(l,k) / s
u2 = a(l1,k) / s
r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
v1 = - ( u1 + r) / r
v2 = - u2 / r
u2 = v2 / v1
do j = k, n
t = a(l,j) + u2 * a(l1,j)
a(l,j) = a(l,j) + t * v1
a(l1,j) = a(l1,j) + t * v2
end do
a(l1,k) = 0.0D+00
do j = l, n
t = b(l,j) + u2 * b(l1,j)
b(l,j) = b(l,j) + t * v1
b(l1,j) = b(l1,j) + t * v2
end do
!
! Zero B(l+1,l).
!
s = abs ( b(l1,l1) ) + abs ( b(l1,l) )
if ( s /= 0.0 ) then
u1 = b(l1,l1) / s
u2 = b(l1,l) / s
r = sign ( sqrt ( u1**2 + u2**2 ), u1 )
v1 = -( u1 + r ) / r
v2 = -u2 / r
u2 = v2 / v1
do i = 1, l1
t = b(i,l1) + u2 * b(i,l)
b(i,l1) = b(i,l1) + t * v1
b(i,l) = b(i,l) + t * v2
end do
b(l1,l) = 0.0D+00
do i = 1, n
t = a(i,l1) + u2 * a(i,l)
a(i,l1) = a(i,l1) + t * v1
a(i,l) = a(i,l) + t * v2
end do
if ( matz ) then
do i = 1, n
t = z(i,l1) + u2 * z(i,l)
z(i,l1) = z(i,l1) + t * v1
z(i,l) = z(i,l) + t * v2
end do
end if
end if
end if
end do
end do
return
end
I would expand the allocation Process
integer :: status1, status2, status3, status4, status5
! check the allocation, returnvalue 0 means ok
ALLOCATE(ma(1:dimen,1:dimen), stat=status1)
ALLOCATE(tabm(1:dimen), stat=status2)
ALLOCATE(ga(1:dimen,1:dimen), stat=status3)
ALLOCATE(tabg(1:dimen), stat=status4)
ALLOCATE(zet(1:dimen,1:dimen), stat=status5)
And at the end of the Program deallocate all arrays, because, you maybe have no memoryleak now, but if you put this program into a subroutine and use it several time with big matricies during a programrun, the program could leak some serious memory.
....
DO i=1,dimen
tabg = ga(1:dimen,i)
WRITE (divg,*) tabg
END DO
CLOSE(divg)
DEALLOCATE(ma, stat=status1)
DEALLOCATE(tabm, stat=status2)
DEALLOCATE(ga, stat=status3)
DEALLOCATE(tabg, stat=status4)
DEALLOCATE(zet, stat=status5)
You can check again with the status integer, if the deallocation was ok, returnvalue again 0.