I'm trying to compile some Fortran code but I keep getting errors with the FORMAT statement. It says I'm missing brackets and characters but it looks fine to me. I am compiling it with silverfrost. The code is shown below:
! PROGRAM TO SOLVE DEEP-BED DRYING MODEL
!
! BASIC STATEMENTS
!
CHARACTER*20 FiIe1, File2
COMMON AMo
COMMON /DENS/ Pmo, Pme
COMMON /THICK/ dxo, Dxe
DIMENSION AM1(50), AM2(50), T(50), Gs(51), Vs(51), Ts(51), Dx(50), X(50)
!
!To define a number of statement functions
AMe(Ts)=0.62*EXP(-1.116*(Ts-100)**0.3339)
A(Ts, Vs)=(1.2925-0.00058*Ts) * (0.9991-0.0963*Vs)
AK(Ts, Vs)=(0.00273*Ts-0.2609)*(2.0984*Vs+0.2174)
AN(Ts)=0.00222*Ts+0.9599
Ps(Ts)=0.7401-0.001505*Ts
!
!INPUT SECTION OF THE PROGR.A,M
!
PRINT*, 'Input the mass of the sample (g) :'
READ*, Wo
PRINT*, 'Input the initial moisture content (db):'
READ*, AMo
PRINT*, 'lnput the depth of the sample bed (mm):'
READ*, Xo
PRINT*, 'Input the number of layers in the bed:'
READ*, Nx
PRINT*, 'Input the steam temperature at inlet (oC):'
READ*, Tso
PRINT*, 'input the steam flow rate at inlet (kg/(m2.s)):'
READ*, Gso
PRINT*, 'lnput the expected drying time (min):'
READ*, Timeo
PRINT*, 'lnput the time interval- (min) :'
READ*, Dt
!
! TO DEFINE AND OPEN DATA FILES
!
PRINT*, 'Name for the file recording the simulation +process:'
READ*, File1
OPEN (1, FILE=File1)
PRINT*, 'Name for the file recording major data:'
READ*, File2
OPEN (2, FILE=File2)
!
! TO WRITE INPUTTED PARAMETERS IN THE DATA FILES
!
WRITE (1, *) 'Mass of sample:', Wo, ' g'
WRITE (1, *) 'Initial moisture content:', AMo, ' kg/kg'
WRITE (1, *) 'Depth of sample bed:', Xo, 'mm'
WRITE (1, *) 'Number of layers in sample bed:', Nx
WRITE (1, *) 'Steam temperature at inlet', Tso, 'deg C'
WRITE (1, *) 'Steam flow rate at inlet', Gso, 'kg/m2s'
WRITE (1, *) 'Expected drying time', Timeo, ' min'
WRITE (1, *) 'Time interval:', Dt, ' min'
!
WRITE (2, *) 'Mass of sample', Wo, 'g'
WRITE (2, *) 'Initial moisture content', AMo, 'kg/kg'
WRITE (2, *) 'Depth of sample bed', Xo, 'mm'
WRITE (2, *) 'Number of layers in sample bed', Nx
WRITE (2, *) 'Steam temperature at inlet', Tso, ' deg C'
WRITE (2, *) 'Steam flow rate at inlet', Gso, ' kg/m2*s'
WRITE (2, *) 'Expected drying time', Timeo, ' min'
WRITE (2, *) 'Time interval:', Dt, ' min'
!
!BASIC CALCULATION BASED ON THE INPUT DATA
!
Dxo=Xo/1000/Nx
Dxe=0.867*Dxo
D1=0.066
Pmo=4*(Wo/l000)/(3.14159*D1**2*(Xo/1000)*(1+AMo))
Pme=Pmo/0.867
AMeo=AMe(Tso)
NT=NINT(Timeo/Dt)
Pso=Ps(Tso)
Vso=Gso/Pso
!
!TO SET VALUES FOR SOME PHYSTCAL AND THERMODYNAMTC PROPERTIES
!
Cs=2000
Cw1=4193
Cw=4313
C=1245
!
!TO CALCULATE THE INTTIAL MOISTURE CONTENT CONSIDERING STEAM CONDENSATION
!
AMo1=AMo+(C+Cw1*AMo)/(2257000+Cs*(Tso-100))*(100-10)
!
!TO SET JUDGE CRITERION FOR TERMINATING THE DRYING OF A LAYER
!(A small difference between moisture content and equilibrium moisture content)
DM=0.0001
!
!MAJOR DERIVATION FOR DRYING SIMULATION
!
J=0
Time=0
m=1
!
WRITE(2, 100)
100 FORMAT(4H J, 9H T(min), 8H M(db),7H Gs , 10H Ts(C) ,9H Front1, 5H L1, 9H Front2, 5h L2, 9H Depth)
!
200 m5=m-1
IF (J .GT. Nt) GO to 800
!
PRINT*, ' '
PRINT*, ' '
PRINT*, 'Time inverval:', J, ' Drying time:', Time, ' min'
WRITE(1, x) ' '
WRITE(1, *) 'Time interval:', J, ' Drying time:', Time, ' min'
WRITE(*, 300)
WRITE(1, 300)
300 FORMAT(1x, 3H, I, 7H, X(i), 8H M(i), 10H T(i), 10H Gs(i), 8H Ts(i))
!
AveM=0
!
! For dried region
!
IF(m .GT. 1) THEN
DO 500 i=1, m-1
Dx(i)=Dxe
X(i)=(i-0.5)*Dxe
AM1(i)=AM2(i)
T(i)=Tso
Gs(i)=Gso
Vs(i)=Vso
Ts(i)=Tso
AveM=AveM+AM1(i)
WRITE(*, 400) i, X(i), AM1(i), T(i), Gs(i), Ts(i)
WRITE(1, 400) i, X(i), AM1(i), T(i), Gs(i), Ts(i)
400 FORMAT(1X, I3, 2X, F6.4, 2X, F6.4, 2X, F8.3, 2X, F7.3, 2X, F7.3)
500 CONTINUE
ENDIF
! Calculation of the drying front position
IF (m .EQ. l) THEN
X1=-1
No1=-1
ELSE
Xl=X(m-1)+Dx(m-1)/2
No1=m-1
ENDIF
!
IF (m .GT. Nx) GO TO 900
!
Ts(m)=Tso
Vs(m)=Vso
L=0
DO 600 i=m, Nx
IF(L .NE.0) GO TO 510
!
! For drying region
!
If (J .EQ. O) THEN
Am1(i)=AMo1
Else
AM1(i)=AM2(i)
ENDIF
Dx(i)=Dxx(AM1(i))
IF (i .EQ. 1) THEN
X(i)=Dx(i)/2
ELSE
X(i)=X(i-1)+Dx(i-1)/2+Dx(i)/2
ENDIF
!
! To define transition variables
!
AMe5=AMe(Ts(i))
A5=A(Ts(i),Vs(i))
AK5=AK(Ts(i),Vs(i))
AN5=AN(Ts(i))
Ps5=Ps(Ts(i))
P5=P(AMl(i))
Dt5=Dt* 60
!
! Derivation
!
AMmax=A5*(AMo-AMe5)/EXP((AN5-1)/AN5)+AMe5
IF (AM1(i) .GE. AMmax) THEN
AM2(i)=AM1(i)-Dt5*AK5*AN5*(AMmax-AMe5)*(ALOG(A5*(AMo-AMe5)/(AMmax-AMe5))/AK5)**((AN5-1)/AN5)/60
ELSE
AM2(i)=AM1(i)-Dt5*AK5*AN5*(AM1(i)-AMe5)*(ALOG(A5*(AMo-AMe5)/(AM1(i)-AMe5))/AK5)**((AN5-1)/AN5)/60
ENDIF
DR=(AM2(i)-AM1(i))/Dt5
!
IF (AM1(i) .GE. AMo) THEN
T(i)=100
DerT=0
ELSE
T(i)=Tso-(Tso-100)*(AM1(i)-AMeo)/(AMo-AMeo)
DerT=-(Tso-l00)/(AMo-AMeo)*DR
ENDIF
!
Gs(i)=Vs(i)*Ps5
Gs(i+l)=Gs(i)-Dx(i)*P5*DR
Vs(i+1)=Gs(i+1)/Ps5
Hv5=Hv(AMl(i), T(i))
Ts(i+1)=Ts(i)+Dx(i)*P5*(Hv5+Cs*(Ts(i)-T(i)))/(Gs(i)*Cs)*DR-Dx(i)*P5*(C+Cw*AMl(i))/(Gs(i)*Cs)*DerT
!
! To find the first layer in wet region
!
IF (Ts(i+l) .LE. l00) THEN
Ts(i+1)=100
L=i
ENDIF
!
! To check if the layer has been dried to equilibrium
!
IF ((AM2(i)-AMeo) .LE. DM) THEN
m5=i
AM2(i)=AMeo
ENDIF
GO TO 520
!
! For wet region
!
510 AM1(i)=AMo1
AM2(i)=AMo1
T(i)=100
Gs(i+l)=Gs(i)
Vs(i+1)=Vs(i)
Ts(i+1)=100
!
Dx(i)=Dxx(AM1(i))
IF (i .EQ. 1) THEN
X(i)=Dx(i)/2
ELSE
X(i)=X(i-1)+Dx(i-1)/2+Dx(i)/2
ENDIF
!
520 AveM=AveM+AM1(i)
WRITE(*, 400) i, X(i), AM1(i), T(i), Gs(i), Ts(i)
WRITE(1, 400) i, X(i), AM1(i), T(i), Gs(i), Ts(i)
600 CONTINUE
!
! Calculation of wet front position
IF (L .EQ. O) THEN
X2=-1
No2=-1
ELSE
X2=X(L)+Dx(L)/2
No2=L+1
ENDIF
!
AveM=AveM/Nx
Depth=X(Nx)+Dx(Nx)/2
!
WRITE(*, 100)
WRITE(*, 700) J, Time, AveM, Gs(Nx*1), Ts(Nx*1), XI, No1, X2, No2, Depth
WRITE (2, 700) J, Time, AveM, Gs(Nx+1), Ts(Nx*1), X1, No1, X2, No2, Depth
700 FORMAT(I4, 2X, F7.3, 2X, F6.4, 2X, F6.4, 2X, F7.3, 2X, F7.4, 2x, I3, 2X, F7.4, 2X, I3, 2x, F7.4)
!
J=J+1
Time=Time+Dt
m=m5+1
GO TO 200
!
800 PRINT*, ' '
PRINT*, 'The drying time was up to the specified time.'
PRINT*, 'The drying simulation was stopped.'
PRINT*, 'The sample was not dried to equilibrium'
WRITE(1,*) ' '
WRITE(1,*) 'The drying time was up to the specified time.'
WRITE(1,*) 'The drying simulation was stopped'
WRITE(1,*) 'The sample was not dried to equilibrium'
WRITE(1,*) ' '
WRITE(2,*) 'The drying time was up to the specified time'
WRITE(2,*) 'The drying simulation was stopped'
WRITE(2,*) 'The drying simulation was stopped'
WRITE(2,*) 'The sample was not dried to equilirbium'
GO TO 910
!
900 No2=-1
X2=-1
AveM=AveM/Nx
WRITE(*, 100)
WRITE(*, 700) J, Time, AveM, Gs(Nx+1), Ts(Nx+1), X1, No1, X2, No2, Depth
WRITE(2, 700) J, Time, AveM, Gs(Nx+1), Ts(Nx+1), X1, No1, X2, No2, Depth
!
PRINT*, ' '
PRINT*, 'The sample was dried to equilibrium'
PRINT*, 'The drying simulation was stopped.'
WRITE(1,*) ' '
WRITE(1,*) 'The sample was dried to equilibrium'
WRITE(1,*) 'The drying simulation was stopped'
WRITE(2,*) ' '
WRITE(2,*) 'The sample was not dried to equilirbium'
WRITE(2,*) 'The drying simulation was stopped'
!
910 CLOSE(1)
CLOSE(2)
END
!
!**********************************************************************************
!
! EXTERNAL FUNCTION FOR LATENT HEAT OF EVAPORATION
!
FUNCTION Hv(AM, T)
Hfg=2257000-2916.7*(T-100)
IF (AM .GE. 0.2) THEN
Hv=Hfg
ELSE
Hv=Hfg*(1+EXP(-19.9*AM))
ENDIF
RETURN
END
!
! EXTERNAL FUNCTION FOR BULK DENSITY
!
FUNCTION P(AM)
COMMON AMo/DENS/ Pmo, Pme
IF (AM .GE. AMo) THEN
P=Pmo
ELSE IF (AM .LT. 0.11) THEN
P=Pme
ELSE
P=Pmo-(Pmo-Pme)*(AMo-AM)/(AMo-0.11)
ENDIF
RETURN
END
!
! EXTERNAL FUNCTION FOR LAYER THICKNESS
!
FUNCTION Dxx(AM)
COMMON AMo/THICK/ Dxo, Dxe
IF (AM .GE. AMO) THEN
Dxx=Dxo
ELSE IF (AM .LT. 0.11) THEN
Dxx=Dxe
ELSE
Dxx=Dxo-(Dxo-Dxe)*(AMo-AM)/(AMo-0.11)
ENDIF
RETURN
END
!
!****************************************************************************************
And the errors are shown below:
Compiling and linking file: SHSDRYING.F95
C:\Users\steva\Desktop\SHSDRYING.F95(104) : error 58 - Unpaired right bracket(s)
C:\Users\steva\Desktop\SHSDRYING.F95(45) : error 259 - Scalar, default-kind, CHARACTER expression expected for the FILE keyword
C:\Users\steva\Desktop\SHSDRYING.F95(45) : warning 868 - Opening unit 1 may affect the operation of input from the default unit '*' - are you sure you want to do this?
C:\Users\steva\Desktop\SHSDRYING.F95(48) : warning 868 - Opening unit 2 may affect the operation of output to the default unit '*' - are you sure you want to do this?
C:\Users\steva\Desktop\SHSDRYING.F95(116) : warning 792 - Comma missing in format
C:\Users\steva\Desktop\SHSDRYING.F95(116) : warning 792 - Comma missing in format
C:\Users\steva\Desktop\SHSDRYING.F95(116) : error 270 - Missing width count for 'G' descriptor
C:\Users\steva\Desktop\SHSDRYING.F95(116) : warning 792 - Comma missing in format
C:\Users\steva\Desktop\SHSDRYING.F95(116) : error 274 - Unknown edit descriptor '(', or missing comma
C:\Users\steva\Desktop\SHSDRYING.F95(292) : warning 868 - Closing unit 1 may affect the operation of input from the default unit '*' - are you sure you want to do this?
C:\Users\steva\Desktop\SHSDRYING.F95(293) : warning 868 - Closing unit 2 may affect the operation of output to the default unit '*' - are you sure you want to do this?
C:\Users\steva\Desktop\SHSDRYING.F95(103) : error 90 - FORMAT label 100 does not exist
Compilation failed.
Unit 5,6 and 1,2 (and others) are reserved... If you make UNIT=1 become UNIT=21 and UNIT=2 become UNIT=22 it will work.
Better is probably to use NEWUNIT
! PROGRAM TO SOLVE DEEP-BED DRYING MODEL
!
! BASIC STATEMENTS
!
PROGRAM DEEP_BED_DRYING !New
IMPLICIT NONE !New
CHARACTER*20 FiIe1, File2
COMMON AMo
COMMON /DENS/ Pmo, Pme
COMMON /THICK/ dxo, Dxe
...
OPEN (NEWUNIT=MyUnit1, FILE=File1) !New
WRITE(*,*)' Unit1=',MyUnit1 !New
...
OPEN (NEWUNIT=MyUnit2, FILE=File2) !New
WRITE(*,*)' Unit2=',MyUnit2 !New
enter code here
!WRITE(1,*) ...
WRITE(MyUnit1,*) ...
IMPLICIT NONE is not a bad habit to get into using.
I would line up things for ease of reading...
WRITE (1, *) 'Mass of sample:' , Wo , ' g'
WRITE (1, *) 'Initial moisture content:' , AMo , ' kg/kg'
WRITE (1, *) 'Depth of sample bed:' , Xo , 'mm'
WRITE (1, *) 'Number of layers in sample bed:' , Nx
WRITE (1, *) 'Steam temperature at inlet' , Tso , 'deg C'
WRITE (1, *) 'Steam flow rate at inlet' , Gso , 'kg/m2s'
WRITE (1, *) 'Expected drying time' , Timeo , ' min'
WRITE (1, *) 'Time interval:' , Dt , ' min'
You either need to compile with -132 or use line continuation...
.F77 or -fixed compiler switch (Anything n Column #6):
WRITE(2, 100)
100 FORMAT(4H J, 9H T(min), 8H M(db),7H Gs , 10H Ts(C) ,
!234567
& 9H Front1, 5H L1, 9H Front2, 5h L2, 9H Depth)
.F90 or -free compiler switch (& at the end):
WRITE(2, 100) !Here
100 FORMAT(4H J, 9H T(min), 8H M(db),7H Gs , 10H Ts(C) , &
!234567
9H Front1, 5H L1, 9H Front2, 5h L2, 9H Depth)
The FORMAT statements in the program use Hollerith edit descriptors, which was a feature deleted from the language as of Fortran 95. These are notoriously error prone - character string edit descriptors should be used instead.
Hollerith edit descriptors are of the form nHxxx - where n characters following the H are equivalent to a character literal. The problem with the identified statement (at least) is that the parenthesis that is meant to close the format statement is being considered part of the literal - probably because a space or similar has been deleted from the source.
100 FORMAT(...9H Depth)
123456789
The error messages also identify that the variable named File1 is not suitable as a FILE= specifier in an open statement. This is because there is no variable declaration for File1, so it is assumed to be of type REAL. There is a declaration for a variable FiIe1. IMPLICIT NONE helps find these sorts of spelling mistakes, but the code has clearly been written using implicit typing.
These sorts of errors suggest that the source has come from optical character recognition or similar. If so, you will need to be very mindful of OCR errors elsewhere in the source.
Related
This program:
C This program calculates cos(x**2)
PROGRAM COSX_SQUARE
IMPLICIT NONE
INTEGER a
REAL y, r
PRINT*, 'INPUT THE DEGREE'
PRINT*, 'BETWEEN 0 AND 360'
READ*, a
a*(3.141592/180) = y
C This part determines minus sign and calculates the function
IF (a .GT. 90) THEN
r = -(1-(y**4)/2+(y**8)/24-(y**12)/720+(y**16)/40320)
ELSEIF (a .GE. 270) THEN
r = 1-(y**4)/2+(y**8)/24-(y**12)/720+(y**16)/40320
ELSEIF (a .GT. 360) THEN
PRINT*, 'INVALID DEGREE'
PRINT*, 'DEGREE MUST BE BETWEEN 0 AND 360'
ELSEIF (a .LT. 0) THEN
PRINT*, 'INVALID DEGREE'
PRINT*, 'DEGREE MUST BE BETWEEN 0 AND 360'
END IF
PRINT*, 'THE RESULT OF COS', a, 'SQUARE IS = ', r
STOP
END
Gives this error:
a*(3.141592/180)=y
1
Error: Unclassifiable statement at (1)
I already defined a as INTEGER. Why this error keeps coming?
Yep. It is an expression which begins a statement. Maybe change it to
y = a*(3.141592/180)
if that is what you really meant.
I have code that works fine to compute eigenvalues in my test case for ARPACK Shamelessly taken from here and adapted to a quick 4x4 matrix. (Comments at the top removed in my sample code for brevity).
Okay, my problem. I have very large matrices, or at least, I will for my actual problems. But, when I make the integers kind 16, ARPACK gives an error. Is there a simple way to convert the ARPACK functions to allow my 16 byte indexing of things? Or, is it possible to alter how it makes the library to allow for this? I made the library with gfortran.
Any insight would be greatly appreciated.
PLEASE NOTE: The code below has been edited (to actually run properly). I've also added 2 subroutines that may be useful for the folks getting started with ARPACK. Please forgive the change in format of the error print statements.
program main
implicit none
integer, parameter :: maxn = 256
integer, parameter :: maxnev = 10
integer, parameter :: maxncv = 25
integer, parameter :: ldv = maxn
intrinsic abs
real :: ax(maxn)
character :: bmat
real :: d(maxncv,2)
integer :: ido, ierr, info
integer :: iparam(11), ipntr(11)
integer ishfts, j, lworkl, maxitr, mode1, n, nconv, ncv, nev, nx, resid(maxn)
logical rvec
logical select(maxncv)
real sigma, tol, v(ldv,maxncv)
real, external :: snrm2
character ( len = 2 ) which
real workl(maxncv*(maxncv+8))
real workd(3*maxn)
real, parameter :: zero = 0.0E+00
!
! Set dimensions for this problem.
!
nx = 4
n = nx
!
! Specifications for ARPACK usage are set below:
!
!
! 2) NCV = 20 sets the length of the Arnoldi factorization.
! 3) This is a standard problem (indicated by bmat = 'I')
! 4) Ask for the NEV eigenvalues of largest magnitude
! (indicated by which = 'LM')
!
! See documentation in SSAUPD for the other options SM, LA, SA, LI, SI.
!
! NEV and NCV must satisfy the following conditions:
!
! NEV <= MAXNEV
! NEV + 1 <= NCV <= MAXNCV
!
nev = 3 ! Asks for 4 eigenvalues to be computed.
ncv = min(25,n)
bmat = 'I'
which = 'LM'
if ( maxn < n ) then
PRINT *, ' '
PRINT *, 'SSSIMP - Fatal error!'
PRINT *, ' N is greater than MAXN '
stop
else if ( maxnev < nev ) then
PRINT *, ' '
PRINT *, 'SSSIMP - Fatal error!'
PRINT *, ' NEV is greater than MAXNEV '
stop
else if ( maxncv < ncv ) then
PRINT *, ' '
PRINT *, 'SSSIMP - Fatal error!'
PRINT *, ' NCV is greater than MAXNCV '
stop
end if
!
! Specification of stopping rules and initial
! conditions before calling SSAUPD
!
! TOL determines the stopping criterion. Expect
! abs(lambdaC - lambdaT) < TOL*abs(lambdaC)
! computed true
! If TOL <= 0, then TOL <- macheps (machine precision) is used.
!
! IDO is the REVERSE COMMUNICATION parameter. Initially be set to 0 before the first call to SSAUPD.
!
! INFO on entry specifies starting vector information and on return indicates error codes
! Initially, setting INFO=0 indicates that a random starting vector is requested to
! start the ARNOLDI iteration.
!
! The work array WORKL is used in SSAUPD as workspace. Its dimension
! LWORKL is set as illustrated below.
!
lworkl = ncv * ( ncv + 8 )
tol = zero
info = 0
ido = 0
!
! Specification of Algorithm Mode:
!
! This program uses the exact shift strategy
! (indicated by setting PARAM(1) = 1).
!
! IPARAM(3) specifies the maximum number of Arnoldi iterations allowed.
!
! Mode 1 of SSAUPD is used (IPARAM(7) = 1).
!
! All these options can be changed by the user. For details see the
! documentation in SSAUPD.
!
ishfts = 0
maxitr = 300
mode1 = 1
iparam(1) = ishfts
iparam(3) = maxitr
iparam(7) = mode1
!
! MAIN LOOP (Reverse communication loop)
!
! Repeatedly call SSAUPD and take actions indicated by parameter
! IDO until convergence is indicated or MAXITR is exceeded.
!
do
call ssaupd ( ido, bmat, n, which, nev, tol, resid, &
ncv, v, ldv, iparam, ipntr, workd, workl, &
lworkl, info )
if ( ido /= -1 .and. ido /= 1 ) then
exit
end if
call av ( nx, workd(ipntr(1)), workd(ipntr(2)) )
end do
!
! Either we have convergence or there is an error.
!
CALL dsaupderrormessage(info)
if ( info < 0 ) then
! Error message. Check the documentation in SSAUPD.
PRINT *, 'SSSIMP - Fatal error!'
PRINT *, ' Error with SSAUPD, INFO = ', info
PRINT *, ' Check documentation in SSAUPD.'
else
!
! No fatal errors occurred.
! Post-Process using SSEUPD.
!
! Computed eigenvalues may be extracted.
!
! Eigenvectors may be also computed now if
! desired. (indicated by rvec = .true.)
!
! The routine SSEUPD now called to do this
! post processing (Other modes may require
! more complicated post processing than mode1.)
!
rvec = .true.
call sseupd ( rvec, 'All', select, d, v, ldv, sigma, &
bmat, n, which, nev, tol, resid, ncv, v, ldv, &
iparam, ipntr, workd, workl, lworkl, ierr )
!
! Eigenvalues are returned in the first column of the two dimensional
! array D and the corresponding eigenvectors are returned in the first
! NCONV (=IPARAM(5)) columns of the two dimensional array V if requested.
!
! Otherwise, an orthogonal basis for the invariant subspace corresponding
! to the eigenvalues in D is returned in V.
!
CALL dseupderrormessage(ierr)
if ( ierr /= 0 ) then
PRINT *, 'SSSIMP - Fatal error!'
PRINT *, ' Error with SSEUPD, IERR = ', ierr
PRINT *, ' Check the documentation of SSEUPD.'
! Compute the residual norm|| A*x - lambda*x ||
! for the NCONV accurately computed eigenvalues and eigenvectors.
! (iparam(5) indicates how many are accurate to the requested tolerance)
!
else
nconv = iparam(5)
do j = 1, nconv
call av ( nx, v(1,j), ax )
call saxpy ( n, -d(j,1), v(1,j), 1, ax, 1 )
d(j,2) = snrm2 ( n, ax, 1)
d(j,2) = d(j,2) / abs ( d(j,1) )
end do
!
! Display computed residuals.
!
call smout ( 6, nconv, 2, d, maxncv, -6, &
'Ritz values and relative residuals' )
! 6: Output to screen Write(6, #internalnumber)
! nconv: number of rows in the matrix d
! 2: Number of columns in matrix d
! maxncv: Leading dimension of the matrix data
! -6: print the matrix d with iabs(-6) decimal digits per number
! Use formatting indexed by -6 to print A
end if
!
! Print additional convergence information.
!
if ( info == 1) then
PRINT *, ' '
PRINT *, ' Maximum number of iterations reached.'
else if ( info == 3) then
PRINT *, ' '
PRINT *, ' No shifts could be applied during implicit' &
// ' Arnoldi update, try increasing NCV.'
end if
PRINT *, ' '
PRINT *, 'SSSIMP:'
PRINT *, '====== '
PRINT *, ' '
PRINT *, ' Size of the matrix is ', n
PRINT *, ' The number of Ritz values requested is ', nev
PRINT *, &
' The number of Arnoldi vectors generated (NCV) is ', ncv
PRINT *, ' What portion of the spectrum: ' // which
PRINT *, &
' The number of converged Ritz values is ', nconv
PRINT *, &
' The number of Implicit Arnoldi update iterations taken is ', iparam(3)
PRINT *, ' The number of OP*x is ', iparam(9)
PRINT *, ' The convergence criterion is ', tol
end if
PRINT *, ' '
PRINT *, 'SSSIMP:'
PRINT *, ' Normal end of execution.'
! write ( *, '(a)' ) ' '
! call timestamp ( )
stop
end
!*******************************************************************************
!
!! Av computes w <- A * V where A is the matri used is
! | 1 1 1 1 |
! | 1 0 1 1 |
! | 1 1 0 1 |
! | 1 1 1 0 |
!
! Parameters:
! Input, integer NX, the length of the vectors.
! Input, real V(NX), the vector to be operated on by A.
! Output, real W(NX), the result of A*V.
!
!*******************************************************************************
subroutine av ( nx, v, w )
implicit none
integer nx
integer :: j, i, lo, n2
real, parameter :: one = 1.0E+00
real :: A(4,4)
real :: h2, temp, v(nx), w(nx)
A(:,:) = one
A(2,2) = 0.0E+00
A(3,3) = 0.0E+00
A(4,4) = 0.0E+00
do j= 1,4
temp = 0.0E+00
do i= 1,4
temp = temp + v(i)* A(i,j)
end do
w(j) = temp
end do
return
end subroutine
SUBROUTINE dsaupderrormessage(dsaupdinfo)
implicit none
integer :: dsaupdinfo
if (dsaupdinfo .EQ. 0) THEN
PRINT *, 'Normal Exit in dsaupd: info = 0.'
elseif (dsaupdinfo .EQ. -1) THEN
PRINT *, 'Error in dsaupd: info = -1.'
PRINT *, 'N must be positive.'
elseif (dsaupdinfo .EQ. -2) THEN
PRINT *, 'Error in dsaupd: info = -2.'
PRINT *, 'NEV must be positive.'
elseif (dsaupdinfo .EQ. -3) THEN
PRINT *, 'Error in dsaupd: info = -3.'
PRINT *, 'NCV must be between NEV and N. '
elseif (dsaupdinfo .EQ. -4) THEN
PRINT *, 'Error in dsaupd: info = -4'
PRINT *, 'The maximum number of Arnoldi update iterations allowed must be greater than zero.'
elseif (dsaupdinfo .EQ. -5) THEN
PRINT *, 'Error in dsaupd: info = -5'
PRINT *, 'WHICH must be LM, SM, LA, SA, or BE. info = -5.'
elseif (dsaupdinfo .EQ. -6) THEN
PRINT *, 'Error in dsauupd: info = -6. '
PRINT *, 'BMAT must be I or G. '
elseif (dsaupdinfo .EQ. -7) THEN
PRINT *, 'Error in dsaupd: info = -7.'
PRINT *, 'Length of private work work WORKL array isnt sufficient.'
elseif (dsaupdinfo .EQ. -8) THEN
PRINT *, 'Error in dsaupd: info = -8.'
PRINT *, 'Error in return from trid. eval calc. Error info from LAPACK dsteqr. info =-8'
elseif (dsaupdinfo .EQ. -9) THEN
PRINT *, 'Error in dsaupd: info = -9.'
PRINT *, 'Starting vector is 0.'
elseif (dsaupdinfo .EQ. -10) THEN
PRINT *, 'Error in dsaupd: info = -10. '
PRINT *, 'IPARAM(7) must be 1,2,3,4, or 5.'
elseif (dsaupdinfo .EQ. -11) THEN
PRINT *, 'Error in dsaupd: info = -11.'
PRINT *, 'IPARAM(7)=1 and BMAT=G are incompatible.'
elseif (dsaupdinfo .EQ. -12) THEN
PRINT *, 'Error in dsaupd: info = -12'
PRINT *, 'NEV and WHICH=BE are incompatible.'
elseif (dsaupdinfo .EQ. -13) THEN
PRINT *, 'Error in dsaupd: info = -13.'
PRINT *, 'DSAUPD did find any eigenvalues to sufficient accuracy.'
elseif (dsaupdinfo .EQ. -9999) THEN
PRINT *, 'Error in dsaupd: info = -9999'
PRINT *, 'Could not build an Arnoldi factorization. IPARAM(5) returns the size of the current Arnoldi factorization. &
The user is advised to check that enough workspace and array storage has been allocated. '
elseif (dsaupdinfo .EQ. 1) THEN
PRINT *, 'Error in dsaupd: info = 1'
PRINT *, 'Maximum number of iterations taken. All possible eigenvalues of OP has been found. '
PRINT *, 'IPARAM(5) returns the number of wanted converged Ritz values.'
elseif (dsaupdinfo .EQ. 3) THEN
PRINT *, 'Error in dsaupd: info =3'
PRINT *, 'No shifts could be applied during a cycle of the Implicitly restarted Arnoldi iteration.'
PRINT *, 'One possibility is to increase the size of NCV relative to NEV.'
else
PRINT *, 'Unknown error. info =', dsaupdinfo
END IF
end subroutine
SUBROUTINE dseupderrormessage(dseupdinfo)
implicit none
integer :: dseupdinfo
if (dseupdinfo .EQ. 0) THEN
PRINT *, 'Normal Exit in dseupd: info = 0.'
elseif (dseupdinfo .EQ. -1) THEN
PRINT *, 'Error in deseupd: N must be positive. info =-1.'
elseif (dseupdinfo .EQ. -2) THEN
PRINT *, 'Error in deseupd: NEV must be positive. info = -2.'
elseif (dseupdinfo .EQ. -3) THEN
PRINT *, 'Error in deseupd: NCV must be between NEV and N. info = -3.'
elseif (dseupdinfo .EQ. -5) THEN
PRINT *, 'Error in deseupd: WHICH must be LM, SM, LA, SA, or BE info = -5.'
elseif (dseupdinfo .EQ. -6) THEN
PRINT *, 'Error in deseupd: BMAT must be I or G. info = -6.'
elseif (dseupdinfo .EQ. -7) THEN
PRINT *, 'Error in deseupd: N Length of private work work WORKL array isnt sufficient. info = -7.'
elseif (dseupdinfo .EQ. -8) THEN
PRINT *, 'Error in deseupd: Error in return from trid. eval calc. Error info from LAPACK dsteqr. info = -8.'
elseif (dseupdinfo .EQ. -9) THEN
PRINT *, 'Error in deseupd: Starting vector is 0. info = -9.'
elseif (dseupdinfo .EQ. -10) THEN
PRINT *, 'Error in deseupd: IPARAM(7) must be 1,2,3,4, or 5. info = -10.'
elseif (dseupdinfo .EQ. -11) THEN
PRINT *, 'Error in deseupd: IPARAM(7)=1 and BMAT=G are incompatible. info = -11.'
elseif (dseupdinfo .EQ. -12) THEN
PRINT *, 'Error in deseupd: NEV and WHICH=BE are incompatible. info = -12.'
elseif (dseupdinfo .EQ. -14) THEN
PRINT *, 'Error in deseupd: DSAUPD did find any eigenvalues to sufficient accuracy. info = -14.'
elseif (dseupdinfo .EQ. -15) THEN
PRINT *, 'Error in deseupd: HOWMANY must one A or S if RVEC=1. info = -15.'
elseif (dseupdinfo .EQ. -16) THEN
PRINT *, 'Error in deseupd: HOWMANY =S not yet implemented. info = -16.'
elseif (dseupdinfo .EQ. -17) THEN
PRINT *, 'Error in deseupd: info =-17.'
PRINT *, 'DSEUPD got a different count of the number of converged Ritz values than DSAUPD.'
PRINT *, 'User likely made an error in passing data DSAUPD -> DSEUPD. info = -17.'
else
PRINT *, 'Unknown error. info =', dseupdinfo
END IF
end subroutine
I am doing a multiple integral, there is a parameter M_D which I can modify. Both M_D=2.9d3 or M_D=3.1d3 works fine, but when I change it into M_D=3.0d0 it got an error
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
#0 0x7F831A103E08
#1 0x7F831A102F90
#2 0x7F83198344AF
#3 0x43587C in __mc_vegas_MOD_vegas
#4 0x400EBE in MAIN__ at MAINqq.f90:?
Segmentation fault (core dumped)
It's very unlikely there is a sigularity which out of range while progressing. From the answer to this kind of problem I found, I guess it's not about array dimension that is out of bounds.
This time I didn't make it to simplify the problem which can demonstrate my question in order to write less amount of code . It's unpractical to post all the code here, so I post the segment which I think is relevant to the error.
module my_fxn
implicit none
private
public :: fxn_1
public :: cos_theta
real(kind(0d0)), parameter :: S=1.690d8
real(kind(0d0)), parameter :: g_s = 0.118d0
real(kind(0d0)), parameter :: M_D = 3.0d3 !!!
real(kind(0d0)), parameter :: m=172d0
real(kind(0d0)), parameter :: Q=2d0
real(kind(0d0)), parameter :: pi=3.14159d0
real(kind(0d0)), external :: CT14pdf
real(kind(0d0)) :: cos_theta
real(kind(0d0)) :: s12
integer :: i
contains
function jacobian( upper, lower) result(jfactor)
implicit none
real(kind(0d0)), dimension(1:6) :: upper, lower
real(kind(0d0)) :: jfactor
jfactor = 1d0
do i = 1, 6
jfactor = jfactor * (upper(i) - lower(i))
end do
end function jacobian
function dot_vec(p,q) result(fourvectordot)
implicit none
real(kind(0d0)) :: fourvectordot
real(kind(0d0)), dimension(0:3) :: p,q
fourvectordot = p(0) * q(0)
do i = 1, 3
fourvectordot = fourvectordot - p(i) * q(i)
end do
end function dot_vec
subroutine commonpart(p3_0, p4_0, eta, k_v,P3_v, p4_v, s13, s14, s23, s24)
implicit none
real(kind(0d0)), intent(in) :: p3_0, p4_0, eta, k_v, p3_v, p4_v
real(kind(0d0)), intent(out):: s13, s14, s23, s24
real(kind(0d0)) :: sin_theta, &
cos_eta, sin_eta, &
cos_ksi, sin_ksi
real(kind(0d0)), dimension(0:3) :: k1, k2, p3, p4, k
sin_theta = sqrt(1-cos_theta**2)
cos_eta = cos(eta)
sin_eta = sqrt(1-cos_eta**2)
cos_ksi = (k_v**2-p3_v**2-p4_v**2)/(2*p3_v*p4_v)
sin_ksi = sqrt(1-cos_ksi**2)
k1 = [sqrt(s12)/2d0,0d0,0d0, sqrt(s12)/2d0]
k2 = [sqrt(s12)/2d0,0d0,0d0, -sqrt(s12)/2d0]
p3 = [p3_0, p3_v*(cos_theta*cos_eta*sin_ksi+sin_theta*cos_ksi), &
p3_v* sin_eta*sin_ksi, p3_v*( cos_theta*cos_ksi-sin_theta*cos_eta*sin_ksi)]
p4 = [p4_0, p4_v*sin_theta, 0d0, p4_v*cos_theta]
do i = 1, 3
k(i) = 0 - p3(i) - p4(i)
end do
k(0) = sqrt(s12) - p3_0-p4_0
s13 = m**2- 2*dot_vec(k1,p3)
s14 = m**2- 2*dot_vec(k1,p4)
s23 = m**2- 2*dot_vec(k2,p3)
s24 = m**2- 2*dot_vec(k2,p3)
end subroutine commonpart
function fxn_1(z, wgt) result(fxn_qq)
implicit none
real(kind(0d0)), dimension(1:6) :: z
real(kind(0d0)) :: wgt
real(kind(0d0)) :: tau_0
real(kind(0d0)) :: sigma, tau, m_plus, m_minus, & ! intermediate var
p3_v, p4_v, k_v, phi
real(kind(0d0)) :: s13,s14,s23, s24, gm
real(kind(0d0)) :: part1_qq,part_qq,fxn_qq
real(kind(0d0)) :: p3_0_max, p4_0_max, eta_max, gm_max, x1_max, x2_max, &
p3_0_min, p4_0_min, eta_min, gm_min, x1_min, x2_min
real(kind(0d0)), dimension(1:6) :: upper, lower
real(kind(0d0)) :: jfactor
wgt = 0
gm_max = M_D
gm_min = 0.1d0
z(1)= (gm_max-gm_min)*z(1) + gm_min
tau_0 = (2*m)**2/S
eta_max = 2*pi
eta_min = 0
z(2) = (eta_max-eta_min)*z(2)+eta_min
x1_max = 1
x1_min = tau_0
z(3) = (x1_max-x1_min)*z(3) + x1_min
x2_max = 1
x2_min = tau_0/z(3)
z(4) = (x2_max-x2_min)*z(4)+x2_min
s12 = z(3)*z(4) * S
if (sqrt(s12) < (2*m+z(1)))then
fxn_qq = 0d0
return
else
end if
p4_0_max = sqrt(s12)/2 - ((m+z(1))**2-m**2)/(2*sqrt(s12))
p4_0_min = m
z(5) = (p4_0_max-p4_0_min)*z(5)+p4_0_min
p4_v = sqrt(z(5)**2-m**2)
sigma = sqrt(s12)-z(5)
tau = sigma**2 - p4_v**2
m_plus = m + z(1)
m_minus = m - z(1)
p3_0_max = 1/(2*tau)*(sigma*(tau+m_plus*m_minus)+p4_v*sqrt((tau-m_plus**2)*(tau-m_minus**2)))
p3_0_min = 1/(2*tau)*(sigma*(tau+m_plus*m_minus)-p4_v-sqrt((tau-m_plus**2)*(tau-m_minus**2)))
z(6) = (p3_0_max-p3_0_min)*z(6)+p3_0_min
p3_v = sqrt(z(6)**2-m**2)
k_v = sqrt((sqrt(s12)-z(5)-z(6))**2-z(1)**2)
gm = z(1)
upper = [gm_max, eta_max, x1_max, x2_max, p4_0_max, p3_0_max]
lower = [gm_min, eta_min, x1_min, x2_min, p4_0_min, p3_0_min]
jfactor = jacobian(upper, lower)
call commonpart(z(6),z(5),z(2), k_v,p3_v, p4_v, s13, s14, s23, s24)
include "juicy.m"
part1_qq = 0d0
do i = 1, 5
part1_qq = part1_qq+CT14Pdf(i, z(3), Q)*CT14Pdf(-i, z(4), Q)*part_qq
end do
phi = 1/(8*(2*pi)**4) * 1/(2*s12)
fxn_qq = jfactor * g_s**4/M_D**5*pi*z(1)**2*phi*part1_qq
end function fxn_1
end module my_fxn
MC_VEGAS
MODULE MC_VEGAS
!*****************************************************************
! This module is a modification f95 version of VEGA_ALPHA.for
! by G.P. LEPAGE SEPT 1976/(REV)AUG 1979.
!*****************************************************************
IMPLICIT NONE
SAVE
INTEGER,PARAMETER :: MAX_SIZE=20 ! The max dimensions of the integrals
INTEGER,PRIVATE :: i_vegas
REAL(KIND(1d0)),DIMENSION(MAX_SIZE),PUBLIC:: XL=(/(0d0,i_vegas=1,MAX_SIZE)/),&
XU=(/(1d0,i_vegas=1,MAX_SIZE)/)
INTEGER,PUBLIC :: NCALL=50000,& ! The number of integrand evaluations per iteration
!+++++++++++++++++++++++++++++++++++++++++++++++++++++
! You can change NCALL to change the precision
!+++++++++++++++++++++++++++++++++++++++++++++++++++++
ITMX=5,& ! The maximum number of iterations
NPRN=5,& ! printed or not
NDEV=6,& ! device number for output
IT=0,& ! number of iterations completed
NDO=1,& ! number of subdivisions on an axis
NDMX=50,& ! determines the maximum number of increments along each axis
MDS=1 ! =0 use importance sampling only
! =\0 use importance sampling and stratified sampling
! increments are concentrated either wehre the
! integrand is largest in magnitude (MDS=1), or
! where the contribution to the error is largest(MDS=-1)
INTEGER,PUBLIC :: IINIP
REAL(KIND(1d0)),PUBLIC :: ACC=-1d0 ! Algorithm stops when the relative accuracy,
! |SD/AVGI|, is less than ACC; accuracy is not
! cheched when ACC<0
REAL(KIND(1d0)),PUBLIC :: MC_SI=0d0,& ! sum(AVGI_i/SD_i^2,i=1,IT)
SWGT=0d0,& ! sum(1/SD_i^2,i=1,IT)
SCHI=0d0,& ! sum(AVGI_i^2/SD_i^2,i=1,IT)
ALPH=1.5d0 ! controls the rate which the grid is modified from
! iteration to iteration; decreasing ALPH slows
! modification of the grid
! (ALPH=0 implies no modification)
REAL(KIND(1d0)),PUBLIC :: DSEED=1234567d0 ! seed of
! location of the I-th division on the J-th axi, normalized to lie between 0 and 1.
REAL(KIND(1d0)),DIMENSION(50,MAX_SIZE),PUBLIC::XI=1d0
REAL(KIND(1d0)),PUBLIC :: CALLS,TI,TSI
CONTAINS
SUBROUTINE RANDA(NR,R)
IMPLICIT NONE
INTEGER,INTENT(IN) :: NR
REAL(KIND(1d0)),DIMENSION(NR),INTENT(OUT) :: R
INTEGER :: I
! D2P31M=(2**31) - 1 D2P31 =(2**31)(OR AN ADJUSTED VALUE)
REAL(KIND(1d0))::D2P31M=2147483647.d0,D2P31=2147483711.d0
!FIRST EXECUTABLE STATEMENT
DO I=1,NR
DSEED = DMOD(16807.d0*DSEED,D2P31M)
R(I) = DSEED / D2P31
ENDDO
END SUBROUTINE RANDA
SUBROUTINE VEGAS(NDIM,FXN,AVGI,SD,CHI2A,INIT)
!***************************************************************
! SUBROUTINE PERFORMS NDIM-DIMENSIONAL MONTE CARLO INTEG'N
! - BY G.P. LEPAGE SEPT 1976/(REV)AUG 1979
! - ALGORITHM DESCRIBED IN J COMP PHYS 27,192(1978)
!***************************************************************
! Without INIT or INIT=0, CALL VEGAS
! INIT=1 CALL VEGAS1
! INIT=2 CALL VEGAS2
! INIT=3 CALL VEGAS3
!***************************************************************
IMPLICIT NONE
INTEGER,INTENT(IN) :: NDIM
REAL(KIND(1d0)),EXTERNAL :: FXN
INTEGER,INTENT(IN),OPTIONAL :: INIT
REAL(KIND(1d0)),INTENT(INOUT) :: AVGI,SD,CHI2A
REAL(KIND(1d0)),DIMENSION(50,MAX_SIZE):: D,DI
REAL(KIND(1d0)),DIMENSION(50) :: XIN,R
REAL(KIND(1d0)),DIMENSION(MAX_SIZE) :: DX,X,DT,RAND
INTEGER,DIMENSION(MAX_SIZE) :: IA,KG
INTEGER :: initflag
REAL(KIND(1d0)),PARAMETER :: ONE=1.d0
INTEGER :: I, J, K, NPG, NG, ND, NDM, LABEL = 0
REAL(KIND(1d0)) :: DXG, DV2G, XND, XJAC, RC, XN, DR, XO, TI2, WGT, FB, F2B, F, F2
!***************************
!SAVE AVGI,SD,CHI2A
!SQRT(A)=DSQRT(A)
!ALOG(A)=DLOG(A)
!ABS(A)=DABS(A)
!***************************
IF(PRESENT(INIT))THEN
initflag=INIT
ELSE
initflag=0
ENDIF
! INIT=0 - INITIALIZES CUMULATIVE VARIABLES AND GRID
ini0:IF(initflag.LT.1) THEN
NDO=1
DO J=1,NDIM
XI(1,J)=ONE
ENDDO
ENDIF ini0
! INIT=1 - INITIALIZES CUMULATIVE VARIABLES, BUT NOT GRID
ini1:IF(initflag.LT.2) THEN
IT=0
MC_SI=0.d0
SWGT=MC_SI
SCHI=MC_SI
ENDIF ini1
! INIT=2 - NO INITIALIZATION
ini2:IF(initflag.LE.2)THEN
ND=NDMX
NG=1
IF(MDS.NE.0) THEN
NG=(NCALL/2.d0)**(1.d0/NDIM)
MDS=1
IF((2*NG-NDMX).GE.0) THEN
MDS=-1
NPG=NG/NDMX+1
ND=NG/NPG
NG=NPG*ND
ENDIF
ENDIF
K=NG**NDIM ! K sub volumes
NPG=NCALL/K ! The number of random numbers in per sub volumes Ms
IF(NPG.LT.2) NPG=2
CALLS=DBLE(NPG*K) ! The total number of random numbers M
DXG=ONE/NG
DV2G=(CALLS*DXG**NDIM)**2/NPG/NPG/(NPG-ONE) ! 1/(Ms-1)
XND=ND ! ~NDMX!
! determines the number of increments along each axis
NDM=ND-1 ! ~NDMX-1
DXG=DXG*XND ! determines the number of increments along each axis per sub-v
XJAC=ONE/CALLS
DO J=1,NDIM
DX(J)=XU(J)-XL(J)
XJAC=XJAC*DX(J) ! XJAC=Volume/M
ENDDO
! REBIN, PRESERVING BIN DENSITY
IF(ND.NE.NDO) THEN
RC=NDO/XND ! XND=ND
outer:DO J=1, NDIM ! Set the new division
K=0
XN=0.d0
DR=XN
I=K
LABEL=0
inner5:DO
IF(LABEL.EQ.0) THEN
inner4:DO
K=K+1
DR=DR+ONE
XO=XN
XN=XI(K,J)
IF(RC.LE.DR) EXIT
ENDDO inner4
ENDIF
I=I+1
DR=DR-RC
XIN(I)=XN-(XN-XO)*DR
IF(I.GE.NDM) THEN
EXIT
ELSEIF(RC.LE.DR) THEN
LABEL=1
ELSE
LABEL=0
ENDIF
ENDDO inner5
inner:DO I=1,NDM
XI(I,J)=XIN(I)
ENDDO inner
XI(ND,J)=ONE
ENDDO outer
NDO=ND
ENDIF
IF(NPRN.GE.0) WRITE(NDEV,200) NDIM,CALLS,IT,ITMX,ACC,NPRN,&
ALPH,MDS,ND,(XL(J),XU(J),J=1,NDIM)
ENDIF ini2
!ENTRY VEGAS3(NDIM,FXN,AVGI,SD,CHI2A) INIT=3 - MAIN INTEGRATION LOOP
mainloop:DO
IT=IT+1
TI=0.d0
TSI=TI
DO J=1,NDIM
KG(J)=1
DO I=1,ND
D(I,J)=TI
DI(I,J)=TI
ENDDO
ENDDO
LABEL=0
level1:DO
level2:DO
ifla:IF(LABEL.EQ.0)THEN
FB=0.d0
F2B=FB
level3:DO K=1,NPG
CALL RANDA(NDIM,RAND)
WGT=XJAC
DO J=1,NDIM
XN=(KG(J)-RAND(J))*DXG+ONE
IA(J)=XN
IF(IA(J).LE.1) THEN
XO=XI(IA(J),J)
RC=(XN-IA(J))*XO
ELSE
XO=XI(IA(J),J)-XI(IA(J)-1,J)
RC=XI(IA(J)-1,J)+(XN-IA(J))*XO
ENDIF
X(J)=XL(J)+RC*DX(J)
WGT=WGT*XO*XND
ENDDO
F=WGT
F=F*FXN(X,WGT)
F2=F*F
FB=FB+F
F2B=F2B+F2
DO J=1,NDIM
DI(IA(J),J)=DI(IA(J),J)+F
IF(MDS.GE.0) D(IA(J),J)=D(IA(J),J)+F2
ENDDO
ENDDO level3
! K=K-1 !K=NPG
F2B=DSQRT(F2B*DBLE(NPG))
F2B=(F2B-FB)*(F2B+FB)
TI=TI+FB
TSI=TSI+F2B
IF(MDS.LT.0) THEN
DO J=1,NDIM
D(IA(J),J)=D(IA(J),J)+F2B
ENDDO
ENDIF
K=NDIM
ENDIF ifla
KG(K)=MOD(KG(K),NG)+1
IF(KG(K).EQ.1) THEN
EXIT
ELSE
LABEL=0
ENDIF
ENDDO level2
K=K-1
IF(K.GT.0) THEN
LABEL=1
ELSE
EXIT
ENDIF
ENDDO level1
! COMPUTE FINAL RESULTS FOR THIS ITERATION
TSI=TSI*DV2G
TI2=TI*TI
WGT=ONE/TSI
MC_SI=MC_SI+TI*WGT
SWGT=SWGT+WGT
SCHI=SCHI+TI2*WGT
AVGI=MC_SI/SWGT
CHI2A=(SCHI-MC_SI*AVGI)/(IT-0.9999d0)
SD=DSQRT(ONE/SWGT)
IF(NPRN.GE.0) THEN
TSI=DSQRT(TSI)
WRITE(NDEV,201) IT,TI,TSI,AVGI,SD,CHI2A
ENDIF
IF(NPRN.GT.0) THEN
DO J=1,NDIM
WRITE(NDEV,202) J,(XI(I,J),DI(I,J),I=1+NPRN/2,ND,NPRN)
ENDDO
ENDIF
!*************************************************************************************
! REFINE GRID
! XI(k,j)=XI(k,j)-(XI(k,j)-XI(k-1,j))*(sum(R(i),i=1,k)-s*sum(R(i),i=1,ND)/M)/R(k)
! divides the original k-th interval into s parts
!*************************************************************************************
outer2:DO J=1,NDIM
XO=D(1,J)
XN=D(2,J)
D(1,J)=(XO+XN)/2.d0
DT(J)=D(1,J)
inner2:DO I=2,NDM
D(I,J)=XO+XN
XO=XN
XN=D(I+1,J)
D(I,J)=(D(I,J)+XN)/3.d0
DT(J)=DT(J)+D(I,J)
ENDDO inner2
D(ND,J)=(XN+XO)/2.d0
DT(J)=DT(J)+D(ND,J)
ENDDO outer2
le1:DO J=1,NDIM
RC=0.d0
DO I=1,ND
R(I)=0.d0
IF(D(I,J).GT.0.) THEN
XO=DT(J)/D(I,J)
R(I)=((XO-ONE)/XO/DLOG(XO))**ALPH
ENDIF
RC=RC+R(I)
ENDDO
RC=RC/XND
K=0
XN=0.d0
DR=XN
I=K
LABEL=0
le2:DO
le3:DO
IF(LABEL.EQ.0)THEN
K=K+1
DR=DR+R(K)
XO=XN
XN=XI(K,J)
ENDIF
IF(RC.LE.DR) THEN
EXIT
ELSE
LABEL=0
ENDIF
ENDDO le3
I=I+1
DR=DR-RC
XIN(I)=XN-(XN-XO)*DR/R(K)
IF(I.GE.NDM) THEN
EXIT
ELSE
LABEL=1
ENDIF
ENDDO le2
DO I=1,NDM
XI(I,J)=XIN(I)
ENDDO
XI(ND,J)=ONE
ENDDO le1
IF(IT.GE.ITMX.OR.ACC*ABS(AVGI).GE.SD) EXIT
ENDDO mainloop
200 FORMAT(/," INPUT PARAMETERS FOR MC_VEGAS: ",/," NDIM=",I3," NCALL=",F8.0,&
" IT=",I3,/," ITMX=",I3," ACC= ",G9.3,&
" NPRN=",I3,/," ALPH=",F5.2," MDS=",I3," ND=",I4,/,&
"(XL,XU)=",(T10,"(" G12.6,",",G12.6 ")"))
201 FORMAT(/," INTEGRATION BY MC_VEGAS ", " ITERATION NO. ",I3, /,&
" INTEGRAL = ",G14.8, /," SQURE DEV = ",G10.4,/,&
" ACCUMULATED RESULTS: INTEGRAL = ",G14.8,/,&
" DEV = ",G10.4, /," CHI**2 PER IT'N = ",G10.4)
! X is the division of the coordinate
! DELTA I is the sum of F in this interval
202 FORMAT(/,"DATA FOR AXIS ",I2,/," X DELTA I ", &
24H X DELTA I ,18H X DELTA I, &
/(1H ,F7.6,1X,G11.4,5X,F7.6,1X,G11.4,5X,F7.6,1X,G11.4))
END SUBROUTINE VEGAS
END MODULE MC_VEGAS
Main.f90
program main
use my_fxn
use MC_VEGAS
implicit none
integer, parameter :: NDIM = 6
real(kind(0d0)) :: avgi, sd, chi2a
Character(len=40) :: Tablefile
data Tablefile/'CT14LL.pds'/
Call SetCT14(Tablefile)
call vegas(NDIM,fxn_1,avgi,sd,chi2a)
print *, avgi
end program main
After running build.sh
#!/bin/sh
rm -rf *.mod
rm -rf *.o
rm -rf ./calc
rm DATAqq.txt
gfortran -c CT14Pdf.for
gfortran -c FXNqq.f90
gfortran -c MC_VEGAS.f90
gfortran -c MAINqq.f90
gfortran -g -fbacktrace -fcheck=all -Wall -o calc MAINqq.o CT14Pdf.o FXNqq.o MC_VEGAS.o
./calc
rm -rf *.mod
rm -rf *.o
rm -rf ./calc
The whole output has not changed
rm: cannot remove 'DATAqq.txt': No such file or directory
INPUT PARAMETERS FOR MC_VEGAS:
NDIM= 6 NCALL= 46875. IT= 0
ITMX= 5 ACC= -1.00 NPRN= 5
ALPH= 1.50 MDS= 1 ND= 50
(XL,XU)= ( 0.00000 , 1.00000 )
( 0.00000 , 1.00000 )
( 0.00000 , 1.00000 )
( 0.00000 , 1.00000 )
( 0.00000 , 1.00000 )
( 0.00000 , 1.00000 )
INTEGRATION BY MC_VEGAS ITERATION NO. 1
INTEGRAL = NaN
SQURE DEV = NaN
ACCUMULATED RESULTS: INTEGRAL = NaN
DEV = NaN
CHI**2 PER IT'N = NaN
DATA FOR AXIS 1
X DELTA I X DELTA I X DELTA I
.060000 0.2431E-14 .160000 0.5475E-15 .260000 0.8216E-14
.360000 0.3641E-14 .460000 0.6229E-12 .560000 0.6692E-13
.660000 0.9681E-15 .760000 0.9121E-15 .860000 0.2753E-13
.960000 -0.9269E-16
DATA FOR AXIS 2
X DELTA I X DELTA I X DELTA I
.060000 0.1658E-13 .160000 0.5011E-14 .260000 0.8006E-12
.360000 0.1135E-14 .460000 0.9218E-13 .560000 0.7337E-15
.660000 0.6192E-12 .760000 0.3676E-14 .860000 0.2315E-14
.960000 0.5426E-13
DATA FOR AXIS 3
X DELTA I X DELTA I X DELTA I
.060000 0.3197E-14 .160000 0.1096E-12 .260000 0.5996E-14
.360000 0.5695E-13 .460000 0.3240E-14 .560000 0.5504E-13
.660000 0.9276E-15 .760000 0.6193E-12 .860000 0.1151E-13
.960000 0.7968E-17
DATA FOR AXIS 4
X DELTA I X DELTA I X DELTA I
.060000 0.3605E-13 .160000 0.1656E-14 .260000 0.7266E-12
.360000 0.2149E-13 .460000 0.8086E-13 .560000 0.9119E-14
.660000 0.3692E-15 .760000 0.6499E-15 .860000 0.1906E-17
.960000 0.1542E-19
DATA FOR AXIS 5
X DELTA I X DELTA I X DELTA I
.060000 -0.4229E-15 .160000 -0.4056E-14 .260000 -0.1121E-14
.360000 0.6757E-15 .460000 0.7460E-14 .560000 0.9331E-15
.660000 0.8301E-14 .760000 0.6595E-14 .860000 -0.5203E-11
.960000 0.6361E-12
DATA FOR AXIS 6
X DELTA I X DELTA I X DELTA I
.060000 0.2111E-12 .160000 0.5410E-13 .260000 0.1418E-12
.360000 0.1103E-13 .460000 0.8338E-14 .560000 -0.5840E-14
.660000 0.1263E-14 .760000 -0.1501E-15 .860000 0.4647E-14
.960000 0.3134E-15
Program received signal SIGSEGV: Segmentation fault - invalid memory reference.
Backtrace for this error:
#0 0x7F9D828B0E08
#1 0x7F9D828AFF90
#2 0x7F9D81FE24AF
#3 0x43586C in __mc_vegas_MOD_vegas
#4 0x400EAE in MAIN__ at MAINqq.f90:?
Segmentation fault (core dumped)
I have a code as enclosed below. It is supposed to read a binary file and produce a special format. (This code is a part of siesta code.) However, I receive the following error when I execute the code:
At line 127 of file grid2cube.f (unit = 5, file = 'stdin')
Fortran runtime error: Bad real number in item 0 of list input
The fortran compiler and flags that I have compiled the main code are:
FC= /usr/local/bin/mpif90
FFLAGS=-g -O2 FPPFLAGS= -DMPI
-DFC_HAVE_FLUSH -DFC_HAVE_ABORT LDFLAGS=
This code is also compiled with the same flag:
/usr/local/bin/mpif90 -c -g -O2 grid2cube.f
/usr/local/bin/mpif90 -o grid2cube grid2cube.o
I also change "-O2" to "-O1" and "O0" and recompiled everything. But the same error was produced.Besides I am using mpich-3.0.4 and gfortran as the base.
Please kindly help me correct this error.
program grid2cube
implicit none
integer maxp, natmax, nskip
parameter (maxp = 12000000)
parameter (natmax = 1000)
integer ipt, isp, ix, iy, iz, i, ip, natoms, np,
. mesh(3), nspin, Ind, id(3), iix, iiy,
. iiz, ii, length, lb
integer is(natmax), izat(natmax)
character sysname*70, fnamein*75, fnameout(2)*75,
. fnamexv*75, paste*74, task*5, fform*12
double precision rho(maxp,2), rhot(maxp,2)
double precision cell(3,3), xat(natmax,3), cm(3), rt(3),
. delta(3), dr(3), residual
external paste, lb
c ---------------------------------------------------------------------------
read(*,*)
read(5,*) sysname
read(5,*) task
read(5,*) rt(1),rt(2),rt(3)
read(5,*) nskip
read(5,*) fform
fnamexv = paste(sysname,'.XV')
if (task .eq. 'rho') then
fnamein = paste(sysname,'.RHO')
else if (task .eq. 'drho') then
fnamein = paste(sysname,'.DRHO')
else if (task .eq. 'ldos') then
fnamein = paste(sysname,'.LDOS')
else if (task .eq. 'vt') then
fnamein = paste(sysname,'.VT')
else if (task .eq. 'vh') then
fnamein = paste(sysname,'.VH')
else if (task .eq. 'bader') then
fnamein = paste(sysname,'.BADER')
else
write(6,*) 'Wrong task'
write(6,*) 'Accepted values: rho, drho, ldos, vh, vt, bader'
write(6,*) '(in lower case!!!!)'
stop
endif
length = lb(fnamein)
write(6,*)
write(6,*) 'Reading grid data from file ',fnamein(1:length)
c read function from the 3D grid --------------------------------------------
open( unit=1, file=fnamein, form=fform, status='old' )
if (fform .eq. 'unformatted') then
read(1) cell
else if (fform .eq. 'formatted') then
do ix=1,3
read(1,*) (cell(iy,ix),iy=1,3)
enddo
else
stop 'ERROR: last input line must be formatted or unformatted'
endif
write(6,*)
write(6,*) 'Cell vectors'
write(6,*)
write(6,*) cell(1,1),cell(2,1),cell(3,1)
write(6,*) cell(1,2),cell(2,2),cell(3,2)
write(6,*) cell(1,3),cell(2,3),cell(3,3)
residual = 0.0d0
do ix=1,3
do iy=ix+1,3
residual = residual + cell(ix,iy)**2
enddo
enddo
if (residual .gt. 1.0d-6) then
write(6,*)
write(6,*) 'ERROR: this progam can only handle orthogonal cells'
write(6,*) ' with vectors pointing in the X, Y and Z directions'
stop
endif
if (fform .eq. 'unformatted') then
read(1) mesh, nspin
else
read(1,*) mesh, nspin
endif
write(6,*)
write(6,*) 'Grid mesh: ',mesh(1),'x',mesh(2),'x',mesh(3)
write(6,*)
write(6,*) 'nspin = ',nspin
write(6,*)
do ix=1,3
dr(ix)=cell(ix,ix)/mesh(ix)
enddo
np = mesh(1) * mesh(2) * mesh(3)
if (np .gt. maxp) stop 'grid2d: Parameter MAXP too small'
C read(1) ( (rho(ip,isp), ip = 1, np), isp = 1,nspin)
do isp=1,nspin
Ind=0
if (fform .eq. 'unformatted') then
do iz=1,mesh(3)
do iy=1,mesh(2)
read(1) (rho(Ind+ix,isp),ix=1,mesh(1))
Ind=Ind+mesh(1)
enddo
enddo
else
do iz=1,mesh(3)
do iy=1,mesh(2)
read(1,'(e15.6)') (rho(Ind+ix,isp),ix=1,mesh(1))
Ind=Ind+mesh(1)
enddo
enddo
endif
enddo
C translate cell
do ix=1,3
delta(ix) = rt(ix)/dr(ix)
id(ix) = delta(ix)
delta(ix) = rt(ix) - id(ix) * dr(ix)
enddo
do iz=1,mesh(3)
do iy=1,mesh(2)
do ix=1,mesh(1)
iix=ix+id(1)
iiy=iy+id(2)
iiz=iz+id(3)
if (iix .lt. 1) iix=iix+mesh(1)
if (iiy .lt. 1) iiy=iiy+mesh(2)
if (iiz .lt. 1) iiz=iiz+mesh(3)
if (iix .gt. mesh(1)) iix=iix-mesh(1)
if (iiy .gt. mesh(2)) iiy=iiy-mesh(2)
if (iiz .gt. mesh(3)) iiz=iiz-mesh(3)
if (iix .lt. 1) stop 'ix < 0'
if (iiy .lt. 1) stop 'iy < 0'
if (iiz .lt. 1) stop 'iz < 0'
if (iix .gt. mesh(1)) stop 'ix > cell'
if (iiy .gt. mesh(2)) stop 'iy > cell'
if (iiz .gt. mesh(3)) stop 'iz > cell'
i=ix+(iy-1)*mesh(1)+(iz-1)*mesh(1)*mesh(2)
ii=iix+(iiy-1)*mesh(1)+(iiz-1)*mesh(1)*mesh(2)
do isp=1,nspin
rhot(ii,isp)=rho(i,isp)
enddo
enddo
enddo
enddo
close(1)
open( unit=3, file=fnamexv, status='old', form='formatted')
read(3,*)
read(3,*)
read(3,*)
read(3,*) natoms
do i=1,natoms
read(3,*) is(i),izat(i),(xat(i,ix),ix=1,3)
enddo
do i=1,natoms
do ix=1,3
xat(i,ix)=xat(i,ix)+rt(ix)-delta(ix)
if (xat(i,ix) .lt. 0.0) xat(i,ix)=xat(i,ix)+cell(ix,ix)
if (xat(i,ix) .gt. cell(ix,ix))
. xat(i,ix)=xat(i,ix)-cell(ix,ix)
enddo
enddo
close(3)
if (nspin .eq. 1) then
fnameout(1) = paste(fnamein,'.cube')
else if (nspin .eq. 2) then
fnameout(1) = paste(fnamein,'.UP.cube')
fnameout(2) = paste(fnamein,'.DN.cube')
else
stop 'nspin must be either 1 or 2'
endif
do isp=1,nspin
length = lb(fnameout(isp))
write(6,*) 'Writing CUBE file ',fnameout(isp)(1:length)
C open( unit=2, file=fnameout(isp), status='new', form='formatted')
open( unit=2, file=fnameout(isp), form='formatted')
length = lb(fnameout(isp))
write(2,*) fnameout(isp)(1:length)
write(2,*) fnameout(isp)(1:length)
write(2,'(i5,4f12.6)') natoms, 0.0,0.0,0.0
do ix=1,3
ii = mesh(ix)/nskip
if (ii*nskip .ne. mesh(ix)) ii = ii+1
write(2,'(i5,4f12.6)')
. ii,(cell(ix,iy)/ii,iy=1,3)
enddo
do i=1,natoms
write(2,'(i5,4f12.6)') izat(i),0.0,(xat(i,ix),ix=1,3)
enddo
do ix=1,mesh(1),nskip
do iy=1,mesh(2),nskip
write(2,'(6e13.5)')
. (rhot(ix+(iy-1)*mesh(1)+(iz-1)*mesh(1)*mesh(2),isp),
. iz=1,mesh(3),nskip)
enddo
enddo
close(2)
enddo
write(6,*)
end
CHARACTER*(*) FUNCTION PASTE( STR1, STR2 )
C CONCATENATES THE STRINGS STR1 AND STR2 REMOVING BLANKS IN BETWEEN
C Writen by Jose M. Soler
CHARACTER*(*) STR1, STR2
DO 10 L = LEN( STR1 ), 1, -1
IF (STR1(L:L) .NE. ' ') GOTO 20
10 CONTINUE
20 PASTE = STR1(1:L)//STR2
END
INTEGER FUNCTION LB ( STR1 )
C RETURNS THE SIZE IF STRING STR1 WITH BLANKS REMOVED
C Writen by P. Ordejon from Soler's paste.f
CHARACTER*(*) STR1
DO 10 L = LEN( STR1 ), 1, -1
IF (STR1(L:L) .NE. ' ') GOTO 20
10 CONTINUE
20 LB = L
END
The statement at the error line is:
read(5,*) rt(1),rt(2),rt(3)
This is is a list-directed formatted read. As you indicated in the comment, you are trying to read binary (unformatted) data. That cannot work. The statement above expects formatted, data, that means text with human readable numbers.
Also the pre-connected unit 5 is standard input. It shouldn't work for unformatted data if you first read formatted from it (with read(5,*) sysname).
Side note: the number 5 for standard input is not standardized, but is quite a safe assumption in practice. But I would use * instead of 5 anyway.
Response to a comment:
The (*,*) also cannot work. Generally, whenever you provide a format, which is the second argument in the parenthesis to read or write, you do formatted i/o. It doesn't matter if the format is * or something different. You cannot read unformatted data this way. You have to open a file for the unformatted read with form=unformatted with any possible access and read it with:
read(file_unit_number) rt(1),rt(2),rt(3)
If you cannot read the numbers in the data file as a text you cannot use formatted read.
This program:
C This program calculates cos(x**2)
PROGRAM COSX_SQUARE
IMPLICIT NONE
INTEGER a
REAL y, r
PRINT*, 'INPUT THE DEGREE'
PRINT*, 'BETWEEN 0 AND 360'
READ*, a
a*(3.141592/180) = y
C This part determines minus sign and calculates the function
IF (a .GT. 90) THEN
r = -(1-(y**4)/2+(y**8)/24-(y**12)/720+(y**16)/40320)
ELSEIF (a .GE. 270) THEN
r = 1-(y**4)/2+(y**8)/24-(y**12)/720+(y**16)/40320
ELSEIF (a .GT. 360) THEN
PRINT*, 'INVALID DEGREE'
PRINT*, 'DEGREE MUST BE BETWEEN 0 AND 360'
ELSEIF (a .LT. 0) THEN
PRINT*, 'INVALID DEGREE'
PRINT*, 'DEGREE MUST BE BETWEEN 0 AND 360'
END IF
PRINT*, 'THE RESULT OF COS', a, 'SQUARE IS = ', r
STOP
END
Gives this error:
a*(3.141592/180)=y
1
Error: Unclassifiable statement at (1)
I already defined a as INTEGER. Why this error keeps coming?
Yep. It is an expression which begins a statement. Maybe change it to
y = a*(3.141592/180)
if that is what you really meant.