Related
This question already has answers here:
Strange Function Call behavior
(1 answer)
Ignoring the intrinsic gamma function with gfortran [duplicate]
(2 answers)
Closed 1 year ago.
The code I'm trying to compile is named gepol93 which was finished in 1994 with FORTRAN 77.
It's a program designed to compute some chemical properties of a molecule.
I tried to compile the file using the command gfortran GEPOL93.FOR but an error was raised:
EPOL93.FOR:598.72:
IF(LPR)CALL STAT(NCOR)
1
Error: Missing actual argument 'values' in call to 'stat' at (1)
I'm not familar with FORTRAN, and I guess that the code is too old to be compatible with the compiler on my computer.
What I'm certain about is that the code is definitely correct because it has never been modified by other people since 1994 (you can check this with ls -l) and many scholars are using it to conduct research nowadays.
But the question is how to compile the code into a .out file? Can anybody help me?
In the first subroutine PCOUNT, STAT is called.
SUBROUTINE PCOUNT(NATOM,NCOR,KSURF,LPR)
C -------------------------------------------------------------------
C This prints general counters
C -------------------------------------------------------------------
IMPLICIT NONE
LOGICAL FIRST
LOGICAL LPR
INTEGER*2 IUSE
INTEGER*4 I,IUC
INTEGER*4 J
INTEGER*4 MC,MI
INTEGER*4 NATOM,NCOR,NEWS
REAL*4 RE
REAL*4 XE
REAL*4 YE
REAL*4 ZE
CHARACTER*5 KSURF
PARAMETER (MC=100000,MI=6)
COMMON/CSFE/XE(MC),YE(MC),ZE(MC),RE(MC),IUSE(MC)
DIMENSION IUC(MI)
IF(LPR)WRITE(6,'(/A)')' ===> Start Subroutine Pcount '
NEWS=NCOR-NATOM
IF(KSURF.EQ.'ESURF')THEN
WRITE(6,'(3(A,I7/))')
& ' Number of INITIAL coordinates ',NATOM,
& ' Number of NEW coordinates ',NEWS,
& ' Number of TOTAL coordinates ',NCOR
ELSE
WRITE(6,'(A,I7/)')
& ' Number of TOTAL coordinates ',NCOR
END IF
IF(LPR)THEN
DO J=1,MI
IUC(J)=0
END DO
DO I=1,NATOM
J=IUSE(I)
IUC(J)=IUC(J)+1
END DO
FIRST=.TRUE.
DO J=1,MI
IF(IUC(J).NE.0)THEN
IF(FIRST)THEN
FIRST=.FALSE.
WRITE(6,'(A)')
& ' MORE INFORMATION ABOUT INITIAL SET OF COORDINATES'
END IF
WRITE(6,'(A,I2,A,I7)')
& ' Number of coordinates with IUSE ',J,'=',IUC(J)
END IF
END DO
IF(KSURF.EQ.'ESURF')THEN
DO J=1,MI
IUC(J)=0
END DO
DO I=NATOM+1,NCOR
J=IUSE(I)
IUC(J)=IUC(J)+1
END DO
FIRST=.TRUE.
DO J=1,MI
IF(IUC(J).NE.0)THEN
IF(FIRST)THEN
FIRST=.FALSE.
WRITE(6,'(A)')
& ' MORE INFORMATION ABOUT NEW SET OF COORDINATES'
END IF
WRITE(6,'(A,I2,A,I7)')
& ' Number of coordinates with IUSE ',J,'=',IUC(J)
END IF
END DO
END IF
IF(LPR)CALL STAT(NCOR)
END IF
RETURN
END
SUBROUTINE STAT(NCOR)
C -------------------------------------------------------------
C This prepares some statistics about the set of spheres
C -------------------------------------------------------------
IMPLICIT NONE
INTEGER*2 IUSE
INTEGER*4 CT6,CT4
INTEGER*4 I
INTEGER*4 J
INTEGER*4 MAXI,MC
INTEGER*4 NCOR,NINT
INTEGER*4 TMIN,TMAX
REAL*4 C
REAL*4 R1,R2,RE
REAL*4 VINT
REAL*4 XE
REAL*4 YE
REAL*4 ZE
PARAMETER (MC=100000,MAXI=100)
COMMON/CSFE/XE(MC),YE(MC),ZE(MC),RE(MC),IUSE(MC)
DIMENSION CT4(MAXI),CT6(MAXI)
WRITE(6,'(/A)')' ==> Start subroutine STAT'
VINT=0.1
TMIN=9000
TMAX=0
DO J=1,MAXI
CT4(J)=0
CT6(J)=0
END DO
DO I=1,NCOR
C=RE(I)/VINT
J=INT(C)+1
IF(IUSE(I).EQ.6)THEN
IF(J.LT.MAXI)THEN
CT6(J)=CT6(J)+1
TMAX=MAX(TMAX,J)
TMIN=MIN(TMIN,J)
END IF
ELSE IF(IUSE(I).EQ.4)THEN
IF(J.LT.MAXI)THEN
CT4(J)=CT4(J)+1
TMAX=MAX(TMAX,J)
TMIN=MIN(TMIN,J)
END IF
END IF
END DO
WRITE(6,'(A)')' RADII .GE. and .LT. TYPE 4 TYPE 6'
DO J=TMIN,TMAX
R1=(J-1)*VINT
R2=J*VINT
WRITE(6,'(2F10.5,2I10)')R1,R2,CT4(J),CT6(J)
END DO
RETURN
END
C
I'm writing a subroutine that transform a regular vector into the one with only non-zero elements. Say, vector a=(0,0,1,2,3)' (n by 1). Then the non-zero vector is c=(1,2,3), and the row index is recorded as ic=(0,0,0,1,2,3) where ic(1)=0, ic(i+1)-ic(i) is the number of non-zero elements in i-th row. The vector index jc=(1,1,1) with size 3 as there are 3 non-zero entries. See the sparse matrix wiki for FYI: https://en.wikipedia.org/wiki/Sparse_matrix.
Despite its simplicity, I'm having troubles in running the following code named sparsem.f90
!This subroutine coverts a regular sparse matrix a into a CSR form
MODULE SPARSEM
CONTAINS
SUBROUTINE vsparse(a,c,jc,ic,counta,ierr,myid)
IMPLICIT NONE
REAL(8), INTENT(IN):: a(:)
INTEGER, INTENT(IN):: counta,myid
REAL(8), INTENT(OUT):: c(counta)
INTEGER, INTENT(OUT):: jc(counta),ic(size(a)+1)
INTEGER:: ierr,countaa,i
character(len=90):: filename
ierr=0
jc=0
c=0.0d0
ic=0
PRINT *, 'SIZE OF A IN VSPARSE', size(a),count(a>0.0d0),counta
IF (COUNT(a>0.0d0) /= counta) THEN
ierr=1
PRINT *, 'ERROR: number count of non-zero a(i,j) is not', counta
ELSE
countaa=0
ic(1)=0
DO i=1,size(a)
IF (a(i) > 0.0d0 ) THEN
countaa=countaa+1
c(countaa)=a(i)
ic(i+1)=ic(i)+1
jc(countaa)=1
IF (countaa<100) PRINT *,'checkcheckcheck', a(i), &
countaa,jc(countaa),c(countaa)，jc(1:5)
ELSE
ic(i+1)=ic(i)
END IF
END DO
PRINT *, 'JCJCJCJC',jc(1:5)
END IF
IF (myid==7) THEN
WRITE(filename,'("sparsedens_dcheck",I1,".txt")') myid+1
OPEN(UNIT=212101, FILE="/home/wenya/Workspace/Model4/valuef/"//filename,ACTION='write',status='replace')
DO i=1,counta+1
IF (i<=counta) THEN
WRITE(212101,*) c(i),jc(i)
ELSE
WRITE(212101,*) 0.0D0,0
END IF
END DO
CLOSE(212101)
END IF
return
END SUBROUTINE vsparse
END MODULE SPARSEM
So the three print jc codes shall give 1 1 1 1 1.... Yet starting from the second print jc code, the result is 6750960 6750691 6750692 .... The array of jc has size 9,000,000. And I know the first 2250000 element is 0.
To replicate this problem, here is the main program
PROGRAM MAIN
USE SPARSEM
IMPICIT NONE
REAL(8):: dens_last(9000000)
REAL(8), ALLOCATABLE :: dens(:)
INTEGER, ALLOCATABLE :: ic(:),jc(:)
INTEGER:: i
dens_last(1:2250000)=0.0d0
dens_last(2250001:9000000)=1.0d0/6750000.0d0
ncount=count(dens_last>0.0d0)
ALLOCATE(dens(ncount), ic(9000000+1), jc(ncount)_
CALL VSPASEM(dens_last, dens, jc, ic, ncount,ierr)
DEALLOCATE(dens,ic,jc)
END PROGRAM MAIN
I am using gfortran 6.3.0 and openmpi latest version on a UBUNTU 17.04 computer. Although openmpi is not used in this example, it's used in the rest of the program. Any thoughts? Thanks!
There are several threads with similar titles of mine, but I do not believe they are the same. One was very similar fortran pass allocated array to main procedure, but the answer required Fortran 2008. I am after a Fortran 90/95 solution.
Another very good, and quite similar thread is Dynamic array allocation in fortran90. However in this method while they allocate in the subroutine, they don't ever appear to deallocate, which seems odd. My method looks on the surface at least to be the same, yet when I print the array in the main program, only blank spaces are printed. When I print in the subroutine itself, the array prints to screen the correct values, and the correct number of values.
In the following a MAIN program calls a subroutine. This subroutine reads data into an allocatable array, and passes the array back to the main program. I do this by using small subroutines each designed to look for specific terms in the input file. All of these subroutines are in one module file. So there are three files: Main.f90, input_read.f90 and filename.inp.
It seems then that I do not know how to pass an array that is allocatable in program Main.f90 as well as in the called subroutine where it is actually allocated, sized, and then deallocated before being passed to program Main. This perhaps sounds confusing, so here is the code for all three programs. I apologize for the poor formatting when I pasted it. I tried to separate all the rows.
main.f90:
Program main
use input_read ! the module with the subroutines used for reading filename.inp
implicit none
REAL, Allocatable :: epsilstar(:)
INTEGER :: natoms
call Obtain_LJ_Epsilon(epsilstar, natoms)
print*, 'LJ Epsilon : ', epsilstar
END Program main
Next is the module with a subroutine (I removed all but the necessary one for space), input_read.f90:
module input_read
contains
!===============================================================
!===============================================================
Subroutine Obtain_LJ_Epsilon(epsilstar,natoms)
! Reads epsilon and sigma parameters for Lennard-Jones Force-Field and also
! counts the number of types of atoms in the system
!===============================================================
!===============================================================
INTEGER :: error,line_number,natoms_eps,i
CHARACTER(120) :: string, next_line, next_next_line,dummy_char
CHARACTER(8) :: dummy_na,dummy_eps
INTEGER,intent(out) :: natoms
LOGICAL :: Proceed
real, intent(out), allocatable :: epsilstar(:)
error = 0
line_number = 0
Proceed = .true.
open(10,file='filename.inp',status='old')
!=============================================
! Find key word LJ_Epsilon
!=============================================
DO
line_number = line_number + 1
Read(10,'(A120)',iostat=error) string
IF (error .NE. 0) THEN
print*, "Error, stopping read input due to an error reading line"
exit
END IF
IF (string(1:12) == '$ LJ_epsilon') THEN
line_number = line_number + 1
exit
ELSE IF (string(1:3) == 'END' .or. line_number > 2000) THEN
print*, "Hit end of file before reading '$ LJ_epsilon' "
Proceed = .false.
exit
ENDIF
ENDDO
!========================================================
! Key word found, now determine number of parameters
! needing to be read
!========================================================
natoms_eps = -1
dummy_eps = 'iii'
do while ((dummy_eps(1:1) .ne. '$') .and. (dummy_eps(1:1) .ne. ' '))
natoms_eps = natoms_eps + 1
read(10,*) dummy_eps
enddo !we now know the number of atoms in the system (# of parameters)
close(10)
Allocate(epsilstar(natoms_eps))
epsilstar = 0.0
!============================================================
! Number of parameters found, now read their values
!============================================================
if(Proceed) then
open(11,file='filename.inp',status='old')
do i = 1,line_number-1
read(11,*) ! note it is not recording anything for this do loop
enddo
do i = 1,natoms_eps
read(11,*) dummy_char
read(dummy_char,*) epsilstar(i) ! convert string read in to real, and store in epsilstar
enddo
close(11)
PRINT*, 'LJ_epsilon: ', epsilstar ! printing to make sure it worked
endif
deallocate(epsilstar)
END Subroutine Obtain_LJ_Epsilon
end module input_read
And finally the input file: filename.inp
# Run_Type
NVT
# Run_Name
Test_Name
# Pressure
1.0
# Temperature
298.15
# Number_Species
# LJ_epsilon
117.1
117.1
117.1
# LJ_sigma
3.251
3.251
3.251
END
And again, I can't figure out how to pass the allocated epsilstar array to the main program. I have tried passing an unallocated array to the subroutine from the main.f90, allocating it inside, passing it back, and deallocating it in the main.f90, but that did not work. I have tried it as the code currently is... the code works (i.e. is bug free) but it does not pass epsilstar from the subroutine where it correctly finds it and creates an array.
It turns out that the mistake I made was in deallocating the array in the subroutine before passing it to the main program. By NOT deallocating, the array was sent back fine. Also, I do not deallocate in the main program either.
Hermite Interpolation woes
I am trying to find the Newton Dividing Differences for the function and derivative values of a given set of x's. I'm running into serious problems with my code working for tiny examples, but failing on bigger one's. As is clearly visible, my answers are very much larger than they original function values.
Does anybody have any idea what I'm doing wrong?
program inter
implicit none
integer ::n,m
integer ::i
real(kind=8),allocatable ::xVals(:),fxVals(:),newtonDivDiff(:),dxVals(:),zxVals(:),zdxVals(:),zfxVals(:)
real(kind=8) ::Px
real(kind=8) ::x
Open(Unit=8,File="data/xVals")
Open(Unit=9,File="data/fxVals")
Open(Unit=10,File="data/dxVals")
n = 4 ! literal number of data pts
m = n*2+1
!after we get the data points allocate the space
allocate(xVals(0:n))
allocate(fxVals(0:n))
allocate(dxVals(0:n))
allocate(newtonDivDiff(0:n))
!allocate the zvalue arrays
allocate(zxVals(0:m))
allocate(zdxVals(0:m))
allocate(zfxVals(0:m))
!since the size is the same we can read in one loop
do i=0,n
Read(8,*) xVals(i)
Read(9,*) fxVals(i)
Read(10,*) dxVals(i)
end do
! contstruct the z illusion
do i=0,m,2
zxVals(i) = xVals(i/2)
zxVals(i+1) = xVals(i/2)
zdxVals(i) = dxVals(i/2)
zdxVals(i+1) = dxVals(i/2)
zfxVals(i) = fxVals(i/2)
zfxVals(i+1) = fxVals(i/2)
end do
!slightly modified business as usual
call getNewtonDivDiff(zxVals,zdxVals,zfxVals,newtonDivDiff,m)
do i=0,n
call evaluatePolynomial(m,newtonDivDiff,xVals(i),Px,zxVals)
print*, xVals(i) ,Px
end do
close(8)
close(9)
close(10)
stop
deallocate(xVals,fxVals,dxVals,newtonDivDiff,zxVals,zdxVals,zfxVals)
end program inter
subroutine getNewtonDivDiff(xVals,dxVals,fxVals,newtonDivDiff,n)
implicit none
integer ::i,k
integer, intent(in) ::n
real(kind=8), allocatable,dimension(:,:) ::table
real(kind=8),intent(in) ::xVals(0:n),dxVals(0:n),fxVals(0:n)
real(kind=8), intent(inout) ::newtonDivDiff(0:n)
allocate(table(0:n,0:n))
table = 0.0d0
do i=0,n
table(i,0) = fxVals(i)
end do
do k=1,n
do i = k,n
if( k .eq. 1 .and. mod(i,2) .eq. 1) then
table(i,k) = dxVals(i)
else
table(i,k) = (table(i,k-1) - table(i-1,k-1))/(xVals(i) - xVals(i-k))
end if
end do
end do
do i=0,n
newtonDivDiff(i) = table(i,i)
!print*, newtonDivDiff(i)
end do
deallocate(table)
end subroutine getNewtonDivDiff
subroutine evaluatePolynomial(n,newtonDivDiff,x,Px,xVals)
implicit none
integer,intent(in) ::n
real(kind=8),intent(in) ::newtonDivDiff(0:n),xVals(0:n)
real(kind=8),intent(in) ::x
real(kind=8), intent(out) ::Px
integer ::i
Px = newtonDivDiff(n)
do i=n,1,-1
Px = Px * (x- xVals(i-1)) + newtonDivDiff(i-1)
end do
end subroutine evaluatePolynomial
Values
x f(x) f'(x)
1.16, 1.2337, 2.6643
1.32, 1.6879, 2.9989
1.48, 2.1814, 3.1464
1.64, 2.6832, 3.0862
1.8, 3.1553, 2.7697
Output
1.1599999999999999 62.040113431002474
1.3200000000000001 180.40121445431600
1.4800000000000000 212.36319446149312
1.6399999999999999 228.61845650513027
1.8000000000000000 245.11610836104515
You are accessing array newtonDivDiff out of bounds.
You are first allocating it as 0:n (main program's n) then you are passing to subroutine getNewtonDivDiff as 0:n (the subroutine's n) but you pass m (m=n*2+1) to the argument n. That means you tell the subroutine that the array has bounds 0:m which is 0:9, but it has only bounds 0:4.
It is quite difficult to debug the program as it stands, I had to use valgrind. If you move your subroutines to a module and change the dummy arguments to assumed shape arrays (:,:) then the bound checking in gfortran (-fcheck=all) will catch the error.
Other notes:
kind=8 is ugly, 8 can mean different things for different compilers. If you want 64bit variables, you can use kind=real64 (real64 comes from module iso_fortran_env in Fortran 2008) or use selected_real_kind() (Fortran 90 kind parameter)
You do not have to deallocate your local arrays in the subroutines, they are deallocated automatically.
Your deallocate statement in the main program is after the stop statement, it will never be executed. I would just delete the stop, there is no reason to have it.
I am writing a generic subroutine in fortran90 that will read in a column of data (real values). The subroutine should first check to see that the file exists and can be opened, then it determines the number of elements (Array_Size) in the column by reading the number of lines until end of file. Next the subroutine rewinds the file back to the beginning and reads in the data points and assigns each to an array (Column1(n)) and also determines the largest element in the array (Max_Value). The hope is that this subroutine can be written to be completely generic and not require any prior knowledge of the number of data points in the file, which is why the number of elements is first determined so the array, "Column1", can be dynamically allocated to contain "Array_Size" number of data points. Once the array is passed to the main program, it is transferred to another array and the initial dynamically allocated array is deallocated so that the routine can be repeated for multiple other input files, although this example only reads in one data file.
As written below, the program compiles just fine on the Intel fortran compiler; however, when it runs it gives me a severe (174): SIGSEV fault. I place the write(,) statements before and after the allocate statement in the subroutine and it prints the first statement "Program works here", but not the second, which indicates that the problem is occurring at the ALLOCATE (Column1(Array_Size)) statement, between the two write(,) statements. I re-compiled it with -C flag and ran the executable, which fails again and states severe (408): "Attempt to fetch from allocatable variable MISC_ARRAY when it is not allocated". The variable MISC_ARRAY is the dummy variable in the main program, which seems to indicate that the compiler wants the array allocated in the main program and not in the subprogram. If I statically allocate the array, the program works just fine. In order to make the program generic and not require any knowledge of the size of each file, it needs to be dynamically allocated and this should happen in the subprogram, not the main program. Is there a way to accomplish this that I am not seeing?
PROGRAM MAIN
IMPLICIT NONE
! - variable Definitions for MAIN program
INTEGER :: n
! - Variable Definitions for EXPENSE READER Subprograms
REAL, DIMENSION(:), ALLOCATABLE :: Misc_Array,MISC_DATA
INTEGER :: Size_Misc
REAL :: Peak_Misc_Value
! REAL :: Misc_Array(365)
CHARACTER(LEN=13) :: File_Name
File_Name = "Misc.txt"
CALL One_Column(File_Name,Size_Misc,Peak_Misc_Value,Misc_Array)
ALLOCATE (MISC_DATA(Size_Misc))
DO n = 1,Size_Misc ! Transfers array data
MISC_DATA(n) = Misc_Array(n)
END DO
DEALLOCATE (Misc_Array)
END PROGRAM MAIN
SUBROUTINE One_Column(File_Name,Array_Size,Max_Value,Column1)
IMPLICIT NONE
REAL, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: Column1
! REAL :: Column1(365)
REAL, INTENT(OUT) :: Max_Value
CHARACTER,INTENT(IN) :: File_Name*13
INTEGER, INTENT(OUT) :: Array_Size
INTEGER :: Open_Status,Input_Status,n
! Open the file and check to ensure it is properly opened
OPEN(UNIT=100,FILE = File_Name,STATUS = 'old',ACTION = 'READ', &
IOSTAT = Open_Status)
IF(Open_Status > 0) THEN
WRITE(*,'(A,A)') "**** Cannot Open ",File_Name
STOP
RETURN
END IF
! Determine the size of the file
Array_Size = 0
DO 300
READ(100,*,IOSTAT = Input_Status)
IF(Input_Status < 0) EXIT
Array_Size = Array_Size + 1
300 CONTINUE
REWIND(100)
WRITE(*,*) "Program works here"
ALLOCATE (Column1(Array_Size))
WRITE(*,*) "Program stops working here"
Max_Value = 0.0
DO n = 1,Array_Size
READ(100,*) Column1(n)
IF(Column1(n) .GT. Max_Value) Max_Value = Column1(n)
END DO
END SUBROUTINE One_Column
This is an educated guess: I think that the subroutine One_Column ought to have an explicit interface. As written the source code has 2 compilation units, a program (called main) and an external subroutine (called One_Column).
At compile-time the compiler can't figure out the correct way to call the subroutine from the program. In good-old (emphasis on old) Fortran style it takes a leap of faith and leaves it to the linker to find a subroutine with the right name and crosses its fingers (as it were) and hopes that the actual arguments match the dummy arguments at run-time. This approach won't work on subroutines returning allocated data structures.
For a simple fix move end program to the end of the source file, in the line vacated enter the keyword contains. The compiler will then take care of creating the necessary interface.
For a more scalable fix, put the subroutine into a module and use-associate it.
I think it is important to show the corrected code so that future users can read the question and also see the solution. I broke the subroutine into a series of smaller functions and one subroutine to keep the data as local as possible and implemented it into a module. The main program and module are attached. The main program includes a call to the functions twice, just to show that it can be used modularly to open multiple files.
PROGRAM MAIN
!
! - Author: Jonathan A. Webb
! - Date: December 11, 2014
! - Purpose: This code calls subprograms in module READ_COLUMNAR_FILE
! to determine the number of elements in an input file, the
! largest element in the input file and reads in the column of
! data as an allocatable array
!***************************************************************************
!***************************************************************************
!********************* **********************
!********************* VARIABLE DEFINITIONS **********************
!********************* **********************
!***************************************************************************
!***************************************************************************
USE READ_COLUMNAR_FILE
IMPLICIT NONE
CHARACTER(LEN=13) :: File_Name
INTEGER :: Size_Misc,Size_Bar,Unit_Number
REAL :: Peak_Misc_Value,Peak_Bar_Value
REAL, DIMENSION(:), ALLOCATABLE :: Misc_Array,Bar_Array
!***************************************************************************
!***************************************************************************
!********************* **********************
!********************* FILE READER BLOCK **********************
!********************* **********************
!***************************************************************************
!***************************************************************************
! - This section reads in data from all of the columnar input decks.
! User defines the input file name and number
File_Name = "Misc.txt"; Unit_Number = 100
! Determines the number of rows in the file
Size_Misc = File_Length(File_Name,Unit_Number)
! Yields the allocatable array and the largest element in the array
CALL Read_File(File_Name,Unit_Number,Misc_Array,Peak_Misc_Value)
File_Name = "Bar.txt"; Unit_Number = 100
Size_Bar = File_Length(File_Name,Unit_Number)
CALL Read_File(File_Name,Unit_Number,Bar_Array,Peak_Bar_Value)
END PROGRAM MAIN
MODULE READ_COLUMNAR_FILE
!***********************************************************************************
!***********************************************************************************
! ***
! Author: Jonathan A. Webb ***
! Purpose: Compilation of subprograms required to read in multi-column ***
! data files ***
! Drafted: December 11, 2014 ***
! ***
!***********************************************************************************
!***********************************************************************************
!
!-----------------------------------
! Public functions and subroutines for this module
!-----------------------------------
PUBLIC :: Read_File
PUBLIC :: File_Length
!-----------------------------------
! Private functions and subroutines for this module
!-----------------------------------
PRIVATE :: Check_File
!===============================================================================
CONTAINS
!===============================================================================
SUBROUTINE Check_File(Unit_Number,Open_Status,File_Name)
INTEGER,INTENT(IN) :: Unit_Number
CHARACTER(LEN=13), INTENT(IN) :: File_Name
INTEGER,INTENT(OUT) :: Open_Status
! Check to see if the file exists
OPEN(UNIT=Unit_Number,FILE = File_Name,STATUS='old',ACTION='read', &
IOSTAT = Open_Status)
IF(Open_Status .GT. 0) THEN
WRITE(*,*) "**** Cannot Open ", File_Name," ****"
STOP
RETURN
END IF
END SUBROUTINE Check_File
!===============================================================================
FUNCTION File_Length(File_Name,Unit_Number)
INTEGER :: File_Length
INTEGER, INTENT(IN) :: Unit_Number
CHARACTER(LEN=13),INTENT(IN) :: File_Name
INTEGER :: Open_Status,Input_Status
! Calls subroutine to check on status of file
CALL Check_File(Unit_Number,Open_Status,File_Name)
IF(Open_Status .GT. 0)THEN
WRITE(*,*) "**** Cannot Read", File_Name," ****"
STOP
RETURN
END IF
! Determine File Size
File_Length = 0
DO 300
READ(Unit_Number,*,IOSTAT = Input_Status)
IF(Input_Status .LT. 0) EXIT
File_Length = File_Length + 1
300 CONTINUE
CLOSE(Unit_Number)
END FUNCTION File_Length
!===============================================================================
SUBROUTINE Read_File(File_Name,Unit_Number,Column1,Max_Value)
INTEGER, INTENT(IN) :: Unit_Number
REAL, DIMENSION(:), ALLOCATABLE,INTENT(OUT) :: Column1
CHARACTER(LEN=13),INTENT(IN) :: File_Name
REAL, INTENT(OUT) :: Max_Value
INTEGER :: Array_Size,n
! Determines the array size and allocates the array
Array_Size = File_Length(File_Name,Unit_Number)
ALLOCATE (Column1(Array_Size))
! - Reads in columnar array and determines the element with
! the largest value
Max_Value = 0.0
OPEN(UNIT= Unit_Number,File = File_Name)
DO n = 1,Array_Size
READ(Unit_Number,*) Column1(n)
IF(Column1(n) .GT. Max_Value) Max_Value = Column1(n)
END DO
CLOSE(Unit_Number)
END SUBROUTINE Read_File
!===============================================================================
END MODULE READ_COLUMNAR_FILE