I am new to Fortran. I am trying to compile and run the code from the paper. https://data.mendeley.com/datasets/nr6y34yg29/1
In that zip file, they have a FortranVersion code. When I am trying to compile and run, I am getting an error (attached screenshot)
Welcome @Nuz!
It would be helpful if you can post your code from main.f, as well as the relevant part of crsmumu.f (assuming the code license allow you to post it), so we can see what could be the cause of this error.
It would also be very helpful if you can post code as text (formatted using code blocks) instead of screenshots.
And please mention your compiler version.
The source files are a bit too long to include here. All the errors were in crsmumu.f file. They are of two kinds:
Below I include the output diff crsmumu.f crsmumu_fixed.f
5a6
> REAL*8 FUN
35a37
> REAL*8 FUNM
539a542
> REAL*8 FUNT
647c650
< DO 3 I = 1,4
---
> DO I = 1,4
649c652,653
< 3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
---
> S8=S8+W(I)*(F(C1+U)+F(C1-U))
> ENDDO
651c655
< DO 4 I = 5,12
---
> DO I = 5,12
653c657,658
< 4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
---
> S16=S16+W(I)*(F(C1+U)+F(C1-U))
> ENDDO
820c825
< DO 1 K = KA,KZ,2
---
> DO K = KA,KZ,2
823c828,829
< 1 Q=-Q
---
> Q=-Q
> ENDDO
@milancurcic Thank you for your reply.
The code form main.f is given below
PROGRAM mumu
IMPLICIT NONE
INTEGER n1,m1,l1,n2,m2,l2,ic,il
INTEGER nn1(3),nn2(3),iq(2)
REAL*8 Z,crs,crsm,TCRS,TCRSM,TRCRS,FT,F
REAL t1,t2
COMMON /iq/iq
c Total, transition, or both cross sections
11 WRITE(*,*)
WRITE(*,3) 'Total, transition, or both cross sections:'
WRITE(*,3) 'ic=1 --- only total cross section'
WRITE(*,3) 'ic=2 --- only transition cross section'
WRITE(*,3) 'ic=3 --- both cross sections'
WRITE(*,3,ADVANCE='NO') 'ic='
READ(*,*) ic
IF(ic.NE.1.AND.ic.NE.2.AND.ic.NE.3) THEN
WRITE(*,*)
WRITE(*,3) 'ic can be only 1,2 or 3 !'
WRITE(*,*)
GO TO 11
END IF
c input iq
12 WRITE(*,*)
WRITE(*,3) 'Quantization axis and computation method:'
WRITE(*,3) 'iq(1)=0 --- along transfered momentum'
WRITE(*,3) 'iq(1)=1 --- along beam direction'
WRITE(*,3) 'iq(2)=1,2,3 --- computation method'
WRITE(*,3,ADVANCE='NO') 'iq='
READ(*,*) iq
IF(iq(1).NE.0.AND.iq(1).NE.1) THEN
WRITE(*,*)
WRITE(*,3) 'iq(1) can be only 0 or 1 !'
WRITE(*,*)
GO TO 12
ELSE IF(iq(2).NE.1.AND.iq(2).NE.2.AND.iq(2).NE.3) THEN
WRITE(*,*)
WRITE(*,3) 'iq(2) can be only 1,2 or 3 !'
WRITE(*,*)
GO TO 12
END IF
c total cross section mode
IF(ic.eq.1) THEN
13 WRITE(*,*)
c input Z
WRITE(*,3,ADVANCE='NO') 'Z='
READ(*,*) Z
c input n
14 WRITE(*,3,ADVANCE='NO') 'n='
READ(*,*) n1
IF(n1.LE.0.OR.n1.GT.100) THEN
WRITE(*,*) 'n=',n1
WRITE(*,*) 'n must be in the range 1-100 !'
GO TO 14
END IF
c input l
15 IF(n1.NE.1) THEN
WRITE(*,3,ADVANCE='NO') 'l='
READ(*,*) l1
IF(l1.LT.0.OR.l1.GT.n1-1) THEN
WRITE(*,*) 'n=',n1,' l=',l1
WRITE(*,*) 'l must be positive and less or equal to n-1 !'
GO TO 15
END IF
ELSE
l1=0
END IF
c input m
16 IF(l1.NE.0) THEN
WRITE(*,3,ADVANCE='NO') 'm='
READ(*,*) m1
IF(IABS(m1).GT.l1) THEN
WRITE(*,*) 'l=',l1,' m=',m1
WRITE(*,*) '|m| must be less or equal to l !'
GO TO 16
END IF
ELSE
m1=0
END IF
crsm=TCRSM(Z,n1,l1)
WRITE(*,*)
WRITE(*,*) '---------------------------------------------------'//
& '----------------------'
WRITE(*,7) 'Z=',IDINT(Z),'n,l,m=',n1,l1,m1
WRITE(*,*)
WRITE(*,4) 'Total cross section avaraged over m, crsm=',
& crsm,' cm^2'
CALL CPU_TIME(t1)
crs=TCRS(Z,n1,l1,m1)
CALL CPU_TIME(t2)
WRITE(*,*)
WRITE(*,4) 'Total cross section, crs= ',crs,' cm^2'
WRITE(*,*) '---------------------------------------------------'//
& '----------------------'
WRITE(*,*)
WRITE(*,6) 'Elapsed CPU time = ', t2 - t1,' sec'
WRITE(*,*)
WRITE(*,*) 'Checking the reliability of the calculation.'
WRITE(*,*) 'F(0) must be one within double precision'//
& ' computational errors'
WRITE(*,5) 'F(0)-1=',F(0.0D0)-1.0D0
WRITE(*,*)
WRITE(*,*) 'Where to return:'
WRITE(*,*) '1 - enter new value of m'
WRITE(*,*) '2 - enter new values of l,m'
WRITE(*,*) '3 - enter new values of n,l,m'
WRITE(*,*) '4 - enter new values of Z,n,l,m'
WRITE(*,*) '5 - enter new values of iq(2)'
WRITE(*,*) '6 - go to top level (new value of ic)'
WRITE(*,*) '7 - stop'
WRITE(*,3,ADVANCE='NO') 'il='
READ(*,*) il
IF(il.EQ.1) GO TO 16
IF(il.EQ.2) GO TO 15
IF(il.EQ.3) GO TO 14
IF(il.EQ.4) GO TO 13
IF(il.EQ.5) GO TO 12
IF(il.EQ.6) GO TO 11
IF(il.EQ.7) STOP
ELSE
c input Z
21 WRITE(*,*)
WRITE(*,3,ADVANCE='NO') 'Z='
READ(*,*) Z
c input n1,l1,m1
22 WRITE(*,3,ADVANCE='NO') 'n1,l1,m1='
READ(*,*) nn1
n1=nn1(1)
l1=nn1(2)
m1=nn1(3)
IF(n1.LE.0.OR.n1.GT.100) THEN
WRITE(*,*) 'n1=',n1
WRITE(*,*) 'n1 must be in the range 1-100 !'
GO TO 22
END IF
IF(l1.LT.0.or.(l1.GT.n1-1)) THEN
WRITE(*,*) 'n1=',n1,' l1=',l1
WRITE(*,*) 'l1 must be positive and less or equal to n1-1 !'
GO TO 22
END IF
IF(IABS(m1).GT.l1) THEN
WRITE(*,*) 'l1=',l1,' m1=',m1
WRITE(*,*) '|m1| must be less or equal to l1 !'
GO TO 22
END IF
c input n2,l2,m2
23 WRITE(*,3,ADVANCE='NO') 'n2,l2,m2='
READ(*,*) nn2
n2=nn2(1)
l2=nn2(2)
m2=nn2(3)
IF(n2.LE.0.OR.n2.GT.100) THEN
WRITE(*,*) 'n2=',n2
WRITE(*,*) 'n2 must be in the range 1-100 !'
GO TO 23
END IF
IF(l2.LT.0.OR.l2.GT.n2-1) THEN
WRITE(*,*) 'n2=',n2,' l2=',l2
WRITE(*,*) 'l2 must be positive and less or equal to n2-1 !'
GO TO 23
END IF
IF(IABS(m2).GT.l2) THEN
WRITE(*,*) 'l2=',l2,' m2=',m2
WRITE(*,*) '|m2| must be less or equal to l2 !'
GO TO 23
END IF
IF(ic.eq.2) THEN
CALL CPU_TIME(t1)
crs=TRCRS(Z,n1,l1,m1,n2,l2,m2)
CALL CPU_TIME(t2)
WRITE(*,*)
WRITE(*,*) '---------------------------------------------------'//
& '----------------------'
WRITE(*,8) 'Z=',IDINT(Z),'n1,l1,m1=',n1,l1,m1,'n2,l2,m2=',n2,l2,m2
WRITE(*,*)
WRITE(*,4) 'Transition cross section, crs= ',crs,' cm^2'
WRITE(*,*) '---------------------------------------------------'//
& '----------------------'
WRITE(*,*)
write ( *, * ) 'Elapsed CPU time = ', t2 - t1
c both cross sections mode
ELSE IF(ic.eq.3) THEN
crsm=TCRSM(Z,n1,l1)
WRITE(*,*)
WRITE(*,*) '---------------------------------------------------'//
& '----------------------'
WRITE(*,8) 'Z=',IDINT(Z),'n1,l1,m1=',n1,l1,m1,'n2,l2,m2=',n2,l2,m2
WRITE(*,*)
WRITE(*,4) 'Total cross section avaraged over m, crsm=',
& crsm,' cm^2 (for n1,l1)'
crs=TCRS(Z,n1,l1,m1)
WRITE(*,*)
WRITE(*,4) 'Total cross section (for n1,l1,m1), crst= ',
& crs,' cm^2'
crs=TRCRS(Z,n1,l1,m1,n2,l2,m2)
WRITE(*,*)
WRITE(*,4) 'Transition cross section, crs= ',crs,' cm^2'
WRITE(*,*) '---------------------------------------------------'//
& '----------------------'
END IF
WRITE(*,*)
WRITE(*,*) 'Where to return:'
WRITE(*,*) '1 - enter new values of n2,l2,m2'
WRITE(*,*) '2 - enter new values of n1,l1,m1'
WRITE(*,*) '3 - enter new value of Z'
WRITE(*,*) '4 - enter new values of iq(2)'
WRITE(*,*) '5 - go to top level (new value of ic)'
WRITE(*,*) '6 - stop'
WRITE(*,3,ADVANCE='NO') 'il='
READ(*,*) il
IF(il.EQ.1) GO TO 23
IF(il.EQ.2) GO TO 22
IF(il.EQ.3) GO TO 21
IF(il.EQ.4) GO TO 12
IF(il.EQ.5) GO TO 11
IF(il.EQ.6) STOP
END IF
3 FORMAT(A)
4 FORMAT(1X,A,ES12.5,A)
5 FORMAT(1X,A,ES12.5)
6 FORMAT(1X,A,ES12.2,A)
7 FORMAT(1X,A,I3,5X,A,3I3)
8 FORMAT(1X,A,I3,5X,A,3I3,5X,A,3I3)
END
The relevant part from crsmumu.f
REAL*8 FUNCTION TCRS(ZZ,n1,l1,m1)
IMPLICIT NONE
REAL*8 Z,ZZ,crs,DGAUSS,xmin,xmax,eps,alpha,pi
REAL*8 mem,rb,cf
INTEGER n,l,m,n1,l1,m1
EXTERNAL FUN
PARAMETER(xmin=0.0D0,xmax=1.0D0,eps=1.0D-8)
PARAMETER(alpha=0.00729735D0,pi=3.14159265D0)
c electron-muon mass ratio and Bohr's radius (in cm)
PARAMETER(mem=0.00483633D0,rb=0.529 177 211D-8)
c electron-charged pion mass ratio and Bohr's radius (in cm)
c PARAMETER(mem=0.00366123298D0,rb=0.529 177 211D-8)
COMMON /Z/Z
COMMON /nl/n,l,m
Z=ZZ
n=n1
l=l1
m=m1
c conversion factor
cf=4*rb**2*mem**2
crs=cf*DGAUSS(FUN,xmin,xmax,eps)*(alpha/pi)
TCRS=crs
END
REAL*8 FUNCTION TCRSM(Z,n,l)
IMPLICIT NONE
REAL*8 Z,Z1,crs,DGAUSS,xmin,xmax,eps,alpha,pi
REAL*8 mem,rb,cf
INTEGER n,l,n1,l1,m
EXTERNAL FUNM
PARAMETER(xmin=0.0D0,xmax=1.0D0,eps=1.0D-8)
PARAMETER(alpha=0.00729735D0,pi=3.14159265D0)
c electron-muon mass ratio and Bohr's radius (in cm)
PARAMETER(mem=0.00483633D0,rb=0.529 177 211D-8)
COMMON /nl/n1,l1,m
COMMON /Z/Z1
Z1=Z
n1=n
l1=l
c conversion factor
cf=4*rb**2*mem**2
crs=cf*DGAUSS(FUNM,xmin,xmax,eps)*(alpha/pi)
TCRSM=crs
END
REAL*8 FUNCTION FUN(x)
IMPLICIT NONE
REAL*8 x,eps,G
PARAMETER(eps=1.0D-8)
IF(x.GT.eps) THEN
FUN=G(x)+G(1.0D0/x)/x**2
ELSE
FUN=G(x)
END IF
END
REAL*8 FUNCTION FUNM(x)
IMPLICIT NONE
REAL*8 x,eps,GM
PARAMETER(eps=1.0D-8)
IF(x.GT.eps) THEN
FUNM=GM(x)+GM(1.0D0/x)/x**2
ELSE
FUNM=GM(x)
END IF
END
REAL*8 FUNCTION G(x)
IMPLICIT NONE
REAL*8 x,U,F
G=U(x)**2*(1-F(x))*x
END
REAL*8 FUNCTION GM(x)
IMPLICIT NONE
REAL*8 x,U,FM
GM=U(x)**2*(1-FM(x))*x
END
REAL*8 FUNCTION F(x)
IMPLICIT NONE
REAL*8 x,FTRANS
INTEGER n,l,m,iq(2)
COMMON /nl/n,l,m
COMMON /iq/iq
F=(-1)**(l+m)*FTRANS(iq,n,l,m,n,l,m,x)
END
REAL*8 FUNCTION LFACT(n)
IMPLICIT NONE
INTEGER i,n
LFACT=0
IF(n.GT.0) THEN
DO i=1,n
LFACT=LFACT+DLOG(DBLE(i))
END DO
END IF
END
REAL*8 FUNCTION Fhyp(n,mm,k,ph,alp)
IMPLICIT NONE
REAL*8 ph,JACOB,alp,bt
INTEGER n,k,m,mm,nn
m=mm/2
IF(MOD(mm,2).EQ.0) THEN
nn=n+m-k
bt=0.5D0
Fhyp=DCOS(ph)**(2*m)*JACOB(nn,alp,bt,DCOS(2*ph))
Fhyp=Fhyp/JACOB(nn,alp,bt,1.0D0)
ELSE
nn=n+m+1-k
bt=-0.5D0
Fhyp=DCOS(ph)**(2*m)*JACOB(nn,alp,bt,DCOS(2*ph))
Fhyp=Fhyp/JACOB(nn,alp,bt,1.0D0)
END IF
END
REAL*8 FUNCTION FM(x)
IMPLICIT NONE
REAL*8 x,ph,JACOB
INTEGER n,l,m
COMMON /nl/n,l,m
IF(n.EQ.1.AND.l.EQ.0) THEN
FM=16.0D0/(4+x**2)**2
ELSE IF(n.EQ.2.AND.l.EQ.1) THEN
FM=(1-x**2)/(1+x**2)**4
ELSE IF(n.EQ.2.AND.l.EQ.0) THEN
FM=(1-3*x**2+2*x**4)/(1+x**2)**4
ELSE IF(n.EQ.3.AND.l.EQ.0) THEN
FM=(27*x**2-4)*(3*x**2-4)*(243*x**4-216*x**2+16)
FM=16*FM/(4+9*x**2)**6
ELSE IF(n.EQ.4.AND.l.EQ.0) THEN
FM=(4*x**2-1)*(16*x**4-24*x**2+1)*(256*x**6-288*x**4+48*x**2-1)
FM=FM/(1+4*x**2)**8
ELSE IF(n.EQ.3.AND.l.EQ.1) THEN
FM=(27*x**2-4)*(3*x**2-4)*(1-9*x**2)
FM=256*FM/(4+9*x**2)**6
ELSE IF(n.EQ.3.AND.l.EQ.2) THEN
FM=(27*x**2-4)*(3*x**2-4)
FM=256*FM/(4+9*x**2)**6
ELSE IF(n.EQ.4.AND.l.EQ.1) THEN
FM=(1-4*x**2)*(16*x**4-24*x**2+1)*(160*x**4-40*x**2+1)
FM=FM/(1+4*x**2)**8
ELSE IF(n.EQ.4.AND.l.EQ.2) THEN
FM=(4*x**2-1)*(16*x**4-24*x**2+1)*(24*x**2-1)
FM=FM/(1+4*x**2)**8
ELSE IF(n.EQ.4.AND.l.EQ.3) THEN
FM=(1-4*x**2)*(16*x**4-24*x**2+1)
FM=FM/(1+4*x**2)**8
ELSE
ph=DATAN(n*x/2.0D0)
FM=JACOB(n-l-1,0.0D0,DBLE(2*l+1),DCOS(2*ph))
FM=FM*DSIN(2*n*ph)*(DCOS(ph))**(2*l+4)
FM=FM/(n*DSIN(2*ph))
END IF
END
REAL*8 FUNCTION JACOB(n,alp,bt,x)
IMPLICIT NONE
integer i,n
REAL*8 x,alp,bt,P(0:n),a,b,c
P(0)=1.0D0
IF(n.EQ.0) GO TO 1
P(1)=0.5*(alp-bt+(2+alp+bt)*x)
IF(n.GE.2) THEN
DO i=2,n
a=2*i*(i+alp+bt)*(2*i+alp+bt-2)
b=(2*i+alp+bt-2)*(2*i+alp+bt)*x+alp**2-bt**2
b=(2*i+alp+bt-1)*b
c=2*(i-1+alp)*(i-1+bt)*(2*i+alp+bt)
P(i)=(b/a)*P(i-1)-(c/a)*P(i-2)
END DO
END IF
1 JACOB=P(n)
END
REAL*8 FUNCTION U(x)
IMPLICIT NONE
REAL*8 x,Z,a1,a2,a3,b1,b2,b3,pi,alpha,bt1,bt2,bt3,me,mem
PARAMETER(a1=0.10D0,a2=0.55D0,a3=0.35D0)
PARAMETER(b1=6.0D0,b2=1.2D0,b3=0.3D0)
PARAMETER(alpha=0.00729735D0,pi=3.14159265D0)
c electron-muon mass ratio
PARAMETER(mem=0.00483633D0)
c electron-charged pion mass ratio
c PARAMETER(mem=0.00366123298D0)
COMMON /Z/Z
me=(2/alpha)*mem
bt1=me*(b1/121.0D0)*Z**(1.0D0/3.0D0)
bt2=me*(b2/121.0D0)*Z**(1.0D0/3.0D0)
bt3=me*(b3/121.0D0)*Z**(1.0D0/3.0D0)
U=a1/(x**2+bt1**2)+a2/(x**2+bt2**2)+a3/(x**2+bt3**2)
U=4*pi*Z*DSQRT(alpha)*U
END
c i**(l1+l2)*(-1)**m1 phase is not included
REAL*8 FUNCTION FTRANS(iq,n1,l1,m1,n2,l2,m2,x)
IMPLICIT NONE
INTEGER n1,l1,m1,n2,l2,m2,l,m,s,sm,iq(2)
REAL*8 N,Al,Il,a,b,sg,LFACT,x,DWIG3J,Blm,IlJN,IlW
m=m1-m2
a=DBLE(n2)/DBLE(n1+n2)
b=DBLE(n1)/DBLE(n1+n2)
sg=x*DBLE(n1*n2)/DBLE(n1+n2)
N=LFACT(n1-l1-1)+LFACT(n2-l2-1)
N=N-LFACT(n1+l1)-LFACT(n2+l2)
N=DEXP(0.5D0*N)*DSQRT(DBLE((2*l1+1)*(2*l2+1)))
N=(2*a)**(l1+1)*(2*b)**(l2+1)*N
N=N/DBLE(n1+n2)
sm=MIN0(l1,l2)
FTRANS=0.0D0
DO s=0,sm
l=l1+l2-2*s
Al=(-1)**s*(2*l+1)
Al=Al*DWIG3J(DBLE(l1),DBLE(l2),DBLE(l),0.0D0,0.0D0,0.0D0)
Al=Al*DWIG3J(DBLE(l1),DBLE(l2),DBLE(l),DBLE(m1),-DBLE(m2)
& ,-DBLE(m))
Al=Al*Blm(l,m,iq(1))
IF(iq(2).EQ.1) THEN
FTRANS=FTRANS+Al*Il(n1,l1,n2,l2,l,a,b,sg)
ELSE IF(iq(2).EQ.2) THEN
FTRANS=FTRANS+Al*IlJN(n1,l1,n2,l2,s,a,b,sg)
ELSE IF(iq(2).EQ.3) THEN
FTRANS=FTRANS+Al*IlW(n1,l1,n2,l2,s,a,b,sg)
END IF
END DO
FTRANS=N*FTRANS
END
c Acta Phys. Pol. B 52, 1209 (2021)
REAL*8 FUNCTION Il(n1,l1,n2,l2,l,a,b,sg)
IMPLICIT NONE
INTEGER n1,l1,n2,l2,l,m1,m2
REAL*8 a,b,sg,N,Nm,Ir,LFACT,ph,alp,Fhyp,cs
Il=0.0D0
ph=DATAN(sg)
alp=l+0.5D0
cs=DCOS(ph)**(2*(l+2))
DO m1=0,n1-l1-1
DO m2=0,n2-l2-1
Nm=LFACT(n1+l1)+LFACT(n2+l2)+LFACT(l+l1+l2+m1+m2+2)
Nm=Nm-LFACT(m1)-LFACT(m2)-LFACT(n1-l1-1-m1)
Nm=Nm-LFACT(n2-l2-1-m2)-LFACT(2*l1+1+m1)
Nm=Nm-LFACT(2*l2+1+m2)
Nm=Dexp(Nm)
Ir=(-1)**(m1+m2)*(2*a)**m1*(2*b)**m2*Nm
Ir=Ir*Fhyp(l,m1+m2+l1+l2-l,l,ph,alp)
Il=Il+Ir*cs*sg**l
END DO
END DO
N=LFACT(l)-LFACT(2*l+1)
N=2.0D0**l*DEXP(N)
Il=N*Il
END
And another part from crsmumu.f
REAL*8 FUNCTION DGAUSS(F,A,B,EPS)
IMPLICIT NONE
REAL*8 F,A,B,EPS,AA,BB,H,CONST,C1,C2,S8,S16,U
REAL*8 W(12),X(12),Z1,HF,CST
INTEGER I
PARAMETER (Z1 = 1.0D0, HF = 0.5D0, CST = 5.0D-3)
DATA X( 1) /9.6028985649753623D-1/,
& W( 1) /1.0122853629037626D-1/
DATA X( 2) /7.9666647741362674D-1/,
& W( 2) /2.2238103445337447D-1/
DATA X( 3) /5.2553240991632899D-1/,
& W( 3) /3.1370664587788729D-1/
DATA X( 4) /1.8343464249564980D-1/,
& W( 4) /3.6268378337836198D-1/
DATA X( 5) /9.8940093499164993D-1/,
& W( 5) /2.7152459411754095D-2/
DATA X( 6) /9.4457502307323258D-1/,
& W( 6) /6.2253523938647893D-2/
DATA X( 7) /8.6563120238783174D-1/,
& W( 7) /9.5158511682492785D-2/
DATA X( 8) /7.5540440835500303D-1/,
& W( 8) /1.2462897125553387D-1/
DATA X( 9) /6.1787624440264375D-1/,
& W( 9) /1.4959598881657673D-1/
DATA X(10) /4.5801677765722739D-1/,
& W(10) /1.6915651939500254D-1/
DATA X(11) /2.8160355077925891D-1/,
& W(11) /1.8260341504492359D-1/
DATA X(12) /9.5012509837637440D-2/,
& W(12) /1.8945061045506850D-1/
H=0
IF(B .EQ. A) GO TO 99
CONST=CST/DABS(B-A)
BB=A
1 AA=BB
BB=B
2 C1=HF*(BB+AA)
C2=HF*(BB-AA)
S8=0
DO 3 I = 1,4
U=C2*X(I)
3 S8=S8+W(I)*(F(C1+U)+F(C1-U))
S16=0
DO 4 I = 5,12
U=C2*X(I)
4 S16=S16+W(I)*(F(C1+U)+F(C1-U))
S16=C2*S16
IF(DABS(S16-C2*S8) .LE. EPS*(1+DABS(S16))) THEN
H=H+S16
IF(BB .NE. B) GO TO 1
ELSE
BB=C1
IF(1+CONST*DABS(C2) .NE. 1) GO TO 2
H=0
WRITE(*,*) 'DGAUSS ERROR: TOO HIGH ACCURACY REQUIRED'
GO TO 99
END IF
99 DGAUSS=H
RETURN
END
@msz59 Thank you very much for your attention.
I could able to compile and run with your fixed code. Thank you again for your help.
With code like this, I often find that it will compile with --std=legacy (and seems to be the case here as well from my tests). Of course it will be better to write correct code, but if the goal is just to get it running…
Indeed, this is one of those instances where a well-intentioned addition of IMPLICIT NONE statements to old Fortran 77 code creates problems that did not exist before. When dummy arguments are present with the attribute EXTERNAL, if such an argument is a subroutine, it cannot have a type, but there is no way to tell the compiler, “this is a typeless external symbol”, i.e., a procedure that does not return a value.
I have encountered Fortran compilers that do not figure out that if a variable is external, with no type specified, and implicit typing does not yield a type, then the variable must be a subroutine.
Well, IMHO there is a way. Just using implicit none and external procname. Also, if the entity declared as external is not used in any procedural context, being used as a function invocation or call-ed, but only as an actual argument to another subprogram, the compiler should not care about its type. The problem the OP encountered was apparently an effect of some interprocedural optimization of the compiler, which analyzed DGAUSS function to find that its first argument is used as a function. It is even marked in the error message: interface mimatch. If one moves the while DGAUSS function to another source file and compile again, there is no error. Interestingly, and somewhat strangely, the fact, that all three subprograms (fun, funm, funt) are defined as functions in the very same source file, is apparently ignored and no error on calling DGAUSS with these functions is reported.
Here is the old example that I had in mind. In that example, the 8.1 version of the Silverfrost compiler complained:
“PROC must appear in a type declaration because IMPLICIT NONE has been used”,
even though the Fortran 95 standard says:
“If the interface of the dummy procedure is implicit and a reference to the procedure appears as a subroutine reference, the actual argument shall be a subroutine or dummy procedure.”
This bug is not present in the current version of FTN95.