I would like to ask about the error occurred with my Fortran code. Since I'm new to fortran I can't handle this after 2 days, I also searched around but still don't know how to fix it.
PROGRAM SUBDEM
IMPLICIT REAL*8(A-H,O-Z)
REAL*8 NTET,NPTK
INTEGER*4 NA,NC,NE,NBAND,NTMAX,IDEF
C CALL SETK08(NA,NC, A,C, PTK,NPTK, IDEF,NTET, NKMAX,NTMAX)
C CALL DOSTET(ENER,IDIME,NBAND,IDEF,NTET,XE,NE,Y,Z)
PRINT *,'Test print'
C with DIMENSION PTK(4,NKMAX),IDEF(5,NTMAX)
C NA,NC are the two k-mesh discretization parameters,
C A,C are the two parameters "a","c" of the direct lattice.
C PTK is a REAL*8 array and IDEF is an INTEGER*4 array
NA=3
NC=3
A=1.67
C=2.1
NKMAX=550
NTMAX=50.D3
CALL SETK08(NA,NC,A,C,PTK,NPTK,IDEF,NTET,NKMAX,NTMAX)
NE = 20
IDIME = 5.0
NBAND = 5
XE = 4
NE = 15
C CALL DOSTET(ENER,IDIME,NBAND,IDEF,NTET,XE,NE,Y,Z)
C ENER (REAL*8 two-dimensional array, input)
C ENER(NU,IK) is the energy of band NU, computed for the k-point IK, defined by the SETK** routine
C IDIME (INTEGER*4, input)
C First dimension of the array ENER, as defined in the calling program. IDIME must be at least equal to NBAND
C NBAND (INTEGER*4, input)
C Number of energy bands included in the summation
C IDEF (INTEGER*4 two-dimensional array,input)
C Table defining the tetrahedron corners, as obtained from the SETK** routines. The first dimension is 5.
C NTET (INTEGER*4, input)
C Number of tetrahedra filling the volume V (provided by a SETK** routine)
C XE (REAL*8 one-dimensional array, input)
C Contains the values of the energies E where the density of states and integrated density of states are to be computed.
C Dimension is at least NE.
C NE (INTEGER*4, input)
C Number of energy points where the density of states and integrated density of states are computed. Only the first NE locations of XE are used by DOSTET.
C Y (REAL*8 one-dimensional array, output)
C The NE first components of this vector contain, on return, the density of states evaluated at energy points corresponding to the NE first components of XE.
C Z (REAL*8 one-dimensional array, output)
C The NE first components of this vector contain, on return, the integrated density of states evaluated at energy points corresponding to the NE first components of XE.
END
SUBROUTINE SETK08(NA,NC,A,C,PTK,NPTK,IDEF,NTET,NKMAX,NTMAX)
C SET THE K-POINTS IN THE 1/16TH OF THE BRILLOUIN ZONE FOR A
C SIMPLE TETRAGONAL LATTICE WITH PARAMETERS A, C
C SYMMETRY IS D4H
IMPLICIT REAL*8(A-H,O-Z)
REAL*4 AVOL
DIMENSION PTK(4,NKMAX),IDEF(5,NTMAX)
EQUIVALENCE (IVOL,AVOL)
PI = 3.141592653589793238D0
IF(NA.LE.0.OR.NC.LE.0) GOTO 97
IF(A.LE.0.0D0 .OR. C.LE.0.0D0) GOTO 98
NPTK = (NA+1)*(NA+2)*(NC+1)/2
IF(NPTK.GT.NKMAX) STOP '*** <SETK08> NPTK EXCEEDS NKMAX ***'
NTET = 3*NC*NA**2
IF(NTET.GT.NTMAX) STOP '*** <SETK08> NTET EXCEEDS NTMAX ***'
C *** SET THE K-POINTS
AK=PI/A/NA
CK=PI/C/NC
WRITE(6,100) NPTK,NTET,NA*AK,NA*AK,NC*CK
W = 2.0D0/(NA*NA*NC)
NPTK=0
DO 1 I=0,NA,1
DO 1 J=0,I,1
DO 1 K=0,NC,1
C NPTK = I*(I+1)/2*NZ1 + J*NZ1 + K+1
WK = W
IF(I.EQ.0) WK = WK/2.0D0
IF(J.EQ.0) WK = WK/2.0D0
IF(J.EQ.I) WK = WK/2.0D0
IF(I.EQ.NA) WK = WK/2.0D0
IF(J.EQ.NA) WK = WK/2.0D0
IF(K.EQ.0 .OR. K.EQ.NC) WK = WK/2.0D0
NPTK=NPTK+1
PTK(1,NPTK)=I*AK
PTK(2,NPTK)=J*AK
PTK(3,NPTK)=K*CK
PTK(4,NPTK)=WK
1 CONTINUE
C *** DEFINE THE TETRAHEDRA
NZ1=NC+1
NTET=0
I7=0
I=0
4 IX=(I+1)*NZ1
J = 0
5 K=0
I7=I*IX/2+J*NZ1
6 I7=I7+1
I6=I7+IX
I2=I6+NZ1
I1=I2+1
NTET=NTET+1
IDEF(1,NTET)=I7
IDEF(2,NTET)=I6
IDEF(3,NTET)=I2
IDEF(4,NTET)=I1
I8=I7+1
I5=I6+1
NTET=NTET+1
IDEF(1,NTET)=I7
IDEF(2,NTET)=I6
IDEF(3,NTET)=I5
IDEF(4,NTET)=I1
NTET=NTET+1
IDEF(1,NTET)=I7
IDEF(2,NTET)=I8
IDEF(3,NTET)=I5
IDEF(4,NTET)=I1
IF(J.EQ.I) GOTO 7
I3=I7+NZ1
I4=I3+1
NTET=NTET+1
IDEF(1,NTET)=I7
IDEF(2,NTET)=I3
IDEF(3,NTET)=I2
IDEF(4,NTET)=I1
NTET=NTET+1
IDEF(1,NTET)=I7
IDEF(2,NTET)=I3
IDEF(3,NTET)=I4
IDEF(4,NTET)=I1
NTET=NTET+1
IDEF(1,NTET)=I7
IDEF(2,NTET)=I8
IDEF(3,NTET)=I4
IDEF(4,NTET)=I1
7 K=K+1
IF(K.LT.NC) GOTO 6
J=J+1
IF(J.LE.I) GOTO 5
I=I+1
IF(I.LT.NA) GOTO 4
AVOL=1.D0/DFLOAT(NTET)
DO 15 IT=1,NTET
15 IDEF(5,IT)=IVOL
PRINT *,NTET,NPTK
RETURN
97 WRITE(6,101)
GOTO 99
98 WRITE(6,102)
99 STOP
100 FORMAT(' SAMPLING THE 16TH PART OF A SQUARE-BASED PRISM'/
.1X,I5,' K-POINTS',I7,' TETRAHEDRA'/
.' KXMAX =',D11.4,' KYMAX =',D11.4,' KZMAX =',D11.4)
101 FORMAT(' *** <SETK08> NA OR NC IS NOT A POSITIVE INTEGER ***')
102 FORMAT(' *** <SETK08> A AND C MUST BE POSITIVE ***')
END
SUBROUTINE DOSTET(ENER,IDIME,NBAND,IDEF,NTET,XE,NE,Y,Z)
C COMPUTE A DENSITY OF STATES USING THE TETRAHEDRONS METHOD.
C XE CONTAINS THE ENERGIES, Y AND Z RETURN THE RELATED DENSITY OF
C STATES AND THE INTEGRATED DENSITY OF STATES, RESPECTIVELY.
IMPLICIT REAL*8(A-H,O-Z)
REAL*4 AVOL
DIMENSION ENER(IDIME,1),XE(1),Y(1),Z(1),IDEF(5,1),C(4)
EQUIVALENCE (IVOL,AVOL),(C(1),E1),(C(2),E2),(C(3),E3),(C(4),E4)
DATA EPS/1.0D-05/
DO 6 IX=1,NE
Y(IX)=0.D0
6 Z(IX)=0.D0
C
C LOOP OVER THE TETRAHEDRONS
DO 9 ITET=1,NTET
C
IA=IDEF(1,ITET)
IB=IDEF(2,ITET)
IC=IDEF(3,ITET)
ID=IDEF(4,ITET)
IVOL=IDEF(5,ITET)
C
C LOOP OVER THE BANDS
DO 9 NB=1,NBAND
C
C *** DEFINE E1, E2, E3, E4, AS THE CORNER ENERGIES ORDERED BY
C *** DECREASING SIZE
C(1)=ENER(NB,IA)
C(2)=ENER(NB,IB)
C(3)=ENER(NB,IC)
C(4)=ENER(NB,ID)
DO 2 I=1,4
CC=C(I)
J=I
1 J=J+1
IF(J.GT.4) GOTO 2
IF(CC.GE.C(J)) GOTO 1
C(I)=C(J)
C(J)=CC
CC=C(I)
GOTO 1
2 CONTINUE
UNITE=1.0D0
IF(E1.GT.E4) UNITE=E1-E4
E12=(E1-E2)/UNITE
E13=(E1-E3)/UNITE
E14=(E1-E4)/UNITE
E23=(E2-E3)/UNITE
E24=(E2-E4)/UNITE
E34=(E3-E4)/UNITE
FACY=3.D0*DBLE(AVOL)/UNITE
DO 9 IX=1,NE
E=XE(IX)
SURFAC=0.D0
VOLUME=1.D0
IF(E.GT.E1) GOTO 8
VOLUME=0.D0
IF(E.LT.E4) GOTO 8
EE1=(E-E1)/UNITE
IF(DABS(EE1).LT.EPS) EE1=0.D0
EE2=(E-E2)/UNITE
IF(DABS(EE2).LT.EPS) EE2=0.D0
EE3=(E-E3)/UNITE
IF(DABS(EE3).LT.EPS) EE3=0.D0
EE4=(E-E4)/UNITE
IF(DABS(EE4).LT.EPS) EE4=0.D0
IF(E.GT.E3) GOTO 5
C *** E4.LE.E.AND.E.LE.E3
IF(E4.EQ.E3) GOTO 3
SURFAC=(EE4/E34)*(EE4/E24)
VOLUME=SURFAC*EE4
GOTO 8
3 IF(E3.LT.E2) GOTO 8
IF(E2.EQ.E1) GOTO 4
SURFAC=1.D0/E12
GOTO 8
4 SURFAC=1.0D+15
VOLUME=0.5D0
GOTO 8
5 IF(E.GT.E2) GOTO 7
C *** E3.LT.E.AND.E.LE.E2
SURFAC=-(EE3*EE2/E23+EE4*EE1)/E13/E24
VOLUME=(0.5D0*EE3*(2.D0*E13*E34+E13*EE4-E34*EE1-2.D0*EE1*EE4+
+ EE3*(EE3-3.D0*EE2)/E23)/E13+E34*E34)/E24
GOTO 8
C *** E2.LT.E.AND.E.LE.E1
7 SURFAC=(EE1/E12)*(EE1/E13)
VOLUME=1.D0+SURFAC*EE1
8 Y(IX)=Y(IX)+FACY*SURFAC
Z(IX)=Z(IX)+DBLE(AVOL)*VOLUME
9 CONTINUE
RETURN
END
Seems like the code broke at line 82:
PTK(1,NPTK)=DFLOAT(I)*DK
You forgot to declare PTK in the main program. Due to the IMPLICIT statement it is interpreted as a scalar REAL*8. The subroutine SETK08, however, expects PTK to be DIMENSION PTK(4,NKMAX). The same holds true for IDEF.
NPTK and NTET are expected to be integers in SETK08 but are declared REAL*8 in the main program!
Please don't use implicit declaration! Always use IMPLICIT NONE and declare your variables.
Fixing these points removes the Segfault and produces
STOP *** <SETK08> NTET EXCEEDS NTMAX ***
Related
I wish to solve the schrodinger time dependent equation . In my code, I introduced two arrays, namely yc and yr, for the complex and real part of wavefunction . Later I tried to store the values in the array in the format yc(x(i),t(j)) as y(x,t) function .There is a warning showing that I am using real as index of an array . I understand where the problem lies, but what is the way out ? Can I define a function whose values I can assign during my program discreetly as an alternative to that array ?
I have googled about this could not find any solution .
function v(x) result(s)
real::s,x
if (x<0) then
s=0
else
s=1
end if
end function v
real::t(10000),x(10000),yc(10000,10000),yr(10000,10000),tf,xi,xf,d
integer::i,j,k,l,m
write(*,*) "tf,xi,xf,step size"
read(*,*) tf,xi,xf,d
x(1)=xi
t(1)=0
i=1
1 if(x(i).lt.xf) then
x(i+1)=x(i)+d
i=i+1
goto 1
end if
do j=1,i
yr(x(j),0)=exp(-x(j)**2) !initial wavefunction
yc(x(j),0)=0
end do
do l=1,i
k=1
3 if(t(k).lt.tf) then
yr(x(l),t(k+1))=yr(x(l),t(k))-(yc(x(l)+2*d,t(k))-2*yc(x(l)+d,t(k))+yc(x(l),t(k)))/d&
+v(x(l))*yc(x(l),t(k))*d
yc(x(l),t(k+1))=yc(x(l),t(k))+(yr(x(l)+2*d,t(k))-2*yr(x(l)+d,t(k))+yr(x(l),t(k)))/d&
-v(x(l))*yr(x(l),t(k))*d
k=k+1
goto 3
end if
end do
open(1,file="q.dat")
do m=1,i
write(1,*) x(m),yr(x(m),t(1))**2+yc(x(m),t(1))**2
end do
close(1)
end
expected result :$ yi(x,t)^2+yc(x,t)^2 versus x at different t
obtained error :
yr(x(j),0)=exp(-x(j)**2) !initial wavefunction
1
Warning: Legacy Extension: REAL array index at (1)
schrodinger.f90:27:8:
yr(x(j),0)=exp(-x(j)**2) !initial wavefunction
1
Warning: Array reference at (1) is out of bounds (0 < 1) in dimension 2
schrodinger.f90:28:3: and so on`enter code here`
I have googled how to use real as index but no use .
function v(x) result(s)
real::s,x
if (x<0) then
s=0
else
s=1
end if
end function v
real::t(10000),x(10000),yc(10000,10000),yr(10000,10000),tf,xi,xf,d
integer::i,j,k,l,m
write(*,*) "tf,xi,xf,step size"
read(*,*) tf,xi,xf,d
x(1)=xi
t(1)=0
i=1
1 if(x(i).lt.xf) then
x(i+1)=x(i)+d
i=i+1
goto 1
end if
do j=1,i
yr(x(j),0)=exp(-x(j)**2) !initial wavefunction
yc(x(j),0)=0
end do
do l=1,i
k=1
3 if(t(k).lt.tf) then
yr(x(l),t(k+1))=yr(x(l),t(k))-(yc(x(l)+2*d,t(k))-2*yc(x(l)+d,t(k))+yc(x(l),t(k)))/d&
+v(x(l))*yc(x(l),t(k))*d
yc(x(l),t(k+1))=yc(x(l),t(k))+(yr(x(l)+2*d,t(k))-2*yr(x(l)+d,t(k))+yr(x(l),t(k)))/d&
-v(x(l))*yr(x(l),t(k))*d
k=k+1
goto 3
end if
end do
open(1,file="q.dat")
do m=1,i
write(1,*) x(m),yr(x(m),t(1))**2+yc(x(m),t(1))**2
end do
close(1)
end
expected : data files with wavefunction at different time .
obtained : warning - using real as indices
Just reference your arrays using the integers i,j etc. If you have x(i),t(j) then yr(i,j) is the corresponding value. To get the offsets of +2*d etc you only need to use use +2 instead. e.g. yr(l+2,k) rather than yr(x(l)+2*d,t(k)).
Also, please use implicit none for a start and get a hold of a modern Fortran reference book or similar. All those go tos are a bit hard on the eyes.
I have a code in Fortran IV that I need to run. I was told to try to compile it in Fortran 77 and fix the error. So I named the file with a .f extension and tried to compile it with gfortran. I got the next error referring to the Fortran IV function copied below:
abel.f:432.24:
REAL FUNCTION DGDT*8(IX,NV,XNG,FNG,GNG,X)
1
Error: Expected formal argument list in function definition at (1)
Since I'm not too familiar with Fortran I'd appreciate if someone can tell me how to fix this problem .
REAL FUNCTION DGDT*8(IX,NV,XNG,FNG,GNG,X) AAOK0429
C AAOK0430
C THIS SUBROUTINE COMPUTES THE VALUE OF THE DERIVATIVE OF THE AAOK0431
C G-FUNCTION FOR A SLIT TRANSMISSION FUNCTION GIVEN BY A AAOK0432
C PIECE-WISE CUBIC SPLINE , WHOSE PARAMETERS ARE AAOK0433
C CONTAINED IN XNG,FNG AND GNG. AAOK0434
C AAOK0435
IMPLICIT REAL*8(A-H,O-Z) AAOK0436
C AAOK0437
C ALLOWABLE ROUNDING ERROR ON POINTS AT EXTREAMS OF KNOT RANGE AAOK0438
C IS 2**IEPS*MAX(!XNG(1)!,!XNG(NV)!). AAOK0439
INTEGER*4 IFLG/0/,IEPS/-50/ AAOK0440
DIMENSION XNG(1),FNG(1),GNG(1) AAOK0441
C AAOK0442
C TEST WETHER POINT IN RANGE. AAOK0443
IF(X.LT.XNG(1)) GO TO 990 AAOK0444
IF(X.GT.XNG(NV)) GO TO 991 AAOK0445
C AAOK0446
C ESTIMATE KNOT INTERVAL BY ASSUMING EQUALLY SPACED KNOTS. AAOK0447
12 J=DABS(X-XNG(1))/(XNG(NV)-XNG(1))*(NV-1)+1 AAOK0448
C ENSURE CASE X=XNG(NV) GIVES J=NV-1 AAOK0449
J=MIN0(J,NV-1) AAOK0450
C INDICATE THAT KNOT INTERVAL INSIDE RANGE HAS BEEN USED. AAOK0451
IFLG=1 AAOK0452
C SEARCH FOR KNOT INTERVAL CONTAINING X. AAOK0453
IF(X.LT.XNG(J)) GO TO 2 AAOK0454
C LOOP TILL INTERVAL FOUND. AAOK0455
1 J=J+1 AAOK0456
11 IF(X.GT.XNG(J+1)) GO TO 1 AAOK0457
GO TO 7 AAOK0458
2 J=J-1 AAOK0459
IF(X.LT.XNG(J)) GO TO 2 AAOK0460
C AAOK0461
C CALCULATE SPLINE PARAMETERS FOR JTH INTERVAL. AAOK0462
7 H=XNG(J+1)-XNG(J) AAOK0463
Q1=H*GNG(J) AAOK0464
Q2=H*GNG(J+1) AAOK0465
SS=FNG(J+1)-FNG(J) AAOK0466
B=3D0*SS-2D0*Q1-Q2 AAOK0467
A=Q1+Q2-2D0*SS AAOK0468
C AAOK0469
C CALCULATE SPLINE VALUE. AAOK0470
8 Z=(X-XNG(J))/H AAOK0471
C TF=((A*Z+B)*Z+Q1)*Z+FNG(J) AAOK0472
C TG=((3.*A*Z+2.*B)*Z+Q1)/H AAOK0473
C DGDT=(TG-TF/X)/X AAOK0474
DGDT=(3.*A*Z*Z+2.*B*Z+Q1)/H AAOK0475
RETURN AAOK0476
C TEST IF X WITHIN ROUNDING ERROR OF XNG(1). AAOK0477
990 IF(X.LE.XNG(1)-2D0**IEPS*DMAX1(DABS(XNG(1)),DABS(XNG(NV)))) GO AAOK0478
1 TO 99 AAOK0479
J=1 AAOK0480
GO TO 7 AAOK0481
C TEST IF X WITHIN ROUNDING ERROR OF XNG(NV). AAOK0482
991 IF(X.GE.XNG(NV)+2D0**IEPS*DMAX1(DABS(XNG(1)),DABS(XNG(NV)))) GO AAOK0483
1 TO 99 AAOK0484
J=NV-1 AAOK0485
GO TO 7 AAOK0486
99 IFLG=0 AAOK0487
C FUNCTION VALUE SET TO ZERO FOR POINTS OUTSIDE THE RANGE. AAOK0488
DGDT=0D0 AAOK0489
RETURN AAOK0490
END AAOK0491
This doesn't look so bad. Modern compilers still accept the real*8 syntax although it isn't standard. So you should (as mentioned) replace the line
REAL FUNCTION DGDT*8(IX,NV,XNG,FNG,GNG,X) AAOK0429
with
REAL*8 FUNCTION DGDT(IX,NV,XNG,FNG,GNG,X) AAOK0429
which compiled successfully for me using gfortran 4.6.2 using gfortran -c DGDT.f.
Good luck, and be on the lookout for other problems. Just because the code compiles does not mean it is running the same way it was designed!
Not really an answer, see the one from Ross. But I just can't stand the requirement for fixed form. Here is how this code probably would look like in F90 with free form:
function DGDT(IX, NV, XNG, FNG, GNG, X)
! THIS FUNCTION COMPUTES THE VALUE OF THE DERIVATIVE OF THE
! G-FUNCTION FOR A SLIT TRANSMISSION FUNCTION GIVEN BY A
! PIECE-WISE CUBIC SPLINE, WHOSE PARAMETERS ARE
! CONTAINED IN XNG,FNG AND GNG.
implicit none
integer, parameter :: rk = selected_real_kind(15)
integer :: ix, nv
real(kind=rk) :: dgdt
real(kind=rk) :: xng(nv)
real(kind=rk) :: fng(nv)
real(kind=rk) :: gng(nv)
real(kind=rk) :: x
! ALLOWABLE ROUNDING ERROR ON POINTS AT EXTREAMS OF KNOT RANGE
! IS 2**IEPS*MAX(!XNG(1)!,!XNG(NV)!).
integer, parameter :: ieps = -50
integer, save :: iflg = 0
integer :: j
real(kind=rk) :: tolerance
real(kind=rk) :: H
real(kind=rk) :: A, B
real(kind=rk) :: Q1, Q2
real(kind=rk) :: SS
real(kind=rk) :: Z
tolerance = 2.0_rk**IEPS * MAXVAL(ABS(XNG([1,NV])))
! TEST WETHER POINT IN RANGE.
if ((X < XNG(1) - tolerance) .or. (X > XNG(NV) + tolerance)) then
! FUNCTION VALUE SET TO ZERO FOR POINTS OUTSIDE THE RANGE.
iflg = 0
DGDT = 0.0_rk
return
end if
! ESTIMATE KNOT INTERVAL BY ASSUMING EQUALLY SPACED KNOTS.
J = abs(x-xng(1)) / (xng(nv)-xng(1)) * (nv-1) + 1
! ENSURE CASE X=XNG(NV) GIVES J=NV-1
J = MIN(J,NV-1)
! INDICATE THAT KNOT INTERVAL INSIDE RANGE HAS BEEN USED.
IFLG = 1
! SEARCH FOR KNOT INTERVAL CONTAINING X.
do
if ( (x >= xng(j)) .or. (j==1) ) EXIT
j = j-1
! LOOP TILL INTERVAL FOUND.
end do
do
if ( (x <= xng(j+1)) .or. (j==nv-1) ) EXIT
j = j+1
! LOOP TILL INTERVAL FOUND.
end do
! CALCULATE SPLINE PARAMETERS FOR JTH INTERVAL.
H = XNG(J+1) - XNG(J)
Q1 = H*GNG(J)
Q2 = H*GNG(J+1)
SS = FNG(J+1) - FNG(J)
B = 3.0_rk*SS - 2.0_rk*Q1 - Q2
A = Q1 + Q2 - 2.0_rk*SS
! CALCULATE SPLINE VALUE.
Z = (X-XNG(J))/H
DGDT = ( (3.0_rk*A*Z + 2.0_rk*B)*Z + Q1 ) / H
end function DGDT
Note, I did not test this in any way, also there might be some wrong guesses in there, like that ieps should be a constant. Also, I am not so sure about iflg, and the ix argument does not appear to be used at all. So I might got something wrong. For the tolerance it is better to use a factor instead of a difference and a 2.**-50 will not change the value for a the maxval in a double precision number here. Also note, I am using some other F90 features besides the free form now.
DISCLAIMER: Just mentioning a possible solution here, not recommending it...
As much as all other answers are valid and that supporting some Fortran IV code as is is a nightmare, you still might want / need to avoid touching it as much as possible. And since Fortran IV had some strange behaviours when it comes to loops for example (with loops always cycled at least once IINM), using a "proper" Fortran IV compiler might be a "good" idea.
Anyway, all this to say that the Intel compiler for example, supports Fortran IV natively with the -f66 compiler switch, and I'm sure other compilers do as well. This may be worth checking.
Fortran 2003 has square bracket syntax for array concatenation, Intel fortran compiler supports it too. I wrote a simple code here for matrix concatenation:
program matrix
implicit none
real,dimension (3,3) :: mat1,mat2
real,dimension(3,6):: mat3
integer i
mat1=reshape( (/1,2,3,4,5,6,7,8,9/),(/3,3/))
mat2=reshape( (/1,2,3,4,5,6,7,8,9/),(/3,3/))
mat3=[mat1,mat2]
!display
do i=1,3,1
write(*,10) mat3(i,:)
10 format(F10.4)
end do
end program
But I get error as
mat3=[mat1,mat2]
Error: Incompatible ranks 2 and 1 in assignment
I expect the output as
1 2 3 1 2 3
4 5 6 4 5 6
7 8 9 7 8 9
Can someone comment where am I going wrong? What is rank 2 and 1 here? I guess all arrays have rank 2.
The array concatenation in fortran 2003 doesn't work as you think. When you concatenate, it's not going to stack the two arrays side by side. It will pick elements from the first array one by one and put into a one-dimensional array. Then it will do the same thing with the second array but it will append this to the 1-D form of first array.
The following code works.
program matrix
implicit none
real,dimension (3,3) :: mat1,mat2
real,dimension(18) :: mat3
integer i
mat1=reshape( (/1,2,3,4,5,6,7,8,9/),(/3,3/))
mat2=reshape( (/1,2,3,4,5,6,7,8,9/),(/3,3/))
mat3=[mat1,mat2]
print*, shape([mat1,mat2]) !check shape of concatenated array
!display
do i=1,18,1
write(*,10) mat3(i)
10 format(F10.4)
end do
end program
However, the result you wanted can be achieved using following code
program matrix
implicit none
real,dimension (3,3) :: mat1,mat2
real,dimension(3,6) :: mat3
integer i
mat1=reshape( (/1,2,3,4,5,6,7,8,9/),(/3,3/))
mat2=reshape( (/1,2,3,4,5,6,7,8,9/),(/3,3/))
do i=1,3
mat3(i,:)=[mat1(:,i),mat2(:,i)]
enddo
!display
do i=1,3,1
write(*,*) mat3(i,:)
end do
end program
Another way could simply be to
mat3(:,1:3) = mat1
mat3(:,4:6) = mat2
I dont know which is faster, this or the do loop above...
Fill it using 1-D arrays then reshape your mat3.
I'm doing a fortran code to find the radial distribution function (RDF) with hard spheres in a cell model.
It's not finished yet, and now I have an error. I'm implementing the histogram. This is my code.
implicit double precision (a-h,o-z)
parameter(npart=3000)
dimension x(0:npart),y(0:npart),z(0:npart)
c n=Number of particules
c rcel=Radius of the cell
c rpart=Radius of the particules
pi=3.1415927
write(*,*)'n,rcel,rpart,dr?'
read(*,*)n,rcel,rpart,dr
write(*,*)'nstep,dp'
read(*,*)nstep,dp
rpart2=(2*rpart)
nfatmax=rcel/dr ! Number of bins
vtotal=(4/3)*pi*rcel*rcel*rcel
dentotal=n/vtotal
write(*,*)'Density of particles, volume and bins = '
write(*,*)dentotal,vtotal,nfatmax
x(0)=0
y(0)=0
z(0)=0
write(*,'(a,/)')'Generating start configurations'
counter1=0
counter2=0
counter3=0
k=0
do i=1,n
21 xx=rcel*(ran()-0.5)*2
yy=rcel*(ran()-0.5)*2
zz=rcel*(ran()-0.5)*2
rr=xx**2+yy**2+zz**2
dist=sqrt(rr)
if(dist.gt.(rcel-rpart2))then !Avoid particles outside the cell
counter1=counter1+1
go to 21
end if
if(dist.lt.rpart2)then ! Avoid overlap with central particle
counter2=counter2+1
go to 21
end if
if(i.ge.1)then
do j=1,i-1,1
sep2=(x(i)-x(j))**2+(y(i)-y(j))**2+(z(i)-z(j))**2
sep=sqrt(sep2)
if(sep.lt.rpart2)then
counter3=counter3+1
go to 21
end if
end do
end if
k=k+1
x(k)=xx
y(k)=yy
z(k)=zz
end do
write(*,*)'Starting config'
write(*,'(3f8.3)')(x(i),y(i),z(i),i=1,n)
counterA=counter1+counter2+counter3
write(*,*)'Rejection = '
write(*,*)counterA
c Monte Carlo loop
counter4=0
counter5=0
counter6=0
do i = 1,nfatmax
h(i) = 0 !!!! Error here!!!!!!
end do
nobs = 0
naccept = 0
do i=1,nstep
do j=1,n
nobs = nobs + 1
xil=x(j)+dp*(ran()-0.5)
yil=y(j)+dp*(ran()-0.5)
zil=z(j)+dp*(ran()-0.5)
r2=(xil**2)+(yil**2)+(zil**2)
r=sqrt(r2)
if(r.gt.(rcel-rpart2))then
counter4=counter4+1
go to 444 ! Avoid particles outside the cell
end if
if(r.lt.rpart2)then
counter5=counter5+1
go to 444 ! Avoid overlap with central particle
end if
do ii=1,j-1
dist2=(x(ii)-xil)**2+(y(ii)-yil)**2+(z(ii)-zil)**2
dist=sqrt(dist2)
if(dist.lt.rpart2)then
counter6=counter6+1
go to 444 ! Avoid overlap wit particles
end if
end do
c Accepted configuration
x(j)=xil
y(j)=yil
z(j)=zil
naccept = naccept + 1
c Rejected configuration
444 continue
do jj=1,n
dist2=(x(jj))**2+(y(jj))**2+(z(jj))**2
dist=sqrt(dist2)
k=(dist/dr)+1
h(k) = h(k)+1 !!!!!!!! Error here!!!!!!!!!
end do
enddo
end do
write(*,*)'Final config'
write(*,'(3f8.3)')(x(j),y(j),z(j),j=1,n)
counterB=counter4+counter5+counter6
write(*,*)'Rejection ='
write(*,*)counterB
stop
end
In your code, h is not declared...
From
do i = 1,nfatmax
h(i) = 0
end do
I assume it should be an array of length nfatmax:
dimension h(nfatmax)
As stated in High Performance Mark's comment, you could have found this error by using implicit none...
I see you dimensioning x, y and z but I see no such beastie for h.
Perhaps you might want to create the array before trying to put values into it.
Suppose you have a file.dat of the form:
1
1
1
2
2
3
3
3
3
...
I want to count how many equal numbers there are and save them iteratively in a string. For instance:
m = 3 (times 1),
m = 2 (times 2),
m = 4 (times 3).
I put here my code:
program sele
implicit none
integer::j,k,s,n,l,r,m
real*8,allocatable::ID(:)
real*8:: j_r8,i_r8
open(10,file='data.dat')
n=0
DO
READ(10,*,END=100)
n=n+1
END DO
100 continue
rewind(10)
allocate(ID(n))
s=0
do s=1, n
read(10,*) ID(s)
end do
do r=1,n-1
if (ID(r)-ID(r+1) .EQ. 0) then
m = m + 1
print*, m
end if
end do
end program
The last do is the condition I'd like to expand, with something like:
if (condition is true) then
save an index of the number of equal digits
use this to do some operations:
do i = 1, number of equal digits
if (condition is not true) then
restart with the other digits.
If the values you want to read are integer values in a given limited range (for instance from 1 to 100), then the simplest way is the following :
program sele
implicit none
integer, parameter :: vmin=1
integer, parameter :: vmax=100
integer :: list(vmin:vmax)
integer :: value,i
open(10,file='data.dat')
list=0
do
read(10,*,end=10) value
if(value < vmin .OR. value > vmax) then
write(*,*) 'invalid value ',value
stop
endif
list(value)=list(value)+1
enddo
10 continue
do i=vmin,vmax
if(list(i) > 0) then
write(*,*) list(i),' times ',i
endif
enddo
end program
Which gives on your example :
3 times 1
2 times 2
4 times 3
It is possible to improve easily that program to manage variable vmin and vmax (the array list must then be declared allocatable and allocated at the right size).
If the range is too large, then a simple array is not accurate anymore and the right algorithm becomes more complicated : it must avoid to store unused values.