My IDE is:
Code::Blocks 20.3 ( compiler: mingw 9.2.0 )
The example code is:
module mod_close_file
implicit none
integer :: n_something
contains
function proc_calling() result(err_loc)
logical :: err_loc
err_loc = .false.
open( unit = 15, file = 'data_aa.txt', action = 'read', status = 'old', err = 100 )
read(15,*, err = 101) n_something
close(unit = 15, status = 'keep' )
return
100 write(*,'(5x,a)') "err_loc - proc_calling - reading format - 100"
err_loc = .true.
!close(unit = 15, status = 'keep' )
return
101 write(*,'(5x,a)') "err_loc - proc_calling - reading format - 101"
err_loc = .true.
!close(unit = 15, status = 'keep' )
end function proc_calling
end module mod_close_file
program close_file
use, non_intrinsic :: mod_close_file
implicit none
logical :: err_glo
err_glo = proc_calling()
if ( err_glo ) stop "err_glo - proc_calling"
end program close_file
In case that the value n_something in the specified file is not an integer the program will report an error. In that case, is it necessary to write the close command after the return command?
You are asking, if you need to close the file prior stopping execution or if it will be closed automatically?
Fortran 2008 Final Draft 9.5.7.1-6 (page 211):
During the completion step (2.3.5) of termination of execution of a program, all units that are connected are closed.
2.3.5-4 (page 33):
Normal termination of execution of an image is initiated when a STOP statement or end-program-stmt is executed.
So no you don't need to close it prior calling STOP, it should close without calling close. (personally I would do it anyway)
I have a function of some variables, which will yield an array consisted of both negative and positive values (Real). But since only positive values are physically meaningful to me, I want to set all negative values inside the array to be zero.
I have provided my code related to this function below:
The reason I declare a temporary variable 'res' is that I try to build in an IF-ELSE in the position I marked in code as follows:
If (res >= 0) Then
result = res
Else
result = 0
End If
But the error says a scalar-valued expression for S_A if required here.
If instead of res we use res(il,ir) is used,
If (res(il,ir) >= 0) Then
result(il,ir) = res(il,ir)
Else
result = 0
End If
the error says error #6351: The number of subscripts is incorrect.
Is there any way to implement this idea?
Function somefunction(x,y,il,ir) Result(result)
!! ---- begin of declaration ---------------------------
Implicit None
!! boundary indices
Integer, Intent ( in ) :: il,ir
!! the vars
Real ( kind = rk ), Intent ( in ), Dimension ( il:ir ) :: x,y
!! the result
Real ( kind = rk ), Dimension ( il:ir ) :: result
!! temp vars
Real ( kind = rk ), Dimension ( il:ir ) :: res
!! loop index
Integer :: i
!! ---- end of declaration -----------------------------
res = x+y
SA = S_A
!!IF-ELSE!!
End Function somefunction
If you want to have an if statement element wise on an array, you should use the where statement, for example:
program min0
implicit none
real :: res(5, 5), result(5, 5)
call random_number(res)
res=res-0.5
print '(5(F5.2,X))', res
where (res>=0)
result = res
elsewhere
result = 0
end where
print *, '---------------------------------------'
print '(5(F5.2,X))', result
end program min0
I don't know why you get a subscript error, it might help if you tell us which line of the code the error occurs. But of course in the second code, you update a single element of result if res is larger than 0, but set the whole array result to 0 if it isn't. This is almost certainly not what you want.
Cheers
The function appears to take in X and Y dimensioned from (il:if)... say from (3:6), so a vector. However the index later says (il,ir) which means it is a 2 dimensional array.
WHERE seems like a good choice. Another would be a logical MASK to associate the where-positions. It makes sense is PACK and unpack are usd,
Why even say what size the vectors are?
ELEMENTAL Function somefunction(x,y) Result(Res)
!! ---- begin of declaration ---------------------------
Implicit None
Real ( kind = rk ), Intent (IN), Dimension (:) :: x,y
!! the result
Real ( kind = rk ), Dimension ( il:ir ) :: res
!! loop index
Integer :: i
!! ---- end of declaration -----------------------------
res = x+y
WHERE res <= 0
Res = 0
ENDWHERE
!!IF-ELSE!!
End Function somefunction
Then on the calling side... call the function over the range of undecided you want.
Z(1:5) = somefunction(X(1:5),Y(1:5))
I have 4 .mtx files that I am reading the values from. Two of them run perfectly when read from with no issues and produce the correct outputs into a .DAT file. However, the last 2 are extremely large files; it appears the code correctly reads from the files and runs, but I get no outputs and no errors when reading from these 2...not even the code timer prints the time. Any help is much appreciated! Here is the code:
program proj2matrixC40
implicit none
integer,parameter::dp=selected_real_kind(15,307)
! Set Global Variables
real(kind=dp), allocatable::Ax(:,:),A(:,:),Iglobal(:,:)
integer::At(1,3)
integer::nnz,w,n,k,ii,ff,kk
real(kind=dp)::t1,t2
call cpu_time(t1)
open(unit=78,file="e40r5000.mtx",status='old')
read(78,*) At
close(unit=78)
nnz = At(1,3)
n = At(1,1)
k = 40
kk = 35
allocate(Ax(nnz+1,3),A(nnz,3),Iglobal(k,k))
open(unit=61,file="e40r5000.mtx",status='old')
do w=1,nnz+1
read(61,*) Ax(w,:)
end do
open (unit = 53, file = "proj2matrixC40points.dat")
do ff=1,k
do ii=1,k
Iglobal(ii,ff) = (ii/ff)*(ff/ii)
end do
end do
A(1:nnz,:) = Ax(2:nnz+1,:)
call Arno(A)
call cpu_time(t2)
print '("Time elapsed = ",f10.8," seconds")', (t2 - t1)
contains
subroutine Arno(a)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp),dimension(k,k)::H
real(kind=dp),dimension(k,k+1)::u,q,qconj
real(kind=dp),dimension(k,1)::x0
integer::j,f
call random_number(x0)
q(:,1) = x0(:,1)/norm2(x0(:,1))
do f=1,k
call spmat(a,q(:,f),u(:,f))
do j=1,f
qconj(j,:) = (q(:,j))
H(j,f) = dot_product(qconj(j,:),u(:,f))
u(:,f) = u(:,f) - H(j,f)*q(:,j)
end do
if (f.lt.k) then
H(f+1,f) = norm2(u(:,f))
if (H(f+1,f)==0) then
print *, "Matrix is reducible"
stop
end if
q(:,f+1) = u(:,f)/H(f+1,f)
end if
if (f==k) then
call qrit(H)
end if
end do
end subroutine
! QR Iteration with Shifts Subroutine
subroutine qrit(a)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp)::sigmak
real(kind=dp),dimension(kk,k)::dia
real(kind=dp),dimension(k,k)::Qfinal,Rfinal,HH
real(kind=dp),dimension(k,k,kk)::H0,needQR
integer::v,z
HH = a
H0(:,:,1) = HH
do v=1,kk
sigmak = H0(k,k,v)
if (v-1==0) then
needQR(:,:,v) = HH - sigmak*Iglobal
else
needQR(:,:,v) = H0(:,:,v-1) - sigmak*Iglobal
end if
call givens2(needQR(:,:,v),Rfinal,Qfinal)
H0(:,:,v) = matmul(Rfinal,Qfinal) + sigmak*Iglobal
do z = 1,k
dia(v,z) = H0(z,z,v)
write(53,*) v," ", dia(v,z) ! Write values to .DAT file
end do
end do
end subroutine
! Sparse Matrix Vector Multiplication Subroutine
subroutine spmat(a,b,c)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp), intent(in), dimension(k,1)::b
real(kind=dp), intent(out), dimension(k,1)::c
integer::m,rowi,columni
real(kind=dp), dimension(k,1)::x,y
x = b
y(:,1) = 0
do m = 1,nnz
rowi = a(m,1)
columni = a(m,2)
y(rowi,1) = y(rowi,1) + a(m,3)*x(columni,1)
end do
c(:,1) = y(:,1)
end subroutine
! QR Factorization Givens Rotations Subroutine
subroutine givens2(a,Rfinal,Qfinal)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp), dimension(k,k,(k*k))::G,QQ
real(kind=dp), dimension(k,k), intent(out)::Rfinal,Qfinal
real(kind=dp), dimension(k,k)::I2,y,aa
real(kind=dp), dimension(1,k)::ek1,ek2
real(kind=dp)::c,s
integer::kt,m,nn,j,i,l,p
m = size(a,1)
nn = size(a,2)
aa = a
i = 1
do kt=1,nn-1
do j=m,kt+1,-1
if (aa(j,kt).eq.0) then
continue
else
ek1(1,:) = 0
ek2(1,:) = 0
do p=1,m
do l=1,m
I2(l,p) = (l/p)*(p/l)
end do
end do
c = aa(kt,kt)/sqrt(aa(kt,kt)**2 + aa(j,kt)**2)
s = aa(j,kt)/sqrt(aa(kt,kt)**2 + aa(j,kt)**2)
ek1(1,kt) = c
ek1(1,j) = s
ek2(1,kt) = -s
ek2(1,j) = c
I2(kt,:) = ek1(1,:)
I2(j,:) = ek2(1,:)
G(:,:,i) = I2
if (i.eq.1) then
QQ(:,:,i) = G(:,:,i)
else
QQ(:,:,i) = matmul(G(:,:,i),QQ(:,:,i-1))
end if
y = matmul(G(:,:,i),aa)
aa = y
if (kt.eq.nn-1) then
if (j.eq.kt+1) then
Qfinal = transpose(QQ(:,:,i))
Rfinal = aa
end if
end if
i = i + 1
end if
end do
end do
end subroutine
end program proj2matrixC40
A couple notes. The line which I put asterisks around (for this question) call mat_print('H',H) can't be deleted otherwise I get the wrong answers (this is strange...thoughts?). Also so your computer won't freeze opening the big files, their names are 'e40r5000.mtx' and 's3dkt3m2.mtx' (these are the two I have issues with). I am using gfortran version 8.1.0
Here is the link to the files
https://1drv.ms/f/s!AjG0dE43DVddaJfY62ABE8Yq3CI
When you need to add a call to a subroutine that shouldn't actually change anything in order to get things working, you probably have a memory corruption. This happens most often when you access arrays outside of their boundaries.
I have compiled it with some run time checks:
gfortran -o p2m -g -O0 -fbacktrace -fcheck=all -Wall proj2mat.f90
And it's already giving me some issues:
It's warning me about implicit type conversions. That shouldn't be too much of an issue if you trust your data.
In line 46 you have an array length mismatch (x0(:, 1) has length 40, q(:,1) is 41)
Similarly on line 108 (x=b) x is really large, but b is only 41 long.
I have stopped now, but I implore you to go through your code and clean it up. Use the compiler options above which will let you know when and where there is an array bound violation.
I'm trying to read a four column data file. However, because I'm having so much trouble, I'm just trying to read a single column of integers. Here is my code:
program RFF_Simple
implicit none
! Variables
character(len = 100):: line_in
character(len = :), allocatable :: filename
integer, dimension(:), allocatable :: weight,numbers
real, dimension(:), allocatable :: fm, fc
integer :: iostat_1, iostat_2
integer :: lun, length, index
! Body of RFF_Simple
! filename = 'data.txt'
filename = 'data_test.txt'
iostat_1 = 0
iostat_2 = 0
length = 0
open(newunit = lun, file = filename, status = 'old', iostat = iostat_1)
!Count how many lines are in the file (length)
if (iostat_1 == 0) then
do while(iostat_2 == 0)
read(lun, '(a)', iostat = iostat_2) line_in
if (iostat_2 == 0) then
length= length + 1
endif
enddo
endif
rewind(lun)
allocate(numbers(length)) !Allocate arrays to have same length as number of lines
iostat_1 = 0 !Reset
iostat_2 = 0
index = 1 !This whole thing is confusing so I don't know whether starting from 1 or 0 is better....
if (iostat_1 == 0) then
do while(iostat_2 == 0)
if(iostat_2 == 0) then
read(lun,*, iostat = iostat_2) numbers(index) !This crashes the program (Severe 408)
index = index + 1
endif
enddo
endif
write(*,*) 'Press Enter to Exit'
read(*,*)
end program RFF_Simple
The code compiles no problem, but running it yields the following: http://imgur.com/a/6ciJS
Yes I that is a print screen.
I don't even know where to start with this one.
The problem here is that you increment index after each successful read. After the last successful read we have index=length. You then add 1 to index and then attempt to read numbers(length+1) which results in a bounds violation. Rather than looping with a do while you can just use a regular do loop since we know the number of lines to read.
do index = 1, length
read(lun,*) numbers(index)
enddo
You could also test whether index is greater than length and bail out of the loop.
I have a fortran project linked to various subroutines, which are called from the main program. Variables are passed using modules. I can compile the code without any error. When I run the code, during the subroutine call i get an error "attempt to call a routine with argument number three as a real(kind =1) when procedure was required. I am not sure where i am going wrong. Can someone point out the error? Your help is very much appreciated. The error appears when the subroutine 'ncalc' is called inside the loop
program partbal
use const
use times
use density
use parameters
use rateconst
use ploss
implicit none
integer :: i
real :: nclp_init, ncl2p_init, ncln_init, ne_init
real :: ncl_init, ncl2_init, Te_init, neTe_init
open (10,file='in.dat')
read (10,*)
read (10,*) pressure
read (10,*)
read (10,*) P, pfreq, duty
read (10,*)
read (10,*) nclp_init, ncl2p_init, ncln_init, Te_init, Ti
pi = 3.14159265
R = 0.043
L = 0.1778
Al = 2*pi*R*R
Ar = 2*pi*R*L
V = pi*R*R*L
S = 0.066
e = 1.6e-19
me = 9.1e-31
mCl = 35.5/(6.023e26)
mCl2 = 2*mCl
k = 1.3806e-23
vi = (3*Ti*e/(53.25/6.023e26))**0.5
ncl2_init = pressure*0.1333/(1.3806e-23*298)/2
ncl_init = ncl2_init
ne_init = nclp_init + ncl2p_init - ncln_init
tot_time = 1/(pfreq*1000)
off_time = duty*tot_time
npoints = 10000
dt = tot_time/npoints
neTe_init = ne_init*Te_init
t_step = 0
call kcalc(Te_init)
call param(nclp_init, ncl2p_init, ncln_init, ne_init, ncl_init,ncl2_init, Te_init, Ti)
do i = 1, npoints, 1
t_step = i*dt + t_step
if (t_step > 0 .and. t_step <= 500) then
Pabs = 500
else if (t_step > 500) then
Pabs = 0
end if
if (i <= 1) then
call ncalc(ne_init, ncl_init, ncl2_init, nclp_init, ncln_init, ncl2p_init)
call powerloss(ne_init, ncl_init, ncl2_init, Pabs, neTe_init)
Te = neTe/ne
call kcalc(Te)
call param(nclp, ncl2p, ncln, ne, ncl, ncl2, Te, Ti)
else
call ncalc(ne, ncl, ncl2, nclp, ncln, ncl2p)
call powerloss(ne, ncl, ncl2, Pabs, neTe)
Te = neTe/ne
call kcalc(Te)
call param(nclp, ncl2p, ncln, ne, ncl, ncl2, Te, Ti)
end if
!open( 70, file = 'density.txt' )
!open( 80, file = 'Te.txt')
!do i = 1, 1001, 1
! np(i) = ncl2p(i) + nclp(i)
!write (70, *) ncl(i), ncl2(i), ncl2p(i), nclp(i), np(i), ncln(i), ne(i)
!close(70)
!write (80, *) Te(i), phi(i)
!close(80)
!end do
end do
end program partbal
subroutine ncalc(n_e, n_cl, n_cl2, n_clp, n_cln, n_cl2p)
use parameters
use const
use density
use rateconst
use times
implicit none
real :: n_e, n_cl, n_cl2, n_clp, n_cln, n_cl2p
nclp = (((kCliz*n_e*n_cl)+((kpair+kdisiz)*n_e*n_cl2)-(5e-14*n_clp*n_cln)-(S*n_clp/V)-((hlclp*Al+hrclp*Ar)*n_clp*ubclp))*dt)+n_clp
ncl2p = (((kCl2iz*n_e*n_cl2)-(5e-14*n_cl2p*n_cln) - (((hlcl2p*Al + hrcl2p*Ar)*n_cl2p*ubcl2p)/V)-(S*n_cl2p/V))*dt)+n_cl2p
ncln = ((((katt+kpair)*n_e*n_cl2)-(5e-14*n_clp*n_cln)-(5e-14*n_cl2p*n_cln)-(kdet*n_e*n_cln)-(S*n_cln/V)-(taun*(Al+Ar)/V))*dt)+n_cln
ne = ncl2p+nclp-ncln
ncl = ((((2*kdis+katt+kdisiz)*n_e*n_cl2)-(kCliz*n_e*n_cl)+(5e-14*n_cl2p *n_cln)+(2*5e-14*n_clp*n_cln)+ (kdet*n_e*n_cln) - (300*n_cl) + ((hlclp*Al + hrclp*Ar)*n_clp*ubclp/V)-(S*n_cl/V))*dt)+n_cl
ncl2 = ((n_cl2(1) + (5e-14*n_cl2p*n_cln) - ((kCl2iz+kdis+katt+kpair+kdisiz)*n_e*n_cl2) + (0.5*300*n_cl) + ((hlcl2p*Al + hrcl2p*Ar)*n_cl2p*ubcl2p/V)-(S*n_cl2/V))*dt)+n_cl2
return
end subroutine ncalc
In the line in subroutine ncalc immediately before the return statement, you have a reference to n_cl2(1) very early in the right hand side of the assignment statement. n_cl2 has not been declared as an array, therefore the compiler assumes that it must be a reference to a function that takes a single default integer argument. Because n_cl2 is a dummy argument, the it then expects you to provide a function for the corresponding actual argument when the routine is called.
(How your compiler manages to compile the preceding references to n_cl2 is a bit of a mystery - I suspect this error violates the syntax rules and hence you should see some sort of compile time diagnostic.)
Given you are using modules, it seems odd that you have not placed the ncalc routine in a module. If you did so, the error would probably become a compile time error rather than a runtime.