+2004-07-17 Toon Moene <toon@moene.indiv.nluug.nl>
+
+ * g77.dg: Removed.
+ * g77.f-torture: Ditto.
+
2004-07-17 Joseph S. Myers <jsm@polyomino.org.uk>
* gcc.dg/Wparentheses-2.c, gcc.dg/Wparentheses-3.c,
+++ /dev/null
-C { dg-do compile }
-C { dg-options "-fbounds-check" }
- INTEGER I(1)
- I(2) = 0 ! { dg-error "out of defined range" "out of defined range" }
- END
-
+++ /dev/null
-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-*-*" } }
-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) /1, -23, -1, 1, 9, 10, -9/
- double precision b(ntests) /1, -23, 12, -12, 10, 9, -10/
- double precision x(ntests) /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
+++ /dev/null
-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
+++ /dev/null
-# Copyright (C) 2001, 2002 Free Software Foundation, Inc.
-
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# Test the functionality of programs compiled with profile-directed block
-# ordering using -fprofile-arcs followed by -fbranch-probabilities.
-
-load_lib target-supports.exp
-
-# Some targets don't have any implementation of __bb_init_func or are
-# missing other needed machinery.
-if { ![check_profiling_available "-fprofile-arcs"] } {
- return
-}
-
-# The procedures in profopt.exp need these parameters.
-set tool g77
-set profile_option -fprofile-arcs
-set feedback_option -fbranch-probabilities
-set prof_ext gcda
-set perf_ext tim
-
-# Override the list defined in profopt.exp.
-set PROFOPT_OPTIONS [list \
- { -g } \
- { -O0 } \
- { -O1 } \
- { -O2 } \
- { -O3 } \
- { -O3 -g } \
- { -Os } ]
-
-if $tracelevel then {
- strace $tracelevel
-}
-
-# Load support procs.
-load_lib profopt.exp
-
-foreach src [lsort [glob -nocomplain $srcdir/$subdir/*.f]] {
- # If we're only testing specific files and this isn't one of them, skip it.
- if ![runtest_file_p $runtests $src] then {
- continue
- }
-
- profopt-execute $src
-}
+++ /dev/null
-C Test profile-directed block ordering with various Fortran 77 constructs
-C to catch basic regressions in the functionality.
-
- program bprob1
- implicit none
- integer i,j,k,n
- integer result
- integer lpall, ieall, gtall
- integer lpval, ieval, gtval
-
- lpval = lpall()
- ieval = ieall()
- gtval = gtall()
- if ((lpval .ne. 1) .or. (ieval .ne. 1) .or. (gtval .ne. 1)) then
- call abort
- end if
-
- end
-
-C Pass a value through a function to thwart optimization.
- integer function foo(i)
- implicit none
- integer i
- foo = i
- end
-
-C Test various flavors of GOTO and compare results against expected values.
- integer function gtall()
- implicit none
- integer gt1, gt2, gt3, gt4, gt5
- integer gtval
-
- gtall = 1
- gtval = 0
- gtval = gtval + gt1(0)
- gtval = gtval + gt1(1)
- if (gtval .ne. 3) then
- print *,"gtall part 1: ", gtval, 3
- gtall = 0
- end if
-
- gtval = 0
- gtval = gtval + gt2(3)
- gtval = gtval + gt2(30)
- if (gtval .ne. 12) then
- print *,"gtall part 2: ", gtval, 12
- gtall = 0
- end if
-
- gtval = 0
- gtval = gtval + gt3(0)
- gtval = gtval + gt3(3)
- if (gtval .ne. 48) then
- print *,"gtall part 3: ", gtval, 48
- gtall = 0
- end if
-
- gtval = 0
- gtval = gtval + gt4(1)
- gtval = gtval + gt4(2)
- gtval = gtval + gt4(3)
- if (gtval .ne. 14) then
- print *,"gtall part 4: ", gtval, 14
- gtall = 0
- end if
-
- gtval = 0
- gtval = gtval + gt5(0)
- gtval = gtval + gt5(-1)
- gtval = gtval + gt5(5)
- if (gtval .ne. 14) then
- print *,"gtall part 5: ", gtval, 14
- gtall = 0
- end if
- end
-
-C Test simple GOTO.
- integer function gt1(f)
- implicit none
- integer f
- if (f .ne. 0) goto 100
- gt1 = 1
- goto 101
- 100 gt1 = 2
- 101 continue
- end
-
-C Test simple GOTO again, this time out of a DO loop.
- integer function gt2(f)
- implicit none
- integer f
- integer i
- do i=1,10
- if (i .eq. f) goto 100
- end do
- gt2 = 4
- goto 101
- 100 gt2 = 8
- 101 continue
- end
-
-C Test computed GOTO.
- integer function gt3(i)
- implicit none
- integer i
- gt3 = 8
- goto (101, 102, 103, 104), i
- goto 105
- 101 gt3 = 1024
- goto 105
- 102 gt3 = 2048
- goto 105
- 103 gt3 = 16
- goto 105
- 104 gt3 = 4096
- goto 105
- 105 gt3 = gt3 * 2
- end
-
-C Test assigned GOTO.
- integer function gt4(i)
- implicit none
- integer i
- integer label
- assign 101 to label
- if (i .eq. 2) assign 102 to label
- if (i .eq. 3) assign 103 to label
- goto label, (101, 102, 103)
- 101 gt4 = 1
- goto 104
- 102 gt4 = 2
- goto 104
- 103 gt4 = 4
- 104 gt4 = gt4 * 2
- end
-
-C Test arithmetic IF (bundled with the GOTO variants).
- integer function gt5(i)
- implicit none
- integer i
- gt5 = 1
- if (i) 101, 102, 103
- 101 gt5 = 2
- goto 104
- 102 gt5 = 4
- goto 104
- 103 gt5 = 8
- 104 continue
- end
-
-C Run all of the loop tests and check results against expected values.
- integer function lpall()
- implicit none
- integer loop1, loop2
- integer loopval
-
- lpall = 1
- loopval = 0
- loopval = loopval + loop1(1,0)
- loopval = loopval + loop1(1,2)
- loopval = loopval + loop1(1,7)
- if (loopval .ne. 12) then
- print *,"lpall part 1: ", loopval, 12
- lpall = 0
- end if
-
- loopval = 0
- loopval = loopval + loop2(1,0,0,0)
- loopval = loopval + loop2(1,1,0,0)
- loopval = loopval + loop2(1,1,3,0)
- loopval = loopval + loop2(1,1,3,1)
- loopval = loopval + loop2(1,3,1,5)
- loopval = loopval + loop2(1,3,7,3)
- if (loopval .ne. 87) then
- print *,"lpall part 2: ", loopval, 87
- lpall = 0
- end if
- end
-
-C Test a simple DO loop.
- integer function loop1(r,n)
- implicit none
- integer r,n,i
-
- loop1 = r
- do i=1,n
- loop1 = loop1 + 1
- end do
- end
-
-C Test nested DO loops.
- integer function loop2(r, l, m, n)
- implicit none
- integer r,l,m,n
- integer i,j,k
- loop2 = r
- do i=1,l
- do j=1,m
- do k=1,n
- loop2 = loop2 + 1
- end do
- end do
- end do
- end
-
-C Test various combinations of IF-THEN-ELSE and check results against
-C expected values.
- integer function ieall()
- implicit none
- integer ie1, ie2, ie3
- integer ieval
- ieall = 1
- ieval = 0
-
- ieval = ieval + ie1(0,2)
- ieval = ieval + ie1(0,0)
- ieval = ieval + ie1(1,2)
- ieval = ieval + ie1(10,2)
- ieval = ieval + ie1(11,11)
- if (ieval .ne. 31) then
- print *,"ieall part 1: ", ieval, 31
- ieall = 0
- end if
-
- ieval = 0
- ieval = ieval + ie2(0)
- ieval = ieval + ie2(2)
- ieval = ieval + ie2(2)
- ieval = ieval + ie2(2)
- ieval = ieval + ie2(3)
- ieval = ieval + ie2(3)
- if (ieval .ne. 23) then
- print *,"ieall part 2: ", ieval, 23
- ieall = 0
- end if
-
- ieval = 0
- ieval = ieval + ie3(11,19)
- ieval = ieval + ie3(25,27)
- ieval = ieval + ie3(11,22)
- ieval = ieval + ie3(11,10)
- ieval = ieval + ie3(21,32)
- ieval = ieval + ie3(21,20)
- ieval = ieval + ie3(1,2)
- ieval = ieval + ie3(32,31)
- ieval = ieval + ie3(3,0)
- ieval = ieval + ie3(0,47)
- ieval = ieval + ie3(65,65)
- if (ieval .ne. 246) then
- print *,"ieall part 3: ", ieval, 246
- ieall = 0
- end if
- end
-
-C Test IF-THEN-ELSE.
- integer function ie1(i,j)
- implicit none
- integer i,j
- integer foo
-
- ie1 = 0
- if (i .ne. 0) then
- if (j .ne. 0) then
- ie1 = foo(4)
- else
- ie1 = foo(1024)
- end if
- else
- if (j .ne. 0) then
- ie1 = foo(1)
- else
- ie1 = foo(2)
- end if
- end if
- if (i .gt. j) then
- ie1 = foo(ie1*2)
- end if
- if (i .gt. 10) then
- if (j .gt. 10) then
- ie1 = foo(ie1*4)
- end if
- end if
- end
-
-C Test a series of simple IF-THEN statements.
- integer function ie2(i)
- implicit none
- integer i
- integer foo
- ie2 = 0
-
- if (i .eq. 0) then
- ie2 = foo(1)
- end if
- if (i .eq. 1) then
- ie2 = foo(1024)
- end if
- if (i .eq. 2) then
- ie2 = foo(2)
- end if
- if (i .eq. 3) then
- ie2 = foo(8)
- end if
- if (i .eq. 4) then
- ie2 = foo(2048)
- end if
-
- end
-
-C Test nested IF statements and IF with compound expressions.
- integer function ie3(i,j)
- implicit none
- integer i,j
- integer foo
-
- ie3 = 1
- if ((i .gt. 10) .and. (j .gt. i) .and. (j .lt. 20)) then
- ie3 = foo(16)
- end if
- if (i .gt. 20) then
- if (j .gt. i) then
- if (j .lt. 30) then
- ie3 = foo(32)
- end if
- end if
- end if
- if ((i .eq. 3) .or. (j .eq. 47) .or. (i .eq.j)) then
- ie3 = foo(64)
- end if
- end
+++ /dev/null
-# Copyright (C) 1997 Free Software Foundation, Inc.
-
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# GCC testsuite that uses the `dg.exp' driver.
-
-# Load support procs.
-load_lib g77-dg.exp
-
-# If a testcase doesn't have special options, use these.
-global DEFAULT_FFLAGS
-if ![info exists DEFAULT_FFLAGS] then {
- set DEFAULT_FFLAGS " -pedantic-errors"
-}
-
-# Initialize `dg'.
-dg-init
-
-# Main loop.
-g77-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.f]] \
- $DEFAULT_FFLAGS
-
-# All done.
-dg-finish
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-C Test Fortran 77 I edit descriptor for input
-C (ANSI X3.9-1978 Section 13.5.9.1)
-C
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-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,'(X,I1)') i
- if ( i.ne.0 ) call abort()
-
- read(buf,'(X,I1,X,I2)') i,j
- if ( i.ne.0 .and. j.ne.-1 ) call abort()
-
- end
+++ /dev/null
-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
+++ /dev/null
-C Test Fortran 77 S, SS and SP edit descriptors
-C (ANSI X3.9-1978 Section 13.5.6)
-C
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-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
+++ /dev/null
-C Test Fortran 77 colon slash descriptor
-C (ANSI X3.9-1978 Section 13.5.4)
-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)/2(I1))') (I,I=1,5)
- end
+++ /dev/null
-C Test Fortran 77 T edit descriptor for input
-C (ANSI X3.9-1978 Section 13.5.3.2)
-C
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-C Test compiler flags: -fbackslash
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fbackslash" }
- if ( len('A\nB') .ne. 3 ) call abort
- end
+++ /dev/null
-C Test compiler flags: -fcase-preserve
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fcase-preserve" }
- i = 3
- I = 4
- if ( i .ne. 3 ) call abort
- end
+++ /dev/null
-C Test compiler flags: -ff90
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C Read the g77 manual entry on CMPAMBIG
-C
-C { dg-do run }
-C { dg-options "-ff90" }
- double complex z
- z = (2.0d0,1.0d0)
- call s(real(z))
- end
- subroutine s(x)
- double precision x
- if ( abs(x-2.0d0) .gt. 1.0e-5 ) call abort
- end
+++ /dev/null
-! Test compiler flags: -ffixed-form
-! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-!
-! { dg-do compile }
-! { dg-options "-ffixed-form" }
- end
+++ /dev/null
-! 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
-
+++ /dev/null
-C Test compiler flags: -ffixed-line-length-0
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do compile }
-C { dg-options "-ffixed-line-length-0" }
-C The next line has length 257
- en d
+++ /dev/null
-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*
+++ /dev/null
-C Test compiler flags: -ffixed-line-length-7
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do compile }
-C { dg-options "-ffixed-line-length-7" }
- e*
- $n*
- $d*
+++ /dev/null
-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*
+++ /dev/null
-C Test compiler flags: -ffixed-line-length-none
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do compile }
-C { dg-options "-ffixed-line-length-none" }
-C The next line has length 257
- en d
+++ /dev/null
-! Test compiler flags: -ffree-form
-! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-!
-! { dg-do compile }
-! { dg-options "-ffree-form" }
-end
+++ /dev/null
-! PR fortran/10843
-! Origin: Brad Davis <bdavis9659@comcast.net>
-!
-! { dg-do compile }
-! { dg-options "-ffree-form" }
- GO TO 3
- GOTO 3
- 3 CONTINUE
- GOTO = 55
- END
-
+++ /dev/null
-! Test acceptance of keywords in free format
-! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-!
-! { 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
+++ /dev/null
-C Test compiler flags: -fno-backslash
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fno-backslash" }
- if ( len('A\nB') .ne. 4 ) call abort
- end
+++ /dev/null
-C Test compiler flags: -fno-f90
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C Read the g77 manual entry on CMPAMBIG
-C
-C { dg-do run }
-C { dg-options "-fno-f90 -fugly-complex" }
- double complex z
- z = (2.0d0,1.0d0)
- call s(real(z))
- end
- subroutine s(x)
- real x
- if ( abs(x-2.0) .gt. 1.0e-5 ) call abort
- end
+++ /dev/null
-! Test compiler flags: -fno-fixed-form
-! Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-!
-! { dg-do compile }
-! { dg-options "-fno-fixed-form" }
-end
+++ /dev/null
-C Test compiler flags: -fno-onetrip
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fno-onetrip -w" }
- do i = 1, 0
- call abort
- end do
- end
+++ /dev/null
-C Test compiler flags: -fno-typeless-boz
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fno-typeless-boz" }
- equivalence (i,r)
- r = Z'ABCD1234'
- j = Z'ABCD1234'
- if ( j .eq. i ) call abort
- end
+++ /dev/null
-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_" } }
+++ /dev/null
-C Test compiler flags: -fno-vxt
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fno-vxt" }
- i = 0
- !1
- if ( i .ne. 0 ) call exit
- call abort
- END
+++ /dev/null
-C Test compiler flags: -fonetrip
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fonetrip -w" }
- do i = 1, 0
- call exit
- end do
- call abort
- end
+++ /dev/null
-C Test compiler flags: -ftypeless-boz
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-ftypeless-boz" }
- equivalence (i,r)
- r = Z'ABCD1234'
- j = Z'ABCD1234'
- if ( j .ne. i ) call abort
- end
+++ /dev/null
-C Test compiler flags: -fugly-assumed
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do compile }
-C { dg-options "-fugly-assumed" }
- function f(i)
- integer i(1)
- f = i(1)+i(2)
- end
+++ /dev/null
-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_" } }
+++ /dev/null
-C Test compiler flags: -fvxt
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do run }
-C { dg-options "-fvxt" }
- i = 0
- !1
- if ( i .eq. 0 ) call exit
- call abort
- END
+++ /dev/null
-C { dg-options "-fprofile-arcs -ftest-coverage" }
-C { dg-do run { target native } }
-C
-C Test gcov reports for line counts and branch and call return percentages
-C for various Fortran 77 constructs to catch basic regressions in the
-C functionality.
-
- program gcov1
- implicit none
- integer i,j,k,n
- integer result
- integer lpall, ieall, gtall
- integer lpval, ieval, gtval
-
- ! returns(100)
- lpval = lpall() ! count(1)
- ! returns(100)
- ieval = ieall() ! count(1)
- ! returns(100)
- gtval = gtall() ! count(1)
- ! returns(end)
- if ((lpval .ne. 1) .or. (ieval .ne. 1) .or. (gtval .ne. 1)) then
- call abort
- end if
-
- end
-
-C Pass a value through a function to thwart optimization.
- integer function foo(i)
- implicit none
- integer i
- foo = i ! count(18)
- end
-
-C Test various flavors of GOTO and compare results against expected values.
- integer function gtall()
- implicit none
- integer gt1, gt2, gt3, gt4, gt5
- integer gtval
-
- gtall = 1 ! count(1)
- gtval = 0 ! count(1)
- ! returns(100)
- gtval = gtval + gt1(0) ! count(1)
- ! returns(100)
- gtval = gtval + gt1(1) ! count(1)
- ! returns(end)
- ! branch(0)
- if (gtval .ne. 3) then ! count(1)
- ! branch(end)
- print *,"gtall part 1: ", gtval, 3
- gtall = 0
- end if
-
- gtval = 0 ! count(1)
- ! returns(100)
- gtval = gtval + gt2(9) ! count(1)
- ! returns(100)
- gtval = gtval + gt2(20) ! count(1)
- ! returns(end)
- ! branch(0)
- if (gtval .ne. 12) then ! count(1)
- ! branch(end)
- print *,"gtall part 2: ", gtval, 12
- gtall = 0
- end if
-
- gtval = 0 ! count(1)
- ! returns(100)
- gtval = gtval + gt3(0) ! count(1)
- ! returns(100)
- gtval = gtval + gt3(3) ! count(1)
- ! returns(end)
- ! branch(0)
- if (gtval .ne. 48) then ! count(1)
- ! branch(end)
- ! branch(end)
- print *,"gtall part 3: ", gtval, 48
- gtall = 0
- end if
-
- gtval = 0 ! count(1)
- ! returns(100)
- gtval = gtval + gt4(1) ! count(1)
- ! returns(100)
- gtval = gtval + gt4(2) ! count(1)
- ! returns(100)
- gtval = gtval + gt4(3) ! count(1)
- ! returns(end)
- ! branch(0)
- if (gtval .ne. 14) then ! count(1)
- ! branch(end)
- print *,"gtall part 4: ", gtval, 14
- gtall = 0
- end if
-
- gtval = 0 ! count(1)
- ! returns(100)
- gtval = gtval + gt5(0) ! count(1)
- ! returns(100)
- gtval = gtval + gt5(-1) ! count(1)
- ! returns(100)
- gtval = gtval + gt5(5) ! count(1)
- ! returns(end)
- ! branch(0)
- if (gtval .ne. 14) then ! count(1)
- ! branch(end)
- print *,"gtall part 5: ", gtval, 14
- gtall = 0
- end if
- end
-
-C Test simple GOTO.
- integer function gt1(f)
- implicit none
- integer f
- ! branch(50)
- if (f .ne. 0) goto 100 ! count(2)
- ! branch(end)
- gt1 = 1 ! count(1)
- goto 101 ! count(1)
- 100 gt1 = 2 ! count(1)
- 101 continue ! count(2)
- end
-
-C Test simple GOTO again, this time out of a DO loop.
- integer function gt2(f)
- implicit none
- integer f
- integer i
- ! branch(95)
- do i=1,10
- ! branch(end)
- if (i .eq. f) goto 100 ! count(19)
- end do
- gt2 = 4 ! count(1)
- goto 101 ! count(1)
- 100 gt2 = 8 ! count(1)
- 101 continue ! count(2)
- end
-
-C Test computed GOTO.
- integer function gt3(i)
- implicit none
- integer i
- goto (101, 102, 103, 104), i ! count(2)
- gt3 = 8 ! count(1)
- goto 105 ! count(1)
- 101 gt3 = 1024
- goto 105
- 102 gt3 = 2048
- goto 105
- 103 gt3 = 16 ! count(1)
- goto 105 ! count(1)
- 104 gt3 = 4096
- goto 105
- 105 gt3 = gt3 * 2 ! count(2)
- end
-
-C Test assigned GOTO.
- integer function gt4(i)
- implicit none
- integer i
- integer label
- assign 101 to label ! count(3)
- if (i .eq. 2) assign 102 to label ! count(3)
- if (i .eq. 3) assign 103 to label ! count(3)
- goto label, (101, 102, 103) ! count(3)
- 101 gt4 = 1 ! count(1)
- goto 104 ! count(1)
- 102 gt4 = 2 ! count(1)
- goto 104 ! count(1)
- 103 gt4 = 4 ! count(1)
- 104 gt4 = gt4 * 2 ! count(3)
- end
-
-C Test arithmetic IF (bundled with the GOTO variants).
- integer function gt5(i)
- implicit none
- integer i
- gt5 = 1 ! count(3)
- ! branch(67 50)
- if (i) 101, 102, 103 ! count(3)
- ! branch(end)
- 101 gt5 = 2 ! count(1)
- goto 104 ! count(1)
- 102 gt5 = 4 ! count(1)
- goto 104 ! count(1)
- 103 gt5 = 8 ! count(1)
- 104 continue ! count(3)
- end
-
-C Run all of the loop tests and check results against expected values.
- integer function lpall()
- implicit none
- integer loop1, loop2
- integer loopval
-
- lpall = 1 ! count(1)
- loopval = 0 ! count(1)
- ! returns(100)
- loopval = loopval + loop1(1,0) ! count(1)
- ! returns(100)
- loopval = loopval + loop1(1,2) ! count(1)
- ! returns(100)
- loopval = loopval + loop1(1,7) ! count(1)
- ! returns(end)
- if (loopval .ne. 12) then ! count(1)
- print *,"lpall part 1: ", loopval, 12
- lpall = 0
- end if
-
- loopval = 0 ! count(1)
- ! returns(100)
- loopval = loopval + loop2(1,0,0,0) ! count(1)
- ! returns(100)
- loopval = loopval + loop2(1,1,0,0) ! count(1)
- ! returns(100)
- loopval = loopval + loop2(1,1,3,0) ! count(1)
- ! returns(100)
- loopval = loopval + loop2(1,1,3,1) ! count(1)
- ! returns(100)
- loopval = loopval + loop2(1,3,1,5) ! count(1)
- ! returns(100)
- loopval = loopval + loop2(1,3,7,3) ! count(1)
- ! returns(end)
- if (loopval .ne. 87) then ! count(1)
- print *,"lpall part 2: ", loopval, 87
- lpall = 0
- end if
- end
-
-C Test a simple DO loop.
- integer function loop1(r,n)
- implicit none
- integer r,n,i
-
- loop1 = r ! count(3)
- ! branch(75)
- do i=1,n
- ! branch(end)
- loop1 = loop1 + 1 ! count(9)
- end do
- end
-
-C Test nested DO loops.
- integer function loop2(r, l, m, n)
- implicit none
- integer r,l,m,n
- integer i,j,k
- loop2 = r ! count(6)
- ! branch(60)
- do i=1,l
- ! branch(77)
- do j=1,m
- ! branch(73)
- do k=1,n
- ! branch(end)
- loop2 = loop2 + 1 ! count(81)
- end do
- end do
- end do
- end
-
-C Test various combinations of IF-THEN-ELSE and check results against
-C expected values.
- integer function ieall()
- implicit none
- integer ie1, ie2, ie3
- integer ieval
- ieall = 1 ! count(1)
- ieval = 0 ! count(1)
-
- ieval = ieval + ie1(0,2) ! count(1)
- ieval = ieval + ie1(0,0) ! count(1)
- ieval = ieval + ie1(1,2) ! count(1)
- ieval = ieval + ie1(10,2) ! count(1)
- ieval = ieval + ie1(11,11) ! count(1)
- if (ieval .ne. 31) then ! count(1)
- print *,"ieall part 1: ", ieval, 31
- ieall = 0
- end if
-
- ieval = 0
- ieval = ieval + ie2(0) ! count(1)
- ieval = ieval + ie2(2) ! count(1)
- ieval = ieval + ie2(2) ! count(1)
- ieval = ieval + ie2(2) ! count(1)
- ieval = ieval + ie2(3) ! count(1)
- ieval = ieval + ie2(3) ! count(1)
- if (ieval .ne. 23) then ! count(1)
- print *,"ieall part 2: ", ieval, 23
- ieall = 0
- end if
-
- ieval = 0
- ieval = ieval + ie3(11,19) ! count(1)
- ieval = ieval + ie3(25,27) ! count(1)
- ieval = ieval + ie3(11,22) ! count(1)
- ieval = ieval + ie3(11,10) ! count(1)
- ieval = ieval + ie3(21,32) ! count(1)
- ieval = ieval + ie3(21,20) ! count(1)
- ieval = ieval + ie3(1,2) ! count(1)
- ieval = ieval + ie3(32,31) ! count(1)
- ieval = ieval + ie3(3,0) ! count(1)
- ieval = ieval + ie3(0,47) ! count(1)
- ieval = ieval + ie3(65,65) ! count(1)
- if (ieval .ne. 246) then ! count(1)
- print *,"ieall part 3: ", ieval, 246
- ieall = 0
- end if
- end
-
-C Test IF-THEN-ELSE.
- integer function ie1(i,j)
- implicit none
- integer i,j
- integer foo
-
- ie1 = 0 ! count(5)
- ! branch(40)
- if (i .ne. 0) then ! count(5)
- ! branch(0)
- if (j .ne. 0) then ! count(3)
- ! branch(end)
- ie1 = foo(4) ! count(3)
- else
- ie1 = foo(1024)
- end if
- else
- ! branch(50)
- if (j .ne. 0) then ! count(2)
- ! branch(end)
- ie1 = foo(1) ! count(1)
- else
- ie1 = foo(2) ! count(1)
- end if
- end if
- ! branch(80)
- if (i .gt. j) then ! count(5)
- ! branch(end)
- ie1 = foo(ie1*2)
- end if
- ! branch(80)
- if (i .gt. 10) then ! count(5)
- ! branch(0)
- if (j .gt. 10) then ! count(1)
- ! branch(end)
- ie1 = foo(ie1*4) ! count(1)
- end if
- end if
- end
-
-C Test a series of simple IF-THEN statements.
- integer function ie2(i)
- implicit none
- integer i
- integer foo
- ie2 = 0 ! count(6)
-
- ! branch(83)
- if (i .eq. 0) then ! count(6)
- ! branch(end)
- ie2 = foo(1) ! count(1)
- end if
- ! branch(100)
- if (i .eq. 1) then ! count(6)
- ! branch(end)
- ie2 = foo(1024)
- end if
- ! branch(50)
- if (i .eq. 2) then ! count(6)
- ! branch(end)
- ie2 = foo(2) ! count(3)
- end if
- ! branch(67)
- if (i .eq. 3) then ! count(6)
- ! branch(end)
- ie2 = foo(8) ! count(2)
- end if
- ! branch(100)
- if (i .eq. 4) then ! count(6)
- ! branch(end)
- ie2 = foo(2048)
- end if
-
- end
-
-C Test nested IF statements and IF with compound expressions.
- integer function ie3(i,j)
- implicit none
- integer i,j
- integer foo
-
- ie3 = 1 ! count(11)
- ! branch(27 50 75)
- if ((i .gt. 10) .and. (j .gt. i) .and. (j .lt. 20)) then ! count(11)
- ! branch(end)
- ie3 = foo(16) ! count(1)
- end if
- ! branch(55)
- if (i .gt. 20) then ! count(11)
- ! branch(60)
- if (j .gt. i) then ! count(5)
- ! branch(50)
- if (j .lt. 30) then ! count(2)
- ! branch(end)
- ie3 = foo(32) ! count(1)
- end if
- end if
- end if
- ! branch(9 10 11)
- if ((i .eq. 3) .or. (j .eq. 47) .or. (i .eq.j)) then ! count(11)
- ! branch(end)
- ie3 = foo(64) ! count(3)
- end if
- end
-C
-C { dg-final { run-gcov branches calls { -b gcov-1.f } } }
+++ /dev/null
-# Copyright (C) 1997, 2001 Free Software Foundation, Inc.
-
-# This program is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# Gcov test driver.
-
-# Load support procs.
-load_lib g77-dg.exp
-load_lib gcov.exp
-
-global G77_UNDER_TEST
-
-# For now find gcov in the same directory as $G77_UNDER_TEST.
-if { ![is_remote host] && [string match "*/*" [lindex $G77_UNDER_TEST 0]] } {
- set GCOV [file dirname [lindex $G77_UNDER_TEST 0]]/gcov
-} else {
- set GCOV gcov
-}
-
-# Initialize harness.
-dg-init
-
-# Delete old .da files.
-set files [glob -nocomplain gcov-*.da];
-if { $files != "" } {
- eval "remote_file build delete $files";
-}
-
-# Main loop.
-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/gcov-*.f]] "" ""
-
-dg-finish
+++ /dev/null
-C Test case for PR fortran/3743
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do link }
- integer i
- i = bit_size(i)
- end
+++ /dev/null
-C Test case for PR fortran/3743
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do link }
-C { dg-options "-fcase-preserve -fintrin-case-upper" }
- integer i
- i = BIT_SIZE(i)
- end
+++ /dev/null
-c Test case for PR fortran/3743
-c Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-c
-c { dg-do link }
-c { dg-options "-fcase-preserve -fintrin-case-lower" }
- integer i
- i = bit_size(i)
- end
+++ /dev/null
-C Test case for PR fortran/3743
-C Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-C
-C { dg-do link }
-C { dg-options "-fcase-preserve -fintrin-case-initcap" }
- integer i
- i = Bit_Size(i)
- end
+++ /dev/null
- program pr5473
-c Derived from g77.f-torture/execute/intrinsic-unix-bessel.f
-c Origin: David Billinghurst <David.Billinghurst@riotinto.com>
-c { dg-do compile }
- real x, a
- double precision dx, da
- integer*8 m
- x = 2.0
- dx = x
- m = 2
- a = BESJN(m,x) ! { dg-error "incorrect type" "incorrect type" }
- a = BESYN(m,x) ! { dg-error "incorrect type" "incorrect type" }
- da = DBESJN(m,dx) ! { dg-error "incorrect type" "incorrect type" }
- da = DBESYN(m,dx) ! { dg-error "incorrect type" "incorrect type" }
- end
+++ /dev/null
-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
- IF (100.LT.A) GOTO 10
- GOTO 40
-C
- 20 IF (B.LT.ABS(A)) GOTO 10
- ASSIGN 30 TO M
- GOTO 40
-C
- 30 ASSIGN 10 TO M
- 40 GOTO M,(10,20,30)
- END
+++ /dev/null
-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
+++ /dev/null
-C PR middle-end/12002
- COMPLEX TE1
- TE1=-2.
- TE1=TE1+TE1
- END
+++ /dev/null
- 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
+++ /dev/null
- 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
+++ /dev/null
-* Date: Fri, 5 Mar 1999 00:35:44 -0500 (EST)
-* From: Denes Molnar <molnard@phys.columbia.edu>
-* 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
- DOUBLE COMPLEX 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
-*
-* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+++ /dev/null
-* 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
+++ /dev/null
-* Mailing-List: contact egcs-bugs-help@egcs.cygnus.com; run by ezmlm
-* Precedence: bulk
-* Sender: owner-egcs-bugs@egcs.cygnus.com
-* From: Norbert Conrad <Norbert.Conrad@hrz.uni-giessen.de>
-* 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 <URL:http://egcs.cygnus.com/faq.html#bugreport> 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
+++ /dev/null
- SUBROUTINE G(IGAMS,IWRK,NADC,NCellsInY)
- INTEGER*2 IGAMS(2,NADC)
- in = 1
- do while (in.le.nadc.and.IGAMS(2,in).le.in)
- enddo
- END
+++ /dev/null
-* 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" <brb@halo.hi.is>
-* 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
+++ /dev/null
-* Date: Tue, 24 Aug 1999 12:25:41 +1200 (NZST)
-* From: Jonathan Ravens <ravens@whio.gns.cri.nz>
-* 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 <prog.f>
-!
-! 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
+++ /dev/null
-* 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
-
-C
- 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
+++ /dev/null
-* =foo0.f in Burley's g77 test suite.
- subroutine sub(a)
- common /info/ iarray(1000)
- equivalence (m,iarray(100)), (n,iarray(200))
- real a(m,n)
- a(1,1) = a(2,2)
- end
+++ /dev/null
-* =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*8(A-H,O-Z),INTEGER*4(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*4 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
+++ /dev/null
- subroutine aap(k)
- equivalence (i,r)
- i = k
- print*,r
- end
+++ /dev/null
- 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
+++ /dev/null
- 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
+++ /dev/null
- 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
+++ /dev/null
- 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
+++ /dev/null
- 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
+++ /dev/null
- SUBROUTINE MIST(N, BETA)
- IMPLICIT REAL*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
+++ /dev/null
- 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
+++ /dev/null
-* GNATS PR Fortran/1636
- PRINT 42, 'HELLO'
- 42 FORMAT(A)
- CALL WORLD
- END
- SUBROUTINE WORLD
- PRINT 42, 'WORLD'
- 42 FORMAT(A)
- END
+++ /dev/null
-# 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
+++ /dev/null
- function f(c)
- implicit none
- real*8 c, f
- f = sqrt(c)
- return
- end
+++ /dev/null
-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*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*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*8 MINONE, MINTWO, MINSIX
- PARAMETER (MINONE = -1.D0, MINTWO = -2.D0, MINSIX = -6.D0)
- REAL*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*8 ANUM,FMARK
- REAL*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*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*8 PI,RADDEG,DEGRAD,TWOPI
- PARAMETER(PI=3.141592653589793D0,TWOPI=2.0D0*PI)
- PARAMETER (RADDEG=180.0D0/PI)
- PARAMETER (DEGRAD=PI/180.0D0)
- REAL*8 COSMAX
- PARAMETER (COSMAX=0.9999999999D0)
- REAL*8 TIMFAC
- PARAMETER (TIMFAC=4.88882129D-02)
- REAL*8 KBOLTZ
- PARAMETER (KBOLTZ=1.987191D-03)
- REAL*8 CCELEC
-C..##IF AMBER
-C..##ELIF DISCOVER
-C..##ELSE
- PARAMETER (CCELEC=332.0716D0)
-C..##ENDIF
- REAL*8 CNVFRQ
- PARAMETER (CNVFRQ=2045.5D0/(2.99793D0*6.28319D0))
- REAL*8 SPEEDL
- PARAMETER (SPEEDL=2.99793D-02)
- REAL*8 ATMOSP
- PARAMETER (ATMOSP=1.4584007D-05)
- REAL*8 PATMOS
- PARAMETER (PATMOS = 1.D0 / ATMOSP )
- REAL*8 BOHRR
- PARAMETER (BOHRR = 0.529177249D0 )
- REAL*8 TOKCAL
- PARAMETER (TOKCAL = 627.5095D0 )
-C..##IF MMFF
- real*8 MDAKCAL
- parameter(MDAKCAL=143.9325D0)
-C..##ENDIF
- REAL*8 DEBYEC
- PARAMETER ( DEBYEC = 2.541766D0 / BOHRR )
- REAL*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*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*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*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*8 EPROP, ETERM, EPRESS
- COMMON /ENER/ EPROP(LENENP), ETERM(LENENT), EPRESS(LENENV)
-C..##IF SAVEFCM
-C..##ENDIF
- REAL*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*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*8 TSMTRM(LENENT),TSMTMP(LENENT)
- COMMON /TSMENG/ TSMTRM,TSMTMP
-C...##IF SAVEFCM
-C...##ENDIF
-C..##ENDIF
- REAL*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*8 X(*),Y(*),Z(*),AMASS(*),DDSCR(*)
- REAL*8 DDV(NAT3,*),PARDDV(PARDIM,*),DDM(*),DDS(*)
- REAL*8 DDF(*),PARDDF(*),DDEV(*),PARDDE(*)
- REAL*8 DD1BLK(*),DD1BLL(*),DD1CMP(*)
- REAL*8 TOLDIM,DDVALM
- REAL*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*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
- GOTO 800
- 801 CONTINUE
-C ALLOCATE-SPACE-FOR-DIAGONALIZATION
- ASSIGN 721 TO I720
- GOTO 720
- 721 CONTINUE
-C ALLOCATE-SPACE-FOR-REDUCED-BASIS
- ASSIGN 761 TO I760
- GOTO 760
- 761 CONTINUE
-C ALLOCATE-SPACE-FOR-OTHER-ARRAYS
- ASSIGN 921 TO I920
- 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
- GOTO 840
- 841 CONTINUE
- ELSE
-C ALLOCATE-DUMMY-SPACE-FOR-LSCI
- ASSIGN 881 TO I880
- 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
- GOTO 620
- 621 CONTINUE
-C SAVE-MODES
- ASSIGN 701 TO I700
- 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
- GOTO 640
- 641 CONTINUE
- QDIAG=.FALSE.
-C DO-THE-DIAGONALISATIONS-WITH-RESIDUALS
- ASSIGN 622 TO I620
- GOTO 620
- 622 CONTINUE
- QDIAG=.TRUE.
-C SAVE-MODES
- ASSIGN 702 TO I700
- 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
- 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
- GOTO 620
- 623 CONTINUE
- QDIAG=.TRUE.
- IF((CVGMX.LE.TOLDIM).OR.(ITER.EQ.ITMX)) GOTO 600
-C SAVE-MODES
- ASSIGN 703 TO I700
- GOTO 700
- 703 CONTINUE
- ENDIF
- ENDDO
- ENDIF
- ENDDO
- 600 CONTINUE
-C
-C SAVE-MODES
- ASSIGN 704 TO I700
- 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
-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
-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
-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
-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
-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
-C
-C-----------------------------------------------------------------------
-C TO ALLOCATE-SPACE-FOR-TRANSROT-VECTORS
- 800 CONTINUE
- TRAROT=ALLHP(IREAL8(6*NAT3))
- GOTO I800
-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
-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
-C
-C-----------------------------------------------------------------------
-C TO ALLOCATE-SPACE-FOR-OTHER-ARRAYS
- 920 CONTINUE
- IUPD=ALLHP(INTEG4(PARDIM+3))
- GOTO I920
-C.##ELSE
-C.##ENDIF
- END
+++ /dev/null
- SUBROUTINE SWEEP
- PARAMETER(MAXDIM=4,MAXVEC=4**3*8,MAXT=20)
- REAL*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
+++ /dev/null
- SUBROUTINE FOO (B)
-
- 10 CALL BAR(A)
- ASSIGN 20 TO M
- IF(100.LT.A) GOTO 10
- GOTO 40
-C
- 20 IF(B.LT.ABS(A)) GOTO 10
- ASSIGN 30 TO M
- GOTO 40
-C
- 30 ASSIGN 10 TO M
- 40 GOTO M,(10,20,30)
- END
+++ /dev/null
-C PR fortran/9793
-C larson@w6yx.stanford.edu
-C
- integer a, b, c
-
- c = -2147483648 / -1
-
- a = 1
- b = 0
- c = a / b
-
- print *, c
-
- end
+++ /dev/null
-C Extracted from PR fortran/8485
- PARAMETER (PPMULT = 1.0E5)
- INTEGER*8 NWRONG
- PARAMETER (NWRONG = 8)
- PARAMETER (DDMULT = PPMULT * NWRONG)
- PRINT 10, DDMULT
-10 FORMAT (F10.3)
- END
+++ /dev/null
-* Date: Sat, 16 Mar 1996 19:58:37 -0500 (EST)
-* From: Kate Hedstrom <kate@ahab.Rutgers.EDU>
-* 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
- 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
+++ /dev/null
-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*4 i4
- integer*8 i8
- integer*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*8 i8
- print *, i4, i4a
- print *, i8, i8a
- end
+++ /dev/null
-* 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
+++ /dev/null
-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
-
+++ /dev/null
-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
+++ /dev/null
-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 <jcardoso@inescn.pt>
-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
+++ /dev/null
-
-C To: egcs-bugs@cygnus.com
-C Subject: -fPIC problem showing up with fortran on x86
-C From: Dave Love <d.love@dl.ac.uk>
-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
+++ /dev/null
-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 '*'.
-
+++ /dev/null
-C From: "David C. Doherty" <doherty@networkcs.com>
-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.
+++ /dev/null
-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 <etseidl@jutland.ca.sandia.gov>
-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 alphaev56-unknown-linux-gnu):
-C
-C foo.f: In subroutine `foobar':
-C foo.f:11:
-C subroutine foobar(norb,nnorb)
-C ^
-C Array `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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-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
+++ /dev/null
-* 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 )
-
- 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
+++ /dev/null
-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
+++ /dev/null
-* egcs-bugs:
-* From: Martin Kahlert <martin.kahlert@mchp.siemens.de>
-* 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
+++ /dev/null
-C Derived from lapack
- SUBROUTINE ZGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
- $ WORK, RWORK, INFO )
- COMPLEX*16 WORK( * )
- DO 20 I = 1, RANK
- WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
- 20 CONTINUE
- END
+++ /dev/null
- REAL*8 A,B,C
- REAL*4 RARRAY(19)/19*(-1)/
- INTEGER BOTTOM,RIGHT
- INTEGER IARRAY(19)/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
+++ /dev/null
-# 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
+++ /dev/null
-# Expect driver script for GCC Regression Tests
-# Copyright (C) 1993, 1995, 1997 Free Software Foundation
-#
-# This file is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This program is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this program; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-
-# These tests come from Torbjorn Granlund's (tege@cygnus.com)
-# F torture test suite, and other contributors.
-
-if $tracelevel then {
- strace $tracelevel
-}
-
-# load support procs
-load_lib f-torture.exp
-
-foreach testcase [glob -nocomplain $srcdir/$subdir/*.f] {
- # If we're only testing specific files and this isn't one of them, skip it.
- if ![runtest_file_p $runtests $testcase] then {
- continue
- }
-
- f-torture $testcase
-}
-
-foreach testcase [glob -nocomplain $srcdir/$subdir/*.F] {
- # If we're only testing specific files and this isn't one of them, skip it.
- if ![runtest_file_p $runtests $testcase] then {
- continue
- }
-
- f-torture $testcase
-}
+++ /dev/null
-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
+++ /dev/null
-C The preprocessor must not introduce a newline after
-C the "a" when ARGUMENTS is expanded.
-
-#define ARGUMENTS a\
-
- subroutine yada (ARGUMENTS)
- end
+++ /dev/null
- SUBROUTINE AAP(NOOT)
- DIMENSION NOOT(*)
- END
+++ /dev/null
- PRINT 10, 2, 3
-10 FORMAT (I1, X, I1)
- END
+++ /dev/null
- IMPLICIT NONE
- LOGICAL ERROR
- CHARACTER*12 FORM
- DATA ERROR /.FALSE./
- DATA FORM /' '/
- OPEN(UNIT=60,ACCESS='DIRECT',STATUS='SCRATCH',RECL=255)
- INQUIRE(UNIT=60,FORM=FORM)
- IF (FORM.EQ.'UNFORMATTED') THEN
- ERROR = .FALSE.
- ELSE
- ERROR = .TRUE.
- ENDIF
- CLOSE(UNIT=60)
- IF (ERROR) CALL ABORT
- END
+++ /dev/null
-# Scratch files aren't implemented for mmixware
-# (_stat is a stub and files can't be deleted).
-# Similar restrictions exist for most simulators.
-
-if { [istarget "mmix-knuth-mmixware"]
- || [istarget "arm*-*-elf"]
- || [istarget "strongarm*-*-elf"]
- || [istarget "xscale*-*-elf"]
- || [istarget "cris-*-elf"] } {
- set torture_execute_xfail [istarget]
-}
-
-return 0
+++ /dev/null
-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
-
+++ /dev/null
- character*120 file
- character*5 string
- file = "c:/dos/adir/bdir/cdir/text.doc"
- write(string, *) "a ", file
- if (string .ne. ' a') call abort
-C-- The leading space is normal for list-directed output
-C-- "file" is not printed because it would overflow "string".
- end
+++ /dev/null
-* X-Delivered: at request of burley on mescaline.gnu.org
-* Date: Sat, 31 Oct 1998 18:26:29 +0200 (EET)
-* From: "B. Yanchitsky" <yan@im.imag.kiev.ua>
-* 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!
+++ /dev/null
-* 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*8 (on x86):
-*
-* $ cat x.f
-*[modified for test suite]
- integer *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.
+++ /dev/null
- integer *8 foo, bar
- double precision r
- data r/4d10/
- foo = 4d10
- bar = r
- if (foo .ne. bar) call abort
- end
+++ /dev/null
- integer *8 foo, bar
- complex c
- data c/(4e10,0)/
- foo = 4e10
- bar = c
- if (foo .ne. bar) call abort
- end
+++ /dev/null
- integer *8 foo, bar
- double complex c
- data c/(4d10,0)/
- foo = 4d10
- bar = c
- if (foo .ne. bar) call abort
- end
+++ /dev/null
-* test whether complex operators properly handle
-* full and partial aliasing.
-* (libf2c/libF77 routines used to assume no aliasing,
-* then were changed to accommodate full aliasing, while
-* the libg2c/libF77 versions were changed to accommodate
-* both full and partial aliasing.)
-*
-* NOTE: this (19990325-0.f) is the single-precision version.
-* See 19990325-1.f for the double-precision version.
-
- program complexalias
- implicit none
-
-* Make sure non-aliased cases work. (Catch roundoff/precision
-* problems, etc., here. Modify subroutine check if they occur.)
-
- call tryfull (1, 3, 5)
-
-* Now check various combinations of aliasing.
-
-* Full aliasing.
- call tryfull (1, 1, 5)
-
-* Partial aliasing.
- call trypart (2, 3, 5)
- call trypart (2, 1, 5)
- call trypart (2, 5, 3)
- call trypart (2, 5, 1)
-
- end
-
- subroutine tryfull (xout, xin1, xin2)
- implicit none
- integer xout, xin1, xin2
-
-* out, in1, and in2 are the desired indexes into the REAL array (array).
-
- complex expect
- integer pwr
- integer out, in1, in2
-
- real array(6)
- complex carray(3)
- equivalence (carray(1), array(1))
-
-* Make sure the indexes can be accommodated by the equivalences above.
-
- if (mod (xout, 2) .ne. 1) call abort
- if (mod (xin1, 2) .ne. 1) call abort
- if (mod (xin2, 2) .ne. 1) call abort
-
-* Convert the indexes into ones suitable for the COMPLEX array (carray).
-
- out = (xout + 1) / 2
- in1 = (xin1 + 1) / 2
- in2 = (xin2 + 1) / 2
-
-* Check some open-coded stuff, just in case.
-
- call prepare1 (carray(in1))
- expect = + carray(in1)
- carray(out) = + carray(in1)
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = - carray(in1)
- carray(out) = - carray(in1)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) + carray(in2)
- carray(out) = carray(in1) + carray(in2)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) - carray(in2)
- carray(out) = carray(in1) - carray(in2)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) * carray(in2)
- carray(out) = carray(in1) * carray(in2)
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 2
- carray(out) = carray(in1) ** 2
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 3
- carray(out) = carray(in1) ** 3
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = abs (carray(in1))
- array(out*2-1) = abs (carray(in1))
- array(out*2) = 0
- call check (expect, carray(out))
-
-* Now check the stuff implemented in libF77.
-
- call prepare1 (carray(in1))
- expect = cos (carray(in1))
- carray(out) = cos (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = exp (carray(in1))
- carray(out) = exp (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = log (carray(in1))
- carray(out) = log (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = sin (carray(in1))
- carray(out) = sin (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = sqrt (carray(in1))
- carray(out) = sqrt (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = conjg (carray(in1))
- carray(out) = conjg (carray(in1))
- call check (expect, carray(out))
-
- call prepare1i (carray(in1), pwr)
- expect = carray(in1) ** pwr
- carray(out) = carray(in1) ** pwr
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) / carray(in2)
- carray(out) = carray(in1) / carray(in2)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) ** carray(in2)
- carray(out) = carray(in1) ** carray(in2)
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** .2
- carray(out) = carray(in1) ** .2
- call check (expect, carray(out))
-
- end
-
- subroutine trypart (xout, xin1, xin2)
- implicit none
- integer xout, xin1, xin2
-
-* out, in1, and in2 are the desired indexes into the REAL array (array).
-
- complex expect
- integer pwr
- integer out, in1, in2
-
- real array(6)
- complex carray(3), carrayp(2)
- equivalence (carray(1), array(1))
- equivalence (carrayp(1), array(2))
-
-* Make sure the indexes can be accommodated by the equivalences above.
-
- if (mod (xout, 2) .ne. 0) call abort
- if (mod (xin1, 2) .ne. 1) call abort
- if (mod (xin2, 2) .ne. 1) call abort
-
-* Convert the indexes into ones suitable for the COMPLEX array (carray).
-
- out = xout / 2
- in1 = (xin1 + 1) / 2
- in2 = (xin2 + 1) / 2
-
-* Check some open-coded stuff, just in case.
-
- call prepare1 (carray(in1))
- expect = + carray(in1)
- carrayp(out) = + carray(in1)
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = - carray(in1)
- carrayp(out) = - carray(in1)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) + carray(in2)
- carrayp(out) = carray(in1) + carray(in2)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) - carray(in2)
- carrayp(out) = carray(in1) - carray(in2)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) * carray(in2)
- carrayp(out) = carray(in1) * carray(in2)
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 2
- carrayp(out) = carray(in1) ** 2
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 3
- carrayp(out) = carray(in1) ** 3
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = abs (carray(in1))
- array(out*2) = abs (carray(in1))
- array(out*2+1) = 0
- call check (expect, carrayp(out))
-
-* Now check the stuff implemented in libF77.
-
- call prepare1 (carray(in1))
- expect = cos (carray(in1))
- carrayp(out) = cos (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = exp (carray(in1))
- carrayp(out) = exp (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = log (carray(in1))
- carrayp(out) = log (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = sin (carray(in1))
- carrayp(out) = sin (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = sqrt (carray(in1))
- carrayp(out) = sqrt (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = conjg (carray(in1))
- carrayp(out) = conjg (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1i (carray(in1), pwr)
- expect = carray(in1) ** pwr
- carrayp(out) = carray(in1) ** pwr
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) / carray(in2)
- carrayp(out) = carray(in1) / carray(in2)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) ** carray(in2)
- carrayp(out) = carray(in1) ** carray(in2)
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** .2
- carrayp(out) = carray(in1) ** .2
- call check (expect, carrayp(out))
-
- end
-
- subroutine prepare1 (in)
- implicit none
- complex in
-
- in = (3.2, 4.2)
-
- end
-
- subroutine prepare1i (in, i)
- implicit none
- complex in
- integer i
-
- in = (2.3, 2.5)
- i = 4
-
- end
-
- subroutine prepare2 (in1, in2)
- implicit none
- complex in1, in2
-
- in1 = (1.3, 2.4)
- in2 = (3.5, 7.1)
-
- end
-
- subroutine check (expect, got)
- implicit none
- complex expect, got
-
- if (aimag(expect) .ne. aimag(got)) call abort
- if (real(expect) .ne. real(got)) call abort
-
- end
+++ /dev/null
-* test whether complex operators properly handle
-* full and partial aliasing.
-* (libf2c/libF77 routines used to assume no aliasing,
-* then were changed to accommodate full aliasing, while
-* the libg2c/libF77 versions were changed to accommodate
-* both full and partial aliasing.)
-*
-* NOTE: this (19990325-1.f) is the double-precision version.
-* See 19990325-0.f for the single-precision version.
-
- program doublecomplexalias
- implicit none
-
-* Make sure non-aliased cases work. (Catch roundoff/precision
-* problems, etc., here. Modify subroutine check if they occur.)
-
- call tryfull (1, 3, 5)
-
-* Now check various combinations of aliasing.
-
-* Full aliasing.
- call tryfull (1, 1, 5)
-
-* Partial aliasing.
- call trypart (2, 3, 5)
- call trypart (2, 1, 5)
- call trypart (2, 5, 3)
- call trypart (2, 5, 1)
-
- end
-
- subroutine tryfull (xout, xin1, xin2)
- implicit none
- integer xout, xin1, xin2
-
-* out, in1, and in2 are the desired indexes into the REAL array (array).
-
- double complex expect
- integer pwr
- integer out, in1, in2
-
- double precision array(6)
- double complex carray(3)
- equivalence (carray(1), array(1))
-
-* Make sure the indexes can be accommodated by the equivalences above.
-
- if (mod (xout, 2) .ne. 1) call abort
- if (mod (xin1, 2) .ne. 1) call abort
- if (mod (xin2, 2) .ne. 1) call abort
-
-* Convert the indexes into ones suitable for the COMPLEX array (carray).
-
- out = (xout + 1) / 2
- in1 = (xin1 + 1) / 2
- in2 = (xin2 + 1) / 2
-
-* Check some open-coded stuff, just in case.
-
- call prepare1 (carray(in1))
- expect = + carray(in1)
- carray(out) = + carray(in1)
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = - carray(in1)
- carray(out) = - carray(in1)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) + carray(in2)
- carray(out) = carray(in1) + carray(in2)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) - carray(in2)
- carray(out) = carray(in1) - carray(in2)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) * carray(in2)
- carray(out) = carray(in1) * carray(in2)
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 2
- carray(out) = carray(in1) ** 2
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 3
- carray(out) = carray(in1) ** 3
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = abs (carray(in1))
- array(out*2-1) = abs (carray(in1))
- array(out*2) = 0
- call check (expect, carray(out))
-
-* Now check the stuff implemented in libF77.
-
- call prepare1 (carray(in1))
- expect = cos (carray(in1))
- carray(out) = cos (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = exp (carray(in1))
- carray(out) = exp (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = log (carray(in1))
- carray(out) = log (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = sin (carray(in1))
- carray(out) = sin (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = sqrt (carray(in1))
- carray(out) = sqrt (carray(in1))
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = conjg (carray(in1))
- carray(out) = conjg (carray(in1))
- call check (expect, carray(out))
-
- call prepare1i (carray(in1), pwr)
- expect = carray(in1) ** pwr
- carray(out) = carray(in1) ** pwr
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) / carray(in2)
- carray(out) = carray(in1) / carray(in2)
- call check (expect, carray(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) ** carray(in2)
- carray(out) = carray(in1) ** carray(in2)
- call check (expect, carray(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** .2
- carray(out) = carray(in1) ** .2
- call check (expect, carray(out))
-
- end
-
- subroutine trypart (xout, xin1, xin2)
- implicit none
- integer xout, xin1, xin2
-
-* out, in1, and in2 are the desired indexes into the REAL array (array).
-
- double complex expect
- integer pwr
- integer out, in1, in2
-
- double precision array(6)
- double complex carray(3), carrayp(2)
- equivalence (carray(1), array(1))
- equivalence (carrayp(1), array(2))
-
-* Make sure the indexes can be accommodated by the equivalences above.
-
- if (mod (xout, 2) .ne. 0) call abort
- if (mod (xin1, 2) .ne. 1) call abort
- if (mod (xin2, 2) .ne. 1) call abort
-
-* Convert the indexes into ones suitable for the COMPLEX array (carray).
-
- out = xout / 2
- in1 = (xin1 + 1) / 2
- in2 = (xin2 + 1) / 2
-
-* Check some open-coded stuff, just in case.
-
- call prepare1 (carray(in1))
- expect = + carray(in1)
- carrayp(out) = + carray(in1)
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = - carray(in1)
- carrayp(out) = - carray(in1)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) + carray(in2)
- carrayp(out) = carray(in1) + carray(in2)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) - carray(in2)
- carrayp(out) = carray(in1) - carray(in2)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) * carray(in2)
- carrayp(out) = carray(in1) * carray(in2)
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 2
- carrayp(out) = carray(in1) ** 2
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** 3
- carrayp(out) = carray(in1) ** 3
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = abs (carray(in1))
- array(out*2) = abs (carray(in1))
- array(out*2+1) = 0
- call check (expect, carrayp(out))
-
-* Now check the stuff implemented in libF77.
-
- call prepare1 (carray(in1))
- expect = cos (carray(in1))
- carrayp(out) = cos (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = exp (carray(in1))
- carrayp(out) = exp (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = log (carray(in1))
- carrayp(out) = log (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = sin (carray(in1))
- carrayp(out) = sin (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = sqrt (carray(in1))
- carrayp(out) = sqrt (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = conjg (carray(in1))
- carrayp(out) = conjg (carray(in1))
- call check (expect, carrayp(out))
-
- call prepare1i (carray(in1), pwr)
- expect = carray(in1) ** pwr
- carrayp(out) = carray(in1) ** pwr
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) / carray(in2)
- carrayp(out) = carray(in1) / carray(in2)
- call check (expect, carrayp(out))
-
- call prepare2 (carray(in1), carray(in2))
- expect = carray(in1) ** carray(in2)
- carrayp(out) = carray(in1) ** carray(in2)
- call check (expect, carrayp(out))
-
- call prepare1 (carray(in1))
- expect = carray(in1) ** .2
- carrayp(out) = carray(in1) ** .2
- call check (expect, carrayp(out))
-
- end
-
- subroutine prepare1 (in)
- implicit none
- double complex in
-
- in = (3.2d0, 4.2d0)
-
- end
-
- subroutine prepare1i (in, i)
- implicit none
- double complex in
- integer i
-
- in = (2.3d0, 2.5d0)
- i = 4
-
- end
-
- subroutine prepare2 (in1, in2)
- implicit none
- double complex in1, in2
-
- in1 = (1.3d0, 2.4d0)
- in2 = (3.5d0, 7.1d0)
-
- end
-
- subroutine check (expect, got)
- implicit none
- double complex expect, got
-
- if (dimag(expect) .ne. dimag(got)) call abort
- if (dble(expect) .ne. dble(got)) call abort
-
- end
+++ /dev/null
-* 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
+++ /dev/null
-* 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.
+++ /dev/null
-* From: "Billinghurst, David (RTD)" <David.Billinghurst@riotinto.com.au>
-* 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
+++ /dev/null
-*
-* 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
+++ /dev/null
- 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
+++ /dev/null
- LOGICAL TF(5)
- CHARACTER*60 LINE
- NAMELIST /LIST/ TF,TT,FF,XYZ
- DATA TF /5*.FALSE./
- DATA LINE /'&LIST,TF=.T.,.F.,.T.,FF=33.,TT=23.,XYZ=-1234.55,/'/
- OPEN(1,STATUS='SCRATCH')
- WRITE(1,*) LINE
- REWIND(1)
- READ(1,LIST)
- CLOSE(1)
- IF (TF(5)) CALL ABORT
- END
+++ /dev/null
-# Scratch files aren't implemented for mmixware
-# (_stat is a stub and files can't be deleted).
-# Similar restrictions exist for most simulators.
-
-if { [istarget "mmix-knuth-mmixware"]
- || [istarget "arm*-*-elf"]
- || [istarget "strongarm*-*-elf"]
- || [istarget "xscale*-*-elf"]
- || [istarget "cris-*-elf"] } {
- set torture_execute_xfail [istarget]
-}
-
-return 0
+++ /dev/null
-*
-* 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
+++ /dev/null
- print*,cos(1.0)
- end
+++ /dev/null
- 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
+++ /dev/null
- DO I = 0, 255
- IF (ICHAR(CHAR(I)) .NE. I) CALL ABORT
- ENDDO
- END
+++ /dev/null
- CHARACTER*20 PARTD(6)
- INTEGER*2 L
- DATA (PARTD(L),L=1,6)/'A','B','C','D','E','F'/
- IF ( PARTD(1) .NE. 'A' .OR. PARTD(2) .NE. 'B'
- , .OR. PARTD(3) .NE. 'C' .OR. PARTD(4) .NE. 'D'
- , .OR. PARTD(5) .NE. 'E' .OR. PARTD(6) .NE. 'F')
- , CALL ABORT
- END
+++ /dev/null
- 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
+++ /dev/null
- program testnl
- character*80 line
- dimension a(10),b(10)
- namelist /nl/ a
- data a / 10 * 0.0 /
- data b / 0., 1., 1., 1., 2., 2., 3., 3., 3., 0. /
- data line /'&nl a(2) = 3*1.0, 2*2.0, 3*3.0 /'/
- open(1,status='scratch')
- write(1,'(a)') line
- rewind(1)
- read(1,nl)
- close(1)
- do i = 1, 10
- if (a(i) .ne. b(i)) call abort
- enddo
- end
+++ /dev/null
-# Scratch files aren't implemented for mmixware
-# (_stat is a stub and files can't be deleted).
-# Similar restrictions exist for most simulators.
-
-if { [istarget "mmix-knuth-mmixware"]
- || [istarget "arm*-*-elf"]
- || [istarget "strongarm*-*-elf"]
- || [istarget "xscalearm*-*-elf"]
- || [istarget "cris-*-elf"] } {
- set torture_execute_xfail [istarget]
-}
-
-return 0
+++ /dev/null
- DIMENSION A(-5:5)
- INTEGER*1 IM5, IZ, IP5
- INTEGER*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
+++ /dev/null
-* 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 <burley@gnu.ai.mit.edu> 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
- 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
- ASSIGN = 9 + LOGICAL
- ASSIGN 7 TO RETURN
- ASSIGN 9 TO GO TO
- GO TO = 5
- STOP = 8
- IF (.NOT.REAL) GOTO STOP
- IF (LOGICAL.GT.INTEGER) THEN
- IF = LOGICAL +5
- IF (LOGICAL.EQ.5) ASSIGN 5 TO IF
- INTEGER=IF
- ELSE
- IF (ASSIGN.GT.STOP) ASSIGN 9 TO GOTO
- ELSE = GO TO
- END IF = ELSE + GO TO
- IF (.NOT.REAL.AND.GOTO.GT.ELSE) GOTO RETURN
- 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.
+++ /dev/null
-* 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
+++ /dev/null
- 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
+++ /dev/null
-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
+++ /dev/null
-* 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
+++ /dev/null
-* 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
+++ /dev/null
-* 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
-
+++ /dev/null
-* 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
+++ /dev/null
-* 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
+++ /dev/null
-* 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,
-* including when initial values are provided (e.g. DATA).
-
- program test
- implicit none
-
- real r
- double precision d
- common /cmn/ r, d
-
- if (r .ne. 1.) call abort
- if (d .ne. 10.) call abort
-
- end
-
- block data init
- implicit none
-
- real r
- double precision d
- common /cmn/ r, d
-
- data r/1./, d/10./
-
- end
+++ /dev/null
-# 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
+++ /dev/null
-* 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,
-* including when initial values are provided (e.g. DATA).
-
- program test
- implicit none
-
- character c
- double precision d
- common /cmn/ c, d
-
- if (c .ne. '1') call abort
- if (d .ne. 10.) call abort
-
- end
-
- block data init
- implicit none
-
- character c
- double precision d
- common /cmn/ c, d
-
- data c/'1'/, d/10./
-
- end
+++ /dev/null
-# 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
+++ /dev/null
-* 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,
-* including when initial values are provided (e.g. DATA).
-
- program test
- implicit none
-
- character c
- double precision d(100)
- common /cmn/ c, d
-
- if (d(80) .ne. 10.) call abort
-
- end
-
- block data init
- implicit none
-
- character c
- double precision d(100)
- common /cmn/ c, d
-
- data d(80)/10./
-
- end
OSDN Git Service
