URL
https://opencores.org/ocsvn/openrisc/openrisc/trunk
Subversion Repositories openrisc
Compare Revisions
- This comparison shows the changes necessary to convert path
/openrisc/trunk/gnu-old/gcc-4.2.2/gcc/testsuite/gfortran.dg/g77
- from Rev 154 to Rev 816
- ↔ Reverse comparison
Rev 154 → Rev 816
/19990826-3.f
0,0 → 1,320
c { dg-do compile } |
* Date: Thu, 19 Aug 1999 10:02:32 +0200 |
* From: Frederic Devernay <devernay@istar.fr> |
* Organization: ISTAR |
* X-Accept-Language: French, fr, en |
* To: gcc-bugs@gcc.gnu.org |
* Subject: g77 2.95 bug (Internal compiler error in `final_scan_insn') |
* X-UIDL: 08443f5c374ffa382a05573281482f4f |
|
* Here's a bug that happens only when I compile with -O (disappears with |
* -O2) |
|
* > g77 -v --save-temps -O -c pcapop.f |
* g77 version 2.95 19990728 (release) (from FSF-g77 version 0.5.25 |
* 19990728 (release)) |
* Reading specs from |
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/specs |
* gcc version 2.95 19990728 (release) |
* /usr/local/lib/gcc-lib/sparc-sun-solaris2.6/2.95/f771 pcapop.f -quiet |
* -dumpbase pcapop.f -O -version -fversion -o pcapop.s |
* GNU F77 version 2.95 19990728 (release) (sparc-sun-solaris2.6) compiled |
* by GNU C version 2.95 19990728 (release). |
* GNU Fortran Front End version 0.5.25 19990728 (release) |
* pcapop.f: In subroutine `pcapop': |
* pcapop.f:291: Internal compiler error in `final_scan_insn', at |
* final.c:2920 |
* Please submit a full bug report. |
* See <URL:http://egcs.cygnus.com/faq.html#bugreport> for instructions. |
|
C* PCAPOP |
SUBROUTINE PCAPOP(M1,M2,L1,L2,NMEM,N1,N2,IB,IBB,K3,TF,TS,TC,TTO) |
DIMENSION NVA(6),C(6),I(6) |
C |
C CALCUL DES PARAMETRES OPTIMAUX N1 N2 IB IBB |
C |
TACC=.035 |
TTRANS=.000004 |
RAD=.000001 |
RMI=.000001 |
RMU=.0000015 |
RDI=.000003 |
RTE=.000003 |
REQ=.000005 |
VY1=3*RTE+RDI+8*REQ+3*(RAD+RMI+RMU) |
VY2=REQ+2*RAD |
AR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ)) |
C VARIATION DE L1,L2, |
C |
TTOTOP=1.E+10 |
N1CO=0 |
N2CO=0 |
IBCO=0 |
IBBCO=0 |
K3CO=0 |
TESOP=0. |
TCOP=0. |
TFOP=0. |
INUN=7 |
INDE=7 |
IF(M1.LT.128)INUN=6 |
IF(M1.LT.64)INUN=5 |
IF(M1.LT.32)INUN=4 |
IF(M2.LT.128)INDE=6 |
IF(M2.LT.64)INDE=5 |
IF(M2.LT.32)INDE=4 |
DO 3 NUN =3,INUN |
DO 3 NDE=3,INDE |
N10=2**NUN |
N20=2**NDE |
NDIF=(N10-N20) |
NDIF=IABS(NDIF) |
C POUR AVOIR CES RESULTATS FAIRE TOURNER LE PROGRAMME VEFFT1 |
TCFFTU=0. |
IF(N10.EQ.128.AND.N20.EQ.128)TCFFTU=3.35 |
IF(N10.EQ.64.AND.N20.EQ.64)TCFFTU=.70 |
IF(N10.EQ.32.AND.N20.EQ.32)TCFFTU=.138 |
IF(N10.EQ.16.AND.N20.EQ.16)TCFFTU=.0332 |
IF(N10.EQ.8.AND.N20.EQ.8)TCFFTU=.00688 |
IF(NDIF.EQ.64)TCFFTU=1.566 |
IF(NDIF.EQ.96)TCFFTU=.709 |
IF(NDIF.EQ.112)TCFFTU=.349 |
IF(NDIF.EQ.120)TCFFTU=.160 |
IF(NDIF.EQ.32)TCFFTU=.315 |
IF(NDIF.EQ.48)TCFFTU=.154 |
IF(NDIF.EQ.56)TCFFTU=.07 |
IF(NDIF.EQ.16)TCFFTU=.067 |
IF(NDIF.EQ.24)TCFFTU=.030 |
IF(NDIF.EQ.8)TCFFTU=.016 |
N30=N10-L1+1 |
N40=N20-L2+1 |
WW=VY1+N30*VY2 |
NDOU=2*N10*N20 |
IF((N10.LT.L1).OR.(N20.LT.L2)) GOTO 3 |
NB=NMEM-NDOU-N20*(L1-1) |
NVC=2*N10*(N20-1)+M1 |
IF(NB.LT.(NVC)) GOTO 3 |
CALL VALENT(M1,N30,K1) |
CALL VALENT(M2,N40,K2) |
IS=K1/2 |
IF((2*IS).NE.K1)K1=K1+1 |
TFF=TCFFTU*K1*K2 |
CALL VALENT(M2,N40,JOFI) |
IF(NB.GE.(K1*N20*N30+2*N20*(L1-1))) GOTO 4 |
TIOOP=1.E+10 |
IC=1 |
18 IB1=2*IC |
MAX=(NB-2*N20*(L1-1))/(N20*N30) |
IN=MAX/2 |
IF(MAX.NE.2*IN) MAX=MAX-1 |
K3=K1/IB1 |
IBB1=K1-K3*IB1 |
IOFI=M1/(IB1*N30) |
IRZ=0 |
IF(IOFI*IB1*N30.EQ.M1) GOTO1234 |
IRZ=1 |
IOFI=IOFI+1 |
IF(IBB1.EQ.0) GOTO 1234 |
IF(M1.EQ.((IOFI-1)*IB1*N30+IBB1*N30)) GOTO 1233 |
IRZ=2 |
GOTO 1234 |
1233 IRZ=3 |
1234 IBX1=IBB1 |
IF(IBX1.EQ.0)IBX1=IB1 |
AR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1-(IOFI-1)*IB1*N30)*2*(REQ+RAD)) |
%+M2*(3*(REQ+RMU+RAD)+4*RMI+(M1-(IOFI-1)*IB1*N30)*(2*RAD+REQ) |
%+(IOFI-1)*IB1*N30*(2*RMI+REQ+RAD)) |
AR5=(JOFI-1)*(N20-L2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU)+REQ) |
%*IOFI+(M2-(JOFI-1)*N40+L2-2)*(M1-(IOFI-1)*IB1*N30)*(2*(RAD+RMU |
%)+REQ)*IOFI |
WQ=((IOFI-1)*IB1+IBX1)*JOFI*WW |
AT1=N20*WQ |
AT2=N40*WQ |
QW=JOFI*(VY1+VY2*IB1*N30) |
AT3=IOFI*N40*QW |
AT4=(IOFI-1)*N40*QW |
AT5=JOFI*((IOFI-1)*N40*(IB1/IBX1)*(VY1+IBX1*N30*VY2) |
%+N40*((IB1/IBX1)*(IOFI-1)+1)*(VY1+IBX1*N30*VY2)) |
AT6=JOFI*((IOFI-1)*N40*(IB1/2)*(VY1+2*N30*VY2)+N40*( |
%IB1*(IOFI-1)/2+IBX1/2)*(VY1+2*N30*VY2)) |
T1=JOFI*N20*(L1-1)*REQ |
T2=M1*(L2-1)*REQ |
T3=JOFI*N20*IBX1*N30*(RAD+REQ) |
T4=JOFI*((IOFI-1)*IB1*N30*N20*(2*RMI+REQ)+IBX1*N30*N20*(2*RMI+R |
%EQ)) |
T5=JOFI*((IOFI-1)*IB1/2+IBX1/2)*N20*N30*(2*RAD+REQ) |
T6=2*JOFI*(((IOFI-1)*IB1+IBX1)*N20)*((5*(RMI+RMU)+4*RAD |
%)+(L1-1)*(2*RAD+REQ)+N30*(2*RAD+REQ)) |
T7=JOFI*2*((IOFI-1)*IB1+IBX1)*(L1-1)*(2*RAD+REQ) |
T8=JOFI*N10*N20*((IOFI-1)*IB1/2+IBX1/2)*(3*REQ+9*RAD+4*RMU+RMI) |
T9=N10*N20*JOFI*((IOFI-1)*IB1/2+IBX1/2)*(REQ+RMI)+M1*M2*(REQ+R |
%DI+2*RAD) |
T10=JOFI*((IOFI-1)*IB1/2+IBX1/2)*2*(3*RMU+2*(RMI+RAD)+N40*(3*RMI |
%+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ))) |
POI=JOFI |
IF(POI.LE.2)POI=2 |
TNRAN=(N40+(POI-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMI+RMU+RAD |
%+REQ+N30*(2*RAD+2*REQ)*(IB1*(IOFI-1)+IBX1)) |
IF(TNRAN.LT.0.)TNRAN=0. |
TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10+TNRAN |
NVA(1)=N40 |
NVA(2)=N40 |
NVA(3)=N20 |
NVA(4)=N20 |
NVA(5)=M2-(JOFI-1)*N40 |
NVA(6)=NVA(5) |
C(1)=FLOAT(IB1*N30)/FLOAT(M1) |
C(2)=FLOAT(M1-(IOFI-1)*IB1*N30)/FLOAT(M1) |
C(3)=C(1) |
C(4)=C(2) |
C(5)=C(1) |
C(6)=C(2) |
K=1 |
P1=FLOAT(NB)/FLOAT(M1) |
10 IP1=P1 |
I(K)=1 |
IF(IP1.GE.NVA(K)) GOTO 7 |
P2=P1 |
IP2=P2 |
8 P2=P2-FLOAT(IP2)*C(K) |
IP2=P2 |
IF(IP2.EQ.0) GOTO 3 |
IP1=IP1+IP2 |
I(K)=I(K)+1 |
IF(IP1.GE.NVA(K))GOTO 7 |
GOTO 8 |
7 IF(K.EQ.6) GOTO 11 |
K=K+1 |
GOTO 10 |
11 IP1=0 |
IP2=0 |
IP3=0 |
POFI=JOFI |
IF(POFI.LE.2)POFI=2 |
TIOL=(I(2)+(IOFI-1)*I(1)+(POFI-2)*(IOFI-1)*I(3)+(POFI- |
%2)*I(4)+(IOFI-1)*I(5)+I(6))*TACC+(IOFI*M1*N40+(POFI-2)*IOFI* |
%M1*N20+(M2-(JOFI-1)*N40+L2-1)*M1*IOFI)*TTRANS |
IF(IBB1.EQ.0) GOTO 33 |
IF(IB1.EQ.IBB1) GOTO 33 |
IF(IBB1.EQ.2)GOTO 34 |
IP3=1 |
INL=NMEM/((IOFI-1)*IB1*N30+IBB1*N30) |
55 IF(INL.GT.N40)INL=N40 |
GOTO 35 |
33 IF(IB1.GT.2) GOTO 36 |
IF((M1-(IOFI-1)*IB1*N30).GE.N30) GOTO 36 |
34 IP1=1 |
INL=NMEM/(2*M1-(IOFI-1)*IB1*N30) |
GOTO 55 |
36 IP2=1 |
INL=NMEM/(IOFI*IB1*N30) |
IF(INL.GT.N40)INL=N40 |
35 CALL VALENT(N40,INL,KN1) |
CALL VALENT(M2-(JOFI-1)*N40,INL,KN2) |
CALL VALENT(INL*IBB1,IB1,KN3) |
CALL VALENT((N40-(KN1-1)*INL)*IBB1,IB1,KN4) |
IF((IP1+IP2+IP3).NE.1) CALL ERMESF(14) |
TIO1=0. |
IF(IP3.EQ.1)TIO1=N30*M2*TTRANS*(IB1*(IOFI-1)+IBB1) |
IF(IP1.EQ.1)TIO1=M1*M2*TTRANS |
IF(IP2.EQ.1) TIO1=(IB1*N30*M2*IOFI*TTRANS) |
TTIO=2.*TIO1+(KN1*IOFI*(JOFI-1)+KN2*IOFI+(KN1-1)*( |
%JOFI-1)+IOFI*(JOFI-1)+KN2-1.+IOFI+(KN1*(JOFI-1)+KN2))*TACC |
%+M1*M2*TTRANS+TIOL |
IF((IP1.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3 |
IF((IP1.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT4+AR1 |
IF((IP2.EQ.1).AND.(IRZ.EQ.0))TCPU=TCPU+AT1+AT2+AT3 |
IF((IP2.EQ.1).AND.(IRZ.NE.0))TCPU=TCPU+AT1+AT2+AT3+AR2 |
IFOIS=IB1/IBX1 |
IF((IP3.EQ.1).AND.(IFOIS*IBX1.EQ.IB1))TCPU=TCPU+AT1+AT2+AT5+AR2 |
IF((IP3.EQ.1).AND.(IFOIS*IBX1.NE.IB1))TCPU=TCPU+AT1+AT2+AT6+AR2 |
IF((IP1.EQ.1).AND.(IRZ.EQ.1))TCPU=TCPU+AR5 |
IF((IP1.EQ.1).AND.(IRZ.EQ.2))TCPU=TCPU+AR5 |
TTIOG=TTIO+TCPU |
IF(TTIOG.LE.0.) GOTO 99 |
IF(TTIOG.GE.TIOOP) GOTO 99 |
IBOP=IB1 |
IBBOP=IBB1 |
K3OP=K3 |
TIOOP=TTIOG |
TIOOP1=TTIO |
TIOOP2=TCPU |
99 IF(IB1.GE.MAX)GOTO17 |
IC=IC+1 |
GOTO 18 |
4 T1=JOFI*N20*(L1-1)*REQ |
T2=M1*(L2-1)*REQ |
T3=JOFI*N20*N30*(RAD+REQ)*K1 |
T4=JOFI*(K1*N30*N20*(2*RMI+REQ)) |
T5=JOFI*N20*N30*(2*RAD+REQ)*K1/2 |
T6=2*JOFI*(K1*N20)*((5*RMI+RMU)+4*RAD+(L1-1)*(2*RAD+REQ)+N30*2* |
%RAD+REQ) |
T7=JOFI*2*K1*(L1-1)*(2*RAD+REQ) |
T9=JOFI*N10*N20*K1*(REQ+RMI)/2+M1*M2*(REQ+RDI+2*RAD) |
T8=JOFI*N10*N20*K1*(3*REQ+9*RAD+4*RMU+RMI)/2 |
T10=JOFI*K1*(3*RMU+2*(RMI+RAD)+N40*(3*RMI |
%+4*RMU+3*(RAD+REQ)+N30*(2*RAD+REQ))) |
PIO=JOFI |
IF(PIO.LE.2)PIO=2 |
TNR=(N40+(PIO-2)*N20+(M2-(JOFI-1)*N40+L2-1))*(RMU+RMI+RAD+REQ+ |
%N30*(2*RAD+2*REQ)*K1) |
IF(TNR.LE.0.)TNR=0. |
BT1=JOFI*N20*WW*K1 |
BT2=JOFI*N40*WW*K1 |
BT3=JOFI*N40*(VY1+K1*N30*VY2) |
BR1=M2*(2*(RAD+RMI+RMU+REQ)+(M1*2*(REQ+RAD)))+M2*(3*( |
$REQ+RAD+RMU)+4*(RMI)+M1*(2*(RAD)+REQ)) |
BR2=M2*(2*(REQ+RMI)+3*RMU+M1*(2*RAD+REQ)) |
TCPU=T1+T2+T3+T4+T5+T6+T7+T8+T9+T10 |
TCPU=TCPU+TNR+BT1+BT2 |
LIOF=M1/(N30) |
IRZ=0 |
IF(LIOF*N30.EQ.M1) GOTO 2344 |
IRZ=1 |
2344 IF(IRZ.EQ.0)TCPU=TCPU+BT3 |
IF(IRZ.NE.0)TCPU=TCPU+BT3+BR2 |
TIOOP=2.*FLOAT(M1)*FLOAT(M2)*TTRANS+2.*FLOAT(K2)*TACC+TCPU |
IBOP=1 |
IBBOP=0 |
K3OP=1 |
TIOOP2=TCPU |
TIOOP1=TIOOP-TCPU |
17 TTOT=TIOOP+TFF |
IF(TTOT.LE.0.) GOTO 3 |
IF(TTOT.GE.TTOTOP)GOTO3 |
N1CO=N10 |
N2CO=N20 |
IBCO=IBOP |
IBBCO=IBBOP |
K3CO=K3OP |
TTOTOP=TTOT |
TESOP=TIOOP1 |
TCOP=TIOOP2 |
TFOP=TFF |
3 CONTINUE |
|
N1=N1CO |
N2=N2CO |
TTO=TTOTOP |
IB=IBCO |
IBB=IBBCO |
K3=K3CO |
TC=TCOP |
TS=TESOP |
TF=TFOP |
TT=TCOP+TFOP |
TWER=TTO-TT |
IF(N1.EQ.0.OR.N2.EQ.0) CALL OUTSTR(0,'PAS DE PLACE MEMOIRE SUFFISA |
$NTE POUR UNE MISE EN OEUVRE PAR BLOCS$') |
IF(IB.NE.1)RETURN |
IHJ=(M1/(N1-L1+1)) |
IF(IHJ*(N1-L1+1).NE.M1)IHJ=IHJ+1 |
IHJ1=IHJ/2 |
IF(IHJ1*2.NE.IHJ)GOTO7778 |
IB=IHJ |
IBB=0 |
RETURN |
7778 IB=IHJ+1 |
IBB=0 |
RETURN |
END |
/intrinsic-unix-bessel.f
0,0 → 1,109
c { dg-do run } |
c intrinsic-unix-bessel.f |
c |
c Test Bessel function intrinsics. |
c These functions are only available if provided by system |
c |
c David Billinghurst <David.Billinghurst@riotinto.com> |
c |
real x, a |
double precision dx, da |
integer i |
integer(kind=2) j |
integer(kind=1) k |
integer(kind=8) m |
logical fail |
common /flags/ fail |
fail = .false. |
|
x = 2.0 |
dx = x |
i = 2 |
j = i |
k = i |
m = i |
c BESJ0 - Bessel function of first kind of order zero |
a = 0.22389077 |
da = a |
call c_r(BESJ0(x),a,'BESJ0(real)') |
call c_d(BESJ0(dx),da,'BESJ0(double)') |
call c_d(DBESJ0(dx),da,'DBESJ0(double)') |
|
c BESJ1 - Bessel function of first kind of order one |
a = 0.57672480 |
da = a |
call c_r(BESJ1(x),a,'BESJ1(real)') |
call c_d(BESJ1(dx),da,'BESJ1(double)') |
call c_d(DBESJ1(dx),da,'DBESJ1(double)') |
|
c BESJN - Bessel function of first kind of order N |
a = 0.3528340 |
da = a |
call c_r(BESJN(i,x),a,'BESJN(integer,real)') |
call c_r(BESJN(j,x),a,'BESJN(integer(2),real)') |
call c_r(BESJN(k,x),a,'BESJN(integer(1),real)') |
call c_d(BESJN(i,dx),da,'BESJN(integer,double)') |
call c_d(BESJN(j,dx),da,'BESJN(integer(2),double)') |
call c_d(BESJN(k,dx),da,'BESJN(integer(1),double)') |
call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)') |
call c_d(DBESJN(j,dx),da,'DBESJN(integer(2),double)') |
call c_d(DBESJN(k,dx),da,'DBESJN(integer(1),double)') |
|
c BESY0 - Bessel function of second kind of order zero |
a = 0.51037567 |
da = a |
call c_r(BESY0(x),a,'BESY0(real)') |
call c_d(BESY0(dx),da,'BESY0(double)') |
call c_d(DBESY0(dx),da,'DBESY0(double)') |
|
c BESY1 - Bessel function of second kind of order one |
a = 0.-0.1070324 |
da = a |
call c_r(BESY1(x),a,'BESY1(real)') |
call c_d(BESY1(dx),da,'BESY1(double)') |
call c_d(DBESY1(dx),da,'DBESY1(double)') |
|
c BESYN - Bessel function of second kind of order N |
a = -0.6174081 |
da = a |
call c_r(BESYN(i,x),a,'BESYN(integer,real)') |
call c_r(BESYN(j,x),a,'BESYN(integer(2),real)') |
call c_r(BESYN(k,x),a,'BESYN(integer(1),real)') |
call c_d(BESYN(i,dx),da,'BESYN(integer,double)') |
call c_d(BESYN(j,dx),da,'BESYN(integer(2),double)') |
call c_d(BESYN(k,dx),da,'BESYN(integer(1),double)') |
call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)') |
call c_d(DBESYN(j,dx),da,'DBESYN(integer(2),double)') |
call c_d(DBESYN(k,dx),da,'DBESYN(integer(1),double)') |
|
if ( fail ) call abort() |
end |
|
subroutine failure(label) |
c Report failure and set flag |
character*(*) label |
logical fail |
common /flags/ fail |
write(6,'(a,a,a)') 'Test ',label,' FAILED' |
fail = .true. |
end |
|
subroutine c_r(a,b,label) |
c Check if REAL a equals b, and fail otherwise |
real a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0e-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_d(a,b,label) |
c Check if DOUBLE PRECISION a equals b, and fail otherwise |
double precision a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0d-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
/980628-10.f
0,0 → 1,59
c { dg-do run } |
c { dg-options "-std=gnu" } |
* g77 0.5.23 and previous had bugs involving too little space |
* allocated for EQUIVALENCE and COMMON areas needing initial |
* padding to meet alignment requirements of the system. |
|
call subr |
end |
|
subroutine subr |
implicit none |
save |
|
character c1(11), c2(11), c3(11) |
real r1, r2, r3 |
character c4, c5, c6 |
equivalence (r1, c1(2)) |
equivalence (r2, c2(2)) |
equivalence (r3, c3(2)) |
|
c1(1) = '1' |
r1 = 1. |
c1(11) = '1' |
c4 = '4' |
c2(1) = '2' |
r2 = 2. |
c2(11) = '2' |
c5 = '5' |
c3(1) = '3' |
r3 = 3. |
c3(11) = '3' |
c6 = '6' |
|
call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) |
|
end |
|
subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) |
implicit none |
|
character c1(11), c2(11), c3(11) |
real r1, r2, r3 |
character c4, c5, c6 |
|
if (c1(1) .ne. '1') call abort |
if (r1 .ne. 1.) call abort |
if (c1(11) .ne. '1') call abort |
if (c4 .ne. '4') call abort |
if (c2(1) .ne. '2') call abort |
if (r2 .ne. 2.) call abort |
if (c2(11) .ne. '2') call abort |
if (c5 .ne. '5') call abort |
if (c3(1) .ne. '3') call abort |
if (r3 .ne. 3.) call abort |
if (c3(11) .ne. '3') call abort |
if (c6 .ne. '6') call abort |
|
end |
|
/20000518.f
0,0 → 1,17
c { dg-do compile } |
SUBROUTINE SORG2R( K, A, N, LDA ) |
* ICE in `verify_wide_reg_1', at flow.c:2605 at -O2 |
* g77 version 2.96 20000515 (experimental) on i686-pc-linux-gnu |
* |
* Originally derived from LAPACK 3.0 test suite failure. |
* |
* David Billinghurst, (David.Billinghurst@riotinto.com.au) |
* 18 May 2000 |
INTEGER I, K, LDA, N |
REAL A( LDA, * ) |
DO I = K, 1, -1 |
IF( I.LT.N ) A( I, I ) = 1.0 |
A( I, I ) = 1.0 |
END DO |
RETURN |
END |
/20010519-1.f
0,0 → 1,1327
c { dg-do compile } |
CHARMM Element source/dimb/nmdimb.src 1.1 |
C.##IF DIMB |
SUBROUTINE NMDIMB(X,Y,Z,NAT3,BNBND,BIMAG,LNOMA,AMASS,DDS,DDSCR, |
1 PARDDV,DDV,DDM,PARDDF,DDF,PARDDE,DDEV,DD1BLK, |
2 DD1BLL,NADD,LRAISE,DD1CMP,INBCMP,JNBCMP, |
3 NPAR,ATMPAR,ATMPAS,BLATOM,PARDIM,NFREG,NFRET, |
4 PARFRQ,CUTF1,ITMX,TOLDIM,IUNMOD,IUNRMD, |
5 LBIG,LSCI,ATMPAD,SAVF,NBOND,IB,JB,DDVALM) |
C----------------------------------------------------------------------- |
C 01-Jul-1992 David Perahia, Liliane Mouawad |
C 15-Dec-1994 Herman van Vlijmen |
C |
C This is the main routine for the mixed-basis diagonalization. |
C See: L.Mouawad and D.Perahia, Biopolymers (1993), 33, 599, |
C and: D.Perahia and L.Mouawad, Comput. Chem. (1995), 19, 241. |
C The method iteratively solves the diagonalization of the |
C Hessian matrix. To save memory space, it uses a compressed |
C form of the Hessian, which only contains the nonzero elements. |
C In the diagonalization process, approximate eigenvectors are |
C mixed with Cartesian coordinates to form a reduced basis. The |
C Hessian is then diagonalized in the reduced basis. By iterating |
C over different sets of Cartesian coordinates the method ultimately |
C converges to the exact eigenvalues and eigenvectors (up to the |
C requested accuracy). |
C If no existing basis set is read, an initial basis will be created |
C which consists of the low-frequency eigenvectors of diagonal blocks |
C of the Hessian. |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/impnon.fcm' |
C..##IF VAX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA |
IMPLICIT NONE |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/stream.fcm' |
LOGICAL LOWER,QLONGL |
INTEGER MXSTRM,POUTU |
PARAMETER (MXSTRM=20,POUTU=6) |
INTEGER NSTRM,ISTRM,JSTRM,OUTU,PRNLEV,WRNLEV,IOLEV |
COMMON /CASE/ LOWER, QLONGL |
COMMON /STREAM/ NSTRM,ISTRM,JSTRM(MXSTRM),OUTU,PRNLEV,WRNLEV,IOLEV |
C..##IF SAVEFCM |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/dimens.fcm' |
INTEGER LARGE,MEDIUM,SMALL,REDUCE |
C..##IF QUANTA |
C..##ELIF T3D |
C..##ELSE |
PARAMETER (LARGE=60120, MEDIUM=25140, SMALL=6120) |
C..##ENDIF |
PARAMETER (REDUCE=15000) |
INTEGER SIZE |
C..##IF XLARGE |
C..##ELIF XXLARGE |
C..##ELIF LARGE |
C..##ELIF MEDIUM |
PARAMETER (SIZE=MEDIUM) |
C..##ELIF REDUCE |
C..##ELIF SMALL |
C..##ELIF XSMALL |
C..##ENDIF |
C..##IF MMFF |
integer MAXDEFI |
parameter(MAXDEFI=250) |
INTEGER NAME0,NAMEQ0,NRES0,KRES0 |
PARAMETER (NAME0=4,NAMEQ0=10,NRES0=4,KRES0=4) |
integer MaxAtN |
parameter (MaxAtN=55) |
INTEGER MAXAUX |
PARAMETER (MAXAUX = 10) |
C..##ENDIF |
INTEGER MAXCSP, MAXHSET |
C..##IF HMCM |
PARAMETER (MAXHSET = 200) |
C..##ELSE |
C..##ENDIF |
C..##IF REDUCE |
C..##ELSE |
PARAMETER (MAXCSP = 500) |
C..##ENDIF |
C..##IF HMCM |
INTEGER MAXHCM,MAXPCM,MAXRCM |
C...##IF REDUCE |
C...##ELSE |
PARAMETER (MAXHCM=500) |
PARAMETER (MAXPCM=5000) |
PARAMETER (MAXRCM=2000) |
C...##ENDIF |
C..##ENDIF |
INTEGER MXCMSZ |
C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE |
C..##ELSE |
PARAMETER (MXCMSZ = 5000) |
C..##ENDIF |
INTEGER CHRSIZ |
PARAMETER (CHRSIZ = SIZE) |
INTEGER MAXATB |
C..##IF REDUCE |
C..##ELIF QUANTA |
C..##ELSE |
PARAMETER (MAXATB = 200) |
C..##ENDIF |
INTEGER MAXVEC |
C..##IFN VECTOR PARVECT |
PARAMETER (MAXVEC = 10) |
C..##ELIF LARGE XLARGE XXLARGE |
C..##ELIF MEDIUM |
C..##ELIF SMALL REDUCE |
C..##ELIF XSMALL |
C..##ELSE |
C..##ENDIF |
INTEGER IATBMX |
PARAMETER (IATBMX = 8) |
INTEGER MAXHB |
C..##IF LARGE XLARGE XXLARGE |
C..##ELIF MEDIUM |
PARAMETER (MAXHB = 8000) |
C..##ELIF SMALL |
C..##ELIF REDUCE XSMALL |
C..##ELSE |
C..##ENDIF |
INTEGER MAXTRN,MAXSYM |
C..##IFN NOIMAGES |
PARAMETER (MAXTRN = 5000) |
PARAMETER (MAXSYM = 192) |
C..##ELSE |
C..##ENDIF |
C..##IF LONEPAIR (lonepair_max) |
INTEGER MAXLP,MAXLPH |
C...##IF REDUCE |
C...##ELSE |
PARAMETER (MAXLP = 2000) |
PARAMETER (MAXLPH = 4000) |
C...##ENDIF |
C..##ENDIF (lonepair_max) |
INTEGER NOEMAX,NOEMX2 |
C..##IF REDUCE |
C..##ELSE |
PARAMETER (NOEMAX = 2000) |
PARAMETER (NOEMX2 = 4000) |
C..##ENDIF |
INTEGER MAXATC, MAXCB, MAXCH, MAXCI, MAXCP, MAXCT, MAXITC, MAXNBF |
C..##IF REDUCE |
C..##ELIF MMFF CFF |
PARAMETER (MAXATC = 500, MAXCB = 1500, MAXCH = 3200, MAXCI = 600, |
& MAXCP = 3000,MAXCT = 15500,MAXITC = 200, MAXNBF=1000) |
C..##ELIF YAMMP |
C..##ELIF LARGE |
C..##ELSE |
C..##ENDIF |
INTEGER MAXCN |
PARAMETER (MAXCN = MAXITC*(MAXITC+1)/2) |
INTEGER MAXA, MAXAIM, MAXB, MAXT, MAXP |
INTEGER MAXIMP, MAXNB, MAXPAD, MAXRES |
INTEGER MAXSEG, MAXGRP |
C..##IF LARGE XLARGE XXLARGE |
C..##ELIF MEDIUM |
PARAMETER (MAXA = SIZE, MAXB = SIZE, MAXT = SIZE, |
& MAXP = 2*SIZE) |
PARAMETER (MAXIMP = 9200, MAXNB = 17200, MAXPAD = 8160, |
& MAXRES = 14000) |
C...##IF MCSS |
C...##ELSE |
PARAMETER (MAXSEG = 1000) |
C...##ENDIF |
C..##ELIF SMALL |
C..##ELIF XSMALL |
C..##ELIF REDUCE |
C..##ELSE |
C..##ENDIF |
C..##IF NOIMAGES |
C..##ELSE |
PARAMETER (MAXAIM = 2*SIZE) |
PARAMETER (MAXGRP = 2*SIZE/3) |
C..##ENDIF |
INTEGER REDMAX,REDMX2 |
C..##IF REDUCE |
C..##ELSE |
PARAMETER (REDMAX = 20) |
PARAMETER (REDMX2 = 80) |
C..##ENDIF |
INTEGER MXRTRS, MXRTA, MXRTB, MXRTT, MXRTP, MXRTI, MXRTX, |
& MXRTHA, MXRTHD, MXRTBL, NICM |
PARAMETER (MXRTRS = 200, MXRTA = 5000, MXRTB = 5000, |
& MXRTT = 5000, MXRTP = 5000, MXRTI = 2000, |
C..##IF YAMMP |
C..##ELSE |
& MXRTX = 5000, MXRTHA = 300, MXRTHD = 300, |
C..##ENDIF |
& MXRTBL = 5000, NICM = 10) |
INTEGER NMFTAB, NMCTAB, NMCATM, NSPLIN |
C..##IF REDUCE |
C..##ELSE |
PARAMETER (NMFTAB = 200, NMCTAB = 3, NMCATM = 12000, NSPLIN = 3) |
C..##ENDIF |
INTEGER MAXSHK |
C..##IF XSMALL |
C..##ELIF REDUCE |
C..##ELSE |
PARAMETER (MAXSHK = SIZE*3/4) |
C..##ENDIF |
INTEGER SCRMAX |
C..##IF IBM IBMRS CRAY INTEL IBMSP T3D REDUCE |
C..##ELSE |
PARAMETER (SCRMAX = 5000) |
C..##ENDIF |
C..##IF TSM |
INTEGER MXPIGG |
C...##IF REDUCE |
C...##ELSE |
PARAMETER (MXPIGG=500) |
C...##ENDIF |
INTEGER MXCOLO,MXPUMB |
PARAMETER (MXCOLO=20,MXPUMB=20) |
C..##ENDIF |
C..##IF ADUMB |
INTEGER MAXUMP, MAXEPA, MAXNUM |
C...##IF REDUCE |
C...##ELSE |
PARAMETER (MAXUMP = 10, MAXNUM = 4) |
C...##ENDIF |
C..##ENDIF |
INTEGER MAXING |
PARAMETER (MAXING=1000) |
C..##IF MMFF |
integer MAX_RINGSIZE, MAX_EACH_SIZE |
parameter (MAX_RINGSIZE = 20, MAX_EACH_SIZE = 1000) |
integer MAXPATHS |
parameter (MAXPATHS = 8000) |
integer MAX_TO_SEARCH |
parameter (MAX_TO_SEARCH = 6) |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/number.fcm' |
REAL(KIND=8) ZERO, ONE, TWO, THREE, FOUR, FIVE, SIX, |
& SEVEN, EIGHT, NINE, TEN, ELEVEN, TWELVE, THIRTN, |
& FIFTN, NINETN, TWENTY, THIRTY |
C..##IF SINGLE |
C..##ELSE |
PARAMETER (ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0, |
& THREE = 3.D0, FOUR = 4.D0, FIVE = 5.D0, |
& SIX = 6.D0, SEVEN = 7.D0, EIGHT = 8.D0, |
& NINE = 9.D0, TEN = 10.D0, ELEVEN = 11.D0, |
& TWELVE = 12.D0, THIRTN = 13.D0, FIFTN = 15.D0, |
& NINETN = 19.D0, TWENTY = 20.D0, THIRTY = 30.D0) |
C..##ENDIF |
REAL(KIND=8) FIFTY, SIXTY, SVNTY2, EIGHTY, NINETY, HUNDRD, |
& ONE2TY, ONE8TY, THRHUN, THR6TY, NINE99, FIFHUN, THOSND, |
& FTHSND,MEGA |
C..##IF SINGLE |
C..##ELSE |
PARAMETER (FIFTY = 50.D0, SIXTY = 60.D0, SVNTY2 = 72.D0, |
& EIGHTY = 80.D0, NINETY = 90.D0, HUNDRD = 100.D0, |
& ONE2TY = 120.D0, ONE8TY = 180.D0, THRHUN = 300.D0, |
& THR6TY=360.D0, NINE99 = 999.D0, FIFHUN = 1500.D0, |
& THOSND = 1000.D0,FTHSND = 5000.D0, MEGA = 1.0D6) |
C..##ENDIF |
REAL(KIND=8) MINONE, MINTWO, MINSIX |
PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0) |
REAL(KIND=8) TENM20,TENM14,TENM8,TENM5,PT0001,PT0005,PT001,PT005, |
& PT01, PT02, PT05, PTONE, PT125, PT25, SIXTH, THIRD, |
& PTFOUR, PTSIX, HALF, PT75, PT9999, ONEPT5, TWOPT4 |
C..##IF SINGLE |
C..##ELSE |
PARAMETER (TENM20 = 1.0D-20, TENM14 = 1.0D-14, TENM8 = 1.0D-8, |
& TENM5 = 1.0D-5, PT0001 = 1.0D-4, PT0005 = 5.0D-4, |
& PT001 = 1.0D-3, PT005 = 5.0D-3, PT01 = 0.01D0, |
& PT02 = 0.02D0, PT05 = 0.05D0, PTONE = 0.1D0, |
& PT125 = 0.125D0, SIXTH = ONE/SIX,PT25 = 0.25D0, |
& THIRD = ONE/THREE,PTFOUR = 0.4D0, HALF = 0.5D0, |
& PTSIX = 0.6D0, PT75 = 0.75D0, PT9999 = 0.9999D0, |
& ONEPT5 = 1.5D0, TWOPT4 = 2.4D0) |
C..##ENDIF |
REAL(KIND=8) ANUM,FMARK |
REAL(KIND=8) RSMALL,RBIG |
C..##IF SINGLE |
C..##ELSE |
PARAMETER (ANUM=9999.0D0, FMARK=-999.0D0) |
PARAMETER (RSMALL=1.0D-10,RBIG=1.0D20) |
C..##ENDIF |
REAL(KIND=8) RPRECI,RBIGST |
C..##IF VAX DEC |
C..##ELIF IBM |
C..##ELIF CRAY |
C..##ELIF ALPHA T3D T3E |
C..##ELSE |
C...##IF SINGLE |
C...##ELSE |
PARAMETER (RPRECI = 2.22045D-16, RBIGST = 4.49423D+307) |
C...##ENDIF |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/consta.fcm' |
REAL(KIND=8) PI,RADDEG,DEGRAD,TWOPI |
PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI) |
PARAMETER (RADDEG=180.0D0/PI) |
PARAMETER (DEGRAD=PI/180.0D0) |
REAL(KIND=8) COSMAX |
PARAMETER (COSMAX=0.9999999999D0) |
REAL(KIND=8) TIMFAC |
PARAMETER (TIMFAC=4.88882129D-02) |
REAL(KIND=8) KBOLTZ |
PARAMETER (KBOLTZ=1.987191D-03) |
REAL(KIND=8) CCELEC |
C..##IF AMBER |
C..##ELIF DISCOVER |
C..##ELSE |
PARAMETER (CCELEC=332.0716D0) |
C..##ENDIF |
REAL(KIND=8) CNVFRQ |
PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0)) |
REAL(KIND=8) SPEEDL |
PARAMETER (SPEEDL=2.99793D-02) |
REAL(KIND=8) ATMOSP |
PARAMETER (ATMOSP=1.4584007D-05) |
REAL(KIND=8) PATMOS |
PARAMETER (PATMOS = 1.D0 / ATMOSP ) |
REAL(KIND=8) BOHRR |
PARAMETER (BOHRR = 0.529177249D0 ) |
REAL(KIND=8) TOKCAL |
PARAMETER (TOKCAL = 627.5095D0 ) |
C..##IF MMFF |
REAL(KIND=8) MDAKCAL |
parameter(MDAKCAL=143.9325D0) |
C..##ENDIF |
REAL(KIND=8) DEBYEC |
PARAMETER ( DEBYEC = 2.541766D0 / BOHRR ) |
REAL(KIND=8) ZEROC |
PARAMETER ( ZEROC = 298.15D0 ) |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/exfunc.fcm' |
C..##IF ACE |
C..##ENDIF |
C..##IF ADUMB |
C..##ENDIF |
CHARACTER*4 GTRMA, NEXTA4, CURRA4 |
CHARACTER*6 NEXTA6 |
CHARACTER*8 NEXTA8 |
CHARACTER*20 NEXT20 |
INTEGER ALLCHR, ALLSTK, ALLHP, DECODI, FIND52, |
* GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL, |
* ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF, |
* INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF, |
* LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL, |
* PARNUM, PARINS, |
* SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE |
C..##IF ACE |
* ,GETNNB |
C..##ENDIF |
LOGICAL CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE, |
* HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5, |
* ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA |
REAL(KIND=8) DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8, |
* RANUMB, R8VAL, RETVAL8, SUMVEC |
C..##IF ADUMB |
* ,UMFI |
C..##ENDIF |
EXTERNAL GTRMA, NEXTA4, CURRA4, NEXTA6, NEXTA8,NEXT20, |
* ALLCHR, ALLSTK, ALLHP, DECODI, FIND52, |
* GETATN, GETRES, GETRSN, GETSEG, GTRMI, I4VAL, |
* ICHAR4, ICMP16, ILOGI4, INDX, INDXA, INDXAF, |
* INDXRA, INTEG4, IREAL4, IREAL8, LOCDIF, |
* LUNASS, MATOM, NEXTI, NINDX, NSELCT, NSELCTV, ATMSEL, |
* PARNUM, PARINS, |
* SRCHWD, SRCHWS, STRLNG, DSIZE, SSIZE, |
* CHKPTR, EQST, EQSTA, EQSTWC, EQWDWC, DOTRIM, CHECQUE, |
* HYDROG, INITIA, LONE, LTSTEQ, ORDER, ORDER5, |
* ORDERR, USEDDT, QTOKDEL, QDIGIT, QALPHA, |
* DECODF, DOTVEC, GTRMF, LENVEC, NEXTF, RANDOM, GTRR8, |
* RANUMB, R8VAL, RETVAL8, SUMVEC |
C..##IF ADUMB |
* ,UMFI |
C..##ENDIF |
C..##IF ACE |
* ,GETNNB |
C..##ENDIF |
C..##IFN NOIMAGES |
INTEGER IMATOM |
EXTERNAL IMATOM |
C..##ENDIF |
C..##IF MBOND |
C..##ENDIF |
C..##IF MMFF |
INTEGER LEN_TRIM |
EXTERNAL LEN_TRIM |
CHARACTER*4 AtName |
external AtName |
CHARACTER*8 ElementName |
external ElementName |
CHARACTER*10 QNAME |
external QNAME |
integer IATTCH, IBORDR, CONN12, CONN13, CONN14 |
integer LEQUIV, LPATH |
integer nbndx, nbnd2, nbnd3, NTERMA |
external IATTCH, IBORDR, CONN12, CONN13, CONN14 |
external LEQUIV, LPATH |
external nbndx, nbnd2, nbnd3, NTERMA |
external find_loc |
REAL(KIND=8) vangle, OOPNGL, TORNGL, ElementMass |
external vangle, OOPNGL, TORNGL, ElementMass |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/stack.fcm' |
INTEGER STKSIZ |
C..##IFN UNICOS |
C...##IF LARGE XLARGE |
C...##ELIF MEDIUM REDUCE |
PARAMETER (STKSIZ=4000000) |
C...##ELIF SMALL |
C...##ELIF XSMALL |
C...##ELIF XXLARGE |
C...##ELSE |
C...##ENDIF |
INTEGER LSTUSD,MAXUSD,STACK |
COMMON /ISTACK/ LSTUSD,MAXUSD,STACK(STKSIZ) |
C..##ELSE |
C..##ENDIF |
C..##IF SAVEFCM |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/heap.fcm' |
INTEGER HEAPDM |
C..##IFN UNICOS (unicos) |
C...##IF XXLARGE (size) |
C...##ELIF LARGE XLARGE (size) |
C...##ELIF MEDIUM (size) |
C....##IF T3D (t3d2) |
C....##ELIF TERRA (t3d2) |
C....##ELIF ALPHA (t3d2) |
C....##ELIF T3E (t3d2) |
C....##ELSE (t3d2) |
PARAMETER (HEAPDM=2048000) |
C....##ENDIF (t3d2) |
C...##ELIF SMALL (size) |
C...##ELIF REDUCE (size) |
C...##ELIF XSMALL (size) |
C...##ELSE (size) |
C...##ENDIF (size) |
INTEGER FREEHP,HEAPSZ,HEAP |
COMMON /HEAPST/ FREEHP,HEAPSZ,HEAP(HEAPDM) |
LOGICAL LHEAP(HEAPDM) |
EQUIVALENCE (LHEAP,HEAP) |
C..##ELSE (unicos) |
C..##ENDIF (unicos) |
C..##IF SAVEFCM (save) |
C..##ENDIF (save) |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/fast.fcm' |
INTEGER IACNB, NITCC, ICUSED, FASTER, LFAST, LMACH, OLMACH |
INTEGER ICCOUNT, LOWTP, IGCNB, NITCC2 |
INTEGER ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD |
COMMON /FASTI/ FASTER, LFAST, LMACH, OLMACH, NITCC, NITCC2, |
& ICUSED(MAXATC), ICCOUNT(MAXATC), LOWTP(MAXATC), |
& IACNB(MAXAIM), IGCNB(MAXATC), |
& ICCNBA, ICCNBB, ICCNBC, ICCNBD, LCCNBA, LCCNBD |
C..##IF SAVEFCM |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/deriv.fcm' |
REAL(KIND=8) DX,DY,DZ |
COMMON /DERIVR/ DX(MAXAIM),DY(MAXAIM),DZ(MAXAIM) |
C..##IF SAVEFCM |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/energy.fcm' |
INTEGER LENENP, LENENT, LENENV, LENENA |
PARAMETER (LENENP = 50, LENENT = 70, LENENV = 50, |
& LENENA = LENENP + LENENT + LENENV ) |
INTEGER TOTE, TOTKE, EPOT, TEMPS, GRMS, BPRESS, PJNK1, PJNK2, |
& PJNK3, PJNK4, HFCTE, HFCKE, EHFC, EWORK, VOLUME, PRESSE, |
& PRESSI, VIRI, VIRE, VIRKE, TEPR, PEPR, KEPR, KEPR2, |
& DROFFA, |
& XTLTE, XTLKE, XTLPE, XTLTEM, XTLPEP, XTLKEP, XTLKP2, |
& TOT4, TOTK4, EPOT4, TEM4, MbMom, BodyT, PartT |
C..##IF ACE |
& , SELF, SCREEN, COUL ,SOLV, INTER |
C..##ENDIF |
C..##IF FLUCQ |
& ,FQKIN |
C..##ENDIF |
PARAMETER (TOTE = 1, TOTKE = 2, EPOT = 3, TEMPS = 4, |
& GRMS = 5, BPRESS = 6, PJNK1 = 7, PJNK2 = 8, |
& PJNK3 = 9, PJNK4 = 10, HFCTE = 11, HFCKE = 12, |
& EHFC = 13, EWORK = 11, VOLUME = 15, PRESSE = 16, |
& PRESSI = 17, VIRI = 18, VIRE = 19, VIRKE = 20, |
& TEPR = 21, PEPR = 22, KEPR = 23, KEPR2 = 24, |
& DROFFA = 26, XTLTE = 27, XTLKE = 28, |
& XTLPE = 29, XTLTEM = 30, XTLPEP = 31, XTLKEP = 32, |
& XTLKP2 = 33, |
& TOT4 = 37, TOTK4 = 38, EPOT4 = 39, TEM4 = 40, |
& MbMom = 41, BodyT = 42, PartT = 43 |
C..##IF ACE |
& , SELF = 45, SCREEN = 46, COUL = 47, |
& SOLV = 48, INTER = 49 |
C..##ENDIF |
C..##IF FLUCQ |
& ,FQKIN = 50 |
C..##ENDIF |
& ) |
C..##IF ACE |
C..##ENDIF |
C..##IF GRID |
C..##ENDIF |
C..##IF FLUCQ |
C..##ENDIF |
INTEGER BOND, ANGLE, UREYB, DIHE, IMDIHE, VDW, ELEC, HBOND, |
& USER, CHARM, CDIHE, CINTCR, CQRT, NOE, SBNDRY, |
& IMVDW, IMELEC, IMHBND, EWKSUM, EWSELF, EXTNDE, RXNFLD, |
& ST2, IMST2, TSM, QMEL, QMVDW, ASP, EHARM, GEO, MDIP, |
& PRMS, PANG, SSBP, BK4D, SHEL, RESD, SHAP, |
& STRB, OOPL, PULL, POLAR, DMC, RGY, EWEXCL, EWQCOR, |
& EWUTIL, PBELEC, PBNP, PINT, MbDefrm, MbElec, STRSTR, |
& BNDBND, BNDTW, EBST, MBST, BBT, SST, GBEnr, GSBP |
C..##IF HMCM |
& , HMCM |
C..##ENDIF |
C..##IF ADUMB |
& , ADUMB |
C..##ENDIF |
& , HYDR |
C..##IF FLUCQ |
& , FQPOL |
C..##ENDIF |
PARAMETER (BOND = 1, ANGLE = 2, UREYB = 3, DIHE = 4, |
& IMDIHE = 5, VDW = 6, ELEC = 7, HBOND = 8, |
& USER = 9, CHARM = 10, CDIHE = 11, CINTCR = 12, |
& CQRT = 13, NOE = 14, SBNDRY = 15, IMVDW = 16, |
& IMELEC = 17, IMHBND = 18, EWKSUM = 19, EWSELF = 20, |
& EXTNDE = 21, RXNFLD = 22, ST2 = 23, IMST2 = 24, |
& TSM = 25, QMEL = 26, QMVDW = 27, ASP = 28, |
& EHARM = 29, GEO = 30, MDIP = 31, PINT = 32, |
& PRMS = 33, PANG = 34, SSBP = 35, BK4D = 36, |
& SHEL = 37, RESD = 38, SHAP = 39, STRB = 40, |
& OOPL = 41, PULL = 42, POLAR = 43, DMC = 44, |
& RGY = 45, EWEXCL = 46, EWQCOR = 47, EWUTIL = 48, |
& PBELEC = 49, PBNP = 50, MbDefrm= 51, MbElec = 52, |
& STRSTR = 53, BNDBND = 54, BNDTW = 55, EBST = 56, |
& MBST = 57, BBT = 58, SST = 59, GBEnr = 60, |
& GSBP = 65 |
C..##IF HMCM |
& , HMCM = 61 |
C..##ENDIF |
C..##IF ADUMB |
& , ADUMB = 62 |
C..##ENDIF |
& , HYDR = 63 |
C..##IF FLUCQ |
& , FQPOL = 65 |
C..##ENDIF |
& ) |
INTEGER VEXX, VEXY, VEXZ, VEYX, VEYY, VEYZ, VEZX, VEZY, VEZZ, |
& VIXX, VIXY, VIXZ, VIYX, VIYY, VIYZ, VIZX, VIZY, VIZZ, |
& PEXX, PEXY, PEXZ, PEYX, PEYY, PEYZ, PEZX, PEZY, PEZZ, |
& PIXX, PIXY, PIXZ, PIYX, PIYY, PIYZ, PIZX, PIZY, PIZZ |
PARAMETER ( VEXX = 1, VEXY = 2, VEXZ = 3, VEYX = 4, |
& VEYY = 5, VEYZ = 6, VEZX = 7, VEZY = 8, |
& VEZZ = 9, |
& VIXX = 10, VIXY = 11, VIXZ = 12, VIYX = 13, |
& VIYY = 14, VIYZ = 15, VIZX = 16, VIZY = 17, |
& VIZZ = 18, |
& PEXX = 19, PEXY = 20, PEXZ = 21, PEYX = 22, |
& PEYY = 23, PEYZ = 24, PEZX = 25, PEZY = 26, |
& PEZZ = 27, |
& PIXX = 28, PIXY = 29, PIXZ = 30, PIYX = 31, |
& PIYY = 32, PIYZ = 33, PIZX = 34, PIZY = 35, |
& PIZZ = 36) |
CHARACTER*4 CEPROP, CETERM, CEPRSS |
COMMON /ANER/ CEPROP(LENENP), CETERM(LENENT), CEPRSS(LENENV) |
LOGICAL QEPROP, QETERM, QEPRSS |
COMMON /QENER/ QEPROP(LENENP), QETERM(LENENT), QEPRSS(LENENV) |
REAL(KIND=8) EPROP, ETERM, EPRESS |
COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV) |
C..##IF SAVEFCM |
C..##ENDIF |
REAL(KIND=8) EPRPA, EPRP2A, EPRPP, EPRP2P, |
& ETRMA, ETRM2A, ETRMP, ETRM2P, |
& EPRSA, EPRS2A, EPRSP, EPRS2P |
COMMON /ENACCM/ EPRPA(LENENP), ETRMA(LENENT), EPRSA(LENENV), |
& EPRP2A(LENENP),ETRM2A(LENENT),EPRS2A(LENENV), |
& EPRPP(LENENP), ETRMP(LENENT), EPRSP(LENENV), |
& EPRP2P(LENENP),ETRM2P(LENENT),EPRS2P(LENENV) |
C..##IF SAVEFCM |
C..##ENDIF |
INTEGER ECALLS, TOT1ST, TOT2ND |
COMMON /EMISCI/ ECALLS, TOT1ST, TOT2ND |
REAL(KIND=8) EOLD, FITA, DRIFTA, EAT0A, CORRA, FITP, DRIFTP, |
& EAT0P, CORRP |
COMMON /EMISCR/ EOLD, FITA, DRIFTA, EAT0A, CORRA, |
& FITP, DRIFTP, EAT0P, CORRP |
C..##IF SAVEFCM |
C..##ENDIF |
C..##IF ACE |
C..##ENDIF |
C..##IF FLUCQ |
C..##ENDIF |
C..##IF ADUMB |
C..##ENDIF |
C..##IF GRID |
C..##ENDIF |
C..##IF FLUCQ |
C..##ENDIF |
C..##IF TSM |
REAL(KIND=8) TSMTRM(LENENT),TSMTMP(LENENT) |
COMMON /TSMENG/ TSMTRM,TSMTMP |
C...##IF SAVEFCM |
C...##ENDIF |
C..##ENDIF |
REAL(KIND=8) EHQBM |
LOGICAL HQBM |
COMMON /HQBMVAR/HQBM |
C..##IF SAVEFCM |
C..##ENDIF |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/dimb.fcm' |
C..##IF DIMB (dimbfcm) |
INTEGER NPARMX,MNBCMP,LENDSK |
PARAMETER (NPARMX=1000,MNBCMP=300,LENDSK=200000) |
INTEGER IJXXCM,IJXYCM,IJXZCM,IJYXCM,IJYYCM |
INTEGER IJYZCM,IJZXCM,IJZYCM,IJZZCM |
INTEGER IIXXCM,IIXYCM,IIXZCM,IIYYCM |
INTEGER IIYZCM,IIZZCM |
INTEGER JJXXCM,JJXYCM,JJXZCM,JJYYCM |
INTEGER JJYZCM,JJZZCM |
PARAMETER (IJXXCM=1,IJXYCM=2,IJXZCM=3,IJYXCM=4,IJYYCM=5) |
PARAMETER (IJYZCM=6,IJZXCM=7,IJZYCM=8,IJZZCM=9) |
PARAMETER (IIXXCM=1,IIXYCM=2,IIXZCM=3,IIYYCM=4) |
PARAMETER (IIYZCM=5,IIZZCM=6) |
PARAMETER (JJXXCM=1,JJXYCM=2,JJXZCM=3,JJYYCM=4) |
PARAMETER (JJYZCM=5,JJZZCM=6) |
INTEGER ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,PDD1CM,LENCMP |
LOGICAL QDISK,QDW,QCMPCT |
COMMON /DIMBI/ ITER,IPAR1,IPAR2,NFSAV,PINBCM,PJNBCM,LENCMP |
COMMON /DIMBL/ QDISK,QDW,QCMPCT |
C...##IF SAVEFCM |
C...##ENDIF |
C..##ENDIF (dimbfcm) |
C----------------------------------------------------------------------- |
C----------------------------------------------------------------------- |
C:::##INCLUDE '~/charmm_fcm/ctitla.fcm' |
INTEGER MAXTIT |
PARAMETER (MAXTIT=32) |
INTEGER NTITLA,NTITLB |
CHARACTER*80 TITLEA,TITLEB |
COMMON /NTITLA/ NTITLA,NTITLB |
COMMON /CTITLA/ TITLEA(MAXTIT),TITLEB(MAXTIT) |
C..##IF SAVEFCM |
C..##ENDIF |
C----------------------------------------------------------------------- |
C Passed variables |
INTEGER NAT3,NADD,NPAR,NFREG,NFRET,BLATOM |
INTEGER ATMPAR(2,*),ATMPAS(2,*),ATMPAD(2,*) |
INTEGER BNBND(*),BIMAG(*) |
INTEGER INBCMP(*),JNBCMP(*),PARDIM |
INTEGER ITMX,IUNMOD,IUNRMD,SAVF |
INTEGER NBOND,IB(*),JB(*) |
REAL(KIND=8) X(*),Y(*),Z(*),AMASS(*),DDSCR(*) |
REAL(KIND=8) DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*) |
REAL(KIND=8) DDF(*),PARDDF(*),DDEV(*),PARDDE(*) |
REAL(KIND=8) DD1BLK(*),DD1BLL(*),DD1CMP(*) |
REAL(KIND=8) TOLDIM,DDVALM |
REAL(KIND=8) PARFRQ,CUTF1 |
LOGICAL LNOMA,LRAISE,LSCI,LBIG |
C Local variables |
INTEGER NATOM,NATP,NDIM,I,J,II,OLDFAS,OLDPRN,IUPD |
INTEGER NPARC,NPARD,NPARS,NFCUT1,NFREG2,NFREG6 |
INTEGER IH1,IH2,IH3,IH4,IH5,IH6,IH7,IH8 |
INTEGER IS1,IS2,IS3,IS4,JSPACE,JSP,DDSS,DD5 |
INTEGER ISTRT,ISTOP,IPA1,IPA2,IRESF |
INTEGER ATMPAF,INIDS,TRAROT |
INTEGER SUBLIS,ATMCOR |
INTEGER NFRRES,DDVBAS |
INTEGER DDV2,DDVAL |
INTEGER LENCM,NTR,NFRE,NFC,N1,N2,NFCUT,NSUBP |
INTEGER SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6 |
INTEGER DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ |
INTEGER I620,I640,I660,I700,I720,I760,I800,I840,I880,I920 |
REAL(KIND=8) CVGMX,TOLER |
LOGICAL LCARD,LAPPE,LPURG,LWDINI,QCALC,QMASWT,QMIX,QDIAG |
C Begin |
QCALC=.TRUE. |
LWDINI=.FALSE. |
INIDS=0 |
IS3=0 |
IS4=0 |
LPURG=.TRUE. |
ITER=0 |
NADD=0 |
NFSAV=0 |
TOLER=TENM5 |
QDIAG=.TRUE. |
CVGMX=HUNDRD |
QMIX=.FALSE. |
NATOM=NAT3/3 |
NFREG6=(NFREG-6)/NPAR |
NFREG2=NFREG/2 |
NFRRES=(NFREG+6)/2 |
IF(NFREG.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>', |
1 'NFREG IS LARGER THAN PARDIM*3') |
C |
C ALLOCATE-SPACE-FOR-TRANSROT-VECTORS |
ASSIGN 801 TO I800 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 800 |
801 CONTINUE |
C ALLOCATE-SPACE-FOR-DIAGONALIZATION |
ASSIGN 721 TO I720 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 720 |
721 CONTINUE |
C ALLOCATE-SPACE-FOR-REDUCED-BASIS |
ASSIGN 761 TO I760 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 760 |
761 CONTINUE |
C ALLOCATE-SPACE-FOR-OTHER-ARRAYS |
ASSIGN 921 TO I920 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 920 |
921 CONTINUE |
C |
C Space allocation for working arrays of EISPACK |
C diagonalization subroutines |
IF(LSCI) THEN |
C ALLOCATE-SPACE-FOR-LSCI |
ASSIGN 841 TO I840 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 840 |
841 CONTINUE |
ELSE |
C ALLOCATE-DUMMY-SPACE-FOR-LSCI |
ASSIGN 881 TO I880 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 880 |
881 CONTINUE |
ENDIF |
QMASWT=(.NOT.LNOMA) |
IF(.NOT. QDISK) THEN |
LENCM=INBCMP(NATOM-1)*9+NATOM*6 |
DO I=1,LENCM |
DD1CMP(I)=0.0 |
ENDDO |
OLDFAS=LFAST |
QCMPCT=.TRUE. |
LFAST = -1 |
CALL ENERGY(X,Y,Z,DX,DY,DZ,BNBND,BIMAG,NAT3,DD1CMP,.TRUE.,1) |
LFAST=OLDFAS |
QCMPCT=.FALSE. |
C |
C Mass weight DD1CMP matrix |
C |
CALL MASSDD(DD1CMP,DDM,INBCMP,JNBCMP,NATOM) |
ELSE |
CALL WRNDIE(-3,'<NMDIMB>','QDISK OPTION NOT SUPPORTED YET') |
C DO I=1,LENDSK |
C DD1CMP(I)=0.0 |
C ENDDO |
C OLDFAS=LFAST |
C LFAST = -1 |
ENDIF |
C |
C Fill DDV with six translation-rotation vectors |
C |
CALL TRROT(X,Y,Z,DDV,NAT3,1,DDM) |
CALL CPARAY(HEAP(TRAROT),DDV,NAT3,1,6,1) |
NTR=6 |
OLDPRN=PRNLEV |
PRNLEV=1 |
CALL ORTHNM(1,6,NTR,HEAP(TRAROT),NAT3,.FALSE.,TOLER) |
PRNLEV=OLDPRN |
IF(IUNRMD .LT. 0) THEN |
C |
C If no previous basis is read |
C |
IF(PRNLEV.GE.2) WRITE(OUTU,502) NPAR |
502 FORMAT(/' NMDIMB: Calculating initial basis from block ', |
1 'diagonals'/' NMDIMB: The number of blocks is ',I5/) |
NFRET = 6 |
DO I=1,NPAR |
IS1=ATMPAR(1,I) |
IS2=ATMPAR(2,I) |
NDIM=(IS2-IS1+1)*3 |
NFRE=NDIM |
IF(NFRE.GT.NFREG6) NFRE=NFREG6 |
IF(NFREG6.EQ.0) NFRE=1 |
CALL FILUPT(HEAP(IUPD),NDIM) |
CALL MAKDDU(DD1BLK,DD1CMP,INBCMP,JNBCMP,HEAP(IUPD), |
1 IS1,IS2,NATOM) |
IF(PRNLEV.GE.9) CALL PRINTE(OUTU,EPROP,ETERM,'VIBR', |
1 'ENR',.TRUE.,1,ZERO,ZERO) |
C |
C Generate the lower section of the matrix and diagonalize |
C |
C..##IF EISPACK |
C..##ENDIF |
IH1=1 |
NATP=NDIM+1 |
IH2=IH1+NATP |
IH3=IH2+NATP |
IH4=IH3+NATP |
IH5=IH4+NATP |
IH6=IH5+NATP |
IH7=IH6+NATP |
IH8=IH7+NATP |
CALL DIAGQ(NDIM,NFRE,DD1BLK,PARDDV,DDS(IH2),DDS(IH3), |
1 DDS(IH4),DDS(IH5),DDS,DDS(IH6),DDS(IH7),DDS(IH8),NADD) |
C..##IF EISPACK |
C..##ENDIF |
C |
C Put the PARDDV vectors into DDV and replace the elements which do |
C not belong to the considered partitioned region by zeros. |
C |
CALL ADJNME(DDV,PARDDV,NAT3,NDIM,NFRE,NFRET,IS1,IS2) |
IF(LSCI) THEN |
DO J=1,NFRE |
PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J))) |
IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J) |
ENDDO |
ELSE |
DO J=1,NFRE |
PARDDE(J)=DDS(J) |
PARDDF(J)=CNVFRQ*SQRT(ABS(PARDDE(J))) |
IF(PARDDE(J) .LT. 0.0) PARDDF(J)=-PARDDF(J) |
ENDDO |
ENDIF |
IF(PRNLEV.GE.2) THEN |
WRITE(OUTU,512) I |
WRITE(OUTU,514) |
WRITE(OUTU,516) (J,PARDDF(J),J=1,NFRE) |
ENDIF |
NFRET=NFRET+NFRE |
IF(NFRET .GE. NFREG) GOTO 10 |
ENDDO |
512 FORMAT(/' NMDIMB: Diagonalization of part',I5,' completed') |
514 FORMAT(' NMDIMB: Frequencies'/) |
516 FORMAT(5(I4,F12.6)) |
10 CONTINUE |
C |
C Orthonormalize the eigenvectors |
C |
OLDPRN=PRNLEV |
PRNLEV=1 |
CALL ORTHNM(1,NFRET,NFRET,DDV,NAT3,LPURG,TOLER) |
PRNLEV=OLDPRN |
C |
C Do reduced basis diagonalization using the DDV vectors |
C and get eigenvectors of zero iteration |
C |
IF(PRNLEV.GE.2) THEN |
WRITE(OUTU,521) ITER |
WRITE(OUTU,523) NFRET |
ENDIF |
521 FORMAT(/' NMDIMB: Iteration number = ',I5) |
523 FORMAT(' NMDIMB: Dimension of the reduced basis set = ',I5) |
IF(LBIG) THEN |
IF(PRNLEV.GE.2) WRITE(OUTU,585) NFRET,IUNMOD |
525 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5) |
REWIND (UNIT=IUNMOD) |
LCARD=.FALSE. |
CALL WRTNMD(LCARD,1,NFRET,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS) |
CALL SAVEIT(IUNMOD) |
ELSE |
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFRET,1) |
ENDIF |
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, |
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, |
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4, |
3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), |
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), |
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), |
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) |
C |
C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS |
C |
ASSIGN 621 TO I620 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 620 |
621 CONTINUE |
C SAVE-MODES |
ASSIGN 701 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 700 |
701 CONTINUE |
IF(ITER.EQ.ITMX) THEN |
CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS, |
1 DDVAL,JSPACE,TRAROT, |
2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6, |
3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF, |
4 ATMCOR,SUBLIS,LSCI,QDW,LBIG) |
RETURN |
ENDIF |
ELSE |
C |
C Read in existing basis |
C |
IF(PRNLEV.GE.2) THEN |
WRITE(OUTU,531) |
531 FORMAT(/' NMDIMB: Calculations restarted') |
ENDIF |
C READ-MODES |
ISTRT=1 |
ISTOP=99999999 |
LCARD=.FALSE. |
LAPPE=.FALSE. |
CALL RDNMD(LCARD,NFRET,NFREG,NAT3,NDIM, |
1 DDV,DDSCR,DDF,DDEV, |
2 IUNRMD,LAPPE,ISTRT,ISTOP) |
NFRET=NDIM |
IF(NFRET.GT.NFREG) THEN |
NFRET=NFREG |
CALL WRNDIE(-1,'<NMDIMB>', |
1 'Not enough space to hold the basis. Increase NMODes') |
ENDIF |
C PRINT-MODES |
IF(PRNLEV.GE.2) THEN |
WRITE(OUTU,533) NFRET,IUNRMD |
WRITE(OUTU,514) |
WRITE(OUTU,516) (J,DDF(J),J=1,NFRET) |
ENDIF |
533 FORMAT(/' NMDIMB: ',I5,' restart modes read from unit ',I5) |
NFRRES=NFRET |
ENDIF |
C |
C ------------------------------------------------- |
C Here starts the mixed-basis diagonalization part. |
C ------------------------------------------------- |
C |
C |
C Check cut-off frequency |
C |
CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) |
C TEST-NFCUT1 |
IF(IUNRMD.LT.0) THEN |
IF(NFCUT1*2-6.GT.NFREG) THEN |
IF(PRNLEV.GE.2) WRITE(OUTU,537) DDF(NFRRES) |
NFCUT1=NFRRES |
CUTF1=DDF(NFRRES) |
ENDIF |
ELSE |
CUTF1=DDF(NFRRES) |
ENDIF |
537 FORMAT(/' NMDIMB: Too many vectors for the given cutoff frequency' |
1 /' Cutoff frequency is decreased to',F9.3) |
C |
C Compute the new partioning of the molecule |
C |
CALL PARTIC(NAT3,NFREG,NFCUT1,NPARMX,NPARC,ATMPAR,NFRRES, |
1 PARDIM) |
NPARS=NPARC |
DO I=1,NPARC |
ATMPAS(1,I)=ATMPAR(1,I) |
ATMPAS(2,I)=ATMPAR(2,I) |
ENDDO |
IF(QDW) THEN |
IF(IPAR1.EQ.0.OR.IPAR2.EQ.0) LWDINI=.TRUE. |
IF(IPAR1.GE.IPAR2) LWDINI=.TRUE. |
IF(IABS(IPAR1).GT.NPARC*2) LWDINI=.TRUE. |
IF(IABS(IPAR2).GT.NPARC*2) LWDINI=.TRUE. |
IF(ITER.EQ.0) LWDINI=.TRUE. |
ENDIF |
ITMX=ITMX+ITER |
IF(PRNLEV.GE.2) THEN |
WRITE(OUTU,543) ITER,ITMX |
IF(QDW) WRITE(OUTU,545) IPAR1,IPAR2 |
ENDIF |
543 FORMAT(/' NMDIMB: Previous iteration number = ',I8/ |
1 ' NMDIMB: Iteration number to reach = ',I8) |
545 FORMAT(' NMDIMB: Previous sub-blocks = ',I5,2X,I5) |
C |
IF(SAVF.LE.0) SAVF=NPARC |
IF(PRNLEV.GE.2) WRITE(OUTU,547) SAVF |
547 FORMAT(' NMDIMB: Eigenvectors will be saved every',I5, |
1 ' iterations') |
C |
C If double windowing is defined, the original block sizes are divided |
C in two. |
C |
IF(QDW) THEN |
NSUBP=1 |
CALL PARTID(NPARC,ATMPAR,NPARD,ATMPAD,NPARMX) |
ATMPAF=ALLHP(INTEG4(NPARD*NPARD)) |
ATMCOR=ALLHP(INTEG4(NATOM)) |
DDVAL=ALLHP(IREAL8(NPARD*NPARD)) |
CALL CORARR(ATMPAD,NPARD,HEAP(ATMCOR),NATOM) |
CALL PARLIS(HEAP(ATMCOR),HEAP(ATMPAF),INBCMP,JNBCMP,NPARD, |
2 NSUBP,NATOM,X,Y,Z,NBOND,IB,JB,DD1CMP,HEAP(DDVAL),DDVALM) |
SUBLIS=ALLHP(INTEG4(NSUBP*2)) |
CALL PARINT(HEAP(ATMPAF),NPARD,HEAP(SUBLIS),NSUBP) |
CALL INIPAF(HEAP(ATMPAF),NPARD) |
C |
C Find out with which block to continue (double window method only) |
C |
IPA1=IPAR1 |
IPA2=IPAR2 |
IRESF=0 |
IF(LWDINI) THEN |
ITER=0 |
LWDINI=.FALSE. |
GOTO 500 |
ENDIF |
DO II=1,NSUBP |
CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF), |
1 NPARD,QCALC) |
IF((IPAR1.EQ.IPA1).AND.(IPAR2.EQ.IPA2)) GOTO 500 |
ENDDO |
ENDIF |
500 CONTINUE |
C |
C Main loop. |
C |
DO WHILE((CVGMX.GT.TOLDIM).AND.(ITER.LT.ITMX)) |
IF(.NOT.QDW) THEN |
ITER=ITER+1 |
IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER |
553 FORMAT(/' NMDIMB: Iteration number = ',I8) |
IF(INIDS.EQ.0) THEN |
INIDS=1 |
ELSE |
INIDS=0 |
ENDIF |
CALL PARTDS(NAT3,NPARC,ATMPAR,NPARS,ATMPAS,INIDS,NPARMX, |
1 DDF,NFREG,CUTF1,PARDIM,NFCUT1) |
C DO-THE-DIAGONALISATIONS |
ASSIGN 641 to I640 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 640 |
641 CONTINUE |
QDIAG=.FALSE. |
C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS |
ASSIGN 622 TO I620 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 620 |
622 CONTINUE |
QDIAG=.TRUE. |
C SAVE-MODES |
ASSIGN 702 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 700 |
702 CONTINUE |
C |
ELSE |
DO II=1,NSUBP |
CALL IPART(HEAP(SUBLIS),II,IPAR1,IPAR2,HEAP(ATMPAF), |
1 NPARD,QCALC) |
IF(QCALC) THEN |
IRESF=IRESF+1 |
ITER=ITER+1 |
IF(PRNLEV.GE.2) WRITE(OUTU,553) ITER |
C DO-THE-DWIN-DIAGONALISATIONS |
ASSIGN 661 TO I660 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 660 |
661 CONTINUE |
ENDIF |
IF((IRESF.EQ.SAVF).OR.(ITER.EQ.ITMX)) THEN |
IRESF=0 |
QDIAG=.FALSE. |
C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS |
ASSIGN 623 TO I620 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 620 |
623 CONTINUE |
QDIAG=.TRUE. |
IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600 |
C SAVE-MODES |
ASSIGN 703 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 700 |
703 CONTINUE |
ENDIF |
ENDDO |
ENDIF |
ENDDO |
600 CONTINUE |
C |
C SAVE-MODES |
ASSIGN 704 TO I700 ! { dg-warning "Obsolete: ASSIGN" "Obsolete: ASSIGN" } |
GOTO 700 |
704 CONTINUE |
CALL CLEANHP(NAT3,NFREG,NPARD,NSUBP,PARDIM,DDV2,DDSS,DDVBAS, |
1 DDVAL,JSPACE,TRAROT, |
2 SCIFV1,SCIFV2,SCIFV3,SCIFV4,SCIFV6, |
3 DRATQ,ERATQ,E2RATQ,BDRATQ,INRATQ,IUPD,ATMPAF, |
4 ATMCOR,SUBLIS,LSCI,QDW,LBIG) |
RETURN |
C----------------------------------------------------------------------- |
C INTERNAL PROCEDURES |
C----------------------------------------------------------------------- |
C TO DO-THE-DIAGONALISATIONS-WITH-RESIDUALS |
620 CONTINUE |
IF(IUNRMD.LT.0) THEN |
CALL SELNMD(DDF,NFRET,CUTF1,NFC) |
N1=NFCUT1 |
N2=(NFRET+6)/2 |
NFCUT=MAX(N1,N2) |
IF(NFCUT*2-6 .GT. NFREG) THEN |
NFCUT=(NFREG+6)/2 |
CUTF1=DDF(NFCUT) |
IF(PRNLEV.GE.2) THEN |
WRITE(OUTU,562) ITER |
WRITE(OUTU,564) CUTF1 |
ENDIF |
ENDIF |
ELSE |
NFCUT=NFRET |
NFC=NFRET |
ENDIF |
562 FORMAT(/' NMDIMB: Not enough space to hold the residual vectors'/ |
1 ' into DDV array during iteration ',I5) |
564 FORMAT(' Cutoff frequency is changed to ',F9.3) |
C |
C do reduced diagonalization with preceding eigenvectors plus |
C residual vectors |
C |
ISTRT=1 |
ISTOP=NFCUT |
CALL CLETR(DDV,HEAP(TRAROT),NAT3,ISTRT,ISTOP,NFCUT,DDEV,DDF) |
CALL RNMTST(DDV,HEAP(DDVBAS),NAT3,DDSCR,DD1CMP,INBCMP,JNBCMP, |
2 7,NFCUT,CVGMX,NFCUT,NFC,QDIAG,LBIG,IUNMOD) |
NFSAV=NFCUT |
IF(QDIAG) THEN |
NFRET=NFCUT*2-6 |
IF(PRNLEV.GE.2) WRITE(OUTU,566) NFRET |
566 FORMAT(/' NMDIMB: Diagonalization with residual vectors. '/ |
1 ' Dimension of the reduced basis set'/ |
2 ' before orthonormalization = ',I5) |
NFCUT=NFRET |
OLDPRN=PRNLEV |
PRNLEV=1 |
CALL ORTHNM(1,NFRET,NFCUT,DDV,NAT3,LPURG,TOLER) |
PRNLEV=OLDPRN |
NFRET=NFCUT |
IF(PRNLEV.GE.2) WRITE(OUTU,568) NFRET |
568 FORMAT(' after orthonormalization = ',I5) |
IF(LBIG) THEN |
IF(PRNLEV.GE.2) WRITE(OUTU,570) NFCUT,IUNMOD |
570 FORMAT(' NMDIMB: ',I5,' basis vectors are saved in unit',I5) |
REWIND (UNIT=IUNMOD) |
LCARD=.FALSE. |
CALL WRTNMD(LCARD,1,NFCUT,NAT3,DDV,DDSCR,DDEV,IUNMOD,AMASS) |
CALL SAVEIT(IUNMOD) |
ELSE |
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) |
ENDIF |
QMIX=.FALSE. |
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, |
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, |
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,0,0,IS3,IS4, |
3 CUTF1,NFCUT1,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), |
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), |
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), |
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) |
CALL SELNMD(DDF,NFRET,CUTF1,NFCUT1) |
ENDIF |
GOTO I620 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO DO-THE-DIAGONALISATIONS |
640 CONTINUE |
DO I=1,NPARC |
NFCUT1=NFRRES |
IS1=ATMPAR(1,I) |
IS2=ATMPAR(2,I) |
NDIM=(IS2-IS1+1)*3 |
IF(PRNLEV.GE.2) WRITE(OUTU,573) I,IS1,IS2 |
573 FORMAT(/' NMDIMB: Mixed diagonalization, part ',I5/ |
1 ' NMDIMB: Block limits: ',I5,2X,I5) |
IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>', |
1 'Error in dimension of block') |
NFRET=NFCUT1 |
IF(NFRET.GT.NFREG) NFRET=NFREG |
CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF) |
NFCUT1=NFCUT |
CALL ADZER(DDV,1,NFCUT1,NAT3,IS1,IS2) |
NFSAV=NFCUT1 |
OLDPRN=PRNLEV |
PRNLEV=1 |
CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) |
PRNLEV=OLDPRN |
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) |
NFRET=NDIM+NFCUT |
QMIX=.TRUE. |
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, |
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, |
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4, |
3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), |
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), |
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), |
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) |
QMIX=.FALSE. |
IF(NFCUT.GT.NFRRES) NFCUT=NFRRES |
NFCUT1=NFCUT |
NFRET=NFCUT |
ENDDO |
GOTO I640 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO DO-THE-DWIN-DIAGONALISATIONS |
660 CONTINUE |
C |
C Store the DDV vectors into DDVBAS |
C |
NFCUT1=NFRRES |
IS1=ATMPAD(1,IPAR1) |
IS2=ATMPAD(2,IPAR1) |
IS3=ATMPAD(1,IPAR2) |
IS4=ATMPAD(2,IPAR2) |
NDIM=(IS2-IS1+IS4-IS3+2)*3 |
IF(PRNLEV.GE.2) WRITE(OUTU,577) IPAR1,IPAR2,IS1,IS2,IS3,IS4 |
577 FORMAT(/' NMDIMB: Mixed double window diagonalization, parts ', |
1 2I5/ |
2 ' NMDIMB: Block limits: ',I5,2X,I5,4X,I5,2X,I5) |
IF(NDIM+NFCUT1.GT.PARDIM) CALL WRNDIE(-3,'<NMDIMB>', |
1 'Error in dimension of block') |
NFRET=NFCUT1 |
IF(NFRET.GT.NFREG) NFRET=NFREG |
C |
C Prepare the DDV vectors consisting of 6 translations-rotations |
C + eigenvectors from 7 to NFCUT1 + cartesian displacements vectors |
C spanning the atoms from IS1 to IS2 |
C |
CALL CLETR(DDV,HEAP(TRAROT),NAT3,1,NFCUT1,NFCUT,DDEV,DDF) |
NFCUT1=NFCUT |
NFSAV=NFCUT1 |
CALL ADZERD(DDV,1,NFCUT1,NAT3,IS1,IS2,IS3,IS4) |
OLDPRN=PRNLEV |
PRNLEV=1 |
CALL ORTHNM(1,NFCUT1,NFCUT,DDV,NAT3,LPURG,TOLER) |
PRNLEV=OLDPRN |
CALL CPARAY(HEAP(DDVBAS),DDV,NAT3,1,NFCUT,1) |
C |
NFRET=NDIM+NFCUT |
QMIX=.TRUE. |
CALL RBDG(X,Y,Z,NAT3,NDIM,NFRET,DDV,DDF,DDEV, |
1 DDSCR,HEAP(DD5),HEAP(DDSS),HEAP(DDV2),NADD, |
2 INBCMP,JNBCMP,HEAP(DDVBAS),DD1CMP,QMIX,IS1,IS2,IS3,IS4, |
3 CUTF1,NFCUT,NFREG,HEAP(IUPD),DD1BLL,HEAP(SCIFV1), |
4 HEAP(SCIFV2),HEAP(SCIFV3),HEAP(SCIFV4),HEAP(SCIFV6), |
5 HEAP(DRATQ),HEAP(ERATQ),HEAP(E2RATQ), |
6 HEAP(BDRATQ),HEAP(INRATQ),LSCI,LBIG,IUNMOD) |
QMIX=.FALSE. |
C |
IF(NFCUT.GT.NFRRES) NFCUT=NFRRES |
NFCUT1=NFCUT |
NFRET=NFCUT |
GOTO I660 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO SAVE-MODES |
700 CONTINUE |
IF(PRNLEV.GE.2) WRITE(OUTU,583) IUNMOD |
583 FORMAT(/' NMDIMB: Saving the eigenvalues and eigenvectors to unit' |
1 ,I4) |
REWIND (UNIT=IUNMOD) |
ISTRT=1 |
ISTOP=NFSAV |
LCARD=.FALSE. |
IF(PRNLEV.GE.2) WRITE(OUTU,585) NFSAV,IUNMOD |
585 FORMAT(' NMDIMB: ',I5,' modes are saved in unit',I5) |
CALL WRTNMD(LCARD,ISTRT,ISTOP,NAT3,DDV,DDSCR,DDEV,IUNMOD, |
1 AMASS) |
CALL SAVEIT(IUNMOD) |
GOTO I700 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO ALLOCATE-SPACE-FOR-DIAGONALIZATION |
720 CONTINUE |
DDV2=ALLHP(IREAL8((PARDIM+3)*(PARDIM+3))) |
JSPACE=IREAL8((PARDIM+4))*8 |
JSP=IREAL8(((PARDIM+3)*(PARDIM+4))/2) |
JSPACE=JSPACE+JSP |
DDSS=ALLHP(JSPACE) |
DD5=DDSS+JSPACE-JSP |
GOTO I720 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO ALLOCATE-SPACE-FOR-REDUCED-BASIS |
760 CONTINUE |
IF(LBIG) THEN |
DDVBAS=ALLHP(IREAL8(NAT3)) |
ELSE |
DDVBAS=ALLHP(IREAL8(NFREG*NAT3)) |
ENDIF |
GOTO I760 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS |
800 CONTINUE |
TRAROT=ALLHP(IREAL8(6*NAT3)) |
GOTO I800 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO ALLOCATE-SPACE-FOR-LSCI |
840 CONTINUE |
SCIFV1=ALLHP(IREAL8(PARDIM+3)) |
SCIFV2=ALLHP(IREAL8(PARDIM+3)) |
SCIFV3=ALLHP(IREAL8(PARDIM+3)) |
SCIFV4=ALLHP(IREAL8(PARDIM+3)) |
SCIFV6=ALLHP(IREAL8(PARDIM+3)) |
DRATQ=ALLHP(IREAL8(PARDIM+3)) |
ERATQ=ALLHP(IREAL8(PARDIM+3)) |
E2RATQ=ALLHP(IREAL8(PARDIM+3)) |
BDRATQ=ALLHP(IREAL8(PARDIM+3)) |
INRATQ=ALLHP(INTEG4(PARDIM+3)) |
GOTO I840 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO ALLOCATE-DUMMY-SPACE-FOR-LSCI |
880 CONTINUE |
SCIFV1=ALLHP(IREAL8(2)) |
SCIFV2=ALLHP(IREAL8(2)) |
SCIFV3=ALLHP(IREAL8(2)) |
SCIFV4=ALLHP(IREAL8(2)) |
SCIFV6=ALLHP(IREAL8(2)) |
DRATQ=ALLHP(IREAL8(2)) |
ERATQ=ALLHP(IREAL8(2)) |
E2RATQ=ALLHP(IREAL8(2)) |
BDRATQ=ALLHP(IREAL8(2)) |
INRATQ=ALLHP(INTEG4(2)) |
GOTO I880 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C |
C----------------------------------------------------------------------- |
C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS |
920 CONTINUE |
IUPD=ALLHP(INTEG4(PARDIM+3)) |
GOTO I920 ! { dg-warning "Obsolete: Assigned" "Assigned GO TO" } |
C.##ELSE |
C.##ENDIF |
END |
/short.f
0,0 → 1,58
c { dg-do run } |
program short |
|
parameter ( N=2 ) |
common /chb/ pi,sig(0:N) |
common /parm/ h(2,2) |
|
c initialize some variables |
h(2,2) = 1117 |
h(2,1) = 1178 |
h(1,2) = 1568 |
h(1,1) = 1621 |
sig(0) = -1. |
sig(1) = 0. |
sig(2) = 1. |
|
call printout |
stop |
end |
|
c ****************************************************************** |
|
subroutine printout |
parameter ( N=2 ) |
common /chb/ pi,sig(0:N) |
common /parm/ h(2,2) |
dimension yzin1(0:N), yzin2(0:N) |
|
c function subprograms |
z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.) |
|
c a four-way average of rhobar |
do 260 k=0,N |
yzin1(k) = 0.25 * |
& ( z(2,2,k) + z(1,2,k) + |
& z(2,1,k) + z(1,1,k) ) |
260 continue |
|
c another four-way average of rhobar |
do 270 k=0,N |
rtmp1 = z(2,2,k) |
rtmp2 = z(1,2,k) |
rtmp3 = z(2,1,k) |
rtmp4 = z(1,1,k) |
yzin2(k) = 0.25 * |
& ( rtmp1 + rtmp2 + rtmp3 + rtmp4 ) |
270 continue |
|
do k=0,N |
if (yzin1(k) .ne. yzin2(k)) call abort |
enddo |
if (yzin1(0) .ne. -1371.) call abort |
if (yzin1(1) .ne. -685.5) call abort |
if (yzin1(2) .ne. 0.) call abort |
|
return |
end |
|
/980310-1.f
0,0 → 1,29
c { dg-do compile } |
C Causes internal compiler error on egcs 1.0.1 on i586-pc-sco3.2v5.0.4 |
C To: egcs-bugs@cygnus.com |
C Subject: backend case range problem/fix |
C From: Dave Love <d.love@dl.ac.uk> |
C Date: 02 Dec 1997 18:11:35 +0000 |
C Message-ID: <rzqpvnfboo8.fsf@djlvig.dl.ac.uk> |
C |
C The following Fortran test case aborts the compiler because |
C tree_int_cst_lt dereferences a null tree; this is a regression from |
C gcc 2.7. |
|
INTEGER N |
READ(*,*) N |
SELECT CASE (N) |
CASE (1:) |
WRITE(*,*) 'case 1' |
CASE (0) |
WRITE(*,*) 'case 0' |
END SELECT |
END |
|
C The relevant change to cure this is: |
C |
C Thu Dec 4 06:34:40 1997 Richard Kenner <kenner@vlsi1.ultra.nyu.edu> |
C |
C * stmt.c (pushcase_range): Clean up handling of "infinite" values. |
C |
|
/cpp2.F
0,0 → 1,8
c { dg-do compile } |
C The preprocessor must not introduce a newline after |
C the "a" when ARGUMENTS is expanded. |
|
#define ARGUMENTS a\ |
|
subroutine yada (ARGUMENTS) |
end |
/alpha1.f
0,0 → 1,27
c { dg-do compile } |
REAL(kind=8) A,B,C |
REAL(kind=4) RARRAY(19) |
DATA RARRAY /19*-1/ |
INTEGER BOTTOM,RIGHT |
INTEGER IARRAY(19) |
DATA IARRAY /0,0,0,0,0,0,0,0,0,0,0,0,13,14,0,0,0,0,0/ |
EQUIVALENCE (RARRAY(13),BOTTOM),(RARRAY(14),RIGHT) |
C |
IF(I.NE.0) call exit(1) |
C gcc: Internal compiler error: program f771 got fatal signal 11 |
C at this point! |
END |
|
! previously g77.ftorture/compile/alpha1.f with following alpha1.x |
! |
!# This test fails compilation in cross-endian environments, for example as |
!# below, with a "sorry" message. |
! |
!if { [ishost "i\[34567\]86-*-*"] } { |
! if { [istarget "mmix-knuth-mmixware"] |
! || [istarget "powerpc-*-*"] } { |
! set torture_compile_xfail [istarget] |
! } |
!} |
! |
!return 0 |
/990115-1.f
0,0 → 1,12
c { dg-do compile } |
C Derived from lapack |
SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK, |
$ WORK, RWORK, INFO ) |
COMPLEX(kind=8) WORK( * ) |
c Following declaration added on transfer to gfortran testsuite. |
c It is present in original lapack source |
integer rank |
DO 20 I = 1, RANK |
WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 ) |
20 CONTINUE |
END |
/funderscoring.f
0,0 → 1,8
C Test compiler flags: -funderscoring |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do compile } |
C { dg-options "-funderscoring" } |
call aaabbbccc |
end |
C { dg-final { scan-assembler "aaabbbccc_" } } |
/7388.f
0,0 → 1,12
C { dg-do run } |
C { dg-options "-fbounds-check" } |
character*25 buff(0:10) |
character*80 line |
integer i, m1, m2 |
i = 1 |
m1 = 1 |
m2 = 7 |
buff(i) = 'tcase0a' |
write(line,*) buff(i)(m1:m2) |
if (line .ne. ' tcase0a') call abort |
end |
/pr9258.f
0,0 → 1,18
C Test case for PR/9258 |
C Origin: kmccarty@princeton.edu |
C |
C { dg-do compile } |
SUBROUTINE FOO (B) |
|
10 CALL BAR (A) |
ASSIGN 20 TO M !{ dg-warning "Obsolete: ASSIGN" "" } |
IF (100.LT.A) GOTO 10 |
GOTO 40 |
C |
20 IF (B.LT.ABS(A)) GOTO 10 |
ASSIGN 30 TO M !{ dg-warning "Obsolete: ASSIGN" "" } |
GOTO 40 |
C |
30 ASSIGN 10 TO M !{ dg-warning "Obsolete: ASSIGN" "" } |
40 GOTO M,(10,20,30) !{ dg-warning "Obsolete: Assigned GOTO" "" } |
END |
/980616-0.f
0,0 → 1,10
c { dg-do compile } |
* Fixed by 1998-07-11 equiv.c change. |
* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER' |
|
* Date: Mon, 15 Jun 1998 21:54:32 -0500 |
* From: Ian A Watson <WATSON_IAN_A@lilly.com> |
* Subject: Mangler Crash |
EQUIVALENCE(I,glerf(P)) ! { dg-error "is a variable" "is a variable" } |
COMMON /foo/ glerf(3) |
c { dg-error "end of file" "end of file" { target *-*-* } 0 } |
/f77-edit-apostrophe-out.f
0,0 → 1,21
C Test Fortran 77 apostrophe edit descriptor |
C (ANSI X3.9-1978 Section 13.5.1) |
C |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do run } |
C { dg-output "^" } |
10 format('abcde') |
20 format('and an apostrophe -''-') |
30 format('''a leading apostrophe') |
40 format('a trailing apostrophe''') |
50 format('''and all of the above -''-''') |
|
write(*,10) ! { dg-output "abcde(\n|\r\n|\r)" } |
write(*,20) ! { dg-output "and an apostrophe -'-(\n|\r\n|\r)" } |
write(*,30) ! { dg-output "'a leading apostrophe(\n|\r\n|\r)" } |
write(*,40) ! { dg-output "a trailing apostrophe'(\n|\r\n|\r)" } |
write(*,50) ! { dg-output "'and all of the above -'-'(\n|\r\n|\r)" } |
|
C { dg-output "\$" } |
end |
/erfc.f
0,0 → 1,39
c { dg-do run } |
c============================================== test.f |
real x, y |
real(kind=8) x1, y1 |
x=0. |
y = erfc(x) |
if (y .ne. 1.) call abort |
|
x=1.1 |
y = erfc(x) |
if (abs(y - .1197949) .ge. 1.e-6) call abort |
|
c modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas. |
x=8 |
y = erfc(x) |
if (y .gt. 1.2e-28) call abort |
|
x1=0. |
y1 = erfc(x1) |
if (y1 .ne. 1.) call abort |
|
x1=1.1d0 |
y1 = erfc(x1) |
if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort |
|
x1=10 |
y1 = erfc(x1) |
if (y1 .gt. 1.5d-44) call abort |
end |
c================================================= |
!output: |
! 0. 1.875 |
! 1.10000002 1.48958981 |
! 10. 5.00220949E-06 |
! |
!The values should be: |
!erfc(0)=1 |
!erfc(1.1)= 0.1197949 |
!erfc(10)<1.543115467311259E-044 |
/f77-edit-i-out.f
0,0 → 1,26
C Test Fortran 77 I edit descriptor for output |
C (ANSI X3.9-1978 Section 13.5.9.1) |
C |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do run } |
C { dg-output "^" } |
|
write(*,'(I1)') 1 ! { dg-output "1(\n|\r\n|\r)" } |
write(*,'(I1)') -1 ! { dg-output "\\*(\n|\r\n|\r)" } |
write(*,'(I2)') 2 ! { dg-output " 2(\n|\r\n|\r)" } |
write(*,'(I2)') -2 ! { dg-output "-2(\n|\r\n|\r)" } |
write(*,'(I3)') 3 ! { dg-output " 3(\n|\r\n|\r)" } |
write(*,'(I3)') -3 ! { dg-output " -3(\n|\r\n|\r)" } |
|
write(*,'(I2.0)') 0 ! { dg-output " (\n|\r\n|\r)" } |
write(*,'(I1.1)') 4 ! { dg-output "4(\n|\r\n|\r)" } |
write(*,'(I1.1)') -4 ! { dg-output "\\*(\n|\r\n|\r)" } |
write(*,'(I2.1)') 5 ! { dg-output " 5(\n|\r\n|\r)" } |
write(*,'(I2.1)') -5 ! { dg-output "-5(\n|\r\n|\r)" } |
write(*,'(I2.2)') 6 ! { dg-output "06(\n|\r\n|\r)" } |
write(*,'(I2.2)') -6 ! { dg-output "\\*\\*(\n|\r\n|\r)" } |
write(*,'(I3.2)') 7 ! { dg-output " 07(\n|\r\n|\r)" } |
write(*,'(I3.2)') -7 ! { dg-output "-07(\n|\r\n|\r)" } |
|
end |
/19990313-3.f
0,0 → 1,8
c { dg-do run } |
integer(kind=8) foo, bar |
complex(kind=8) c |
data c/(4d10,0)/ |
foo = 4d10 |
bar = c |
if (foo .ne. bar) call abort |
end |
/19990218-0.f
0,0 → 1,14
c { dg-do compile } |
program test |
double precision a,b,c |
data a,b/1.0d-46,1.0d0/ |
c=fun(a,b) |
print*,'in main: fun=',c |
end |
double precision function fun(a,b) |
double precision a,b |
print*,'in sub: a,b=',a,b |
fun=a*b |
print*,'in sub: fun=',fun |
return |
end |
/20010321-1.f
0,0 → 1,9
c { dg-do compile } |
# 1 "20010321-1.f" |
SUBROUTINE TWOEXP |
# 1 "include/implicit.h" 1 3 |
IMPLICIT DOUBLE PRECISION (A-H) |
# 3 "20010321-1.f" 2 3 |
LOGICAL ANTI |
ANTI = .FALSE. |
END |
/19990419-0.f
0,0 → 1,8
c { dg-do compile } |
* Test case Toon submitted, cut down to expose the one bug. |
* Belongs in compile/. |
SUBROUTINE INIERS1 |
IMPLICIT LOGICAL(L) |
COMMON/COMIOD/ NHIERS1, LERS1 |
inquire(nhiers1, exist=lers1) |
END |
/20000601-1.f
0,0 → 1,29
c { dg-do compile } |
SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB ) |
|
* PR fortran/275 |
* ICE in `change_address', at emit-rtl.c:1589 with -O1 and above |
* g77 version 2.96 20000530 (experimental) on mips-sgi-irix6.5/-mabi=64 |
* |
* Originally derived from LAPACK 3.0 test suite failure. |
* |
* David Billinghurst, (David.Billinghurst@riotinto.com.au) |
* 1 June 2000 |
|
INTEGER KL, KU, LDAB, M |
REAL AB( LDAB, * ) |
|
INTEGER J, JB, JJ, JP, KV, KM |
REAL WORK13(65,64), WORK31(65,64) |
KV = KU + KL |
DO J = 1, M |
JB = MIN( 1, M-J+1 ) |
DO JJ = J, J + JB - 1 |
KM = MIN( KL, M-JJ ) |
JP = KM+1 |
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, |
$ AB( KV+JP+JJ-J, J ), LDAB-1 ) |
END DO |
END DO |
RETURN |
END |
/20010426.f
0,0 → 1,7
c { dg-do compile } |
function f(c) |
implicit none |
real(kind=8) c, f |
f = sqrt(c) |
return |
end |
/f90-intrinsic-numeric.f
0,0 → 1,283
c { dg-do run } |
c f90-intrinsic-numeric.f |
c |
c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13 |
c David Billinghurst <David.Billinghurst@riotinto.com> |
c |
c Notes: |
c * g77 does not fully comply with F90. Noncompliances noted in comments. |
c * Section 13.12: Specific names for intrinsic functions tested in |
c intrinsic77.f |
|
logical fail |
integer(kind=2) j, j2, ja |
integer(kind=1) k, k2, ka |
|
common /flags/ fail |
fail = .false. |
|
c ABS - Section 13.13.1 |
j = -9 |
ja = 9 |
k = j |
ka = ja |
call c_i(ABS(-7),7,'ABS(integer)') |
call c_i2(ABS(j),ja,'ABS(integer(2))') |
call c_i1(ABS(k),ka,'ABS(integer(1))') |
call c_r(ABS(-7.),7.,'ABS(real)') |
call c_d(ABS(-7.d0),7.d0,'ABS(double)') |
call c_r(ABS((3.,-4.)),5.0,'ABS(complex)') |
call c_d(ABS((3.d0,-4.d0)),5.0d0,'ABS(complex(kind=8))') |
|
c AIMAG - Section 13.13.6 |
call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)') |
c g77: AIMAG(complex(kind=8)) does not comply with F90 |
c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(complex(kind=8))') |
|
c AINT - Section 13.13.7 |
call c_r(AINT(2.783),2.0,'AINT(real) 1') |
call c_r(AINT(-2.783),-2.0,'AINT(real) 2') |
call c_d(AINT(2.783d0),2.0d0,'AINT(double precision) 1') |
call c_d(AINT(-2.783d0),-2.0d0,'AINT(double precision) 2') |
c Note: g77 does not support optional argument KIND |
|
c ANINT - Section 13.13.10 |
call c_r(ANINT(2.783),3.0,'ANINT(real) 1') |
call c_r(ANINT(-2.783),-3.0,'ANINT(real) 2') |
call c_d(ANINT(2.783d0),3.0d0,'ANINT(double precision) 1') |
call c_d(ANINT(-2.783d0),-3.0d0,'ANINT(double precision) 2') |
c Note: g77 does not support optional argument KIND |
|
c CEILING - Section 13.13.18 |
c Not implemented |
|
c CMPLX - Section 13.13.20 |
j = 1 |
ja = 2 |
k = 1 |
ka = 2 |
call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)') |
call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)') |
call c_c(CMPLX(j),(1.,0.),'CMPLX(integer(2))') |
call c_c(CMPLX(j,ja),(1.,2.),'CMPLX(integer(2), integer(2))') |
call c_c(CMPLX(k),(1.,0.),'CMPLX(integer(1)') |
call c_c(CMPLX(k,ka),(1.,2.),'CMPLX(integer(1), integer(1))') |
call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)') |
call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)') |
call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)') |
call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)') |
call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(complex(kind=8))') |
c NOTE: g77 does not support optional argument KIND |
|
c CONJG - Section 13.13.21 |
call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)') |
call c_z(CONJG((2.d0,-7.d0)),(2.d0,7.d0),'CONJG(complex(kind=8))') |
|
c DBLE - Section 13.13.27 |
j = 5 |
k = 5 |
call c_d(DBLE(5),5.0d0,'DBLE(integer)') |
call c_d(DBLE(j),5.0d0,'DBLE(integer(2))') |
call c_d(DBLE(k),5.0d0,'DBLE(integer(1))') |
call c_d(DBLE(5.),5.0d0,'DBLE(real)') |
call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)') |
call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)') |
call c_d(DBLE((5.0d0,0.5d0)),5.0d0,'DBLE(complex(kind=8))') |
|
c DIM - Section 13.13.29 |
j = -8 |
j2 = -3 |
ja = 0 |
k = -8 |
k2 = -3 |
ka = 0 |
call c_i(DIM(-8,-3),0,'DIM(integer)') |
call c_i2(DIM(j,j2),ja,'DIM(integer(2))') |
call c_i1(DIM(k,k2),ka,'DIM(integer(1)') |
call c_r(DIM(-8.,-3.),0.,'DIM(real,real)') |
call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)') |
|
c DPROD - Section 13.13.31 |
call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)') |
|
c FLOOR - Section 13.13.36 |
c Not implemented |
|
c INT - Section 13.13.47 |
j = 5 |
k = 5 |
call c_i(INT(5),5,'INT(integer)') |
call c_i(INT(j),5,'INT(integer(2))') |
call c_i(INT(k),5,'INT(integer(1))') |
call c_i(INT(5.01),5,'INT(real)') |
call c_i(INT(5.01d0),5,'INT(double)') |
c Note: Does not accept optional second argument KIND |
|
c MAX - Section 13.13.63 |
j = 1 |
j2 = 2 |
ja = 2 |
k = 1 |
k2 = 2 |
ka = 2 |
call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)') |
call c_i2(MAX(j,j2),ja,'MAX(integer(2),integer(2))') |
call c_i1(MAX(k,k2),ka,'MAX(integer(1),integer(1))') |
call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)') |
call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)') |
|
c MIN - Section 13.13.68 |
j = 1 |
j2 = 2 |
ja = 1 |
k = 1 |
k2 = 2 |
ka = 1 |
call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)') |
call c_i2(MIN(j,j2),ja,'MIN(integer(2),integer(2))') |
call c_i1(MIN(k,k2),ka,'MIN(integer(1),integer(1))') |
call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)') |
call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)') |
|
c MOD - Section 13.13.72 |
call c_i(MOD(8,5),3,'MOD(integer,integer) 1') |
call c_i(MOD(-8,5),-3,'MOD(integer,integer) 2') |
call c_i(MOD(8,-5),3,'MOD(integer,integer) 3') |
call c_i(MOD(-8,-5),-3,'MOD(integer,integer) 4') |
j = 8 |
j2 = 5 |
ja = 3 |
call c_i2(MOD(j,j2),ja,'MOD(integer(2),integer(2)) 1') |
call c_i2(MOD(-j,j2),-ja,'MOD(integer(2),integer(2)) 2') |
call c_i2(MOD(j,-j2),ja,'MOD(integer(2),integer(2)) 3') |
call c_i2(MOD(-j,-j2),-ja,'MOD(integer(2),integer(2)) 4') |
k = 8 |
k2 = 5 |
ka = 3 |
call c_i1(MOD(k,k2),ka,'MOD(integer(1),integer(1)) 1') |
call c_i1(MOD(-k,k2),-ka,'MOD(integer(1),integer(1)) 2') |
call c_i1(MOD(k,-k2),ka,'MOD(integer(1),integer(1)) 3') |
call c_i1(MOD(-k,-k2),-ka,'MOD(integer(1),integer(1)) 4') |
call c_r(MOD(8.,5.),3.,'MOD(real,real) 1') |
call c_r(MOD(-8.,5.),-3.,'MOD(real,real) 2') |
call c_r(MOD(8.,-5.),3.,'MOD(real,real) 3') |
call c_r(MOD(-8.,-5.),-3.,'MOD(real,real) 4') |
call c_d(MOD(8.d0,5.d0),3.d0,'MOD(double,double) 1') |
call c_d(MOD(-8.d0,5.d0),-3.d0,'MOD(double,double) 2') |
call c_d(MOD(8.d0,-5.d0),3.d0,'MOD(double,double) 3') |
call c_d(MOD(-8.d0,-5.d0),-3.d0,'MOD(double,double) 4') |
|
c MODULO - Section 13.13.73 |
c Not implemented |
|
c NINT - Section 13.13.76 |
call c_i(NINT(2.783),3,'NINT(real)') |
call c_i(NINT(2.783d0),3,'NINT(double)') |
c Optional second argument KIND not implemented |
|
c REAL - Section 13.13.86 |
j = -2 |
k = -2 |
call c_r(REAL(-2),-2.0,'REAL(integer)') |
call c_r(REAL(j),-2.0,'REAL(integer(2))') |
call c_r(REAL(k),-2.0,'REAL(integer(1))') |
call c_r(REAL(-2.0),-2.0,'REAL(real)') |
call c_r(REAL(-2.0d0),-2.0,'REAL(double)') |
call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)') |
c REAL(complex(kind=8)) not implemented |
c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(complex(kind=8))') |
|
c SIGN - Section 13.13.96 |
j = -3 |
j2 = 2 |
ja = 3 |
k = -3 |
k2 = 2 |
ka = 3 |
call c_i(SIGN(-3,2),3,'SIGN(integer)') |
call c_i2(SIGN(j,j2),ja,'SIGN(integer(2))') |
call c_i1(SIGN(k,k2),ka,'SIGN(integer(1))') |
call c_r(SIGN(-3.0,2.),3.,'SIGN(real,real)') |
call c_d(SIGN(-3.d0,2.d0),3.d0,'SIGN(double,double)') |
|
if ( fail ) call abort() |
end |
|
subroutine failure(label) |
c Report failure and set flag |
character*(*) label |
logical fail |
common /flags/ fail |
write(6,'(a,a,a)') 'Test ',label,' FAILED' |
fail = .true. |
end |
|
subroutine c_i(i,j,label) |
c Check if INTEGER i equals j, and fail otherwise |
integer i,j |
character*(*) label |
if ( i .ne. j ) then |
call failure(label) |
write(6,*) 'Got ',i,' expected ', j |
end if |
end |
|
subroutine c_i2(i,j,label) |
c Check if INTEGER(kind=2) i equals j, and fail otherwise |
integer(kind=2) i,j |
character*(*) label |
if ( i .ne. j ) then |
call failure(label) |
write(6,*) 'Got ',i,' expected ', j |
end if |
end |
|
subroutine c_i1(i,j,label) |
c Check if INTEGER(kind=1) i equals j, and fail otherwise |
integer(kind=1) i,j |
character*(*) label |
if ( i .ne. j ) then |
call failure(label) |
write(6,*) 'Got ',i,' expected ', j |
end if |
end |
|
subroutine c_r(a,b,label) |
c Check if REAL a equals b, and fail otherwise |
real a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0e-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_d(a,b,label) |
c Check if DOUBLE PRECISION a equals b, and fail otherwise |
double precision a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0d-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_c(a,b,label) |
c Check if COMPLEX a equals b, and fail otherwise |
complex a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0e-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_z(a,b,label) |
c Check if COMPLEX a equals b, and fail otherwise |
complex(kind=8) a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0d-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
/ffixed-line-length-72.f
0,0 → 1,7
C Test compiler flags: -ffixed-line-length-72 |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do compile } |
C { dg-options "-ffixed-line-length-72" } |
c2345678901234567890123456789012345678901234567890123456789012345678901234567890 |
en d* |
/980520-1.f
0,0 → 1,7
c { dg-do run } |
c Produced a link error through not eliminating the unused statement |
c function after 1998-05-15 change to gcc/toplev.c. It's in |
c `execute' since it needs to link. |
c Fixed by 1998-05-23 change to f/com.c. |
values(i,j) = val((i-1)*n+j) |
end |
/ffixed-form-2.f
0,0 → 1,12
! PR fortran/10843 |
! Origin: Brad Davis <bdavis9659@comcast.net> |
! |
! { dg-do compile } |
! { dg-options "-ffixed-form" } |
GO TO 3 |
GOTO 3 |
3 CONTINUE |
GOTO = 55 |
GO TO = 55 |
END |
|
/980424-0.f
0,0 → 1,7
c { dg-do compile } |
C crashes in subst_stack_regs_pat on x86-linux, in the "abort();" |
C within the switch statement. |
SUBROUTINE C(A) |
COMPLEX A |
WRITE(*,*) A.NE.CMPLX(0.0D0) |
END |
/cpp6.f
0,0 → 1,20
# 1 "test.F" |
# 1 "<built-in>" |
# 1 "<command line>" |
# 1 "test.F" |
! { dg-do compile } |
|
# 1 "A234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 |
|
# 1 "B234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 |
|
# 1 "C234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 |
|
# 1 "D234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 1 |
PARAMETER (I=1) |
|
# 2 "C234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 |
# 2 "B234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 |
# 2 "A234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890" 2 |
# 3 "test.F" 2 |
END |
/13060.f
0,0 → 1,14
c { dg-do compile } |
subroutine geo2() |
implicit none |
|
integer ms,n,ne(2) |
|
ne(1) = 1 |
ne(2) = 2 |
ms = 1 |
|
call call_me(ne(1)*ne(1)) |
|
n = ne(ms) |
end |
/ffixed-line-length-132.f
0,0 → 1,7
C Test compiler flags: -ffixed-line-length-132 |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do compile } |
C { dg-options "-ffixed-line-length-132" } |
c23456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012345678901234567890123456789012 |
en d* |
/980628-2.f
0,0 → 1,57
c { dg-do run } |
c { dg-options "-std=gnu" } |
* g77 0.5.23 and previous had bugs involving too little space |
* allocated for EQUIVALENCE and COMMON areas needing initial |
* padding to meet alignment requirements of the system. |
|
call subr |
end |
|
subroutine subr |
implicit none |
|
character c1(11), c2(11), c3(11) |
real r1, r2, r3 |
character c4, c5, c6 |
equivalence (c1(2), r1) |
equivalence (c2(2), r2) |
equivalence (c3(2), r3) |
|
c1(1) = '1' |
r1 = 1. |
c1(11) = '1' |
c4 = '4' |
c2(1) = '2' |
r2 = 2. |
c2(11) = '2' |
c5 = '5' |
c3(1) = '3' |
r3 = 3. |
c3(11) = '3' |
c6 = '6' |
|
call x (c1, r1, c2, r2, c3, r3, c4, c5, c6) |
|
end |
|
subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6) |
implicit none |
|
character c1(11), c2(11), c3(11) |
real r1, r2, r3 |
character c4, c5, c6 |
|
if (c1(1) .ne. '1') call abort |
if (r1 .ne. 1.) call abort |
if (c1(11) .ne. '1') call abort |
if (c4 .ne. '4') call abort |
if (c2(1) .ne. '2') call abort |
if (r2 .ne. 2.) call abort |
if (c2(11) .ne. '2') call abort |
if (c5 .ne. '5') call abort |
if (c3(1) .ne. '3') call abort |
if (r3 .ne. 3.) call abort |
if (c3(11) .ne. '3') call abort |
if (c6 .ne. '6') call abort |
|
end |
/fno-underscoring.f
0,0 → 1,8
C Test compiler flags: -fno-underscoring |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do compile } |
C { dg-options "-fno-underscoring" } |
call aaabbbccc |
end |
C { dg-final { scan-assembler-not "aaabbbccc_" } } |
/19990905-0.f
0,0 → 1,12
c { dg-do compile } |
* =foo0.f in Burley's g77 test suite. |
! Used to give "Variable 'm' cannot appear" "Variable 'm' cannot appear" |
! after REAL a(m,n), as described in PR 16511. |
! |
subroutine sub(a) |
equivalence (m,iarray(100)) |
common /info/ iarray(1000) |
equivalence (n,iarray(200)) |
real a(m,n) |
a(1,1) = a(2,2) |
end |
/20000511-2.f
0,0 → 1,62
c { dg-do compile } |
subroutine sgbcon(norm,n,kl,ku,ab,ldab,ipiv,anorm,rcond,work,iwork |
&,info) |
C |
C -- LAPACK routine (version 3.0) -- |
C Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., |
C Courant Institute, Argonne National Lab, and Rice University |
C September 30, 1994 |
C |
C .. Scalar Arguments .. |
character norm |
integer info,kl,ku,ldab,n |
real anorm,rcond |
C .. |
C .. Array Arguments .. |
integer ipiv(n),iwork(n) |
real ab(ldab,n),work(n) |
C .. |
C |
C Purpose |
C ======= |
C demonstrate g77 bug at -O -funroll-loops |
C ===================================================================== |
C |
C .. Parameters .. |
real one,zero |
parameter(one= 1.0e+0,zero= 0.0e+0) |
C .. |
C .. Local Scalars .. |
logical lnoti,onenrm |
character normin |
integer ix,j,jp,kase,kase1,kd,lm |
real ainvnm,scale,smlnum,t |
C .. |
C .. External Functions .. |
logical lsame |
integer isamax |
real sdot,slamch |
externallsame,isamax,sdot,slamch |
C .. |
C .. External Subroutines .. |
externalsaxpy,slacon,slatbs,srscl,xerbla |
C .. |
C .. Executable Statements .. |
C |
C Multiply by inv(L). |
C |
do j= 1,n-1 |
C the following min() intrinsic provokes this bug |
lm= min(kl,n-j) |
jp= ipiv(j) |
t= work(jp) |
if(jp.ne.j)then |
C but only when combined with this if block |
work(jp)= work(j) |
work(j)= t |
endif |
C and this subroutine call |
call saxpy(lm,-t,ab(kd+1,j),1,work(j+1),1) |
enddo |
return |
end |
/19990826-0.f
0,0 → 1,20
c { dg-do run } |
* From: niles@fan745.gsfc.nasa.gov |
* To: fortran@gnu.org |
* Cc: niles@fan745.gsfc.nasa.gov |
* Subject: problem with DNINT() on Linux/Alpha. |
* Date: Sun, 06 Jun 1999 16:39:35 -0400 |
* X-UIDL: 6aa9208d7bda8b6182a095dfd37016b7 |
|
IF (DNINT(0.0D0) .NE. 0.) CALL ABORT |
STOP |
END |
|
* Result on Linux/i386: " 0." (and every other computer!) |
* Result on Linux/alpha: " 3.6028797E+16" |
|
* It seems to work fine if I change it to the generic NINT(). Probably |
* a name pollution problem in the new C library, but it seems bad. no? |
|
* Thanks, |
* Rick Niles. |
/20010216-1.f
0,0 → 1,52
C Test for bug in reg-stack handling conditional moves. |
C Reported by Tim Prince <tprince@computer.org> |
C |
C { dg-do run { target { { i[6789]86-*-* x86_64-*-* } && ilp32 } } } |
C { dg-options "-ffast-math -march=pentiumpro" } |
|
double precision function foo(x, y) |
implicit none |
double precision x, y |
double precision a, b, c, d |
if (x /= y) then |
if (x * y >= 0) then |
a = abs(x) |
b = abs(y) |
c = max(a, b) |
d = min(a, b) |
foo = 1 - d/c |
else |
foo = 1 |
end if |
else |
foo = 0 |
end if |
end |
|
program test |
implicit none |
|
integer ntests |
parameter (ntests=7) |
double precision tolerance |
parameter (tolerance=1.0D-6) |
|
C Each column is a pair of values to feed to foo, |
C and its expected return value. |
double precision a(ntests), b(ntests), x(ntests) |
data a /1, -23, -1, 1, 9, 10, -9/ |
data b /1, -23, 12, -12, 10, 9, -10/ |
data x /0, 0, 1, 1, 0.1, 0.1, 0.1/ |
|
double precision foo |
double precision result |
integer i |
|
do i = 1, ntests |
result = foo(a(i), b(i)) |
if (abs(result - x(i)) > tolerance) then |
print *, i, a(i), b(i), x(i), result |
call abort |
end if |
end do |
end |
/20010610.f
0,0 → 1,5
c { dg-do run } |
DO I = 0, 255 |
IF (ICHAR(CHAR(I)) .NE. I) CALL ABORT |
ENDDO |
END |
/20010116.f
0,0 → 1,39
c { dg-do run } |
* |
* Derived from LAPACK 3.0 routine CHGEQZ |
* Fails on i686-pc-cygwin with gcc-2.97 snapshots at -O2 and higher |
* PR fortran/1645 |
* |
* David Billinghurst, (David.Billinghurst@riotinto.com) |
* 14 January 2001 |
* Rewritten by Toon Moene (toon@moene.indiv.nluug.nl) |
* 15 January 2001 |
* |
COMPLEX A(5,5) |
DATA A/25*(0.0,0.0)/ |
A(4,3) = (0.05,0.2)/3.0E-7 |
A(4,4) = (-0.03,-0.4) |
A(5,4) = (-2.0E-07,2.0E-07) |
CALL CHGEQZ( 5, A ) |
END |
SUBROUTINE CHGEQZ( N, A ) |
COMPLEX A(N,N), X |
ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) ) |
DO J = 4, 2, -1 |
I = J |
TEMP = ABS1( A(J,J) ) |
TEMP2 = ABS1( A( J+1, J ) ) |
TEMPR = MAX( TEMP, TEMP2 ) |
IF( TEMPR .LT. 1.0 .AND. TEMPR .NE. 0.0 ) THEN |
TEMP = TEMP / TEMPR |
TEMP2 = TEMP2 / TEMPR |
END IF |
IF ( ABS1(A(J,J-1))*TEMP2 .LE. TEMP ) GO TO 90 |
END DO |
c Should not reach here, but need a statement |
PRINT* |
90 IF ( I .NE. 4 ) THEN |
PRINT*,'I =', I, ' but should be 4' |
CALL ABORT() |
END IF |
END |
/f77-edit-colon-out.f
0,0 → 1,9
C Test Fortran 77 colon edit descriptor |
C (ANSI X3.9-1978 Section 13.5.5) |
C |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do run } |
C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" } |
write(*,'((3(I1:)))') (I,I=1,5) |
end |
/980310-2.f
0,0 → 1,44
c { dg-do compile } |
C unable to confirm this bug on egcs 1.0.1 for i586-pc-sco3.2v5.0.4 robertl |
C |
C Date: Sat, 23 Aug 1997 00:47:53 -0400 (EDT) |
C From: David Bristow <dbristow@lynx.dac.neu.edu> |
C To: egcs-bugs@cygnus.com |
C Subject: g77 crashes compiling Dungeon |
C Message-ID: <Pine.OSF.3.91.970823003521.11281A-100000@lynx.dac.neu.edu> |
C |
C The following small segment of Dungeon (the adventure that became the |
C commercial hit Zork) causes an internal error in f771. The platform is |
C i586-pc-linux-gnulibc1, the compiler is egcs-ss-970821 (g77-GNU Fortran |
C 0.5.21-19970811) |
C |
C --cut here--cut here--cut here--cut here--cut here--cut here-- |
C g77 --verbose -fugly -fvxt -c subr_.f |
C g77 version 0.5.21-19970811 |
C gcc --verbose -fugly -fvxt -xf77 subr_.f -xnone -lf2c -lm |
C Reading specs from /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/specs |
C gcc version egcs-2.90.01 970821 (gcc2-970802 experimental) |
C /usr/lib/gcc-lib/i586-pc-linux-gnulibc1/egcs-2.90.01/f771 subr_.f -fset-g77-defaults -quiet -dumpbase subr_.f -version -fversion -fugly -fvxt -o /tmp/cca23974.s |
C f771: warning: -fugly is overloaded with meanings and likely to be removed; |
C f771: warning: use only the specific -fugly-* options you need |
C GNU F77 version egcs-2.90.01 970821 (gcc2-970802 experimental) (i586-pc-linux-gnulibc1) compiled by GNU C version egcs-2.90.01 970821 (gcc2-970802 experimental). |
C GNU Fortran Front End version 0.5.21-19970811 |
C f/com.c:941: failed assertion `TYPE_PRECISION (type) <= TYPE_PRECISION (TREE_TYPE (e))' |
C gcc: Internal compiler error: program f771 got fatal signal 6 |
C --cut here--cut here--cut here--cut here--cut here--cut here-- |
C |
C Here's the FORTRAN code, it's basically a single subroutine from subr.f |
C in the Dungeon source, slightly altered (the original calls RAN(), which |
C doesn't exist in the g77 runtime) |
C |
C RND - Return a random integer mod n |
C |
INTEGER FUNCTION RND (N) |
IMPLICIT INTEGER (A-Z) |
REAL RAND |
COMMON /SEED/ RNSEED |
|
RND = RAND(RNSEED)*FLOAT(N) |
RETURN |
|
END |
/cpp3.F
0,0 → 1,6
c { dg-do run } |
! Some versions of cpp will delete "//'World' as a C++ comment. |
character*40 title |
title = 'Hello '//'World' |
if (title .ne. 'Hello World') call abort |
end |
/claus.f
0,0 → 1,14
c { dg-do run } |
PROGRAM TEST |
REAL AB(3) |
do i=1,3 |
AB(i)=i |
enddo |
k=1 |
n=2 |
ind=k-n+2 |
if (ind /= 1) call abort |
if (ab(ind) /= 1) call abort |
if (k-n+2 /= 1) call abort |
if (ab(k-n+2) /= 1) call abort |
END |
/980310-6.f
0,0 → 1,22
c { dg-do compile } |
C From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de> |
C Message-Id: <199711131008.LAA12272@marvin.hrz.uni-giessen.de> |
C Subject: 971105 g77 bug |
C To: egcs-bugs@cygnus.com |
C Date: Thu, 13 Nov 1997 11:08:19 +0100 (CET) |
|
C I found a bug in g77 in snapshot 971105 |
|
subroutine ai (a) |
dimension a(-1:*) |
return |
end |
C ai.f: In subroutine `ai': |
C ai.f:1: |
C subroutine ai (a) |
C ^ |
C Array `a' at (^) is too large to handle |
C |
C This happens whenever the lower index boundary is negative and the upper index |
C boundary is '*'. |
|
/980519-2.f
0,0 → 1,51
c { dg-do compile } |
* Date: Fri, 17 Apr 1998 14:12:51 +0200 |
* From: Jean-Paul Jeannot <jeannot@gx-tech.fr> |
* Organization: GX Technology France |
* To: egcs-bugs@cygnus.com |
* Subject: identified bug in g77 on Alpha |
* |
* Dear Sir, |
* |
* You will find below the assembly code of a simple Fortran routine which |
* crashes with segmentation fault when storing the first element |
* in( jT_f-hd_T ) = Xsp |
* whereas everything is fine when commenting this line. |
* |
* The assembly code (generated with |
* -ffast-math -fexpensive-optimizations -fomit-frame-pointer -fno-inline |
* or with -O5) |
* uses a zapnot instruction to copy an address. |
* BUT the zapnot parameter is 15 (copuing 4 bytes) instead of 255 (to copy |
* 8 bytes). |
* |
* I guess this is typically a 64 bit issue. As, from my understanding, |
* zapnots are used a lot to copy registers, this may create problems |
* elsewhere. |
* |
* Thanks for your help |
* |
* Jean-Paul Jeannot |
* |
subroutine simul_trace( in, Xsp, Ysp, Xrcv, Yrcv ) |
|
c Next declaration added on transfer to gfortran testsuite |
integer hd_S, hd_Z, hd_T |
|
common /Idim/ jT_f, jT_l, nT, nT_dim |
common /Idim/ jZ_f, jZ_l, nZ, nZ_dim |
common /Idim/ jZ2_f, jZ2_l, nZ2, nZ2_dim |
common /Idim/ jzs_f, jzs_l, nzs, nzs_dim, l_amp |
common /Idim/ hd_S, hd_Z, hd_T |
common /Idim/ nlay, nlayz |
common /Idim/ n_work |
common /Idim/ nb_calls |
|
real Xsp, Ysp, Xrcv, Yrcv |
real in( jT_f-hd_T : jT_l ) |
|
in( jT_f-hd_T ) = Xsp |
in( jT_f-hd_T + 1 ) = Ysp |
in( jT_f-hd_T + 2 ) = Xrcv |
in( jT_f-hd_T + 3 ) = Yrcv |
end |
/970816-3.f
0,0 → 1,21
c { dg-do run } |
* Date: Wed, 13 Aug 1997 15:34:23 +0200 (METDST) |
* From: Claus Denk <denk@cica.es> |
* To: g77-alpha@gnu.ai.mit.edu |
* Subject: 970811 report - segfault bug on alpha still there |
*[...] |
* Now, the bug that I reported some weeks ago is still there, I'll post |
* the test program again: |
* |
PROGRAM TEST |
C a bug in g77-0.5.21 - alpha. Works with NSTART=0 and segfaults with |
C NSTART=1 on the second write. |
PARAMETER (NSTART=1,NADD=NSTART+1) |
REAL AB(NSTART:NSTART) |
AB(NSTART)=1.0 |
I=1 |
J=2 |
IND=I-J+NADD |
write(*,*) AB(IND) |
write(*,*) AB(I-J+NADD) |
END |
/19990313-0.f
0,0 → 1,34
c { dg-do run } |
* To: craig@jcb-sc.com |
* Subject: Re: G77 and KIND=2 |
* Content-Type: text/plain; charset=us-ascii |
* From: Dave Love <d.love@dl.ac.uk> |
* Date: 03 Mar 1999 18:20:11 +0000 |
* In-Reply-To: craig@jcb-sc.com's message of "1 Mar 1999 21:04:38 -0000" |
* User-Agent: Gnus/5.07007 (Pterodactyl Gnus v0.70) Emacs/20.3 |
* X-UIDL: d442bafe961c2a6ec6904f492e05d7b0 |
* |
* ISTM that there is a real problem printing integer(kind=8) (on x86): |
* |
* $ cat x.f |
*[modified for test suite] |
integer(kind=8) foo, bar |
data r/4e10/ |
foo = 4e10 |
bar = r |
if (foo .ne. bar) call abort |
end |
* $ g77 x.f && ./a.out |
* 1345294336 |
* 123 |
* $ f2c x.f && g77 x.c && ./a.out |
* x.f: |
* MAIN: |
* 40000000000 |
* 123 |
* $ |
* |
* Gdb shows the upper half of the buffer passed to do_lio is zeroed in |
* the g77 case. |
* |
* I've forgotten how the code generation happens. |
/f77-edit-h-out.f
0,0 → 1,14
C Test Fortran 77 H edit descriptor |
C (ANSI X3.9-1978 Section 13.5.2) |
C |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do run } |
C { dg-output "^" } |
10 format(1H1) |
20 format(6H 6) |
write(*,10) ! { dg-output "1(\n|\r\n|\r)" } |
write(*,20) ! { dg-output " 6(\n|\r\n|\r)" } |
write(*,'(16H''apostrophe'' fun)') ! { dg-output "'apostrophe' fun(\n|\r\n|\r)" } |
C { dg-output "\$" } |
end |
/dnrm2.f
0,0 → 1,75
c { dg-do run } |
CCC g77 0.5.21 `Actual Bugs': |
CCC * A code-generation bug afflicts Intel x86 targets when `-O2' is |
CCC specified compiling, for example, an old version of the `DNRM2' |
CCC routine. The x87 coprocessor stack is being somewhat mismanaged |
CCC in cases where assigned `GOTO' and `ASSIGN' are involved. |
CCC |
CCC Version 0.5.21 of `g77' contains an initial effort to fix the |
CCC problem, but this effort is incomplete, and a more complete fix is |
CCC planned for the next release. |
|
C Currently this test fails with (at least) `-O2 -funroll-loops' on |
C i586-unknown-linux-gnulibc1. |
|
C (This is actually an obsolete version of dnrm2 -- consult the |
c current Netlib BLAS.) |
|
integer i |
double precision a(1:100), dnrm2 |
do i=1,100 |
a(i)=0.D0 |
enddo |
if (dnrm2(100,a,1) .ne. 0.0) call abort |
end |
|
double precision function dnrm2 ( n, dx, incx) |
integer i, incx, ix, j, n, next |
double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one |
data zero, one /0.0d0, 1.0d0/ |
data cutlo, cuthi / 8.232d-11, 1.304d19 / |
j = 0 |
if(n .gt. 0 .and. incx.gt.0) go to 10 |
dnrm2 = zero |
go to 300 |
10 assign 30 to next ! { dg-warning "ASSIGN" "" } |
sum = zero |
i = 1 |
ix = 1 |
20 go to next,(30, 50, 70, 110) ! { dg-warning "Assigned GOTO" "" } |
30 if( dabs(dx(i)) .gt. cutlo) go to 85 |
assign 50 to next ! { dg-warning "ASSIGN" "" } |
xmax = zero |
50 if( dx(i) .eq. zero) go to 200 |
if( dabs(dx(i)) .gt. cutlo) go to 85 |
assign 70 to next ! { dg-warning "ASSIGN" "" } |
go to 105 |
100 continue |
ix = j |
assign 110 to next ! { dg-warning "ASSIGN" "" } |
sum = (sum / dx(i)) / dx(i) |
105 xmax = dabs(dx(i)) |
go to 115 |
70 if( dabs(dx(i)) .gt. cutlo ) go to 75 |
110 if( dabs(dx(i)) .le. xmax ) go to 115 |
sum = one + sum * (xmax / dx(i))**2 |
xmax = dabs(dx(i)) |
go to 200 |
115 sum = sum + (dx(i)/xmax)**2 |
go to 200 |
75 sum = (sum * xmax) * xmax |
85 hitest = cuthi/float( n ) |
do 95 j = ix,n |
if(dabs(dx(i)) .ge. hitest) go to 100 |
sum = sum + dx(i)**2 |
i = i + incx |
95 continue |
dnrm2 = dsqrt( sum ) |
go to 300 |
200 continue |
ix = ix + 1 |
i = i + incx |
if( ix .le. n ) go to 20 |
dnrm2 = xmax * dsqrt(sum) |
300 continue |
end |
/19990218-1.f
0,0 → 1,25
c { dg-do compile } |
c |
c g77 used to warn for this case |
c 19990218-1.f: In program `test': |
c 19990218-1.f:13: |
c double precision function fun(a,b) |
c 1 |
c 19990218-1.f:23: (continued): |
c c=fun(a,b) |
c 2 |
c Global name `fun' at (2) has different type at (1) [info -f g77 M GLOBALS] |
c |
double precision function fun(a,b) |
double precision a,b |
print*,'in sub: a,b=',a,b |
fun=a*b |
print*,'in sub: fun=',fun |
return |
end |
program test |
double precision a,b,c |
data a,b/1.0d-46,1.0d0/ |
c=fun(a,b) |
print*,'in main: fun=',c |
end |
/f90-intrinsic-mathematical.f
0,0 → 1,138
c { dg-do run } |
c f90-intrinsic-mathematical.f |
c |
c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and |
c 13.13 |
c David Billinghurst <David.Billinghurst@riotinto.com> |
c |
c Notes: |
c * g77 does not fully comply with F90. Noncompliances noted in comments. |
c * Section 13.12: Specific names for intrinsic functions tested in |
c intrinsic77.f |
|
logical fail |
common /flags/ fail |
fail = .false. |
|
c ACOS - Section 13.13.3 |
call c_r(ACOS(0.54030231),1.0,'ACOS(real)') |
call c_d(ACOS(0.54030231d0),1.d0,'ACOS(double)') |
|
c ASIN - Section 13.13.12 |
call c_r(ASIN(0.84147098),1.0,'ASIN(real)') |
call c_d(ASIN(0.84147098d0),1.d0,'ASIN(double)') |
|
c ATAN - Section 13.13.14 |
call c_r(ATAN(1.5574077),1.0,'ATAN(real)') |
call c_d(ATAN(1.5574077d0),1.d0,'ATAN(double)') |
|
c ATAN2 - Section 13.13.15 |
call c_r(ATAN2(1.5574077,1.),1.0,'ATAN2(real)') |
call c_d(ATAN2(1.5574077d0,1.d0),1.d0,'ATAN2(double)') |
|
c COS - Section 13.13.22 |
call c_r(COS(1.0),0.54030231,'COS(real)') |
call c_d(COS(1.d0),0.54030231d0,'COS(double)') |
call c_c(COS((1.,0.)),(0.54030231,0.),'COS(complex)') |
call c_z(COS((1.d0,0.d0)),(0.54030231d0,0.d0), |
$ 'COS(complex(kind=8))') |
|
c COSH - Section 13.13.23 |
call c_r(COSH(1.0),1.5430806,'COSH(real)') |
call c_d(COSH(1.d0),1.5430806d0,'COSH(double)') |
|
c EXP - Section 13.13.34 |
call c_r(EXP(1.0),2.7182818,'EXP(real)') |
call c_d(EXP(1.d0),2.7182818d0,'EXP(double)') |
call c_c(EXP((1.,0.)),(2.7182818,0.),'EXP(complex)') |
call c_z(EXP((1.d0,0.d0)),(2.7182818d0,0.d0), |
$ 'EXP(complex(kind=8))') |
|
c LOG - Section 13.13.59 |
call c_r(LOG(10.0),2.3025851,'LOG(real)') |
call c_d(LOG(10.d0),2.3025851d0,'LOG(double)') |
call c_c(LOG((10.,0.)),(2.3025851,0.),'LOG(complex)') |
call c_z(LOG((10.d0,0.)),(2.3025851d0,0.d0), |
$ 'LOG(complex(kind=8))') |
|
c LOG10 - Section 13.13.60 |
call c_r(LOG10(10.0),1.0,'LOG10(real)') |
call c_d(LOG10(10.d0),1.d0,'LOG10(double)') |
|
c SIN - Section 13.13.97 |
call c_r(SIN(1.0),0.84147098,'SIN(real)') |
call c_d(SIN(1.d0),0.84147098d0,'SIN(double)') |
call c_c(SIN((1.,0.)),(0.84147098,0.),'SIN(complex)') |
call c_z(SIN((1.d0,0.d0)),(0.84147098d0,0.d0), |
$ 'SIN(complex(kind=8))') |
|
c SINH - Section 13.13.98 |
call c_r(SINH(1.0),1.175201,'SINH(real)') |
call c_d(SINH(1.d0),1.175201d0,'SINH(double)') |
|
c SQRT - Section 13.13.102 |
call c_r(SQRT(4.0),2.0,'SQRT(real)') |
call c_d(SQRT(4.d0),2.d0,'SQRT(double)') |
call c_c(SQRT((4.,0.)),(2.,0.),'SQRT(complex)') |
call c_z(SQRT((4.d0,0.)),(2.d0,0.), |
$ 'SQRT(complex(kind=8))') |
|
c TAN - Section 13.13.105 |
call c_r(TAN(1.0),1.5574077,'TAN(real)') |
call c_d(TAN(1.d0),1.5574077d0,'TAN(double)') |
|
c TANH - Section 13.13.106 |
call c_r(TANH(1.0),0.76159416,'TANH(real)') |
call c_d(TANH(1.d0),0.76159416d0,'TANH(double)') |
|
if ( fail ) call abort() |
end |
|
subroutine failure(label) |
c Report failure and set flag |
character*(*) label |
logical fail |
common /flags/ fail |
write(6,'(a,a,a)') 'Test ',label,' FAILED' |
fail = .true. |
end |
|
subroutine c_r(a,b,label) |
c Check if REAL a equals b, and fail otherwise |
real a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0e-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_d(a,b,label) |
c Check if DOUBLE PRECISION a equals b, and fail otherwise |
double precision a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0d-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_c(a,b,label) |
c Check if COMPLEX a equals b, and fail otherwise |
complex a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0e-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_z(a,b,label) |
c Check if COMPLEX a equals b, and fail otherwise |
complex(kind=8) a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0d-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
/ffree-form-1.f
0,0 → 1,6
! Test compiler flags: -ffree-form |
! Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
! |
! { dg-do compile } |
! { dg-options "-ffree-form" } |
end |
/20000503-1.f
0,0 → 1,25
c { dg-do run } |
* |
* Originally derived from LAPACK 3.0 test suite failure. |
* |
* David Billinghurst, (David.Billinghurst@riotinto.com.au) |
* 23 February 2000 |
* |
INTEGER N, I, SLASQX |
N = 20 |
I = SLASQX( N ) |
IF ( I .NE. 2*N ) THEN |
WRITE(6,*) 'I = ', I, ' but should be ', 2*N |
CALL ABORT() |
END IF |
END |
|
INTEGER FUNCTION SLASQX( N ) |
INTEGER N, I0, I, K |
I0 = 1 |
DO I = 4*I0, 2*( I0+N-1 ), 4 |
K = I |
END DO |
SLASQX = K |
RETURN |
END |
/19990419-1.f
0,0 → 1,22
c { dg-do run } |
* Test DO WHILE, to make sure it fully reevaluates its expression. |
* Belongs in execute/. |
common /x/ ival |
j = 0 |
do while (i() .eq. 1) |
j = j + 1 |
if (j .gt. 5) call abort |
end do |
if (j .ne. 4) call abort |
if (ival .ne. 5) call abort |
end |
function i() |
common /x/ ival |
ival = ival + 1 |
i = 10 |
if (ival .lt. 5) i = 1 |
end |
block data |
common /x/ ival |
data ival/0/ |
end |
/20000601-2.f
0,0 → 1,28
c { dg-do compile } |
SUBROUTINE SGBTRF( M, KL, KU, AB, LDAB ) |
|
* Slightly modified version of 20000601-1.f that still ICES with |
* CVS 20010118 g77 on mips-sgi-irix6.5/-mabi=64. |
* |
* Originally derived from LAPACK 3.0 test suite failure. |
* |
* David Billinghurst, (David.Billinghurst@riotinto.com.au) |
* 18 January 2001 |
|
INTEGER KL, KU, LDAB, M |
REAL AB( LDAB, * ) |
|
INTEGER J, JB, JJ, JP, KV, KM, F |
REAL WORK13(65,64), WORK31(65,64) |
KV = KU + KL |
DO J = 1, M |
JB = MIN( 1, M-J+1 ) |
DO JJ = J, J + JB - 1 |
KM = MIN( KL, M-JJ ) |
JP = F( KM+1, AB( KV+1, JJ ) ) |
CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, |
$ AB( KV+JP+JJ-J, J ), LDAB-1 ) |
END DO |
END DO |
RETURN |
END |
/strlen0.f
0,0 → 1,95
C Substring range checking test program, to check behavior with respect |
C to X3J3/90.4 paragraph 5.7.1. |
C |
C Patches relax substring checking for subscript expressions in order to |
C simplify coding (elimination of length checks for strings passed as |
C parameters) and to avoid contradictory behavior of subscripted substring |
C expressions with respect to unsubscripted string expressions. |
C |
C Key part of 5.7.1 interpretation comes down to statement that in the |
C substring expression, |
C v ( e1 : e2 ) |
C 1 <= e1 <= e2 <= len to be valid, yet the expression |
C v ( : ) |
C is equivalent to |
C v(1:len(v)) |
C |
C meaning that any statement that reads |
C str = v // 'tail' |
C (where v is a string passed as a parameter) would require coding as |
C if (len(v) .gt. 0) then |
C str = v // 'tail' |
C else |
C str = 'tail' |
C endif |
C to comply with the standard specification. Under the stricter |
C interpretation, functions strcat and strlat would be incorrect as |
C written for null values of str1 and/or str2. |
C |
C This code compiles and runs without error on |
C SunOS 4.1.3 f77 (-C option) |
C SUNWspro SPARCcompiler 4.2 f77 (-C option) |
C (and with proposed patches, gcc-2.9.2 -fbounds-check except for test 6, |
C which is a genuine, deliberate error - comment out to make further |
C tests) |
C |
C { dg-do run } |
C { dg-options "-fbounds-check" } |
C |
C G. Helffrich/Tokyo Inst. Technology Jul 24 2001 |
|
character str*8,strres*16,strfun*16,strcat*16,strlat*16 |
|
str='Hi there' |
|
C Test 1 - (current+patched) two char substring result |
strres=strfun(str,1,2) |
write(*,*) 'strres is ',strres |
|
C Test 2 - (current+patched) null string result |
strres=strfun(str,5,4) |
write(*,*) 'strres is ',strres |
|
C Test 3 - (current+patched) null string result |
strres=strfun(str,8,7) |
write(*,*) 'strres is ',strres |
|
C Test 4 - (current) error; (patched) null string result |
strres=strfun(str,9,8) |
write(*,*) 'strres is ',strres |
|
C Test 5 - (current) error; (patched) null string result |
strres=strfun(str,1,0) |
write(*,*) 'strres is ',strres |
|
C Test 6 - (current+patched) error |
C strres=strfun(str,20,20) |
C write(*,*) 'strres is ',strres |
|
C Test 7 - (current+patched) str result |
strres=strcat(str,'') |
write(*,*) 'strres is ',strres |
|
C Test 8 - (current) error; (patched) str result |
strres=strlat('',str) |
write(*,*) 'strres is ',strres |
|
end |
|
character*(*) function strfun(str,i,j) |
character str*(*) |
|
strfun = str(i:j) |
end |
|
character*(*) function strcat(str1,str2) |
character str1*(*), str2*(*) |
|
strcat = str1 // str2 |
end |
|
character*(*) function strlat(str1,str2) |
character str1*(*), str2*(*) |
|
strlat = str1(1:len(str1)) // str2(1:len(str2)) |
end |
/f77-edit-t-out.f
0,0 → 1,12
C Test Fortran 77 T edit descriptor |
C (ANSI X3.9-1978 Section 13.5.3.2) |
C |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do run } |
C ( dg-output "^" } |
write(*,'(I4,T8,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" } |
write(*,'(I4,TR3,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" } |
write(*,'(I4,5X,TL2,I1)') 1234,8 ! { dg-output "1234 8(\n|\r\n|\r)" } |
C ( dg-output "\$" } |
end |
/20010426-1.f
0,0 → 1,3
c { dg-do run } |
print*,cos(1.0) |
end |
/1832.f
0,0 → 1,7
c { dg-do run } |
character*5 string |
write(string, *) "a " |
if (string .ne. ' a') call abort |
C-- The leading space is normal for list-directed output |
|
end |
/intrinsic-unix-erf.f
0,0 → 1,61
c { dg-do run } |
c intrinsic-unix-erf.f |
c |
c Test Bessel function intrinsics. |
c These functions are only available if provided by system |
c |
c David Billinghurst <David.Billinghurst@riotinto.com> |
c |
real x, a |
double precision dx, da |
logical fail |
common /flags/ fail |
fail = .false. |
|
x = 0.6 |
dx = x |
c ERF - error function |
a = 0.6038561 |
da = a |
call c_r(ERF(x),a,'ERF(real)') |
call c_d(ERF(dx),da,'ERF(double)') |
call c_d(DERF(dx),da,'DERF(double)') |
|
c ERFC - complementary error function |
a = 1.0 - a |
da = a |
call c_r(ERFC(x),a,'ERFC(real)') |
call c_d(ERFC(dx),da,'ERFC(double)') |
call c_d(DERFC(dx),da,'DERFC(double)') |
|
if ( fail ) call abort() |
end |
|
subroutine failure(label) |
c Report failure and set flag |
character*(*) label |
logical fail |
common /flags/ fail |
write(6,'(a,a,a)') 'Test ',label,' FAILED' |
fail = .true. |
end |
|
subroutine c_r(a,b,label) |
c Check if REAL a equals b, and fail otherwise |
real a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0e-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
|
subroutine c_d(a,b,label) |
c Check if DOUBLE PRECISION a equals b, and fail otherwise |
double precision a, b |
character*(*) label |
if ( abs(a-b) .gt. 1.0d-5 ) then |
call failure(label) |
write(6,*) 'Got ',a,' expected ', b |
end if |
end |
/f77-edit-x-out.f
0,0 → 1,12
C Test Fortran 77 X descriptor |
C (ANSI X3.9-1978 Section 13.5.3.2) |
C |
C Origin: David Billinghurst <David.Billinghurst@riotinto.com> |
C |
C { dg-do run } |
C ( dg-output "^" } |
write(*,'(I1,1X,I1,2X,I1)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" } |
C Section 13.5.3 explains why there are no trailing blanks |
write(*,'(I1,1X,I1,2X,I1,3X)') 1,2,3 ! { dg-output "1 2 3(\n|\r\n|\r)" } |
C { dg-output "\$" } |
end |
/20000629-1.f
0,0 → 1,12
c { dg-do compile } |
SUBROUTINE MIST(N, BETA) |
IMPLICIT REAL(kind=8) (A-H,O-Z) |
INTEGER IA, IQ, M1 |
DIMENSION BETA(N) |
DO 80 IQ=1,M1 |
IF (BETA(IQ).EQ.0.0D0) GO TO 120 |
80 CONTINUE |
120 IF (IQ.NE.1) GO TO 160 |
160 M1 = IA(IQ) |
RETURN |
END |
/970125-0.f
0,0 → 1,45
c { dg-do compile } |
c |
c Following line added on transfer to gfortran testsuite |
c { dg-excess-errors "" } |
c |
C JCB comments: |
C g77 doesn't accept the added line "integer(kind=7) ..." -- |
C it crashes! |
C |
C It's questionable that g77 DTRT with regarding to passing |
C %LOC() as an argument (thus by reference) and the new global |
C analysis. I need to look into that further; my feeling is that |
C passing %LOC() as an argument should be treated like passing an |
C INTEGER(KIND=7) by reference, and no more specially than that |
C (and that INTEGER(KIND=7) should be permitted as equivalent to |
C INTEGER(KIND=1), INTEGER(KIND=2), or whatever, depending on the |
C system's pointer size). |
C |
C The back end *still* has a bug here, which should be fixed, |
C because, currently, what g77 is passing to it is, IMO, correct. |
|
C No options: |
C ../../egcs/gcc/f/info.c:259: failed assertion `ffeinfo_types_[basictype][kindtype] != NULL' |
C -fno-globals -O: |
C ../../egcs/gcc/expr.c:7291: Internal compiler error in function expand_expr |
|
c Frontend bug fixed by JCB 1998-06-01 com.c &c changes. |
|
integer i4 |
integer(kind=8) i8 |
integer(kind=8) max4 |
data max4/2147483647/ |
i4 = %loc(i4) |
i8 = %loc(i8) |
print *, max4 |
print *, i4, %loc(i4) |
print *, i8, %loc(i8) |
call foo(i4, %loc(i4), i8, %loc(i8)) |
end |
subroutine foo(i4, i4a, i8, i8a) |
integer(kind=7) i4a, i8a |
integer(kind=8) i8 |
print *, i4, i4a |
print *, i8, i8a |
end |
/8485.f
0,0 → 1,9
c { dg-do compile } |
C Extracted from PR fortran/8485 |
PARAMETER (PPMULT = 1.0E5) |
INTEGER(kind=8) NWRONG |
PARAMETER (NWRONG = 8) |
PARAMETER (DDMULT = PPMULT * NWRONG) |
PRINT 10, DDMULT |
10 FORMAT (F10.3) |
END |
/README
0,0 → 1,201
The g77 testsuite is being transferred to the gfortran testsuite. |
This file documents the status of each test case. |
|
Y Test has been transferred. |
Y XFAIL This test has been transferred but fails |
N This feature will not be supported by gfortran. |
F This test fails with gfortran. Not transferred (yet). |
? We looked at this case, but haven't decided. |
|
Directory g77.dg |
|
12632.f Y |
20010216-1.f Y |
7388.f Y |
f77-edit-apostrophe-out.f Y |
f77-edit-colon-out.f Y |
f77-edit-h-out.f Y |
f77-edit-i-in.f Y |
f77-edit-i-out.f Y |
f77-edit-s-out.f Y XFAIL PR 16434 |
f77-edit-slash-out.f Y |
f77-edit-t-in.f Y XFAIL PR 16436 |
f77-edit-t-out.f Y |
f77-edit-x-out.f Y XFAIL PR 16435 |
fbackslash.f ? |
fcase-preserve.f ? |
ff90-1.f ? |
ffixed-form-1.f Y |
ffixed-form-2.f Y |
ffixed-line-length-0.f Y |
ffixed-line-length-132.f Y |
ffixed-line-length-7.f F PR 16465 |
ffixed-line-length-72.f Y |
ffixed-line-length-none.f Y |
ffree-form-1.f Y |
ffree-form-2.f Y |
ffree-form-3.f Y |
fno-backslash.f ? |
fno-f90-1.f ? |
fno-fixed-form-1.f ? |
fno-onetrip.f ? |
fno-typeless-boz.f ? |
fno-underscoring.f Y |
fno-vxt-1.f ? |
fonetrip.f ? |
ftypeless-boz.f ? |
fugly-assumed.f ? |
funderscoring.f Y |
fvxt-1.f ? |
pr3743-1.f ? |
pr3743-2.f ? |
pr3743-3.f ? |
pr3743-4.f ? |
pr5473.f ? |
pr9258.f Y |
strlen0.f Y |
|
|
Directory g77.dg/bprob |
g77-bprob-1.f |
|
|
Directory g77.dg/gcov |
gcov-1.f |
|
Directory g77.f-torture/compile |
12002.f Y |
13060.f Y |
19990218-0.f Y |
19990305-0.f Y |
19990419-0.f Y |
19990502-0.f Y |
19990502-1.f Y |
19990525-0.f Y |
19990826-1.f Y |
19990826-3.f Y |
19990905-0.f Y XFAIL PR 16511 |
19990905-2.f Y |
20000412-1.f Y |
20000511-1.f Y |
20000511-2.f Y |
20000518.f Y |
20000601-1.f Y |
20000601-2.f Y |
20000629-1.f Y |
20000630-2.f Y |
20010115.f Y |
20010321-1.f Y |
20010426.f Y |
20010519-1.f Y Add dg-warnings for ASSIGN |
20020307-1.f Y |
20030115-1.f Y Add dg-warnings for ASSIGN |
20030326-1.f Y |
8485.f Y |
960317-1.f Y |
970125-0.f Y Add dg-excess-errors. Investigate.later. |
970915-0.f Y |
980310-1.f Y |
980310-2.f Y |
980310-3.f Y |
980310-4.f Y |
980310-6.f Y |
980310-7.f Y |
980310-8.f Y |
980419-2.f Y |
980424-0.f Y |
980427-0.f Y |
980519-2.f Y Modify slightly |
980729-0.f Y |
981117-1.f Y |
990115-1.f Y Declare variable RANK |
alpha1.f Y Work around PR 16508 and PR 16509 |
toon_1.f Y |
xformat.f Y Add dg-warning for extension |
cpp.F Y |
cpp2.F Y |
|
g77.f-torture/execute |
10197.f & 10197.x |
13037.f Y |
1832.f Y |
19981119-0.f Y |
19990313-0.f Y |
19990313-1.f Y |
19990313-2.f Y |
19990313-3.f Y |
19990325-0.f F Execution failure |
19990325-1.f F Execution failure |
19990419-1.f Y |
19990826-0.f Y |
19990826-2.f Y |
20000503-1.f Y |
20001111.f Y |
20001201.f & 20001201.x |
20010116.f Y |
20010426.f renamed 20010426-1.f Y |
20010430.f Y |
20010610.f Y |
5122.f - Assembler failure |
6177.f Y |
6367.f & 6367.x |
947.f Y |
970625-2.f Y Add dg-warnings and declare variables |
970816-3.f Y |
971102-1.f Y |
980520-1.f Y |
980628-0.f Y |
980628-1.f Y |
980628-10.f Y |
980628-2.f Y |
980628-3.f Y |
980628-4.f & 980628-4.x |
980628-5.f & 980628-5.x |
980628-6.f & 980628-6.x |
980628-7.f Y |
980628-8.f Y |
980628-9.f Y |
980701-0.f Y |
980701-1.f Y |
alpha2.f & alpha2.x |
auto0.f & auto0.x |
auto1.f & auto1.x |
cabs.f Y |
claus.f Y |
complex_1.f Y |
cpp.F (Renamed cpp3.F) Y |
cpp2.F - Compiler warnings |
dcomplex.f Y |
dnrm2.f Y Add dg-warning as required |
erfc.f Y |
exp.f Compiler warnings and fails |
f90-intrinsic-bit.f F 16581 Compile errors |
f90-intrinsic-mathematical.f Y |
f90-intrinsic-numeric.f Y |
int8421.f Y |
intrinsic-f2c-z.f F Execution fail |
intrinsic-unix-bessel.f Y |
intrinsic-unix-erf.f Y |
intrinsic-vax-cd.f F Execution fail |
intrinsic77.f F PR 16580 Compiler ICE |
io0.f & io0.x |
io1.f & io1.x |
labug1.f Y |
large_vec.f Y |
le.f Y |
select.f Lots of compiler warnings |
short.f Y |
u77-test.f & u77-test.x |
|
|
Directory g77.f-torture/noncompile |
19981216-0.f Y Accepted by gfortran |
19990218-1.f Y g77 issued warning. |
19990826-4.f ? |
19990905-1.f Y XFAIL 16520 gfortran ICE on invalid |
9263.f Y |
970626-2.f ? |
980615-0.f Y |
980616-0.f Y |
check0.f Y |
select_no_compile.f Y |
README
Property changes :
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+Id
\ No newline at end of property
Index: f90-intrinsic-bit.f
===================================================================
--- f90-intrinsic-bit.f (nonexistent)
+++ f90-intrinsic-bit.f (revision 816)
@@ -0,0 +1,468 @@
+c { dg-do run }
+c f90-intrinsic-bit.f
+c
+c Test Fortran 90
+c * intrinsic bit manipulation functions - Section 13.10.10
+c * bitcopy subroutine - Section 13.9.3
+c David Billinghurst
+c
+c Notes:
+c * g77 only supports scalar arguments
+c * third argument of ISHFTC is not optional in g77
+
+ logical fail
+ integer i, i2, ia, i3
+ integer(kind=2) j, j2, j3, ja
+ integer(kind=1) k, k2, k3, ka
+ integer(kind=8) m, m2, m3, ma
+
+ common /flags/ fail
+ fail = .false.
+
+c BIT_SIZE - Section 13.13.16
+c Determine BIT_SIZE by counting the bits
+ ia = 0
+ i = 0
+ i = not(i)
+ do while ( (i.ne.0) .and. (ia.lt.127) )
+ ia = ia + 1
+ i = ishft(i,-1)
+ end do
+ call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)')
+ ja = 0
+ j = 0
+ j = not(j)
+ do while ( (j.ne.0) .and. (ja.lt.127) )
+ ja = ja + 1
+ j = ishft(j,-1)
+ end do
+ call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer(2))')
+ ka = 0
+ k = 0
+ k = not(k)
+ do while ( (k.ne.0) .and. (ka.lt.127) )
+ ka = ka + 1
+ k = ishft(k,-1)
+ end do
+ call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer(1))')
+ ma = 0
+ m = 0
+ m = not(m)
+ do while ( (m.ne.0) .and. (ma.lt.127) )
+ ma = ma + 1
+ m = ishft(m,-1)
+ end do
+ call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer(8))')
+
+c BTEST - Section 13.13.17
+ j = 7
+ j2 = 3
+ k = 7
+ k2 = 3
+ m = 7
+ m2 = 3
+ call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)')
+ call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer(2))')
+ call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer(1))')
+ call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer(8))')
+ call c_l(BTEST(j,3),.true.,'BTEST(integer(2),integer)')
+ call c_l(BTEST(j,j2),.true.,'BTEST(integer(2),integer(2))')
+ call c_l(BTEST(j,k2),.true.,'BTEST(integer(2),integer(1))')
+ call c_l(BTEST(j,m2),.true.,'BTEST(integer(2),integer(8))')
+ call c_l(BTEST(k,3),.true.,'BTEST(integer(1),integer)')
+ call c_l(BTEST(k,j2),.true.,'BTEST(integer(1),integer(2))')
+ call c_l(BTEST(k,k2),.true.,'BTEST(integer(1),integer(1))')
+ call c_l(BTEST(k,m2),.true.,'BTEST(integer(1),integer(8))')
+ call c_l(BTEST(m,3),.true.,'BTEST(integer(8),integer)')
+ call c_l(BTEST(m,j2),.true.,'BTEST(integer(8),integer(2))')
+ call c_l(BTEST(m,k2),.true.,'BTEST(integer(8),integer(1))')
+ call c_l(BTEST(m,m2),.true.,'BTEST(integer(8),integer(8))')
+
+c IAND - Section 13.13.40
+ j = 3
+ j2 = 1
+ ja = 1
+ k = 3
+ k2 = 1
+ ka = 1
+ m = 3
+ m2 = 1
+ ma = 1
+ call c_i(IAND(3,1),1,'IAND(integer,integer)')
+ call c_i2(IAND(j,j2),ja,'IAND(integer(2),integer(2)')
+ call c_i1(IAND(k,k2),ka,'IAND(integer(1),integer(1))')
+ call c_i8(IAND(m,m2),ma,'IAND(integer(8),integer(8))')
+
+
+c IBCLR - Section 13.13.41
+ j = 14
+ j2 = 1
+ ja = 12
+ k = 14
+ k2 = 1
+ ka = 12
+ m = 14
+ m2 = 1
+ ma = 12
+ call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)')
+ call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer(2))')
+ call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer(1))')
+ call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer(8))')
+ call c_i2(IBCLR(j,1),ja,'IBCLR(integer(2),integer)')
+ call c_i2(IBCLR(j,j2),ja,'IBCLR(integer(2),integer(2))')
+ call c_i2(IBCLR(j,k2),ja,'IBCLR(integer(2),integer(1))')
+ call c_i2(IBCLR(j,m2),ja,'IBCLR(integer(2),integer(8))')
+ call c_i1(IBCLR(k,1),ka,'IBCLR(integer(1),integer)')
+ call c_i1(IBCLR(k,j2),ka,'IBCLR(integer(1),integer(2))')
+ call c_i1(IBCLR(k,k2),ka,'IBCLR(integer(1),integer(1))')
+ call c_i1(IBCLR(k,m2),ka,'IBCLR(integer(1),integer(8))')
+ call c_i8(IBCLR(m,1),ma,'IBCLR(integer(8),integer)')
+ call c_i8(IBCLR(m,j2),ma,'IBCLR(integer(8),integer(2))')
+ call c_i8(IBCLR(m,k2),ma,'IBCLR(integer(8),integer(1))')
+ call c_i8(IBCLR(m,m2),ma,'IBCLR(integer(8),integer(8))')
+
+c IBSET - Section 13.13.43
+ j = 12
+ j2 = 1
+ ja = 14
+ k = 12
+ k2 = 1
+ ka = 14
+ m = 12
+ m2 = 1
+ ma = 14
+ call c_i(IBSET(12,1),14,'IBSET(integer,integer)')
+ call c_i(IBSET(12,j2),14,'IBSET(integer,integer(2))')
+ call c_i(IBSET(12,k2),14,'IBSET(integer,integer(1))')
+ call c_i(IBSET(12,m2),14,'IBSET(integer,integer(8))')
+ call c_i2(IBSET(j,1),ja,'IBSET(integer(2),integer)')
+ call c_i2(IBSET(j,j2),ja,'IBSET(integer(2),integer(2))')
+ call c_i2(IBSET(j,k2),ja,'IBSET(integer(2),integer(1))')
+ call c_i2(IBSET(j,m2),ja,'IBSET(integer(2),integer(8))')
+ call c_i1(IBSET(k,1),ka,'IBSET(integer(1),integer)')
+ call c_i1(IBSET(k,j2),ka,'IBSET(integer(1),integer(2))')
+ call c_i1(IBSET(k,k2),ka,'IBSET(integer(1),integer(1))')
+ call c_i1(IBSET(k,m2),ka,'IBSET(integer(1),integer(8))')
+ call c_i8(IBSET(m,1),ma,'IBSET(integer(8),integer)')
+ call c_i8(IBSET(m,j2),ma,'IBSET(integer(8),integer(2))')
+ call c_i8(IBSET(m,k2),ma,'IBSET(integer(8),integer(1))')
+ call c_i8(IBSET(m,m2),ma,'IBSET(integer(8),integer(8))')
+
+c IEOR - Section 13.13.45
+ j = 3
+ j2 = 1
+ ja = 2
+ k = 3
+ k2 = 1
+ ka = 2
+ m = 3
+ m2 = 1
+ ma = 2
+ call c_i(IEOR(3,1),2,'IEOR(integer,integer)')
+ call c_i2(IEOR(j,j2),ja,'IEOR(integer(2),integer(2))')
+ call c_i1(IEOR(k,k2),ka,'IEOR(integer(1),integer(1))')
+ call c_i8(IEOR(m,m2),ma,'IEOR(integer(8),integer(8))')
+
+c ISHFT - Section 13.13.49
+ i = 3
+ i2 = 1
+ i3 = 0
+ ia = 6
+ j = 3
+ j2 = 1
+ j3 = 0
+ ja = 6
+ k = 3
+ k2 = 1
+ k3 = 0
+ ka = 6
+ m = 3
+ m2 = 1
+ m3 = 0
+ ma = 6
+ call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)')
+ call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2')
+ call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3')
+ call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4')
+ call c_i2(ISHFT(j,j2),ja,'ISHFT(integer(2),integer(2))')
+ call c_i2(ISHFT(j,BIT_SIZE(j)),j3,
+ $ 'ISHFT(integer(2),integer(2)) 2')
+ call c_i2(ISHFT(j,-BIT_SIZE(j)),j3,
+ $ 'ISHFT(integer(2),integer(2)) 3')
+ call c_i2(ISHFT(j,0),j,'ISHFT(integer(2),integer(2)) 4')
+ call c_i1(ISHFT(k,k2),ka,'ISHFT(integer(1),integer(1))')
+ call c_i1(ISHFT(k,BIT_SIZE(k)),k3,
+ $ 'ISHFT(integer(1),integer(1)) 2')
+ call c_i1(ISHFT(k,-BIT_SIZE(k)),k3,
+ $ 'ISHFT(integer(1),integer(1)) 3')
+ call c_i1(ISHFT(k,0),k,'ISHFT(integer(1),integer(1)) 4')
+ call c_i8(ISHFT(m,m2),ma,'ISHFT(integer(8),integer(8))')
+ call c_i8(ISHFT(m,BIT_SIZE(m)),m3,
+ $ 'ISHFT(integer(8),integer(8)) 2')
+ call c_i8(ISHFT(m,-BIT_SIZE(m)),m3,
+ $ 'ISHFT(integer(8),integer(8)) 3')
+ call c_i8(ISHFT(m,0),m,'ISHFT(integer(8),integer(8)) 4')
+
+c ISHFTC - Section 13.13.50
+c The third argument is not optional in g77
+ i = 3
+ i2 = 2
+ i3 = 3
+ ia = 5
+ j = 3
+ j2 = 2
+ j3 = 3
+ ja = 5
+ k = 3
+ k2 = 2
+ k3 = 3
+ ka = 5
+ m2 = 2
+ m3 = 3
+ ma = 5
+c test all the combinations of arguments
+ call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)')
+ call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer(2))')
+ call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer(1))')
+ call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer(8))')
+ call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer(2),integer)')
+ call c_i(ISHFTC(i,j2,j3),5,
+ & 'ISHFTC(integer,integer(2),integer(2))')
+ call c_i(ISHFTC(i,j2,k3),5,
+ & 'ISHFTC(integer,integer(2),integer(1))')
+ call c_i(ISHFTC(i,j2,m3),5,
+ & 'ISHFTC(integer,integer(2),integer(8))')
+ call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer(1),integer)')
+ call c_i(ISHFTC(i,k2,j3),5,
+ & 'ISHFTC(integer,integer(1),integer(2))')
+ call c_i(ISHFTC(i,k2,k3),5,
+ & 'ISHFTC(integer,integer(1),integer(1))')
+ call c_i(ISHFTC(i,k2,m3),5,
+ & 'ISHFTC(integer,integer(1),integer(8))')
+ call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer(8),integer)')
+ call c_i(ISHFTC(i,m2,j3),5,
+ & 'ISHFTC(integer,integer(8),integer(2))')
+ call c_i(ISHFTC(i,m2,k3),5,
+ & 'ISHFTC(integer,integer(8),integer(1))')
+ call c_i(ISHFTC(i,m2,m3),5,
+ & 'ISHFTC(integer,integer(8),integer(8))')
+
+ call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer(2),integer,integer)')
+ call c_i2(ISHFTC(j,i2,j3),ja,
+ $ 'ISHFTC(integer(2),integer,integer(2))')
+ call c_i2(ISHFTC(j,i2,k3),ja,
+ $ 'ISHFTC(integer(2),integer,integer(1))')
+ call c_i2(ISHFTC(j,i2,m3),ja,
+ $ 'ISHFTC(integer(2),integer,integer(8))')
+ call c_i2(ISHFTC(j,j2,i3),ja,
+ $ 'ISHFTC(integer(2),integer(2),integer)')
+ call c_i2(ISHFTC(j,j2,j3),ja,
+ $ 'ISHFTC(integer(2),integer(2),integer(2))')
+ call c_i2(ISHFTC(j,j2,k3),ja,
+ $ 'ISHFTC(integer(2),integer(2),integer(1))')
+ call c_i2(ISHFTC(j,j2,m3),ja,
+ $ 'ISHFTC(integer(2),integer(2),integer(8))')
+ call c_i2(ISHFTC(j,k2,i3),ja,
+ $ 'ISHFTC(integer(2),integer(1),integer)')
+ call c_i2(ISHFTC(j,k2,j3),ja,
+ $ 'ISHFTC(integer(2),integer(1),integer(2))')
+ call c_i2(ISHFTC(j,k2,k3),ja,
+ $ 'ISHFTC(integer(2),integer(1),integer(1))')
+ call c_i2(ISHFTC(j,k2,m3),ja,
+ $ 'ISHFTC(integer(2),integer(1),integer(8))')
+ call c_i2(ISHFTC(j,m2,i3),ja,
+ $ 'ISHFTC(integer(2),integer(8),integer)')
+ call c_i2(ISHFTC(j,m2,j3),ja,
+ $ 'ISHFTC(integer(2),integer(8),integer(2))')
+ call c_i2(ISHFTC(j,m2,k3),ja,
+ $ 'ISHFTC(integer(2),integer(8),integer(1))')
+ call c_i2(ISHFTC(j,m2,m3),ja,
+ $ 'ISHFTC(integer(2),integer(8),integer(8))')
+
+ call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer(1),integer,integer)')
+ call c_i1(ISHFTC(k,i2,j3),ka,
+ $ 'ISHFTC(integer(1),integer,integer(2))')
+ call c_i1(ISHFTC(k,i2,k3),ka,
+ $ 'ISHFTC(integer(1),integer,integer(1))')
+ call c_i1(ISHFTC(k,i2,m3),ka,
+ $ 'ISHFTC(integer(1),integer,integer(8))')
+ call c_i1(ISHFTC(k,j2,i3),ka,
+ $ 'ISHFTC(integer(1),integer(2),integer)')
+ call c_i1(ISHFTC(k,j2,j3),ka,
+ $ 'ISHFTC(integer(1),integer(2),integer(2))')
+ call c_i1(ISHFTC(k,j2,k3),ka,
+ $ 'ISHFTC(integer(1),integer(2),integer(1))')
+ call c_i1(ISHFTC(k,j2,m3),ka,
+ $ 'ISHFTC(integer(1),integer(2),integer(8))')
+ call c_i1(ISHFTC(k,k2,i3),ka,
+ $ 'ISHFTC(integer(1),integer(1),integer)')
+ call c_i1(ISHFTC(k,k2,j3),ka,
+ $ 'ISHFTC(integer(1),integer(1),integer(2))')
+ call c_i1(ISHFTC(k,k2,k3),ka,
+ $ 'ISHFTC(integer(1),integer(1),integer(1))')
+ call c_i1(ISHFTC(k,k2,m3),ka,
+ $ 'ISHFTC(integer(1),integer(1),integer(8))')
+ call c_i1(ISHFTC(k,m2,i3),ka,
+ $ 'ISHFTC(integer(1),integer(8),integer)')
+ call c_i1(ISHFTC(k,m2,j3),ka,
+ $ 'ISHFTC(integer(1),integer(8),integer(2))')
+ call c_i1(ISHFTC(k,m2,k3),ka,
+ $ 'ISHFTC(integer(1),integer(8),integer(1))')
+ call c_i1(ISHFTC(k,m2,m3),ka,
+ $ 'ISHFTC(integer(1),integer(8),integer(8))')
+
+ call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer(8),integer,integer)')
+ call c_i8(ISHFTC(m,i2,j3),ma,
+ $ 'ISHFTC(integer(8),integer,integer(2))')
+ call c_i8(ISHFTC(m,i2,k3),ma,
+ $ 'ISHFTC(integer(8),integer,integer(1))')
+ call c_i8(ISHFTC(m,i2,m3),ma,
+ $ 'ISHFTC(integer(8),integer,integer(8))')
+ call c_i8(ISHFTC(m,j2,i3),ma,
+ $ 'ISHFTC(integer(8),integer(2),integer)')
+ call c_i8(ISHFTC(m,j2,j3),ma,
+ $ 'ISHFTC(integer(8),integer(2),integer(2))')
+ call c_i8(ISHFTC(m,j2,k3),ma,
+ $ 'ISHFTC(integer(8),integer(2),integer(1))')
+ call c_i8(ISHFTC(m,j2,m3),ma,
+ $ 'ISHFTC(integer(8),integer(2),integer(8))')
+ call c_i8(ISHFTC(m,k2,i3),ma,
+ $ 'ISHFTC(integer(8),integer(1),integer)')
+ call c_i8(ISHFTC(m,k2,j3),ma,
+ $ 'ISHFTC(integer(1),integer(8),integer(2))')
+ call c_i8(ISHFTC(m,k2,k3),ma,
+ $ 'ISHFTC(integer(1),integer(8),integer(1))')
+ call c_i8(ISHFTC(m,k2,m3),ma,
+ $ 'ISHFTC(integer(1),integer(8),integer(8))')
+ call c_i8(ISHFTC(m,m2,i3),ma,
+ $ 'ISHFTC(integer(8),integer(8),integer)')
+ call c_i8(ISHFTC(m,m2,j3),ma,
+ $ 'ISHFTC(integer(8),integer(8),integer(2))')
+ call c_i8(ISHFTC(m,m2,k3),ma,
+ $ 'ISHFTC(integer(8),integer(8),integer(1))')
+ call c_i8(ISHFTC(m,m2,m3),ma,
+ $ 'ISHFTC(integer(8),integer(8),integer(8))')
+
+c test the corner cases
+ call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i,
+ $ 'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer')
+ call c_i(ISHFTC(i,0,BIT_SIZE(i)),i,
+ $ 'ISHFTC(i,0,BIT_SIZE(i)) i = integer')
+ call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i,
+ $ 'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer')
+ call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j,
+ $ 'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer(2)')
+ call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j,
+ $ 'ISHFTC(j,0,BIT_SIZE(j)) j = integer(2)')
+ call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j,
+ $ 'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer(2)')
+ call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k,
+ $ 'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer(1)')
+ call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k,
+ $ 'ISHFTC(k,0,BIT_SIZE(k)) k = integer(1)')
+ call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k,
+ $ 'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer(1)')
+ call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m,
+ $ 'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer(8)')
+ call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m,
+ $ 'ISHFTC(m,0,BIT_SIZE(m)) m = integer(8)')
+ call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m,
+ $ 'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer(8)')
+
+c MVBITS - Section 13.13.74
+ i = 6
+ call MVBITS(7,2,2,i,0)
+ call c_i(i,5,'MVBITS 1')
+ j = 6
+ j2 = 7
+ ja = 5
+ call MVBITS(j2,2,2,j,0)
+ call c_i2(j,ja,'MVBITS 2')
+ k = 6
+ k2 = 7
+ ka = 5
+ call MVBITS(k2,2,2,k,0)
+ call c_i1(k,ka,'MVBITS 3')
+ m = 6
+ m2 = 7
+ ma = 5
+ call MVBITS(m2,2,2,m,0)
+ call c_i8(m,ma,'MVBITS 4')
+
+c NOT - Section 13.13.77
+c Rather than assume integer sizes, mask off high bits
+ j = 21
+ j2 = 31
+ ja = 10
+ k = 21
+ k2 = 31
+ ka = 10
+ m = 21
+ m2 = 31
+ ma = 10
+ call c_i(IAND(NOT(21),31),10,'NOT(integer)')
+ call c_i2(IAND(NOT(j),j2),ja,'NOT(integer(2))')
+ call c_i1(IAND(NOT(k),k2),ka,'NOT(integer(1))')
+ call c_i8(IAND(NOT(m),m2),ma,'NOT(integer(8))')
+
+ if ( fail ) call abort()
+ end
+
+ subroutine failure(label)
+c Report failure and set flag
+ character*(*) label
+ logical fail
+ common /flags/ fail
+ write(6,'(a,a,a)') 'Test ',label,' FAILED'
+ fail = .true.
+ end
+
+ subroutine c_l(i,j,label)
+c Check if LOGICAL i equals j, and fail otherwise
+ logical i,j
+ character*(*) label
+ if ( i .eqv. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_i(i,j,label)
+c Check if INTEGER i equals j, and fail otherwise
+ integer i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_i2(i,j,label)
+c Check if INTEGER(kind=2) i equals j, and fail otherwise
+ integer(kind=2) i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_i1(i,j,label)
+c Check if INTEGER(kind=1) i equals j, and fail otherwise
+ integer(kind=1) i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
+
+ subroutine c_i8(i,j,label)
+c Check if INTEGER(kind=8) i equals j, and fail otherwise
+ integer(kind=8) i,j
+ character*(*) label
+ if ( i .ne. j ) then
+ call failure(label)
+ write(6,*) 'Got ',i,' expected ', j
+ end if
+ end
Index: labug1.f
===================================================================
--- labug1.f (nonexistent)
+++ labug1.f (revision 816)
@@ -0,0 +1,58 @@
+c { dg-do run }
+ PROGRAM LABUG1
+
+* This program core dumps on mips-sgi-irix6.2 when compiled
+* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots
+* with -O2
+*
+* Originally derived from LAPACK test suite.
+* Almost any change allows it to run.
+*
+* David Billinghurst, (David.Billinghurst@riotinto.com.au)
+* 25 November 1998
+*
+* .. Parameters ..
+ INTEGER LDA, LDE
+ PARAMETER ( LDA = 2500, LDE = 50 )
+ COMPLEX CZERO
+ PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
+
+ INTEGER I, J, M, N
+ REAL V
+ COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE)
+ COMPLEX Z
+
+ N=2
+ M=1
+*
+ do i = 1, m
+ do j = 1, n
+ e(i,j) = czero
+ f(i,j) = czero
+ end do
+ end do
+*
+ DO J = 1, N
+ DO I = 1, M
+ V = ABS( E(I,J) - F(I,J) )
+ END DO
+ END DO
+
+ CALL SUB2(M,Z)
+
+ END
+
+ subroutine SUB2(I,A)
+ integer i
+ complex a
+ end
+
+
+
+
+
+
+
+
+
+
Index: 980628-3.f
===================================================================
--- 980628-3.f (nonexistent)
+++ 980628-3.f (revision 816)
@@ -0,0 +1,59 @@
+c { dg-do run }
+c { dg-options "-std=gnu" }
+c
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+ save
+
+ character c1(11), c2(11), c3(11)
+ real r1, r2, r3
+ character c4, c5, c6
+ equivalence (c1(2), r1)
+ equivalence (c2(2), r2)
+ equivalence (c3(2), r3)
+
+ c1(1) = '1'
+ r1 = 1.
+ c1(11) = '1'
+ c4 = '4'
+ c2(1) = '2'
+ r2 = 2.
+ c2(11) = '2'
+ c5 = '5'
+ c3(1) = '3'
+ r3 = 3.
+ c3(11) = '3'
+ c6 = '6'
+
+ call x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
+
+ end
+
+ subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
+ implicit none
+
+ character c1(11), c2(11), c3(11)
+ real r1, r2, r3
+ character c4, c5, c6
+
+ if (c1(1) .ne. '1') call abort
+ if (r1 .ne. 1.) call abort
+ if (c1(11) .ne. '1') call abort
+ if (c4 .ne. '4') call abort
+ if (c2(1) .ne. '2') call abort
+ if (r2 .ne. 2.) call abort
+ if (c2(11) .ne. '2') call abort
+ if (c5 .ne. '5') call abort
+ if (c3(1) .ne. '3') call abort
+ if (r3 .ne. 3.) call abort
+ if (c3(11) .ne. '3') call abort
+ if (c6 .ne. '6') call abort
+
+ end
Index: 19990525-0.f
===================================================================
--- 19990525-0.f (nonexistent)
+++ 19990525-0.f (revision 816)
@@ -0,0 +1,51 @@
+c { dg-do compile }
+* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
+* Precedence: bulk
+* Sender: owner-egcs-bugs@egcs.cygnus.com
+* From: "Bjorn R. Bjornsson"
+* Subject: g77 char expr. as arg to subroutine bug
+* To: egcs-bugs@egcs.cygnus.com
+* Date: Tue, 25 May 1999 14:45:56 +0000 (GMT)
+* Content-Type: text/plain; charset=US-ASCII
+* X-UIDL: 06000c94269ed6dfe826493e52a818b9
+*
+* The following bug is in all snapshots starting
+* from April 18. I have only tested this on Alpha linux,
+* and with FFECOM_FASTER_ARRAY_REFS set to 1.
+*
+* Run the following through g77:
+*
+ subroutine a
+ character*2 string1
+ character*2 string2
+ character*4 string3
+ string1 = 's1'
+ string2 = 's2'
+c
+c the next 2 lines are ok.
+ string3 = (string1 // string2)
+ call b(string1//string2)
+c
+c this line gives gcc/f/com.c:10660: failed assertion `hook'
+ call b((string1//string2))
+ end
+*
+* the output from:
+*
+* /usr/local/egcs-19990418/bin/g77 --verbose -c D.f
+*
+* is:
+*
+* on egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (from FSF-g77 version 0.5.24-19990418)
+* Reading specs from /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/specs
+* gcc version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental)
+* /usr/local/egcs-19990418/lib/gcc-lib/alphaev56-unknown-linux-gnu/egcs-2.93.19/f771 D.f -quiet -dumpbase D.f -version -fversion -o /tmp/ccNpaaaa.s
+* GNU F77 version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental) (alphaev56-unknown-linux-gnu) compiled by GNU C version egcs-2.93.19 19990418 (gcc2 ss-980929 experimental).
+* GNU Fortran Front End version 0.5.24-19990418
+* ../../../egcs-19990418/gcc/f/com.c:10351: failed assertion `hook'
+* g77: Internal compiler error: program f771 got fatal signal 6
+*
+* Yours,
+*
+* Bjorn R. Bjornsson
+* brb@halo.hi.is
Index: 980628-7.f
===================================================================
--- 980628-7.f (nonexistent)
+++ 980628-7.f (revision 816)
@@ -0,0 +1,63 @@
+c { dg-do run }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+ equivalence (d1, r1(2))
+ equivalence (d2, r2(2))
+ equivalence (d3, r3(2))
+
+ r1(1) = 1.
+ d1 = 10.
+ r1(4) = 1.
+ r1(5) = 1.
+ i1 = 1
+ r2(1) = 2.
+ d2 = 20.
+ r2(4) = 2.
+ r2(5) = 2.
+ i2 = 2
+ r3(1) = 3.
+ d3 = 30.
+ r3(4) = 3.
+ r3(5) = 3.
+ i3 = 3
+
+ call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+
+ end
+
+ subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+
+ if (r1(1) .ne. 1.) call abort
+ if (d1 .ne. 10.) call abort
+ if (r1(4) .ne. 1.) call abort
+ if (r1(5) .ne. 1.) call abort
+ if (i1 .ne. 1) call abort
+ if (r2(1) .ne. 2.) call abort
+ if (d2 .ne. 20.) call abort
+ if (r2(4) .ne. 2.) call abort
+ if (r2(5) .ne. 2.) call abort
+ if (i2 .ne. 2) call abort
+ if (r3(1) .ne. 3.) call abort
+ if (d3 .ne. 30.) call abort
+ if (r3(4) .ne. 3.) call abort
+ if (r3(5) .ne. 3.) call abort
+ if (i3 .ne. 3) call abort
+
+ end
+
Index: 19990905-1.f
===================================================================
--- 19990905-1.f (nonexistent)
+++ 19990905-1.f (revision 816)
@@ -0,0 +1,19 @@
+c { dg-do compile }
+c
+c g77 gave error
+c 19990905-1.f: In subroutine `x':
+c 19990905-1.f:15:
+c common /foo/n
+c 1
+c 19990905-1.f:18: (continued):
+c call foo(a(1))
+c 2
+c Invalid declaration of or reference to symbol `foo' at (2) [initially seen at (1)]
+* =foo7.f in Burley's g77 test suite.
+ subroutine x
+ real a(n)
+ common /foo/n ! { dg-error "is already being used as a COMMON" }
+ continue
+ entry y(a)
+ call foo(a(1)) ! { dg-error "is already being used as a COMMON" }
+ end
Index: complex_1.f
===================================================================
--- complex_1.f (nonexistent)
+++ complex_1.f (revision 816)
@@ -0,0 +1,19 @@
+c { dg-do run }
+ program complex_1
+ complex z0, z1, z2
+
+ z0 = cmplx(0.,.5)
+ z1 = 1./z0
+ if (z1 .ne. cmplx(0.,-2)) call abort
+
+ z0 = 10.*z0
+ if (z0 .ne. cmplx(0.,5.)) call abort
+
+ z2 = cmplx(1.,2.)
+ z1 = z0/z2
+ if (z1 .ne. cmplx(2.,1.)) call abort
+
+ z1 = z0*z2
+ if (z1 .ne. cmplx(-10.,5.)) call abort
+ end
+
Index: 19990826-1.f
===================================================================
--- 19990826-1.f (nonexistent)
+++ 19990826-1.f (revision 816)
@@ -0,0 +1,287 @@
+c { dg-do compile }
+* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST)
+* From: Jonathan Ravens
+* To: gcc-bugs@gcc.gnu.org
+* Subject: g77 bug report
+* X-UIDL: a0bf5ecc21487cde48d9104983ab04d6
+
+! This fortran source will not compile - if the penultimate elseif block is 0
+! included then the message appears :
+!
+! /usr/src/egcs//gcc-2.95.1/gcc/f/stw.c:308: failed assertion `b->uses_ > 0'
+! g77: Internal compiler error: program f771 got fatal signal 6
+!
+! The command was : g77 -c
+!
+! The OS is Red Hat 6, and the output from uname -a is
+! Linux grfw1452.gns.cri.nz 2.2.5-15 #1 Mon Apr 19 23:00:46 EDT 1999 i686 unknown
+!
+! The configure script I used was
+! /usr/src/egcs/gcc/gcc-2.95.1/configure --enable-languages=f77 i585-unknown-linux
+!
+! I was installing 2.95 because under EGCS 2.1.1 none of my code was working
+! with optimisation turned on, and there were still bugs with no optimisation
+! (all of which code works fine under g77 0.5.21 and Sun/IBM/Dec/HP fortrans).
+!
+! The version of g77 is :
+!
+!g77 version 2.95.1 19990816 (release) (from FSF-g77 version 0.5.25 19990816 (release))
+
+ program main
+ if (i.eq.1) then
+ call abc(1)
+ else if (i.eq. 1) then
+ call abc( 1)
+ else if (i.eq. 2) then
+ call abc( 2)
+ else if (i.eq. 3) then
+ call abc( 3)
+ else if (i.eq. 4) then
+ call abc( 4)
+ else if (i.eq. 5) then
+ call abc( 5)
+ else if (i.eq. 6) then
+ call abc( 6)
+ else if (i.eq. 7) then
+ call abc( 7)
+ else if (i.eq. 8) then
+ call abc( 8)
+ else if (i.eq. 9) then
+ call abc( 9)
+ else if (i.eq. 10) then
+ call abc( 10)
+ else if (i.eq. 11) then
+ call abc( 11)
+ else if (i.eq. 12) then
+ call abc( 12)
+ else if (i.eq. 13) then
+ call abc( 13)
+ else if (i.eq. 14) then
+ call abc( 14)
+ else if (i.eq. 15) then
+ call abc( 15)
+ else if (i.eq. 16) then
+ call abc( 16)
+ else if (i.eq. 17) then
+ call abc( 17)
+ else if (i.eq. 18) then
+ call abc( 18)
+ else if (i.eq. 19) then
+ call abc( 19)
+ else if (i.eq. 20) then
+ call abc( 20)
+ else if (i.eq. 21) then
+ call abc( 21)
+ else if (i.eq. 22) then
+ call abc( 22)
+ else if (i.eq. 23) then
+ call abc( 23)
+ else if (i.eq. 24) then
+ call abc( 24)
+ else if (i.eq. 25) then
+ call abc( 25)
+ else if (i.eq. 26) then
+ call abc( 26)
+ else if (i.eq. 27) then
+ call abc( 27)
+ else if (i.eq. 28) then
+ call abc( 28)
+ else if (i.eq. 29) then
+ call abc( 29)
+ else if (i.eq. 30) then
+ call abc( 30)
+ else if (i.eq. 31) then
+ call abc( 31)
+ else if (i.eq. 32) then
+ call abc( 32)
+ else if (i.eq. 33) then
+ call abc( 33)
+ else if (i.eq. 34) then
+ call abc( 34)
+ else if (i.eq. 35) then
+ call abc( 35)
+ else if (i.eq. 36) then
+ call abc( 36)
+ else if (i.eq. 37) then
+ call abc( 37)
+ else if (i.eq. 38) then
+ call abc( 38)
+ else if (i.eq. 39) then
+ call abc( 39)
+ else if (i.eq. 40) then
+ call abc( 40)
+ else if (i.eq. 41) then
+ call abc( 41)
+ else if (i.eq. 42) then
+ call abc( 42)
+ else if (i.eq. 43) then
+ call abc( 43)
+ else if (i.eq. 44) then
+ call abc( 44)
+ else if (i.eq. 45) then
+ call abc( 45)
+ else if (i.eq. 46) then
+ call abc( 46)
+ else if (i.eq. 47) then
+ call abc( 47)
+ else if (i.eq. 48) then
+ call abc( 48)
+ else if (i.eq. 49) then
+ call abc( 49)
+ else if (i.eq. 50) then
+ call abc( 50)
+ else if (i.eq. 51) then
+ call abc( 51)
+ else if (i.eq. 52) then
+ call abc( 52)
+ else if (i.eq. 53) then
+ call abc( 53)
+ else if (i.eq. 54) then
+ call abc( 54)
+ else if (i.eq. 55) then
+ call abc( 55)
+ else if (i.eq. 56) then
+ call abc( 56)
+ else if (i.eq. 57) then
+ call abc( 57)
+ else if (i.eq. 58) then
+ call abc( 58)
+ else if (i.eq. 59) then
+ call abc( 59)
+ else if (i.eq. 60) then
+ call abc( 60)
+ else if (i.eq. 61) then
+ call abc( 61)
+ else if (i.eq. 62) then
+ call abc( 62)
+ else if (i.eq. 63) then
+ call abc( 63)
+ else if (i.eq. 64) then
+ call abc( 64)
+ else if (i.eq. 65) then
+ call abc( 65)
+ else if (i.eq. 66) then
+ call abc( 66)
+ else if (i.eq. 67) then
+ call abc( 67)
+ else if (i.eq. 68) then
+ call abc( 68)
+ else if (i.eq. 69) then
+ call abc( 69)
+ else if (i.eq. 70) then
+ call abc( 70)
+ else if (i.eq. 71) then
+ call abc( 71)
+ else if (i.eq. 72) then
+ call abc( 72)
+ else if (i.eq. 73) then
+ call abc( 73)
+ else if (i.eq. 74) then
+ call abc( 74)
+ else if (i.eq. 75) then
+ call abc( 75)
+ else if (i.eq. 76) then
+ call abc( 76)
+ else if (i.eq. 77) then
+ call abc( 77)
+ else if (i.eq. 78) then
+ call abc( 78)
+ else if (i.eq. 79) then
+ call abc( 79)
+ else if (i.eq. 80) then
+ call abc( 80)
+ else if (i.eq. 81) then
+ call abc( 81)
+ else if (i.eq. 82) then
+ call abc( 82)
+ else if (i.eq. 83) then
+ call abc( 83)
+ else if (i.eq. 84) then
+ call abc( 84)
+ else if (i.eq. 85) then
+ call abc( 85)
+ else if (i.eq. 86) then
+ call abc( 86)
+ else if (i.eq. 87) then
+ call abc( 87)
+ else if (i.eq. 88) then
+ call abc( 88)
+ else if (i.eq. 89) then
+ call abc( 89)
+ else if (i.eq. 90) then
+ call abc( 90)
+ else if (i.eq. 91) then
+ call abc( 91)
+ else if (i.eq. 92) then
+ call abc( 92)
+ else if (i.eq. 93) then
+ call abc( 93)
+ else if (i.eq. 94) then
+ call abc( 94)
+ else if (i.eq. 95) then
+ call abc( 95)
+ else if (i.eq. 96) then
+ call abc( 96)
+ else if (i.eq. 97) then
+ call abc( 97)
+ else if (i.eq. 98) then
+ call abc( 98)
+ else if (i.eq. 99) then
+ call abc( 99)
+ else if (i.eq. 100) then
+ call abc( 100)
+ else if (i.eq. 101) then
+ call abc( 101)
+ else if (i.eq. 102) then
+ call abc( 102)
+ else if (i.eq. 103) then
+ call abc( 103)
+ else if (i.eq. 104) then
+ call abc( 104)
+ else if (i.eq. 105) then
+ call abc( 105)
+ else if (i.eq. 106) then
+ call abc( 106)
+ else if (i.eq. 107) then
+ call abc( 107)
+ else if (i.eq. 108) then
+ call abc( 108)
+ else if (i.eq. 109) then
+ call abc( 109)
+ else if (i.eq. 110) then
+ call abc( 110)
+ else if (i.eq. 111) then
+ call abc( 111)
+ else if (i.eq. 112) then
+ call abc( 112)
+ else if (i.eq. 113) then
+ call abc( 113)
+ else if (i.eq. 114) then
+ call abc( 114)
+ else if (i.eq. 115) then
+ call abc( 115)
+ else if (i.eq. 116) then
+ call abc( 116)
+ else if (i.eq. 117) then
+ call abc( 117)
+ else if (i.eq. 118) then
+ call abc( 118)
+ else if (i.eq. 119) then
+ call abc( 119)
+ else if (i.eq. 120) then
+ call abc( 120)
+ else if (i.eq. 121) then
+ call abc( 121)
+ else if (i.eq. 122) then
+ call abc( 122)
+ else if (i.eq. 123) then
+ call abc( 123)
+ else if (i.eq. 124) then
+ call abc( 124)
+ else if (i.eq. 125) then !< Miscompiles if present
+ call abc( 125) !<
+
+c else if (i.eq. 126) then
+c call abc( 126)
+ endif
+ end
Index: 980310-3.f
===================================================================
--- 980310-3.f (nonexistent)
+++ 980310-3.f (revision 816)
@@ -0,0 +1,260 @@
+c { dg-do compile }
+c
+c This demonstrates a problem with g77 and pic on x86 where
+c egcs 1.0.1 and earlier will generate bogus assembler output.
+c unfortunately, gas accepts the bogus acssembler output and
+c generates code that almost works.
+c
+
+
+C Date: Wed, 17 Dec 1997 23:20:29 +0000
+C From: Joao Cardoso
+C To: egcs-bugs@cygnus.com
+C Subject: egcs-1.0 f77 bug on OSR5
+C When trying to compile the Fortran file that I enclose bellow,
+C I got an assembler error:
+C
+C ./g77 -B./ -fpic -O -c scaleg.f
+C /usr/tmp/cca002D8.s:123:syntax error at (
+C
+C ./g77 -B./ -fpic -O0 -c scaleg.f
+C /usr/tmp/cca002EW.s:246:invalid operand combination: leal
+C
+C Compiling without the -fpic flag runs OK.
+
+ subroutine scaleg (n,ma,a,mb,b,low,igh,cscale,cperm,wk)
+c
+c *****parameters:
+ integer igh,low,ma,mb,n
+ double precision a(ma,n),b(mb,n),cperm(n),cscale(n),wk(n,6)
+c
+c *****local variables:
+ integer i,ir,it,j,jc,kount,nr,nrp2
+ double precision alpha,basl,beta,cmax,coef,coef2,coef5,cor,
+ * ew,ewc,fi,fj,gamma,pgamma,sum,t,ta,tb,tc
+c
+c *****fortran functions:
+ double precision dabs, dlog10, dsign
+c float
+c
+c *****subroutines called:
+c none
+c
+c ---------------------------------------------------------------
+c
+c *****purpose:
+c scales the matrices a and b in the generalized eigenvalue
+c problem a*x = (lambda)*b*x such that the magnitudes of the
+c elements of the submatrices of a and b (as specified by low
+c and igh) are close to unity in the least squares sense.
+c ref.: ward, r. c., balancing the generalized eigenvalue
+c problem, siam j. sci. stat. comput., vol. 2, no. 2, june 1981,
+c 141-152.
+c
+c *****parameter description:
+c
+c on input:
+c
+c ma,mb integer
+c row dimensions of the arrays containing matrices
+c a and b respectively, as declared in the main calling
+c program dimension statement;
+c
+c n integer
+c order of the matrices a and b;
+c
+c a real(ma,n)
+c contains the a matrix of the generalized eigenproblem
+c defined above;
+c
+c b real(mb,n)
+c contains the b matrix of the generalized eigenproblem
+c defined above;
+c
+c low integer
+c specifies the beginning -1 for the rows and
+c columns of a and b to be scaled;
+c
+c igh integer
+c specifies the ending -1 for the rows and columns
+c of a and b to be scaled;
+c
+c cperm real(n)
+c work array. only locations low through igh are
+c referenced and altered by this subroutine;
+c
+c wk real(n,6)
+c work array that must contain at least 6*n locations.
+c only locations low through igh, n+low through n+igh,
+c ..., 5*n+low through 5*n+igh are referenced and
+c altered by this subroutine.
+c
+c on output:
+c
+c a,b contain the scaled a and b matrices;
+c
+c cscale real(n)
+c contains in its low through igh locations the integer
+c exponents of 2 used for the column scaling factors.
+c the other locations are not referenced;
+c
+c wk contains in its low through igh locations the integer
+c exponents of 2 used for the row scaling factors.
+c
+c *****algorithm notes:
+c none.
+c
+c *****history:
+c written by r. c. ward.......
+c modified 8/86 by bobby bodenheimer so that if
+c sum = 0 (corresponding to the case where the matrix
+c doesn't need to be scaled) the routine returns.
+c
+c ---------------------------------------------------------------
+c
+ if (low .eq. igh) go to 410
+ do 210 i = low,igh
+ wk(i,1) = 0.0d0
+ wk(i,2) = 0.0d0
+ wk(i,3) = 0.0d0
+ wk(i,4) = 0.0d0
+ wk(i,5) = 0.0d0
+ wk(i,6) = 0.0d0
+ cscale(i) = 0.0d0
+ cperm(i) = 0.0d0
+ 210 continue
+c
+c compute right side vector in resulting linear equations
+c
+ basl = dlog10(2.0d0)
+ do 240 i = low,igh
+ do 240 j = low,igh
+ tb = b(i,j)
+ ta = a(i,j)
+ if (ta .eq. 0.0d0) go to 220
+ ta = dlog10(dabs(ta)) / basl
+ 220 continue
+ if (tb .eq. 0.0d0) go to 230
+ tb = dlog10(dabs(tb)) / basl
+ 230 continue
+ wk(i,5) = wk(i,5) - ta - tb
+ wk(j,6) = wk(j,6) - ta - tb
+ 240 continue
+ nr = igh-low+1
+ coef = 1.0d0/float(2*nr)
+ coef2 = coef*coef
+ coef5 = 0.5d0*coef2
+ nrp2 = nr+2
+ beta = 0.0d0
+ it = 1
+c
+c start generalized conjugate gradient iteration
+c
+ 250 continue
+ ew = 0.0d0
+ ewc = 0.0d0
+ gamma = 0.0d0
+ do 260 i = low,igh
+ gamma = gamma + wk(i,5)*wk(i,5) + wk(i,6)*wk(i,6)
+ ew = ew + wk(i,5)
+ ewc = ewc + wk(i,6)
+ 260 continue
+ gamma = coef*gamma - coef2*(ew**2 + ewc**2)
+ + - coef5*(ew - ewc)**2
+ if (it .ne. 1) beta = gamma / pgamma
+ t = coef5*(ewc - 3.0d0*ew)
+ tc = coef5*(ew - 3.0d0*ewc)
+ do 270 i = low,igh
+ wk(i,2) = beta*wk(i,2) + coef*wk(i,5) + t
+ cperm(i) = beta*cperm(i) + coef*wk(i,6) + tc
+ 270 continue
+c
+c apply matrix to vector
+c
+ do 300 i = low,igh
+ kount = 0
+ sum = 0.0d0
+ do 290 j = low,igh
+ if (a(i,j) .eq. 0.0d0) go to 280
+ kount = kount+1
+ sum = sum + cperm(j)
+ 280 continue
+ if (b(i,j) .eq. 0.0d0) go to 290
+ kount = kount+1
+ sum = sum + cperm(j)
+ 290 continue
+ wk(i,3) = float(kount)*wk(i,2) + sum
+ 300 continue
+ do 330 j = low,igh
+ kount = 0
+ sum = 0.0d0
+ do 320 i = low,igh
+ if (a(i,j) .eq. 0.0d0) go to 310
+ kount = kount+1
+ sum = sum + wk(i,2)
+ 310 continue
+ if (b(i,j) .eq. 0.0d0) go to 320
+ kount = kount+1
+ sum = sum + wk(i,2)
+ 320 continue
+ wk(j,4) = float(kount)*cperm(j) + sum
+ 330 continue
+ sum = 0.0d0
+ do 340 i = low,igh
+ sum = sum + wk(i,2)*wk(i,3) + cperm(i)*wk(i,4)
+ 340 continue
+ if(sum.eq.0.0d0) return
+ alpha = gamma / sum
+c
+c determine correction to current iterate
+c
+ cmax = 0.0d0
+ do 350 i = low,igh
+ cor = alpha * wk(i,2)
+ if (dabs(cor) .gt. cmax) cmax = dabs(cor)
+ wk(i,1) = wk(i,1) + cor
+ cor = alpha * cperm(i)
+ if (dabs(cor) .gt. cmax) cmax = dabs(cor)
+ cscale(i) = cscale(i) + cor
+ 350 continue
+ if (cmax .lt. 0.5d0) go to 370
+ do 360 i = low,igh
+ wk(i,5) = wk(i,5) - alpha*wk(i,3)
+ wk(i,6) = wk(i,6) - alpha*wk(i,4)
+ 360 continue
+ pgamma = gamma
+ it = it+1
+ if (it .le. nrp2) go to 250
+c
+c end generalized conjugate gradient iteration
+c
+ 370 continue
+ do 380 i = low,igh
+ ir = wk(i,1) + dsign(0.5d0,wk(i,1))
+ wk(i,1) = ir
+ jc = cscale(i) + dsign(0.5d0,cscale(i))
+ cscale(i) = jc
+ 380 continue
+c
+c scale a and b
+c
+ do 400 i = 1,igh
+ ir = wk(i,1)
+ fi = 2.0d0**ir
+ if (i .lt. low) fi = 1.0d0
+ do 400 j =low,n
+ jc = cscale(j)
+ fj = 2.0d0**jc
+ if (j .le. igh) go to 390
+ if (i .lt. low) go to 400
+ fj = 1.0d0
+ 390 continue
+ a(i,j) = a(i,j)*fi*fj
+ b(i,j) = b(i,j)*fi*fj
+ 400 continue
+ 410 continue
+ return
+c
+c last line of scaleg
+c
+ end
Index: cpp4.F
===================================================================
--- cpp4.F (nonexistent)
+++ cpp4.F (revision 816)
@@ -0,0 +1,12 @@
+ ! { dg-do run }
+C The preprocessor must not mangle Hollerith constants
+C which contain apostrophes.
+ integer i
+ character*4 j
+ data i /4hbla'/
+ write (j, '(4a)') i
+ if (j .ne. "bla'") call abort
+ end
+
+ ! { dg-warning "Hollerith constant" "const" { target *-*-* } 6 }
+ ! { dg-warning "Conversion" "conversion" { target *-*-* } 6 }
Index: 960317-1.f
===================================================================
--- 960317-1.f (nonexistent)
+++ 960317-1.f (revision 816)
@@ -0,0 +1,104 @@
+c { dg-do compile }
+* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST)
+* From: Kate Hedstrom
+* To: burley@gnu.ai.mit.edu
+* Subject: g77 bug in assign
+*
+* I found some files in the NCAR graphics source code which used to
+* compile with g77 and now don't. All contain the following combination
+* of "save" and "assign". It fails on a Sun running SunOS 4.1.3 and a
+* Sun running SunOS 5.5 (slightly older g77), but compiles on an
+* IBM/RS6000:
+*
+C
+ SUBROUTINE QUICK
+ SAVE
+C
+ ASSIGN 101 TO JUMP ! { dg-warning "Obsolete: ASSIGN" "" }
+ 101 Continue
+C
+ RETURN
+ END
+*
+* Everything else in the NCAR distribution compiled, including quite a
+* few C routines.
+*
+* Kate
+*
+*
+* nemo% g77 -v -c quick.f
+* gcc -v -c -xf77 quick.f
+* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/specs
+* gcc version 2.7.2
+* /usr/local/lib/gcc-lib/sparc-sun-sunos4.1.3/2.7.2/f771 quick.f -fset-g77-defaults -quiet -dumpbase quick.f -version -fversion -o /usr/tmp/cca24166.s
+* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.1.
+* GNU Fortran Front End version 0.5.18-960314 compiled: Mar 16 1996 14:28:11
+* gcc: Internal compiler error: program f771 got fatal signal 11
+*
+*
+* nemo% gdb /usr/local/lib/gcc-lib/*/*/f771 core
+* GDB is free software and you are welcome to distribute copies of it
+* under certain conditions; type "show copying" to see the conditions.
+* There is absolutely no warranty for GDB; type "show warranty" for details.
+* GDB 4.14 (sparc-sun-sunos4.1.3),
+* Copyright 1995 Free Software Foundation, Inc...
+* Core was generated by `f771'.
+* Program terminated with signal 11, Segmentation fault.
+* Couldn't read input and local registers from core file
+* find_solib: Can't read pathname for load map: I/O error
+*
+* Couldn't read input and local registers from core file
+* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881
+* 7881 if ((ffesymbol_save (s) || ffe_is_saveall ())
+* (gdb) where
+* #0 0x21aa4 in ffecom_sym_transform_assign_ (s=???) at f/com.c:7881
+* Error accessing memory address 0xefffefcc: Invalid argument.
+* (gdb)
+*
+*
+* ahab% g77 -v -c quick.f
+* gcc -v -c -xf77 quick.f
+* Reading specs from /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/specs
+* gcc version 2.7.2
+* /usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase quick.f -version -fversion -o /var/tmp/cca003D2.s
+* GNU F77 version 2.7.2 (sparc) compiled by GNU C version 2.7.2.
+* GNU Fortran Front End version 0.5.18-960304 compiled: Mar 5 1996 16:12:46
+* gcc: Internal compiler error: program f771 got fatal signal 11
+*
+*
+* ahab% !gdb
+* gdb /usr/local/lib/gcc-lib/*/*/f771 core
+* GDB is free software and you are welcome to distribute copies of it
+* under certain conditions; type "show copying" to see the conditions.
+* There is absolutely no warranty for GDB; type "show warranty" for details.
+* GDB 4.15.1 (sparc-sun-solaris2.4),
+* Copyright 1995 Free Software Foundation, Inc...
+* Core was generated by
+* `/usr/local/lib/gcc-lib/sparc-sun-solaris2.5/2.7.2/f771 quick.f -quiet -dumpbase'.
+* Program terminated with signal 11, Segmentation fault.
+* Reading symbols from /usr/lib/libc.so.1...done.
+* Reading symbols from /usr/lib/libdl.so.1...done.
+* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963
+* Source file is more recent than executable.
+* 7963 assert (st != NULL);
+* (gdb) where
+* #0 0x43e04 in ffecom_sym_transform_assign_ (s=0x3a22f8) at f/com.c:7963
+* #1 0x38044 in ffecom_expr_ (expr=0x3a23c0, dest_tree=0x0, dest=0x0, dest_used=0x0, assignp=true) at f/com.c:2100
+* #2 0x489c8 in ffecom_expr_assign_w (expr=0x3a23c0) at f/com.c:10238
+* #3 0xe9228 in ffeste_R838 (label=0x3a1ba8, target=0x3a23c0) at f/ste.c:2769
+* #4 0xdae60 in ffestd_stmt_pass_ () at f/std.c:840
+* #5 0xdc090 in ffestd_exec_end () at f/std.c:1405
+* #6 0xcb534 in ffestc_shriek_subroutine_ (ok=true) at f/stc.c:4849
+* #7 0xd8f00 in ffestc_R1225 (name=0x0) at f/stc.c:12307
+* #8 0xcc808 in ffestc_end () at f/stc.c:5572
+* #9 0x9fa84 in ffestb_end3_ (t=0x3a19c8) at f/stb.c:3216
+* #10 0x9f30c in ffestb_end (t=0x3a19c8) at f/stb.c:2995
+* #11 0x98414 in ffesta_save_ (t=0x3a19c8) at f/sta.c:453
+* #12 0x997ec in ffesta_second_ (t=0x3a19c8) at f/sta.c:1178
+* #13 0x8ed84 in ffelex_send_token_ () at f/lex.c:1614
+* #14 0x8cab8 in ffelex_finish_statement_ () at f/lex.c:946
+* #15 0x91684 in ffelex_file_fixed (wf=0x397780, f=0x37a560) at f/lex.c:2946
+* #16 0x107a94 in ffe_file (wf=0x397780, f=0x37a560) at f/top.c:456
+* #17 0x96218 in yyparse () at f/parse.c:77
+* #18 0x10beac in compile_file (name=0xdffffaf7 "quick.f") at toplev.c:2239
+* #19 0x110dc0 in main (argc=9, argv=0xdffff994, envp=0xdffff9bc) at toplev.c:3927
Index: 980310-7.f
===================================================================
--- 980310-7.f (nonexistent)
+++ 980310-7.f (revision 816)
@@ -0,0 +1,51 @@
+c { dg-do compile }
+C From: "David C. Doherty"
+C Message-Id: <199711171846.MAA27947@uh.msc.edu>
+C Subject: g77: auto arrays + goto = no go
+C To: egcs-bugs@cygnus.com
+C Date: Mon, 17 Nov 1997 12:46:27 -0600 (CST)
+
+C I sent the following to fortran@gnu.ai.mit.edu, and Dave Love
+C replied that he was able to reproduce it on rs6000-aix; not on
+C others. He suggested that I send it to egcs-bugs.
+
+C Hi - I've observed the following behavior regarding
+C automatic arrays and gotos. Seems similar to what I found
+C in the docs about computed gotos (but not exactly the same).
+C
+C I suspect from the nature of the error msg that it's in the GBE.
+C
+C I'm using egcs-971105, under linux-ppc.
+C
+C I also observed the same in g77-0.5.19 (and gcc 2.7.2?).
+C
+C I'd appreciate any advice on this. thanks for the great work.
+C --
+C >cat testg77.f
+ subroutine testg77(n, a)
+c
+ implicit none
+c
+ integer n
+ real a(n)
+ real b(n)
+ integer i
+c
+ do i = 1, 10
+ if (i .gt. 4) goto 100
+ write(0, '(i2)')i
+ enddo
+c
+ goto 200
+100 continue
+200 continue
+c
+ return
+ end
+C >g77 -c testg77.f
+C testg77.f: In subroutine `testg77':
+C testg77.f:19: label `200' used before containing binding contour
+C testg77.f:18: label `100' used before containing binding contour
+C --
+C If I comment out the b(n) line or replace it with, e.g., b(10),
+C it compiles fine.
Index: 980615-0.f
===================================================================
--- 980615-0.f (nonexistent)
+++ 980615-0.f (revision 816)
@@ -0,0 +1,12 @@
+c { dg-do compile }
+* Fixed by JCB 1998-07-25 change to stc.c.
+
+* Date: Thu, 11 Jun 1998 22:35:20 -0500
+* From: Ian A Watson
+* Subject: crash
+*
+ CaLL foo(W)
+ END
+ SUBROUTINE foo(W)
+ yy(I)=A(I)Q(X) ! { dg-error "Error: Unclassifiable statement" "" }
+c { dg-error "end of file" "end of file" { target *-*-* } 0 }
Index: 980419-2.f
===================================================================
--- 980419-2.f (nonexistent)
+++ 980419-2.f (revision 816)
@@ -0,0 +1,49 @@
+c { dg-do compile }
+c SEGVs in loop.c with -O2.
+
+ character*80 function nxtlin(lun,ierr,itok)
+ character onechr*1,twochr*2,thrchr*3
+ itok=0
+ do while (.true.)
+ read (lun,'(a)',iostat=ierr) nxtlin
+ if (nxtlin(1:1).ne.'#') then
+ ito=0
+ do 10 it=1,79
+ if (nxtlin(it:it).ne.' ' .and. nxtlin(it+1:it+1).eq.' ')
+ $ then
+ itast=0
+ itstrt=0
+ do itt=ito+1,it
+ if (nxtlin(itt:itt).eq.'*') itast=itt
+ enddo
+ itstrt=ito+1
+ do while (nxtlin(itstrt:itstrt).eq.' ')
+ itstrt=itstrt+1
+ enddo
+ if (itast.gt.0) then
+ nchrs=itast-itstrt
+ if (nchrs.eq.1) then
+ onechr=nxtlin(itstrt:itstrt)
+ read (onechr,*) itokn
+ elseif (nchrs.eq.2) then
+ twochr=nxtlin(itstrt:itstrt+1)
+ read (twochr,*) itokn
+ elseif (nchrs.eq.3) then
+ thrchr=nxtlin(itstrt:itstrt+2)
+ read (thrchr,*) itokn
+ elseif (nchrs.eq.4) then
+ thrchr=nxtlin(itstrt:itstrt+3)
+ read (thrchr,*) itokn
+ endif
+ itok=itok+itokn
+ else
+ itok=itok+1
+ endif
+ ito=it+1
+ endif
+ 10 continue
+ return
+ endif
+ enddo
+ return
+ end
Index: 19990313-1.f
===================================================================
--- 19990313-1.f (nonexistent)
+++ 19990313-1.f (revision 816)
@@ -0,0 +1,8 @@
+c { dg-do run }
+ integer(kind=8) foo, bar
+ double precision r
+ data r/4d10/
+ foo = 4d10
+ bar = r
+ if (foo .ne. bar) call abort
+ end
Index: ffree-form-2.f
===================================================================
--- ffree-form-2.f (nonexistent)
+++ ffree-form-2.f (revision 816)
@@ -0,0 +1,11 @@
+! PR fortran/10843
+! Origin: Brad Davis
+!
+! { dg-do compile }
+! { dg-options "-ffree-form" }
+ GO TO 3
+ GOTO 3
+ 3 CONTINUE
+ GOTO = 55
+ END
+
Index: f77-edit-s-out.f
===================================================================
--- f77-edit-s-out.f (nonexistent)
+++ f77-edit-s-out.f (revision 816)
@@ -0,0 +1,20 @@
+C Test Fortran 77 S, SS and SP edit descriptors
+C (ANSI X3.9-1978 Section 13.5.6)
+C
+C Origin: David Billinghurst
+C
+C { dg-do run }
+C ( dg-output "^" }
+ 10 format(SP,I3,1X,SS,I3)
+ 20 format(SP,I3,1X,SS,I3,SP,I3)
+ 30 format(SP,I3,1X,SS,I3,S,I3)
+ 40 format(SP,I3)
+ 50 format(SP,I2)
+ write(*,10) 10, 20 ! { dg-output "\\+10 20(\n|\r\n|\r)" }
+ write(*,20) 10, 20, 30 ! { dg-output "\\+10 20\\+30(\n|\r\n|\r)" }
+ write(*,30) 10, 20, 30 ! { dg-output "\\+10 20 30(\n|\r\n|\r)" }
+ write(*,40) 0 ! { dg-output " \\+0(\n|\r\n|\r)" }
+C 15.5.9 - Note 5: When SP editing is in effect, the plus sign is not optional
+ write(*,50) 11 ! { dg-output "\\*\\*(\n|\r\n|\r)" }
+C { dg-output "\$" }
+ end
Index: 20030326-1.f
===================================================================
--- 20030326-1.f (nonexistent)
+++ 20030326-1.f (revision 816)
@@ -0,0 +1,10 @@
+! { dg-do compile }
+! { dg-options -pedantic }
+! PR fortran/9793
+! larson@w6yx.stanford.edu
+!
+! For gfortran, see PR 13490
+!
+ integer c
+ c = -2147483648 / (-1) ! { dg-error "too big for its kind" "" }
+ end
Index: toon_1.f
===================================================================
--- toon_1.f (nonexistent)
+++ toon_1.f (revision 816)
@@ -0,0 +1,4 @@
+c { dg-do compile }
+ SUBROUTINE AAP(NOOT)
+ DIMENSION NOOT(*)
+ END
Index: cpp5inc.h
===================================================================
--- cpp5inc.h (nonexistent)
+++ cpp5inc.h (revision 816)
@@ -0,0 +1 @@
+ FOO = 1
cpp5inc.h
Property changes :
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+Id
\ No newline at end of property
Index: 980701-0.f
===================================================================
--- 980701-0.f (nonexistent)
+++ 980701-0.f (revision 816)
@@ -0,0 +1,73 @@
+c { dg-do run }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ real s1(2), s2(2), s3(2)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+ equivalence (r1, s1(2))
+ equivalence (d1, r1(2))
+ equivalence (r2, s2(2))
+ equivalence (d2, r2(2))
+ equivalence (r3, s3(2))
+ equivalence (d3, r3(2))
+
+ s1(1) = 1.
+ r1(1) = 1.
+ d1 = 10.
+ r1(4) = 1.
+ r1(5) = 1.
+ i1 = 1
+ s2(1) = 2.
+ r2(1) = 2.
+ d2 = 20.
+ r2(4) = 2.
+ r2(5) = 2.
+ i2 = 2
+ s3(1) = 3.
+ r3(1) = 3.
+ d3 = 30.
+ r3(4) = 3.
+ r3(5) = 3.
+ i3 = 3
+
+ call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
+
+ end
+
+ subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ real s1(2), s2(2), s3(2)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+
+ if (s1(1) .ne. 1.) call abort
+ if (r1(1) .ne. 1.) call abort
+ if (d1 .ne. 10.) call abort
+ if (r1(4) .ne. 1.) call abort
+ if (r1(5) .ne. 1.) call abort
+ if (i1 .ne. 1) call abort
+ if (s2(1) .ne. 2.) call abort
+ if (r2(1) .ne. 2.) call abort
+ if (d2 .ne. 20.) call abort
+ if (r2(4) .ne. 2.) call abort
+ if (r2(5) .ne. 2.) call abort
+ if (i2 .ne. 2) call abort
+ if (s3(1) .ne. 3.) call abort
+ if (r3(1) .ne. 3.) call abort
+ if (d3 .ne. 30.) call abort
+ if (r3(4) .ne. 3.) call abort
+ if (r3(5) .ne. 3.) call abort
+ if (i3 .ne. 3) call abort
+
+ end
Index: int8421.f
===================================================================
--- int8421.f (nonexistent)
+++ int8421.f (revision 816)
@@ -0,0 +1,21 @@
+c { dg-do run }
+ integer(kind=1) i1, i11
+ integer(kind=2) i2, i22
+ integer i, ii
+ integer(kind=4) i4, i44
+ integer(kind=8) i8, i88
+ real r, rr
+ real(kind=4) r4, r44
+ double precision d, dd
+ real(kind=8) r8, r88
+ parameter (i1 = 1, i2 = 2, i4 = 4, i = 5, i8 = i + i4*i2 + i2*i1)
+ parameter (r = 3.0, r4 = 4.0, r8 = 8.d0, d = i8*r + r4*i2 + r8*i1)
+ if (i8 .ne. 15 ) call abort
+ if (d .ne. 61.d0) call abort
+ i11 = 1; i22 = 2; i44 = 4; ii = 5
+ i88 = i + i4*i2 + i2*i1
+ if (i88 .ne. i8) call abort
+ rr = 3.0; r44 = 4.0; r88 = 8.0d0
+ dd = i88*rr + r44*i22 + r88*i11
+ if (dd .ne. d) call abort
+ end
Index: 980427-0.f
===================================================================
--- 980427-0.f (nonexistent)
+++ 980427-0.f (revision 816)
@@ -0,0 +1,9 @@
+c { dg-do compile }
+c ../../egcs/gcc/f/com.c:938: failed assertion `TREE_CODE (TREE_TYPE (e)) == REAL_TYPE'
+c Fixed by 28-04-1998 global.c (ffeglobal_ref_progunit_) change.
+ external b
+ call y(b)
+ end
+ subroutine x
+ a = b()
+ end
Index: 970625-2.f
===================================================================
--- 970625-2.f (nonexistent)
+++ 970625-2.f (revision 816)
@@ -0,0 +1,84 @@
+* Date: Wed, 25 Jun 1997 12:48:26 +0200 (MET DST)
+* MIME-Version: 1.0
+* From: R.Hooft@EuroMail.com (Rob Hooft)
+* To: g77-alpha@gnu.ai.mit.edu
+* Subject: Re: testing 970624.
+* In-Reply-To: <199706251027.GAA07892@churchy.gnu.ai.mit.edu>
+* References: <199706251018.MAA21538@nu>
+* <199706251027.GAA07892@churchy.gnu.ai.mit.edu>
+* X-Mailer: VM 6.30 under Emacs 19.34.1
+* Content-Type: text/plain; charset=US-ASCII
+*
+* >>>>> "CB" == Craig Burley writes:
+*
+* CB> but OTOH I'd like to see more problems like this on other
+* CB> applications, and especially other systems
+*
+* How about this one: An application that prints "112." on all
+* compilers/platforms I have tested, except with the new g77 on ALPHA (I
+* don't have the new g77 on any other platform here to test)?
+*
+* Application Appended. Source code courtesy of my boss.....
+* Disclaimer: I do not know the right answer, or even whether there is a
+* single right answer.....
+*
+* Regards,
+* --
+* ===== R.Hooft@EuroMail.com http://www.Sander.EMBL-Heidelberg.DE/rob/ ==
+* ==== In need of protein modeling? http://www.Sander.EMBL-Heidelberg.DE/whatif/
+* Validation of protein structures? http://biotech.EMBL-Heidelberg.DE:8400/ ====
+* == PGPid 0xFA19277D == Use Linux! Free Software Rules The World! =============
+*
+* nu[152]for% cat humor.f
+ PROGRAM SUBROUTINE
+ LOGICAL ELSE IF
+ INTEGER REAL, GO TO PROGRAM, WHILE, THEN, END DO
+ REAL FORMAT(2)
+ DATA IF,REAL,END DO,WHILE,FORMAT(2),I2/2,6,7,1,112.,1/
+ DO THEN=1, END DO, WHILE
+ CALL = END DO - IF
+ PROGRAM = THEN - IF
+ ELSE IF = THEN .GT. IF
+ IF (THEN.GT.REAL) THEN
+ CALL FUNCTION PROGRAM (ELSE IF, GO TO PROGRAM, THEN)
+ ELSE IF (ELSE IF) THEN
+ REAL = THEN + END DO
+ END IF
+ END DO
+ 10 FORMAT(I2/I2) = WHILE*REAL*THEN
+ IF (FORMAT(I2) .NE. FORMAT(I2+I2)) CALL ABORT
+ END ! DO
+ SUBROUTINE FUNCTION PROGRAM (REAL,INTEGER, LOGICAL)
+ LOGICAL REAL
+ REAL LOGICAL
+ INTEGER INTEGER, STOP, RETURN, GO TO
+ ASSIGN 9 TO STOP ! { dg-warning "ASSIGN" "" }
+ ASSIGN = 9 + LOGICAL
+ ASSIGN 7 TO RETURN ! { dg-warning "ASSIGN" "" }
+ ASSIGN 9 TO GO TO ! { dg-warning "ASSIGN" "" }
+ GO TO = 5
+ STOP = 8
+ IF (.NOT.REAL) GOTO STOP ! { dg-warning "Assigned GOTO" "" }
+ IF (LOGICAL.GT.INTEGER) THEN
+ IF = LOGICAL +5
+ IF (LOGICAL.EQ.5) ASSIGN 5 TO IF ! { dg-warning "ASSIGN" "" }
+ INTEGER=IF
+ ELSE
+ IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO ! { dg-warning "ASSIGN" "" }
+ ELSE = GO TO
+ END IF = ELSE + GO TO
+ IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN ! { dg-warning "Assigned GOTO" "" }
+ END IF
+ 5 CONTINUE
+ 7 LOGICAL=LOGICAL+STOP
+ 9 RETURN
+ END ! IF
+* nu[153]for% f77 humor.f
+* nu[154]for% ./a.out
+* 112.0000
+* nu[155]for% f90 humor.f
+* nu[156]for% ./a.out
+* 112.0000
+* nu[157]for% g77 humor.f
+* nu[158]for% ./a.out
+* 40.
Index: 980628-0.f
===================================================================
--- 980628-0.f (nonexistent)
+++ 980628-0.f (revision 816)
@@ -0,0 +1,62 @@
+c { dg-do run }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+ equivalence (r1(2), d1)
+ equivalence (r2(2), d2)
+ equivalence (r3(2), d3)
+
+ r1(1) = 1.
+ d1 = 10.
+ r1(4) = 1.
+ r1(5) = 1.
+ i1 = 1
+ r2(1) = 2.
+ d2 = 20.
+ r2(4) = 2.
+ r2(5) = 2.
+ i2 = 2
+ r3(1) = 3.
+ d3 = 30.
+ r3(4) = 3.
+ r3(5) = 3.
+ i3 = 3
+
+ call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+
+ end
+
+ subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+
+ if (r1(1) .ne. 1.) call abort
+ if (d1 .ne. 10.) call abort
+ if (r1(4) .ne. 1.) call abort
+ if (r1(5) .ne. 1.) call abort
+ if (i1 .ne. 1) call abort
+ if (r2(1) .ne. 2.) call abort
+ if (d2 .ne. 20.) call abort
+ if (r2(4) .ne. 2.) call abort
+ if (r2(5) .ne. 2.) call abort
+ if (i2 .ne. 2) call abort
+ if (r3(1) .ne. 3.) call abort
+ if (d3 .ne. 30.) call abort
+ if (r3(4) .ne. 3.) call abort
+ if (r3(5) .ne. 3.) call abort
+ if (i3 .ne. 3) call abort
+
+ end
Index: 19990502-0.f
===================================================================
--- 19990502-0.f (nonexistent)
+++ 19990502-0.f (revision 816)
@@ -0,0 +1,67 @@
+c { dg-do compile }
+* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
+* Precedence: bulk
+* Sender: owner-egcs-bugs@egcs.cygnus.com
+* From: Norbert Conrad
+* Subject: egcs g77 19990524pre Internal compiler error in `print_operand'
+* To: egcs-bugs@egcs.cygnus.com
+* Date: Mon, 31 May 1999 11:46:52 +0200 (CET)
+* Content-Type: text/plain; charset=US-ASCII
+* X-UIDL: 9a00095a5fe4d774b7223de071157374
+*
+* Hi,
+*
+* I ./configure --prefix=/opt and bootstrapped egcs g77 snapshot 19990524
+* on an i686-pc-linux-gnu. The program below gives an internal compiler error.
+*
+*
+* Script started on Mon May 31 11:30:01 1999
+* lx{g010}:/tmp>/opt/bin/g77 -v -O3 -malign-double -c e3.f
+* g77 version gcc-2.95 19990524 (prerelease) (from FSF-g77 version 0.5.24-19990515)
+* Reading specs from /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/specs
+* gcc version gcc-2.95 19990524 (prerelease)
+* /opt/lib/gcc-lib/i686-pc-linux-gnu/gcc-2.95/f771 e3.f -quiet -dumpbase e3.f -malign-double -O3 -version -fversion -o /tmp/ccQgeaaa.s
+* GNU F77 version gcc-2.95 19990524 (prerelease) (i686-pc-linux-gnu) compiled by GNU C version gcc-2.95 19990524 (prerelease).
+* GNU Fortran Front End version 0.5.24-19990515
+* e3.f:25: Internal compiler error in `print_operand', at ./config/i386/i386.c:3405
+* Please submit a full bug report to `egcs-bugs@egcs.cygnus.com'.
+* See for details.
+* lx{g010}:/tmp>cat e3.f
+ SUBROUTINE DLASQ2( QQ, EE, TOL2, SMALL2 )
+ DOUBLE PRECISION SMALL2, TOL2
+ DOUBLE PRECISION EE( * ), QQ( * )
+ INTEGER ICONV, N, OFF
+ DOUBLE PRECISION QEMAX, XINF
+ EXTERNAL DLASQ3
+ INTRINSIC MAX, SQRT
+ XINF = 0.0D0
+ ICONV = 0
+ IF( EE( N ).LE.MAX( QQ( N ), XINF, SMALL2 )*TOL2 ) THEN
+ END IF
+ IF( EE( N-2 ).LE.MAX( XINF, SMALL2,
+ $ ( QQ( N ) / ( QQ( N )+EE( N-1 ) ) )* QQ( N-1 ))*TOL2 ) THEN
+ QEMAX = MAX( QQ( N ), QQ( N-1 ), EE( N-1 ) )
+ END IF
+ IF( N.EQ.0 ) THEN
+ IF( OFF.EQ.0 ) THEN
+ RETURN
+ ELSE
+ XINF =0.0D0
+ END IF
+ ELSE IF( N.EQ.2 ) THEN
+ END IF
+ CALL DLASQ3(ICONV)
+ END
+* lx{g010}:/tmp>exit
+*
+* Script done on Mon May 31 11:30:23 1999
+*
+* Best regards,
+*
+* Norbert.
+* --
+* Norbert Conrad phone: ++49 641 9913021
+* Hochschulrechenzentrum email: conrad@hrz.uni-giessen.de
+* Heinrich-Buff-Ring 44
+* 35392 Giessen
+* Germany
Index: 19990305-0.f
===================================================================
--- 19990305-0.f (nonexistent)
+++ 19990305-0.f (revision 816)
@@ -0,0 +1,56 @@
+c { dg-do compile }
+* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST)
+* From: Denes Molnar
+* To: fortran@gnu.org
+* Subject: f771 gets fatal signal 6
+* Content-Type: TEXT/PLAIN; charset=US-ASCII
+* X-UIDL: 8d81e9cbdcc96209c6e9b298d966ba7f
+*
+* Hi,
+*
+*
+* Comiling object from the source code below WORKS FINE with
+* 'g77 -o hwuci2 -c hwuci2.F'
+* but FAILS with fatal signal 6
+* 'g77 -o hwuci2 -O -c hwuci2.F'
+*
+* Any explanations?
+*
+* I am running GNU Fortran 0.5.23 with GCC 2.8.1 (glibc1).
+*
+*
+* Denes Molnar
+*
+* %%%%%%%%%%%%%%%%%%%%%%%%%
+* %the source:
+* %%%%%%%%%%%%%%%%%%%%%%%%%
+*
+CDECK ID>, HWUCI2.
+*CMZ :- -23/08/94 13.22.29 by Mike Seymour
+*-- Author : Ulrich Baur & Nigel Glover, adapted by Ian Knowles
+C-----------------------------------------------------------------------
+ FUNCTION HWUCI2(A,B,Y0)
+C-----------------------------------------------------------------------
+C Integral LOG(A-EPSI-BY(1-Y))/(Y-Y0)
+C-----------------------------------------------------------------------
+ IMPLICIT NONE
+ complex(kind=8) HWUCI2,HWULI2,EPSI,Y1,Y2,Z1,Z2,Z3,Z4
+ DOUBLE PRECISION A,B,Y0,ZERO,ONE,FOUR,HALF
+ EXTERNAL HWULI2
+ COMMON/SMALL/EPSI
+ PARAMETER (ZERO=0.D0, ONE =1.D0, FOUR= 4.D0, HALF=0.5D0)
+ IF(B.EQ.ZERO)THEN
+ HWUCI2=CMPLX(ZERO,ZERO)
+ ELSE
+ Y1=HALF*(ONE+SQRT(ONE-FOUR*(A+EPSI)/B))
+ Y2=ONE-Y1
+ Z1=Y0/(Y0-Y1)
+ Z2=(Y0-ONE)/(Y0-Y1)
+ Z3=Y0/(Y0-Y2)
+ Z4=(Y0-ONE)/(Y0-Y2)
+ HWUCI2=HWULI2(Z1)-HWULI2(Z2)+HWULI2(Z3)-HWULI2(Z4)
+ ENDIF
+ RETURN
+ END
+*
+* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
Index: 947.f
===================================================================
--- 947.f (nonexistent)
+++ 947.f (revision 816)
@@ -0,0 +1,13 @@
+c { dg-do run }
+ DIMENSION A(-5:5)
+ INTEGER(kind=1) IM5, IZ, IP5
+ INTEGER(kind=2) IM1, IP1
+ PARAMETER (IM5=-5, IM1=-1, IZ=0, IP1=1, IP5=5)
+ DATA A(IM5) /-5./, A(IM1) /-1./
+ DATA A(IZ) /0./
+ DATA A(IP5) /+5./, A(IP1) /+1./
+ IF (A(IM5) .NE. -5. .OR. A(IM1) .NE. -1. .OR.
+ , A(IZ) .NE. 0. .OR.
+ , A(IP5) .NE. +5. .OR. A(IP1) .NE. +1. )
+ , CALL ABORT
+ END
Index: 19981119-0.f
===================================================================
--- 19981119-0.f (nonexistent)
+++ 19981119-0.f (revision 816)
@@ -0,0 +1,41 @@
+c { dg-do run }
+* X-Delivered: at request of burley on mescaline.gnu.org
+* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET)
+* From: "B. Yanchitsky"
+* To: fortran@gnu.org
+* Subject: Bug report
+* MIME-Version: 1.0
+* Content-Type: TEXT/PLAIN; charset=US-ASCII
+*
+* There is a trouble with g77 on Alpha.
+* My configuration:
+* Digital Personal Workstation 433au,
+* Digital Unix 4.0D,
+* GNU Fortran 0.5.23 and GNU C 2.8.1.
+*
+* The following program treated successfully but crashed when running.
+*
+* C --- PROGRAM BEGIN -------
+*
+ subroutine sub(N,u)
+ integer N
+ double precision u(-N:N,-N:N)
+
+C vvvv CRASH HERE vvvvv
+ u(-N,N)=0d0
+ return
+ end
+
+
+ program bug
+ integer N
+ double precision a(-10:10,-10:10)
+ data a/441*1d0/
+ N=10
+ call sub(N,a)
+ if (a(-N,N) .ne. 0d0) call abort
+ end
+*
+* C --- PROGRAM END -------
+*
+* Good luck!
Index: 980628-8.f
===================================================================
--- 980628-8.f (nonexistent)
+++ 980628-8.f (revision 816)
@@ -0,0 +1,64 @@
+c { dg-do run }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+ save
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+ equivalence (d1, r1(2))
+ equivalence (d2, r2(2))
+ equivalence (d3, r3(2))
+
+ r1(1) = 1.
+ d1 = 10.
+ r1(4) = 1.
+ r1(5) = 1.
+ i1 = 1
+ r2(1) = 2.
+ d2 = 20.
+ r2(4) = 2.
+ r2(5) = 2.
+ i2 = 2
+ r3(1) = 3.
+ d3 = 30.
+ r3(4) = 3.
+ r3(5) = 3.
+ i3 = 3
+
+ call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+
+ end
+
+ subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+
+ if (r1(1) .ne. 1.) call abort
+ if (d1 .ne. 10.) call abort
+ if (r1(4) .ne. 1.) call abort
+ if (r1(5) .ne. 1.) call abort
+ if (i1 .ne. 1) call abort
+ if (r2(1) .ne. 2.) call abort
+ if (d2 .ne. 20.) call abort
+ if (r2(4) .ne. 2.) call abort
+ if (r2(5) .ne. 2.) call abort
+ if (i2 .ne. 2) call abort
+ if (r3(1) .ne. 3.) call abort
+ if (d3 .ne. 30.) call abort
+ if (r3(4) .ne. 3.) call abort
+ if (r3(5) .ne. 3.) call abort
+ if (i3 .ne. 3) call abort
+
+ end
+
Index: 20000412-1.f
===================================================================
--- 20000412-1.f (nonexistent)
+++ 20000412-1.f (revision 816)
@@ -0,0 +1,6 @@
+c { dg-do compile }
+ subroutine aap(k)
+ equivalence (i,r)
+ i = k
+ print*,r
+ end
Index: 19990905-2.f
===================================================================
--- 19990905-2.f (nonexistent)
+++ 19990905-2.f (revision 816)
@@ -0,0 +1,23 @@
+c { dg-do compile }
+* =watson11.f in Burley's g77 test suite.
+* Probably originally submitted by Ian Watson.
+* Too small to worry about copyright issues, IMO, since it
+* doesn't do anything substantive.
+ SUBROUTINE OUTDNS(A,B,LCONV)
+ IMPLICIT REAL(kind=8) (A-H,O-Z),INTEGER(I-N)
+ COMMON/ARRAYS/Z(64,8),AB(30,30),PAIRS(9,9),T(9,9),TEMP(9,9),C1(3),
+ > C2(3),AA(30),BB(30)
+ EQUIVALENCE (X1,C1(1)),(Y1,C1(2)),(Z1,C1(3))
+ EQUIVALENCE (X2,C2(1)),(Y2,C2(2)),(Z2,C2(3))
+ COMMON /CONTRL/
+ > SHIFT,CONV,SCION,DIVERG,
+ > IOPT,KCNDO,KINDO,KMINDO,I2EINT,KOHNO,KSLATE,
+ > N,NG,NUMAT,NSEK,NELECS,NIT,OCCA,OCCB,NOLDAT,NOLDFN
+ INTEGER OCCA,OCCB
+ DIMENSION W(N),A(N,N),B(N,N)
+ DIMENSION BUF(100)
+ occb=5
+ ENTRY INDNS (A,B)
+ 40 READ(IREAD) BUF
+ STOP
+ END
Index: 20000630-2.f
===================================================================
--- 20000630-2.f (nonexistent)
+++ 20000630-2.f (revision 816)
@@ -0,0 +1,10 @@
+c { dg-do compile }
+ SUBROUTINE CHOUT(CHR,ICNT)
+C ICE: failed assertion `expr != NULL'
+C Reduced version of GNATS PR fortran/329 from trond.bo@dnmi.no
+ INTEGER CHR(ICNT)
+ CHARACTER*255 BUF
+ BUF(1:1)=CHAR(CHR(1))
+ CALL FPUTC(1,BUF(1:1))
+ RETURN
+ END
Index: 19990826-2.f
===================================================================
--- 19990826-2.f (nonexistent)
+++ 19990826-2.f (revision 816)
@@ -0,0 +1,34 @@
+c { dg-do run }
+* From: "Billinghurst, David (RTD)"
+* Subject: RE: single precision complex bug in g77 - was Testing g77 with LA
+* PACK 3.0
+* Date: Thu, 8 Jul 1999 00:55:11 +0100
+* X-UIDL: b00d9d8081a36fef561b827d255dd4a5
+
+* Here is a slightly simpler and neater test case
+
+ program labug3
+ implicit none
+
+* This program gives the wrong answer on mips-sgi-irix6.5
+* when compiled with g77 from egcs-19990629 (gcc 2.95 prerelease)
+* Get a = 0.0 when it should be 1.0
+*
+* Works with: -femulate-complex
+* egcs-1.1.2
+*
+* Originally derived from LAPACK 3.0 test suite.
+*
+* David Billinghurst, (David.Billinghurst@riotinto.com.au)
+* 8 July 1999
+*
+ complex one, z
+ real a, f1
+ f1(z) = real(z)
+ one = (1.,0.)
+ a = f1(one)
+ if ( abs(a-1.0) .gt. 1.0e-5 ) then
+ write(6,*) 'A should be 1.0 but it is',a
+ call abort()
+ end if
+ end
Index: f77-edit-t-in.f
===================================================================
--- f77-edit-t-in.f (nonexistent)
+++ f77-edit-t-in.f (revision 816)
@@ -0,0 +1,31 @@
+C Test Fortran 77 T edit descriptor for input
+C (ANSI X3.9-1978 Section 13.5.3.2)
+C
+C Origin: David Billinghurst
+C
+C { dg-do run }
+ integer i,j
+ real a,b,c,d,e
+ character*32 in
+
+ in = '1234 8'
+ read(in,'(T3,I1)') i
+ if ( i.ne.3 ) call abort()
+ read(in,'(5X,TL4,I2)') i
+ if ( i.ne.23 ) call abort()
+ read(in,'(3X,I1,TR3,I1)') i,j
+ if ( i.ne.4 ) call abort()
+ if ( j.ne.8 ) call abort()
+
+ in = ' 1.5 -12.62 348.75 1.0E-6'
+ 100 format(F6.0,TL6,I4,1X,I1,8X,I5,F3.0,T10,F5.0,T17,F6.0,TR2,F6.0)
+ read(in,100) a,i,j,k,b,c,d,e
+ if ( abs(a-1.5).gt.1.0e-5 ) call abort()
+ if ( i.ne.1 ) call abort()
+ if ( j.ne.5 ) call abort()
+ if ( k.ne.348 ) call abort()
+ if ( abs(b-0.75).gt.1.0e-5 ) call abort()
+ if ( abs(c-12.62).gt.1.0e-5 ) call abort()
+ if ( abs(d-348.75).gt.1.0e-4 ) call abort()
+ if ( abs(e-1.0e-6).gt.1.0e-11 ) call abort()
+ end
Index: 971102-1.f
===================================================================
--- 971102-1.f (nonexistent)
+++ 971102-1.f (revision 816)
@@ -0,0 +1,12 @@
+c { dg-do run }
+ i=3
+ j=0
+ do i=i,5
+ j = j+i
+ end do
+ do i=3,i
+ j = j+i
+ end do
+ if (i.ne.7) call abort()
+ print *, i,j
+ end
Index: 9263.f
===================================================================
--- 9263.f (nonexistent)
+++ 9263.f (revision 816)
@@ -0,0 +1,11 @@
+C { dg-do compile }
+ PARAMETER (Q=1)
+ PARAMETER (P=10)
+ INTEGER C(10),D(10),E(10),F(10)
+C TERMINAL NOT INTEGER
+ DATA (C(I),I=1,P) /10*10/ ! { dg-error "End expression in DO loop" "" }
+C START NOT INTEGER
+ DATA (D(I),I=Q,10) /10*10/ ! { dg-error "Start expression in DO loop" "" }
+C INCREMENT NOT INTEGER
+ DATA (E(I),I=1,10,Q) /10*10/ ! { dg-error "Step expression in DO loop" "" }
+ END
Index: 6177.f
===================================================================
--- 6177.f (nonexistent)
+++ 6177.f (revision 816)
@@ -0,0 +1,15 @@
+c { dg-do run }
+ program pr6177
+C
+C Test case for PR optimization/6177.
+C This bug (an ICE) originally showed up in file cblat2.f from LAPACK.
+C
+ complex x
+ complex w(1)
+ intrinsic conjg
+ x = (2.0d0, 1.0d0)
+ w(1) = x
+ x = conjg(x)
+ w(1) = conjg(w(1))
+ if (abs(x-w(1)) .gt. 1.0e-5) call abort
+ end
Index: 12002.f
===================================================================
--- 12002.f (nonexistent)
+++ 12002.f (revision 816)
@@ -0,0 +1,6 @@
+C PR middle-end/12002
+C { dg-do compile }
+ COMPLEX TE1
+ TE1=-2.
+ TE1=TE1+TE1
+ END
Index: 980310-4.f
===================================================================
--- 980310-4.f (nonexistent)
+++ 980310-4.f (revision 816)
@@ -0,0 +1,348 @@
+c { dg-do compile }
+C To: egcs-bugs@cygnus.com
+C Subject: -fPIC problem showing up with fortran on x86
+C From: Dave Love
+C Date: 19 Dec 1997 19:31:41 +0000
+C
+C
+C This illustrates a long-standing problem noted at the end of the g77
+C `Actual Bugs' info node and thought to be in the back end. Although
+C the report is against gcc 2.7 I can reproduce it (specifically on
+C redhat 4.2) with the 971216 egcs snapshot.
+C
+C g77 version 0.5.21
+C gcc -v -fnull-version -o /tmp/gfa00415 -xf77-cpp-input /tmp/gfa00415.f -xnone
+C -lf2c -lm
+C
+
+C ------------
+ subroutine dqage(f,a,b,epsabs,epsrel,limit,result,abserr,
+ * neval,ier,alist,blist,rlist,elist,iord,last)
+C --------------------------------------------------
+C
+C Modified Feb 1989 by Barry W. Brown to eliminate key
+C as argument (use key=1) and to eliminate all Fortran
+C output.
+C
+C Purpose: to make this routine usable from within S.
+C
+C --------------------------------------------------
+c***begin prologue dqage
+c***date written 800101 (yymmdd)
+c***revision date 830518 (yymmdd)
+c***category no. h2a1a1
+c***keywords automatic integrator, general-purpose,
+c integrand examinator, globally adaptive,
+c gauss-kronrod
+c***author piessens,robert,appl. math. & progr. div. - k.u.leuven
+c de doncker,elise,appl. math. & progr. div. - k.u.leuven
+c***purpose the routine calculates an approximation result to a given
+c definite integral i = integral of f over (a,b),
+c hopefully satisfying following claim for accuracy
+c abs(i-reslt).le.max(epsabs,epsrel*abs(i)).
+c***description
+c
+c computation of a definite integral
+c standard fortran subroutine
+c double precision version
+c
+c parameters
+c on entry
+c f - double precision
+c function subprogram defining the integrand
+c function f(x). the actual name for f needs to be
+c declared e x t e r n a l in the driver program.
+c
+c a - double precision
+c lower limit of integration
+c
+c b - double precision
+c upper limit of integration
+c
+c epsabs - double precision
+c absolute accuracy requested
+c epsrel - double precision
+c relative accuracy requested
+c if epsabs.le.0
+c and epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
+c the routine will end with ier = 6.
+c
+c key - integer
+c key for choice of local integration rule
+c a gauss-kronrod pair is used with
+c 7 - 15 points if key.lt.2,
+c 10 - 21 points if key = 2,
+c 15 - 31 points if key = 3,
+c 20 - 41 points if key = 4,
+c 25 - 51 points if key = 5,
+c 30 - 61 points if key.gt.5.
+c
+c limit - integer
+c gives an upperbound on the number of subintervals
+c in the partition of (a,b), limit.ge.1.
+c
+c on return
+c result - double precision
+c approximation to the integral
+c
+c abserr - double precision
+c estimate of the modulus of the absolute error,
+c which should equal or exceed abs(i-result)
+c
+c neval - integer
+c number of integrand evaluations
+c
+c ier - integer
+c ier = 0 normal and reliable termination of the
+c routine. it is assumed that the requested
+c accuracy has been achieved.
+c ier.gt.0 abnormal termination of the routine
+c the estimates for result and error are
+c less reliable. it is assumed that the
+c requested accuracy has not been achieved.
+c error messages
+c ier = 1 maximum number of subdivisions allowed
+c has been achieved. one can allow more
+c subdivisions by increasing the value
+c of limit.
+c however, if this yields no improvement it
+c is rather advised to analyze the integrand
+c in order to determine the integration
+c difficulties. if the position of a local
+c difficulty can be determined(e.g.
+c singularity, discontinuity within the
+c interval) one will probably gain from
+c splitting up the interval at this point
+c and calling the integrator on the
+c subranges. if possible, an appropriate
+c special-purpose integrator should be used
+c which is designed for handling the type of
+c difficulty involved.
+c = 2 the occurrence of roundoff error is
+c detected, which prevents the requested
+c tolerance from being achieved.
+c = 3 extremely bad integrand behavior occurs
+c at some points of the integration
+c interval.
+c = 6 the input is invalid, because
+c (epsabs.le.0 and
+c epsrel.lt.max(50*rel.mach.acc.,0.5d-28),
+c result, abserr, neval, last, rlist(1) ,
+c elist(1) and iord(1) are set to zero.
+c alist(1) and blist(1) are set to a and b
+c respectively.
+c
+c alist - double precision
+c vector of dimension at least limit, the first
+c last elements of which are the left
+c end points of the subintervals in the partition
+c of the given integration range (a,b)
+c
+c blist - double precision
+c vector of dimension at least limit, the first
+c last elements of which are the right
+c end points of the subintervals in the partition
+c of the given integration range (a,b)
+c
+c rlist - double precision
+c vector of dimension at least limit, the first
+c last elements of which are the
+c integral approximations on the subintervals
+c
+c elist - double precision
+c vector of dimension at least limit, the first
+c last elements of which are the moduli of the
+c absolute error estimates on the subintervals
+c
+c iord - integer
+c vector of dimension at least limit, the first k
+c elements of which are pointers to the
+c error estimates over the subintervals,
+c such that elist(iord(1)), ...,
+c elist(iord(k)) form a decreasing sequence,
+c with k = last if last.le.(limit/2+2), and
+c k = limit+1-last otherwise
+c
+c last - integer
+c number of subintervals actually produced in the
+c subdivision process
+c
+c***references (none)
+c***routines called d1mach,dqk15,dqk21,dqk31,
+c dqk41,dqk51,dqk61,dqpsrt
+c***end prologue dqage
+c
+ double precision a,abserr,alist,area,area1,area12,area2,a1,a2,b,
+ * blist,b1,b2,dabs,defabs,defab1,defab2,dmax1,d1mach,elist,epmach,
+ * epsabs,epsrel,errbnd,errmax,error1,error2,erro12,errsum,f,
+ * resabs,result,rlist,uflow
+ integer ier,iord,iroff1,iroff2,k,last,limit,maxerr,neval,
+ * nrmax
+c
+ dimension alist(limit),blist(limit),elist(limit),iord(limit),
+ * rlist(limit)
+c
+ external f
+c
+c list of major variables
+c -----------------------
+c
+c alist - list of left end points of all subintervals
+c considered up to now
+c blist - list of right end points of all subintervals
+c considered up to now
+c rlist(i) - approximation to the integral over
+c (alist(i),blist(i))
+c elist(i) - error estimate applying to rlist(i)
+c maxerr - pointer to the interval with largest
+c error estimate
+c errmax - elist(maxerr)
+c area - sum of the integrals over the subintervals
+c errsum - sum of the errors over the subintervals
+c errbnd - requested accuracy max(epsabs,epsrel*
+c abs(result))
+c *****1 - variable for the left subinterval
+c *****2 - variable for the right subinterval
+c last - index for subdivision
+c
+c
+c machine dependent constants
+c ---------------------------
+c
+c epmach is the largest relative spacing.
+c uflow is the smallest positive magnitude.
+c
+c***first executable statement dqage
+ epmach = d1mach(4)
+ uflow = d1mach(1)
+c
+c test on validity of parameters
+c ------------------------------
+c
+ ier = 0
+ neval = 0
+ last = 0
+ result = 0.0d+00
+ abserr = 0.0d+00
+ alist(1) = a
+ blist(1) = b
+ rlist(1) = 0.0d+00
+ elist(1) = 0.0d+00
+ iord(1) = 0
+ if(epsabs.le.0.0d+00.and.
+ * epsrel.lt.dmax1(0.5d+02*epmach,0.5d-28)) ier = 6
+ if(ier.eq.6) go to 999
+c
+c first approximation to the integral
+c -----------------------------------
+c
+ neval = 0
+ call dqk15(f,a,b,result,abserr,defabs,resabs)
+ last = 1
+ rlist(1) = result
+ elist(1) = abserr
+ iord(1) = 1
+c
+c test on accuracy.
+c
+ errbnd = dmax1(epsabs,epsrel*dabs(result))
+ if(abserr.le.0.5d+02*epmach*defabs.and.abserr.gt.errbnd) ier = 2
+ if(limit.eq.1) ier = 1
+ if(ier.ne.0.or.(abserr.le.errbnd.and.abserr.ne.resabs)
+ * .or.abserr.eq.0.0d+00) go to 60
+c
+c initialization
+c --------------
+c
+c
+ errmax = abserr
+ maxerr = 1
+ area = result
+ errsum = abserr
+ nrmax = 1
+ iroff1 = 0
+ iroff2 = 0
+c
+c main do-loop
+c ------------
+c
+ do 30 last = 2,limit
+c
+c bisect the subinterval with the largest error estimate.
+c
+ a1 = alist(maxerr)
+ b1 = 0.5d+00*(alist(maxerr)+blist(maxerr))
+ a2 = b1
+ b2 = blist(maxerr)
+ call dqk15(f,a1,b1,area1,error1,resabs,defab1)
+ call dqk15(f,a2,b2,area2,error2,resabs,defab2)
+c
+c improve previous approximations to integral
+c and error and test for accuracy.
+c
+ neval = neval+1
+ area12 = area1+area2
+ erro12 = error1+error2
+ errsum = errsum+erro12-errmax
+ area = area+area12-rlist(maxerr)
+ if(defab1.eq.error1.or.defab2.eq.error2) go to 5
+ if(dabs(rlist(maxerr)-area12).le.0.1d-04*dabs(area12)
+ * .and.erro12.ge.0.99d+00*errmax) iroff1 = iroff1+1
+ if(last.gt.10.and.erro12.gt.errmax) iroff2 = iroff2+1
+ 5 rlist(maxerr) = area1
+ rlist(last) = area2
+ errbnd = dmax1(epsabs,epsrel*dabs(area))
+ if(errsum.le.errbnd) go to 8
+c
+c test for roundoff error and eventually set error flag.
+c
+ if(iroff1.ge.6.or.iroff2.ge.20) ier = 2
+c
+c set error flag in the case that the number of subintervals
+c equals limit.
+c
+ if(last.eq.limit) ier = 1
+c
+c set error flag in the case of bad integrand behavior
+c at a point of the integration range.
+c
+ if(dmax1(dabs(a1),dabs(b2)).le.(0.1d+01+0.1d+03*
+ * epmach)*(dabs(a2)+0.1d+04*uflow)) ier = 3
+c
+c append the newly-created intervals to the list.
+c
+ 8 if(error2.gt.error1) go to 10
+ alist(last) = a2
+ blist(maxerr) = b1
+ blist(last) = b2
+ elist(maxerr) = error1
+ elist(last) = error2
+ go to 20
+ 10 alist(maxerr) = a2
+ alist(last) = a1
+ blist(last) = b1
+ rlist(maxerr) = area2
+ rlist(last) = area1
+ elist(maxerr) = error2
+ elist(last) = error1
+c
+c call subroutine dqpsrt to maintain the descending ordering
+c in the list of error estimates and select the subinterval
+c with the largest error estimate (to be bisected next).
+c
+ 20 call dqpsrt(limit,last,maxerr,errmax,elist,iord,nrmax)
+c ***jump out of do-loop
+ if(ier.ne.0.or.errsum.le.errbnd) go to 40
+ 30 continue
+c
+c compute final result.
+c ---------------------
+c
+ 40 result = 0.0d+00
+ do 50 k=1,last
+ result = result+rlist(k)
+ 50 continue
+ abserr = errsum
+ 60 neval = 30*neval+15
+ 999 return
+ end
Index: ffixed-line-length-none.f
===================================================================
--- ffixed-line-length-none.f (nonexistent)
+++ ffixed-line-length-none.f (revision 816)
@@ -0,0 +1,7 @@
+C Test compiler flags: -ffixed-line-length-none
+C Origin: David Billinghurst
+C
+C { dg-do compile }
+C { dg-options "-ffixed-line-length-none" }
+C The next line has length 257
+ en d
Index: cpp5.F
===================================================================
--- cpp5.F (nonexistent)
+++ cpp5.F (revision 816)
@@ -0,0 +1,4 @@
+ ! { dg-do run }
+#include "cpp5.h"
+ IF (FOO().NE.1) CALL ABORT ()
+ END
Index: cabs.f
===================================================================
--- cabs.f (nonexistent)
+++ cabs.f (revision 816)
@@ -0,0 +1,15 @@
+c { dg-do run { xfail mips-sgi-irix6* } } PR 16292
+ program cabs_1
+ complex z0
+ real r0
+ complex(kind=8) z1
+ real(kind=8) r1
+
+ z0 = cmplx(3.,4.)
+ r0 = cabs(z0)
+ if (r0 .ne. 5.) call abort
+
+ z1 = dcmplx(3.d0,4.d0)
+ r1 = zabs(z1)
+ if (r1 .ne. 5.d0) call abort
+ end
Index: 980310-8.f
===================================================================
--- 980310-8.f (nonexistent)
+++ 980310-8.f (revision 816)
@@ -0,0 +1,41 @@
+c { dg-do compile }
+C To: egcs-bugs@cygnus.com
+C Subject: egcs-g77 and array indexing
+C Reply-To: etseidl@jutland.ca.sandia.gov
+C Date: Wed, 26 Nov 1997 10:38:27 -0800
+C From: Edward Seidl
+C
+C I have some horrible spaghetti code I'm trying compile with egcs-g77,
+C but it's puking on code like the example below. I have no idea if it's
+C legal fortran or not, and I'm in no position to change it. All I do know
+C is it compiles with a number of other compilers, including f2c and
+C g77-0.5.19.1/gcc-2.7.2.1. When I try to compile with egcs-2.90.18 971122
+C I get the following (on both i686-pc-linux-gnu and
+C alphaev56-unknown-linux-gnu):
+C
+Cfoo.f: In subroutine `foobar':
+Cfoo.f:11:
+C subroutine foobar(norb,nnorb)
+C ^
+CArray `norb' at (^) is too large to handle
+
+ program foo
+ implicit integer(A-Z)
+ dimension norb(6)
+ nnorb=6
+
+ call foobar(norb,nnorb)
+
+ stop
+ end
+
+ subroutine foobar(norb,nnorb)
+ implicit integer(A-Z)
+ dimension norb(-1:*)
+
+ do 10 i=-1,nnorb-2
+ norb(i) = i+999
+ 10 continue
+
+ return
+ end
Index: 970915-0.f
===================================================================
--- 970915-0.f (nonexistent)
+++ 970915-0.f (revision 816)
@@ -0,0 +1,21 @@
+c { dg-do compile }
+* fixed by patch to safe_from_p to avoid visiting any SAVE_EXPR
+* node twice in a given top-level call to it.
+* (JCB com.c patch of 1998-06-04.)
+
+ SUBROUTINE TSTSIG11
+ IMPLICIT COMPLEX (A-Z)
+ EXTERNAL gzi1,gzi2
+ branch3 = sw2 / cw
+ . * ( rdw * (epsh*gzi1(A,B)-gzi2(A,B))
+ . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
+ . + (-1./2. + 2.*sw2/3.) / (sw*cw)
+ . * rdw * (epsh*gzi1(A,B)-gzi2(A,B)
+ . + rdw * (epsh*gzi1(A,B)-gzi2(A,B))
+ . + rdw * (epsh*gzi1(A,B)-gzi2(A,B)) )
+ . * rup * (epsh*gzi1(A,B)-gzi2(A,B)
+ . + rup * (epsh*gzi1(A,B)-gzi2(A,B)) )
+ . * 4.*(3.-tw**2) * gzi2(A,B)
+ . + ((1.+2./tauw)*tw**2-(5.+2./tauw))* gzi1(A,B)
+ RETURN
+ END
Index: 13037.f
===================================================================
--- 13037.f (nonexistent)
+++ 13037.f (revision 816)
@@ -0,0 +1,59 @@
+c { dg-do run }
+c PR optimization/13037
+c Contributed by Kirill Smelkov
+c bug symptom: zeta(kkzc) seems to reference to zeta(kkzc-1) instead
+c with gcc-3.2.2 it is OK, so it is a regression.
+c
+ subroutine bug1(expnt)
+ implicit none
+
+ double precision zeta
+ common /bug1_area/zeta(3)
+
+ double precision expnt(3)
+
+
+ integer k, kkzc
+
+ kkzc=0
+ do k=1,3
+ kkzc = kkzc + 1
+ zeta(kkzc) = expnt(k)
+ enddo
+
+c the following line activates the bug
+ call bug1_activator(kkzc)
+ end
+
+
+c dummy subroutine
+ subroutine bug1_activator(inum)
+ implicit none
+ integer inum
+ end
+
+
+c test driver
+ program test_bug1
+ implicit none
+
+ double precision zeta
+ common /bug1_area/zeta(3)
+
+ double precision expnt(3)
+
+ zeta(1) = 0.0d0
+ zeta(2) = 0.0d0
+ zeta(3) = 0.0d0
+
+ expnt(1) = 1.0d0
+ expnt(2) = 2.0d0
+ expnt(3) = 3.0d0
+
+ call bug1(expnt)
+ if ((zeta(1).ne.1) .or. (zeta(2).ne.2) .or. (zeta(3).ne.3)) then
+ call abort
+ endif
+
+ end
+
Index: f77-edit-i-in.f
===================================================================
--- f77-edit-i-in.f (nonexistent)
+++ f77-edit-i-in.f (revision 816)
@@ -0,0 +1,22 @@
+C Test Fortran 77 I edit descriptor for input
+C (ANSI X3.9-1978 Section 13.5.9.1)
+C
+C Origin: David Billinghurst
+C
+C { dg-do run }
+
+ integer i,j
+ character*10 buf
+
+ write(buf,'(A)') '1 -1'
+
+ read(buf,'(I1)') i
+ if ( i.ne.1 ) call abort()
+
+ read(buf,'(1X,I1)') i
+ if ( i.ne.0 ) call abort()
+
+ read(buf,'(1X,I1,1X,I2)') i,j
+ if ( i.ne.0 .and. j.ne.-1 ) call abort()
+
+ end
Index: 19990313-2.f
===================================================================
--- 19990313-2.f (nonexistent)
+++ 19990313-2.f (revision 816)
@@ -0,0 +1,8 @@
+c { dg-do run }
+ integer(kind=8) foo, bar
+ complex c
+ data c/(4e10,0)/
+ foo = 4e10
+ bar = c
+ if (foo .ne. bar) call abort
+ end
Index: 20001111.f
===================================================================
--- 20001111.f (nonexistent)
+++ 20001111.f (revision 816)
@@ -0,0 +1,13 @@
+c { dg-do run }
+ DOUBLE PRECISION VALUE(2), TOLD, BK
+ DATA VALUE /0D0, 1D0/
+ DATA TOLD /0D0/
+ DO I=1, 2
+ BK = VALUE(I)
+ IF(BK .GT. TOLD) GOTO 10
+ ENDDO
+ WRITE(*,*)'Error: BK = ', BK
+ CALL ABORT
+ 10 CONTINUE
+ WRITE(*,*)'No Error: BK = ', BK
+ END
Index: ffree-form-3.f
===================================================================
--- ffree-form-3.f (nonexistent)
+++ ffree-form-3.f (revision 816)
@@ -0,0 +1,20 @@
+! Test acceptance of keywords in free format
+! Origin: David Billinghurst
+!
+! { dg-do compile }
+! { dg-options "-ffree-form" }
+ integer i, j
+ i = 1
+ if ( i .eq. 1 ) then
+ go = 2
+ endif
+ if ( i .eq. 3 ) then
+ i = 4
+ end if
+ do i = 1, 3
+ j = i
+ end do
+ do j = 1, 3
+ i = j
+ enddo
+ end
Index: 20020307-1.f
===================================================================
--- 20020307-1.f (nonexistent)
+++ 20020307-1.f (revision 816)
@@ -0,0 +1,22 @@
+c { dg-do compile }
+ SUBROUTINE SWEEP
+ PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20)
+ REAL(KIND=8) B,W1,W2,BNORM,BINV,WT,W0,C1,C2,R1,R2
+ DIMENSION B(MAXVEC,0:3),W1(MAXVEC,0:3),W2(MAXVEC,0:3)
+ DIMENSION BNORM(MAXVEC),BINV(MAXVEC),WT(MAXVEC),W0(MAXVEC)
+ DIMENSION C1(MAXVEC),C2(MAXVEC),R1(MAXVEC),R2(MAXVEC)
+ DO 200 ILAT=1,2**IDIM
+ DO 200 I1=1,IDIM
+ DO 220 I2=1,IDIM
+ CALL INTACT(ILAT,I1,I1,W1)
+220 CONTINUE
+ DO 310 IATT=1,IDIM
+ DO 311 I=1,100
+ WT(I)=ONE + C1(I)*LOG(EPS+R1(I))
+ IF( R2(I)**2 .LE. (ONE-WT(I)**2) )THEN
+ W0(I)=WT(I)
+ ENDIF
+311 CONTINUE
+310 CONTINUE
+200 CONTINUE
+ END
Index: check0.f
===================================================================
--- check0.f (nonexistent)
+++ check0.f (revision 816)
@@ -0,0 +1,12 @@
+c { dg-do compile }
+CCC Abort fixed by:
+CCC1998-04-21 Jim Wilson
+CCC
+CCC * stmt.c (check_seenlabel): When search for line number note for
+CCC warning, handle case where there is no such note.
+ logical l(10)
+ integer i(10)
+ goto (10,20),l ! { dg-error "Selection expression in computed GOTO" "" }
+ goto (10,20),i ! { dg-error "Selection expression in computed GOTO" "" }
+ 10 stop
+ 20 end
Index: le.f
===================================================================
--- le.f (nonexistent)
+++ le.f (revision 816)
@@ -0,0 +1,30 @@
+c { dg-do run }
+ program fool
+
+ real foo
+ integer n
+ logical t
+
+ foo = 2.5
+ n = 5
+
+ t = (n > foo)
+ if (t .neqv. .true.) call abort
+ t = (n >= foo)
+ if (t .neqv. .true.) call abort
+ t = (n < foo)
+ if (t .neqv. .false.) call abort
+ t = (n <= 5)
+ if (t .neqv. .true.) call abort
+ t = (n >= 5 )
+ if (t .neqv. .true.) call abort
+ t = (n == 5)
+ if (t .neqv. .true.) call abort
+ t = (n /= 5)
+ if (t .neqv. .false.) call abort
+ t = (n /= foo)
+ if (t .neqv. .true.) call abort
+ t = (n == foo)
+ if (t .neqv. .false.) call abort
+
+ end
Index: f77-edit-slash-out.f
===================================================================
--- f77-edit-slash-out.f (nonexistent)
+++ f77-edit-slash-out.f (revision 816)
@@ -0,0 +1,9 @@
+C Test Fortran 77 colon slash descriptor
+C (ANSI X3.9-1978 Section 13.5.4)
+C
+C Origin: David Billinghurst
+C
+C { dg-do run }
+C { dg-output "^123(\n|\r\n|\r)45(\n|\r\n|\r)\$" }
+ write(*,'(3(I1)/2(I1))') (I,I=1,5)
+ end
Index: ffixed-form-1.f
===================================================================
--- ffixed-form-1.f (nonexistent)
+++ ffixed-form-1.f (revision 816)
@@ -0,0 +1,6 @@
+! Test compiler flags: -ffixed-form
+! Origin: David Billinghurst
+!
+! { dg-do compile }
+! { dg-options "-ffixed-form" }
+ end
Index: 980701-1.f
===================================================================
--- 980701-1.f (nonexistent)
+++ 980701-1.f (revision 816)
@@ -0,0 +1,73 @@
+c { dg-do run }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ real s1(2), s2(2), s3(2)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+ equivalence (d1, r1(2))
+ equivalence (r1, s1(2))
+ equivalence (d2, r2(2))
+ equivalence (r2, s2(2))
+ equivalence (d3, r3(2))
+ equivalence (r3, s3(2))
+
+ s1(1) = 1.
+ r1(1) = 1.
+ d1 = 10.
+ r1(4) = 1.
+ r1(5) = 1.
+ i1 = 1
+ s2(1) = 2.
+ r2(1) = 2.
+ d2 = 20.
+ r2(4) = 2.
+ r2(5) = 2.
+ i2 = 2
+ s3(1) = 3.
+ r3(1) = 3.
+ d3 = 30.
+ r3(4) = 3.
+ r3(5) = 3.
+ i3 = 3
+
+ call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
+
+ end
+
+ subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ real s1(2), s2(2), s3(2)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+
+ if (s1(1) .ne. 1.) call abort
+ if (r1(1) .ne. 1.) call abort
+ if (d1 .ne. 10.) call abort
+ if (r1(4) .ne. 1.) call abort
+ if (r1(5) .ne. 1.) call abort
+ if (i1 .ne. 1) call abort
+ if (s2(1) .ne. 2.) call abort
+ if (r2(1) .ne. 2.) call abort
+ if (d2 .ne. 20.) call abort
+ if (r2(4) .ne. 2.) call abort
+ if (r2(5) .ne. 2.) call abort
+ if (i2 .ne. 2) call abort
+ if (s3(1) .ne. 3.) call abort
+ if (r3(1) .ne. 3.) call abort
+ if (d3 .ne. 30.) call abort
+ if (r3(4) .ne. 3.) call abort
+ if (r3(5) .ne. 3.) call abort
+ if (i3 .ne. 3) call abort
+
+ end
Index: ffixed-line-length-0.f
===================================================================
--- ffixed-line-length-0.f (nonexistent)
+++ ffixed-line-length-0.f (revision 816)
@@ -0,0 +1,7 @@
+C Test compiler flags: -ffixed-line-length-0
+C Origin: David Billinghurst
+C
+C { dg-do compile }
+C { dg-options "-ffixed-line-length-0" }
+C The next line has length 257
+ en d
Index: 981117-1.f
===================================================================
--- 981117-1.f (nonexistent)
+++ 981117-1.f (revision 816)
@@ -0,0 +1,24 @@
+c { dg-do compile }
+* egcs-bugs:
+* From: Martin Kahlert
+* Subject: ICE in g77 from egcs-19981109
+* Message-Id: <199811101134.MAA29838@keksy.mchp.siemens.de>
+
+* As of 1998-11-17, fails -O2 -fomit-frame-pointer with
+* egcs/gcc/testsuite/g77.f-torture/compile/981117-1.f:8: internal error--insn does not satisfy its constraints:
+* (insn 31 83 32 (set (reg:SF 8 %st(0))
+* (mult:SF (reg:SF 8 %st(0))
+* (const_double:SF (mem/u:SF (symbol_ref/u:SI ("*.LC1")) 0) 0 0 1073643520))) 350 {strlensi-3} (nil)
+* (nil))
+* ../../egcs/gcc/toplev.c:1390: Internal compiler error in function fatal_insn
+
+* Fixed sometime before 1998-11-21 -- don't know by which change.
+
+ SUBROUTINE SSPTRD
+ PARAMETER (HALF = 0.5 )
+ DO I = 1, N
+ CALL SSPMV(TAUI)
+ ALPHA = -HALF*TAUI
+ CALL SAXPY(ALPHA)
+ ENDDO
+ END
Index: cpp5.h
===================================================================
--- cpp5.h (nonexistent)
+++ cpp5.h (revision 816)
@@ -0,0 +1,3 @@
+ FUNCTION FOO()
+#include "cpp5inc.h"
+ END FUNCTION
cpp5.h
Property changes :
Added: svn:eol-style
## -0,0 +1 ##
+native
\ No newline at end of property
Added: svn:keywords
## -0,0 +1 ##
+Id
\ No newline at end of property
Index: dcomplex.f
===================================================================
--- dcomplex.f (nonexistent)
+++ dcomplex.f (revision 816)
@@ -0,0 +1,19 @@
+c { dg-do run }
+ program foo
+ complex(kind=8) z0, z1, z2
+
+ z0 = dcmplx(0.,.5)
+ z1 = 1./z0
+ if (z1 .ne. dcmplx(0.,-2)) call abort
+
+ z0 = 10.*z0
+ if (z0 .ne. dcmplx(0.,5.)) call abort
+
+ z2 = cmplx(1.,2.)
+ z1 = z0/z2
+ if (z1 .ne. dcmplx(2.,1.)) call abort
+
+ z1 = z0*z2
+ if (z1 .ne. dcmplx(-10.,5.)) call abort
+ end
+
Index: 12632.f
===================================================================
--- 12632.f (nonexistent)
+++ 12632.f (revision 816)
@@ -0,0 +1,6 @@
+C { dg-do compile }
+C { dg-options "-fbounds-check" }
+ INTEGER I(1)
+ I(2) = 0 ! { dg-error "out of bounds" "out of bounds" }
+ END
+
Index: 980628-1.f
===================================================================
--- 980628-1.f (nonexistent)
+++ 980628-1.f (revision 816)
@@ -0,0 +1,63 @@
+c { dg-do run }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+ save
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+ equivalence (r1(2), d1)
+ equivalence (r2(2), d2)
+ equivalence (r3(2), d3)
+
+ r1(1) = 1.
+ d1 = 10.
+ r1(4) = 1.
+ r1(5) = 1.
+ i1 = 1
+ r2(1) = 2.
+ d2 = 20.
+ r2(4) = 2.
+ r2(5) = 2.
+ i2 = 2
+ r3(1) = 3.
+ d3 = 30.
+ r3(4) = 3.
+ r3(5) = 3.
+ i3 = 3
+
+ call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+
+ end
+
+ subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
+ implicit none
+
+ real r1(5), r2(5), r3(5)
+ double precision d1, d2, d3
+ integer i1, i2, i3
+
+ if (r1(1) .ne. 1.) call abort
+ if (d1 .ne. 10.) call abort
+ if (r1(4) .ne. 1.) call abort
+ if (r1(5) .ne. 1.) call abort
+ if (i1 .ne. 1) call abort
+ if (r2(1) .ne. 2.) call abort
+ if (d2 .ne. 20.) call abort
+ if (r2(4) .ne. 2.) call abort
+ if (r2(5) .ne. 2.) call abort
+ if (i2 .ne. 2) call abort
+ if (r3(1) .ne. 3.) call abort
+ if (d3 .ne. 30.) call abort
+ if (r3(4) .ne. 3.) call abort
+ if (r3(5) .ne. 3.) call abort
+ if (i3 .ne. 3) call abort
+
+ end
Index: 980729-0.f
===================================================================
--- 980729-0.f (nonexistent)
+++ 980729-0.f (revision 816)
@@ -0,0 +1,6 @@
+c { dg-do compile }
+c Got ICE on Alpha only with -mieee (currently not tested).
+c Fixed by rth 1998-07-30 alpha.md change.
+ subroutine a(b,c)
+ b = max(b,c)
+ end
Index: 19990502-1.f
===================================================================
--- 19990502-1.f (nonexistent)
+++ 19990502-1.f (revision 816)
@@ -0,0 +1,7 @@
+c { dg-do compile }
+ SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY)
+ INTEGER(kind=2) IGAMS(2,NADC)
+ in = 1
+ do while (in.le.nadc.and.IGAMS(2,in).le.in)
+ enddo
+ END
Index: xformat.f
===================================================================
--- xformat.f (nonexistent)
+++ xformat.f (revision 816)
@@ -0,0 +1,4 @@
+c { dg-do compile }
+ PRINT 10, 2, 3
+10 FORMAT (I1, X, I1) ! { dg-warning "Extension: X descriptor" "Extension: X descriptor" }
+ END
Index: 19981216-0.f
===================================================================
--- 19981216-0.f (nonexistent)
+++ 19981216-0.f (revision 816)
@@ -0,0 +1,90 @@
+c { dg-do compile }
+* Resent-From: Craig Burley
+* Resent-To: craig@jcb-sc.com
+* X-Delivered: at request of burley on mescaline.gnu.org
+* Date: Wed, 16 Dec 1998 18:31:24 +0100
+* From: Dieter Stueken
+* Organization: con terra GmbH
+* To: fortran@gnu.org
+* Subject: possible bug
+* Content-Type: text/plain; charset=iso-8859-1
+* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085
+* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2
+*
+* Hi,
+*
+* I'm about to compile a very old, very ugly Fortran program.
+* For one part I got:
+*
+* f77: Internal compiler error: program f771 got fatal signal 6
+*
+* instead of any detailed error message. I was able to break down the
+* problem to the following source fragment:
+*
+* -------------------------------------------
+ PROGRAM WAP
+
+ integer(kind=8) ios
+ character*80 name
+
+ name = 'blah'
+ open(unit=8,status='unknown',file=name,form='formatted',
+ F iostat=ios) ! { dg-warning "INTEGER in IOSTAT" }
+
+ END
+* -------------------------------------------
+*
+* The problem seems to be caused by the "integer(kind=2) ios" declaration.
+* So far I solved it by simply using a plain integer instead.
+*
+* I'm running gcc on a Linux system compiled/installed
+* with no special options:
+*
+* -> g77 -v
+* g77 version 0.5.23
+* Driving: g77 -v -c -xf77-version /dev/null -xnone
+* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs
+* gcc version 2.8.1
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef
+* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__
+* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional
+* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__
+* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null
+* /dev/null
+* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF)
+* #include "..." search starts here:
+* #include <...> search starts here:
+* /usr/local/include
+* /usr/i686-pc-linux-gnulibc1/include
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include
+* /usr/include
+* End of search list.
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version
+* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s
+* /dev/null
+* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version
+* 2.8.1.
+* GNU Fortran Front End version 0.5.23
+* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s
+* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1
+* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911
+* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o
+* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o
+* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc
+* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o
+* /usr/lib/crtn.o
+* /tmp/cca24911
+* __G77_LIBF77_VERSION__: 0.5.23
+* @(#)LIBF77 VERSION 19970919
+* __G77_LIBI77_VERSION__: 0.5.23
+* @(#) LIBI77 VERSION pjw,dmg-mods 19980405
+* __G77_LIBU77_VERSION__: 0.5.23
+* @(#) LIBU77 VERSION 19970919
+*
+*
+* Regards, Dieter.
+* --
+* Dieter Stüken, con terra GmbH, Münster
+* stueken@conterra.de stueken@qgp.uni-muenster.de
+* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken
+* (0)251-980-2027 (0)251-83-334974
Index: cpp.F
===================================================================
--- cpp.F (nonexistent)
+++ cpp.F (revision 816)
@@ -0,0 +1,10 @@
+c { dg-do compile }
+C When run through the C preprocessor, the indentation of the
+C CONTINUE line must not be mangled.
+ subroutine aap(a, n)
+ dimension a(n)
+ do 10 i = 1, n
+ a(i) = i
+ 10 continue
+ print *, a(1)
+ end
Index: 980628-9.f
===================================================================
--- 980628-9.f (nonexistent)
+++ 980628-9.f (revision 816)
@@ -0,0 +1,58 @@
+c { dg-do run }
+c { dg-options "-std=gnu" }
+* g77 0.5.23 and previous had bugs involving too little space
+* allocated for EQUIVALENCE and COMMON areas needing initial
+* padding to meet alignment requirements of the system.
+
+ call subr
+ end
+
+ subroutine subr
+ implicit none
+
+ character c1(11), c2(11), c3(11)
+ real r1, r2, r3
+ character c4, c5, c6
+ equivalence (r1, c1(2))
+ equivalence (r2, c2(2))
+ equivalence (r3, c3(2))
+
+ c1(1) = '1'
+ r1 = 1.
+ c1(11) = '1'
+ c4 = '4'
+ c2(1) = '2'
+ r2 = 2.
+ c2(11) = '2'
+ c5 = '5'
+ c3(1) = '3'
+ r3 = 3.
+ c3(11) = '3'
+ c6 = '6'
+
+ call x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
+
+ end
+
+ subroutine x (c1, r1, c2, r2, c3, r3, c4, c5, c6)
+ implicit none
+
+ character c1(11), c2(11), c3(11)
+ real r1, r2, r3
+ character c4, c5, c6
+
+ if (c1(1) .ne. '1') call abort
+ if (r1 .ne. 1.) call abort
+ if (c1(11) .ne. '1') call abort
+ if (c4 .ne. '4') call abort
+ if (c2(1) .ne. '2') call abort
+ if (r2 .ne. 2.) call abort
+ if (c2(11) .ne. '2') call abort
+ if (c5 .ne. '5') call abort
+ if (c3(1) .ne. '3') call abort
+ if (r3 .ne. 3.) call abort
+ if (c3(11) .ne. '3') call abort
+ if (c6 .ne. '6') call abort
+
+ end
+
Index: 20000511-1.f
===================================================================
--- 20000511-1.f (nonexistent)
+++ 20000511-1.f (revision 816)
@@ -0,0 +1,22 @@
+c { dg-do compile }
+ subroutine saxpy(n,sa,sx,incx,sy,incy)
+C
+C constant times a vector plus a vector.
+C uses unrolled loop for increments equal to one.
+C jack dongarra, linpack, 3/11/78.
+C modified 12/3/93, array(1) declarations changed to array(*)
+C
+ real sx(*),sy(*),sa
+ integer i,incx,incy,ix,iy,m,mp1,n
+C
+C -ffast-math ICE provoked by this conditional
+ if(sa /= 0.0)then
+C
+C code for both increments equal to 1
+C
+ do i= 1,n
+ sy(i)= sy(i)+sa*sx(i)
+ enddo
+ endif
+ return
+ end
Index: large_vec.f
===================================================================
--- large_vec.f (nonexistent)
+++ large_vec.f (revision 816)
@@ -0,0 +1,4 @@
+c { dg-do run }
+ parameter (nmax=165000)
+ double precision x(nmax)
+ end
Index: 20010115.f
===================================================================
--- 20010115.f (nonexistent)
+++ 20010115.f (revision 816)
@@ -0,0 +1,10 @@
+c { dg-do compile }
+* GNATS PR Fortran/1636
+ PRINT 42, 'HELLO'
+ 42 FORMAT(A)
+ CALL WORLD
+ END
+ SUBROUTINE WORLD
+ PRINT 42, 'WORLD'
+ 42 FORMAT(A)
+ END
Index: 20010430.f
===================================================================
--- 20010430.f (nonexistent)
+++ 20010430.f (revision 816)
@@ -0,0 +1,21 @@
+c { dg-do run }
+ REAL DAT(2,5)
+ DO I = 1, 5
+ DAT(1,I) = I*1.6356-NINT(I*1.6356)
+ DAT(2,I) = I
+ ENDDO
+ DO I = 1, 4
+ DO J = I+1, 5
+ IF (DAT(1,J) - DAT(1,I) .LT. 0.0) THEN
+ DO K = 1, 2
+ TMP = DAT(K,I)
+ DAT(K,I) = DAT(K,J)
+ DAT(K,J) = TMP
+ ENDDO
+ ENDIF
+ ENDDO
+ ENDDO
+ DO I = 1, 4
+ IF (DAT(1,I) .GT. DAT(1,I+1)) CALL ABORT
+ ENDDO
+ END