+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
+++ /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.
-
- call subr
- end
-
- subroutine subr
- implicit none
-
- real r1(5), r2(5), r3(5)
- double precision d1, d2, d3
- integer i1, i2, i3
- equivalence (d1, r1(2))
- equivalence (d2, r2(2))
- equivalence (d3, r3(2))
-
- r1(1) = 1.
- d1 = 10.
- r1(4) = 1.
- r1(5) = 1.
- i1 = 1
- r2(1) = 2.
- d2 = 20.
- r2(4) = 2.
- r2(5) = 2.
- i2 = 2
- r3(1) = 3.
- d3 = 30.
- r3(4) = 3.
- r3(5) = 3.
- i3 = 3
-
- call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
-
- end
-
- subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
- implicit none
-
- real r1(5), r2(5), r3(5)
- double precision d1, d2, d3
- integer i1, i2, i3
-
- if (r1(1) .ne. 1.) call abort
- if (d1 .ne. 10.) call abort
- if (r1(4) .ne. 1.) call abort
- if (r1(5) .ne. 1.) call abort
- if (i1 .ne. 1) call abort
- if (r2(1) .ne. 2.) call abort
- if (d2 .ne. 20.) call abort
- if (r2(4) .ne. 2.) call abort
- if (r2(5) .ne. 2.) call abort
- if (i2 .ne. 2) call abort
- if (r3(1) .ne. 3.) call abort
- if (d3 .ne. 30.) call abort
- if (r3(4) .ne. 3.) call abort
- if (r3(5) .ne. 3.) call abort
- if (i3 .ne. 3) call abort
-
- end
-
+++ /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 (d1, r1(2))
- equivalence (d2, r2(2))
- equivalence (d3, r3(2))
-
- r1(1) = 1.
- d1 = 10.
- r1(4) = 1.
- r1(5) = 1.
- i1 = 1
- r2(1) = 2.
- d2 = 20.
- r2(4) = 2.
- r2(5) = 2.
- i2 = 2
- r3(1) = 3.
- d3 = 30.
- r3(4) = 3.
- r3(5) = 3.
- i3 = 3
-
- call x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
-
- end
-
- subroutine x (r1, d1, i1, r2, d2, i2, r3, d3, i3)
- implicit none
-
- real r1(5), r2(5), r3(5)
- double precision d1, d2, d3
- integer i1, i2, i3
-
- if (r1(1) .ne. 1.) call abort
- if (d1 .ne. 10.) call abort
- if (r1(4) .ne. 1.) call abort
- if (r1(5) .ne. 1.) call abort
- if (i1 .ne. 1) call abort
- if (r2(1) .ne. 2.) call abort
- if (d2 .ne. 20.) call abort
- if (r2(4) .ne. 2.) call abort
- if (r2(5) .ne. 2.) call abort
- if (i2 .ne. 2) call abort
- if (r3(1) .ne. 3.) call abort
- if (d3 .ne. 30.) call abort
- if (r3(4) .ne. 3.) call abort
- if (r3(5) .ne. 3.) call abort
- if (i3 .ne. 3) call abort
-
- end
-
+++ /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 (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
-
- real r1(5), r2(5), r3(5)
- real s1(2), s2(2), s3(2)
- double precision d1, d2, d3
- integer i1, i2, i3
- equivalence (r1, s1(2))
- equivalence (d1, r1(2))
- equivalence (r2, s2(2))
- equivalence (d2, r2(2))
- equivalence (r3, s3(2))
- equivalence (d3, r3(2))
-
- s1(1) = 1.
- r1(1) = 1.
- d1 = 10.
- r1(4) = 1.
- r1(5) = 1.
- i1 = 1
- s2(1) = 2.
- r2(1) = 2.
- d2 = 20.
- r2(4) = 2.
- r2(5) = 2.
- i2 = 2
- s3(1) = 3.
- r3(1) = 3.
- d3 = 30.
- r3(4) = 3.
- r3(5) = 3.
- i3 = 3
-
- call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
-
- end
-
- subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
- implicit none
-
- real r1(5), r2(5), r3(5)
- real s1(2), s2(2), s3(2)
- double precision d1, d2, d3
- integer i1, i2, i3
-
- if (s1(1) .ne. 1.) call abort
- if (r1(1) .ne. 1.) call abort
- if (d1 .ne. 10.) call abort
- if (r1(4) .ne. 1.) call abort
- if (r1(5) .ne. 1.) call abort
- if (i1 .ne. 1) call abort
- if (s2(1) .ne. 2.) call abort
- if (r2(1) .ne. 2.) call abort
- if (d2 .ne. 20.) call abort
- if (r2(4) .ne. 2.) call abort
- if (r2(5) .ne. 2.) call abort
- if (i2 .ne. 2) call abort
- if (s3(1) .ne. 3.) call abort
- if (r3(1) .ne. 3.) call abort
- if (d3 .ne. 30.) call abort
- if (r3(4) .ne. 3.) call abort
- if (r3(5) .ne. 3.) call abort
- if (i3 .ne. 3) call abort
-
- end
+++ /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)
- real s1(2), s2(2), s3(2)
- double precision d1, d2, d3
- integer i1, i2, i3
- equivalence (d1, r1(2))
- equivalence (r1, s1(2))
- equivalence (d2, r2(2))
- equivalence (r2, s2(2))
- equivalence (d3, r3(2))
- equivalence (r3, s3(2))
-
- s1(1) = 1.
- r1(1) = 1.
- d1 = 10.
- r1(4) = 1.
- r1(5) = 1.
- i1 = 1
- s2(1) = 2.
- r2(1) = 2.
- d2 = 20.
- r2(4) = 2.
- r2(5) = 2.
- i2 = 2
- s3(1) = 3.
- r3(1) = 3.
- d3 = 30.
- r3(4) = 3.
- r3(5) = 3.
- i3 = 3
-
- call x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
-
- end
-
- subroutine x (s1, r1, d1, i1, s2, r2, d2, i2, s3, r3, d3, i3)
- implicit none
-
- real r1(5), r2(5), r3(5)
- real s1(2), s2(2), s3(2)
- double precision d1, d2, d3
- integer i1, i2, i3
-
- if (s1(1) .ne. 1.) call abort
- if (r1(1) .ne. 1.) call abort
- if (d1 .ne. 10.) call abort
- if (r1(4) .ne. 1.) call abort
- if (r1(5) .ne. 1.) call abort
- if (i1 .ne. 1) call abort
- if (s2(1) .ne. 2.) call abort
- if (r2(1) .ne. 2.) call abort
- if (d2 .ne. 20.) call abort
- if (r2(4) .ne. 2.) call abort
- if (r2(5) .ne. 2.) call abort
- if (i2 .ne. 2) call abort
- if (s3(1) .ne. 3.) call abort
- if (r3(1) .ne. 3.) call abort
- if (d3 .ne. 30.) call abort
- if (r3(4) .ne. 3.) call abort
- if (r3(5) .ne. 3.) call abort
- if (i3 .ne. 3) call abort
-
- end
+++ /dev/null
-c This was originally a compile test.
- IMPLICIT REAL*8 (A-H,O-Z)
- COMMON /C/ A(9), INT
- DATA A /
- 1 0.49999973986348730D01, 0.40000399113084100D01,
- 2 0.29996921166596490D01, 0.20016917082678680D01,
- 3 0.99126390351864390D00, 0.97963256554443300D-01,
- 4 -0.87360964813570100D-02, 0.16917082678692080D-02,
- 5 7./
-C Data values were once mis-compiled on (OSF/1 ?) Alpha with -O2
-c such that, for instance, `7.' appeared as `4.' in the assembler
-c output.
- call test(a(9), 7)
- END
- subroutine test(r, i)
- double precision r
- if (nint(r)/=i) call abort
- 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
-* Test automatic arrays.
- program auto0
- implicit none
- integer i
- integer j0(40)
- integer j1(40)
- integer jc0(40)
- integer jc1(40)
- common /jc0/ jc0
- common /jc1/ jc1
-
- data j0/40*3/
- data j1/40*4/
-
- i = 40
- call a1 (j0, j1, i)
-
- do i = 1, 40
- if (j0(i) .ne. 4) call abort
- if (j1(i) .ne. 3) call abort
- if (jc0(i) .ne. 6) call abort
- if (jc1(i) .ne. 5) call abort
- end do
-
- end
-
- block data jc
- implicit none
- integer jc0(40)
- integer jc1(40)
- common /jc0/ jc0
- common /jc1/ jc1
-
- data jc0/40*5/
- data jc1/40*6/
-
- end
-
- subroutine a1 (j0, j1, n)
- implicit none
- integer j0(40), j1(40), n
- integer k0(n), k1(n)
- integer i
- integer jc0(40)
- integer jc1(40)
- common /jc0/ jc0
- common /jc1/ jc1
-
- do i = 1, 40
- j0(i) = j1(i) - j0(i)
- jc0(i) = jc1(i) - jc0(i)
- end do
-
- n = -1
-
- do i = 1, 40
- k0(i) = n
- k1(i) = n
- end do
-
- do i = 1, 40
- j1(i) = j1(i) + k0(i) * j0(i)
- jc1(i) = jc1(i) + k1(i) * jc0(i)
- end do
-
- n = 500
-
- do i = 1, 40
- if (k0(i) .ne. -1) call abort
- k0(i) = n
- if (k1(i) .ne. -1) call abort
- k1(i) = n
- end do
-
- do i = 1, 40
- j0(i) = j1(i) + j0(i)
- jc0(i) = jc1(i) + jc0(i)
- end do
-
- 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
-* Test automatic arrays.
- program auto1
- implicit none
- integer i
- integer j0(40)
- integer j1(40)
- integer jc0(40)
- integer jc1(40)
- common /jc0/ jc0
- common /jc1/ jc1
-
- data j0/40*3/
- data j1/40*4/
-
- i = 40
- call a1 (j0, j1, i)
-
- do i = 1, 40
- if (j0(i) .ne. 4) call abort
- if (j1(i) .ne. 3) call abort
- if (jc0(i) .ne. 6) call abort
- if (jc1(i) .ne. 5) call abort
- end do
-
- end
-
- block data jc
- implicit none
- integer jc0(40)
- integer jc1(40)
- common /jc0/ jc0
- common /jc1/ jc1
-
- data jc0/40*5/
- data jc1/40*6/
-
- end
-
- subroutine a1 (j0, j1, n)
- implicit none
- integer j0(40), j1(40), n
- integer k0(n,3,2), k1(n,3,2)
- integer i,j,k
- integer jc0(40)
- integer jc1(40)
- common /jc0/ jc0
- common /jc1/ jc1
-
- do i = 1, 40
- j0(i) = j1(i) - j0(i)
- jc0(i) = jc1(i) - jc0(i)
- end do
-
- n = -1
-
- do k = 1, 2
- do j = 1, 3
- do i = 1, 40
- k0(i, j, k) = n
- k1(i, j, k) = n
- end do
- end do
- end do
-
- do i = 1, 40
- j1(i) = j1(i) + k0(i, 3, 2) * j0(i)
- jc1(i) = jc1(i) + k1(i, 1, 1) * jc0(i)
- end do
-
- n = 500
-
- do k = 1, 2
- do j = 1, 3
- do i = 1, 40
- if (k0(i, j, k) .ne. -1) call abort
- k0(i, j, k) = n
- if (k1(i, j, k) .ne. -1) call abort
- k1(i, j, k) = n
- end do
- end do
- end do
-
- do i = 1, 40
- j0(i) = j1(i) + j0(i)
- jc0(i) = jc1(i) + jc0(i)
- end do
-
- 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
- program cabs_1
- complex z0
- real r0
- complex*16 z1
- real*8 r1
-
- z0 = cmplx(3.,4.)
- r0 = cabs(z0)
- if (r0 .ne. 5.) call abort
-
- z1 = dcmplx(3.d0,4.d0)
- r1 = zabs(z1)
- if (r1 .ne. 5.d0) call abort
- end
+++ /dev/null
- PROGRAM TEST
- REAL AB(3)
- do i=1,3
- AB(i)=i
- enddo
- k=1
- n=2
- ind=k-n+2
- if (ind /= 1) call abort
- if (ab(ind) /= 1) call abort
- if (k-n+2 /= 1) call abort
- if (ab(k-n+2) /= 1) call abort
- END
+++ /dev/null
- program complex_1
- complex z0, z1, z2
-
- z0 = cmplx(0.,.5)
- z1 = 1./z0
- if (z1 .ne. cmplx(0.,-2)) call abort
-
- z0 = 10.*z0
- if (z0 .ne. cmplx(0.,5.)) call abort
-
- z2 = cmplx(1.,2.)
- z1 = z0/z2
- if (z1 .ne. cmplx(2.,1.)) call abort
-
- z1 = z0*z2
- if (z1 .ne. cmplx(-10.,5.)) call abort
- end
-
+++ /dev/null
-! Some versions of cpp will delete "//'World' as a C++ comment.
- character*40 title
- title = 'Hello '//'World'
- if (title .ne. 'Hello World') call abort
- end
+++ /dev/null
-C The preprocessor must not mangle Hollerith constants
-C which contain apostrophes.
- integer i, j
- data i /4hbla'/
- data j /"bla'"/
- if (i .ne. j) call abort
- end
+++ /dev/null
- program foo
- complex*16 z0, z1, z2
-
- z0 = dcmplx(0.,.5)
- z1 = 1./z0
- if (z1 .ne. dcmplx(0.,-2)) call abort
-
- z0 = 10.*z0
- if (z0 .ne. dcmplx(0.,5.)) call abort
-
- z2 = cmplx(1.,2.)
- z1 = z0/z2
- if (z1 .ne. dcmplx(2.,1.)) call abort
-
- z1 = z0*z2
- if (z1 .ne. dcmplx(-10.,5.)) call abort
- end
-
+++ /dev/null
-CCC g77 0.5.21 `Actual Bugs':
-CCC * A code-generation bug afflicts Intel x86 targets when `-O2' is
-CCC specified compiling, for example, an old version of the `DNRM2'
-CCC routine. The x87 coprocessor stack is being somewhat mismanaged
-CCC in cases where assigned `GOTO' and `ASSIGN' are involved.
-CCC
-CCC Version 0.5.21 of `g77' contains an initial effort to fix the
-CCC problem, but this effort is incomplete, and a more complete fix is
-CCC planned for the next release.
-
-C Currently this test fails with (at least) `-O2 -funroll-loops' on
-C i586-unknown-linux-gnulibc1.
-
-C (This is actually an obsolete version of dnrm2 -- consult the
-c current Netlib BLAS.)
-
- integer i
- double precision a(1:100), dnrm2
- do i=1,100
- a(i)=0.D0
- enddo
- if (dnrm2(100,a,1) .ne. 0.0) call abort
- end
-
- double precision function dnrm2 ( n, dx, incx)
- integer i, incx, ix, j, n, next
- double precision dx(1), cutlo, cuthi, hitest, sum, xmax,zero,one
- data zero, one /0.0d0, 1.0d0/
- data cutlo, cuthi / 8.232d-11, 1.304d19 /
- j = 0
- if(n .gt. 0 .and. incx.gt.0) go to 10
- dnrm2 = zero
- go to 300
- 10 assign 30 to next
- sum = zero
- i = 1
- ix = 1
- 20 go to next,(30, 50, 70, 110)
- 30 if( dabs(dx(i)) .gt. cutlo) go to 85
- assign 50 to next
- xmax = zero
- 50 if( dx(i) .eq. zero) go to 200
- if( dabs(dx(i)) .gt. cutlo) go to 85
- assign 70 to next
- go to 105
- 100 continue
- ix = j
- assign 110 to next
- sum = (sum / dx(i)) / dx(i)
- 105 xmax = dabs(dx(i))
- go to 115
- 70 if( dabs(dx(i)) .gt. cutlo ) go to 75
- 110 if( dabs(dx(i)) .le. xmax ) go to 115
- sum = one + sum * (xmax / dx(i))**2
- xmax = dabs(dx(i))
- go to 200
- 115 sum = sum + (dx(i)/xmax)**2
- go to 200
- 75 sum = (sum * xmax) * xmax
- 85 hitest = cuthi/float( n )
- do 95 j = ix,n
- if(dabs(dx(i)) .ge. hitest) go to 100
- sum = sum + dx(i)**2
- i = i + incx
- 95 continue
- dnrm2 = dsqrt( sum )
- go to 300
- 200 continue
- ix = ix + 1
- i = i + incx
- if( ix .le. n ) go to 20
- dnrm2 = xmax * dsqrt(sum)
- 300 continue
- end
+++ /dev/null
-c============================================== test.f
- real x, y
- real*8 x1, y1
- x=0.
- y = erfc(x)
- if (y .ne. 1.) call abort
-
- x=1.1
- y = erfc(x)
- if (abs(y - .1197949) .ge. 1.e-6) call abort
-
-* modified from x=10, y .gt. 1.5e-44 to avoid lack of -mieee on Alphas.
- x=8
- y = erfc(x)
- if (y .gt. 1.2e-28) call abort
-
- x1=0.
- y1 = erfc(x1)
- if (y1 .ne. 1.) call abort
-
- x1=1.1d0
- y1 = erfc(x1)
- if (abs(y1 - .1197949d0) .ge. 1.d-6) call abort
-
- x1=10
- y1 = erfc(x1)
- if (y1 .gt. 1.5d-44) call abort
- end
-c=================================================
-!output:
-! 0. 1.875
-! 1.10000002 1.48958981
-! 10. 5.00220949E-06
-!
-!The values should be:
-!erfc(0)=1
-!erfc(1.1)= 0.1197949
-!erfc(10)<1.543115467311259E-044
+++ /dev/null
-# Copyright (C) 1991, 1992, 1993, 1995, 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.
-
-# This file was written by Rob Savoye. (rob@cygnus.com)
-# Modified and maintained by Jeffrey Wheat (cassidy@cygnus.com)
-
-#
-# These tests come from Torbjorn Granlund (tege@cygnus.com)
-# Fortran torture test suite.
-#
-
-if $tracelevel then {
- strace $tracelevel
-}
-
-# load support procs
-load_lib f-torture.exp
-
-#
-# main test loop
-#
-
-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
- }
-
- f-torture-execute $src
-}
-
-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
- }
-
- f-torture-execute $src
-}
+++ /dev/null
- a = 2**-2*1.
- if (a .ne. .25) call abort
- end
+++ /dev/null
-c f90-intrinsic-bit.f
-c
-c Test Fortran 90
-c * intrinsic bit manipulation functions - Section 13.10.10
-c * bitcopy subroutine - Section 13.9.3
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
-c Notes:
-c * g77 only supports scalar arguments
-c * third argument of ISHFTC is not optional in g77
-
- logical fail
- integer i, i2, ia, i3
- integer*2 j, j2, j3, ja
- integer*1 k, k2, k3, ka
- integer*8 m, m2, m3, ma
-
- common /flags/ fail
- fail = .false.
-
-c BIT_SIZE - Section 13.13.16
-c Determine BIT_SIZE by counting the bits
- ia = 0
- i = 0
- i = not(i)
- do while ( (i.ne.0) .and. (ia.lt.127) )
- ia = ia + 1
- i = ishft(i,-1)
- end do
- call c_i(BIT_SIZE(i),ia,'BIT_SIZE(integer)')
- ja = 0
- j = 0
- j = not(j)
- do while ( (j.ne.0) .and. (ja.lt.127) )
- ja = ja + 1
- j = ishft(j,-1)
- end do
- call c_i2(BIT_SIZE(j),ja,'BIT_SIZE(integer*2)')
- ka = 0
- k = 0
- k = not(k)
- do while ( (k.ne.0) .and. (ka.lt.127) )
- ka = ka + 1
- k = ishft(k,-1)
- end do
- call c_i1(BIT_SIZE(k),ka,'BIT_SIZE(integer*1)')
- ma = 0
- m = 0
- m = not(m)
- do while ( (m.ne.0) .and. (ma.lt.127) )
- ma = ma + 1
- m = ishft(m,-1)
- end do
- call c_i8(BIT_SIZE(m),ma,'BIT_SIZE(integer*8)')
-
-c BTEST - Section 13.13.17
- j = 7
- j2 = 3
- k = 7
- k2 = 3
- m = 7
- m2 = 3
- call c_l(BTEST(7,3),.true.,'BTEST(integer,integer)')
- call c_l(BTEST(7,j2),.true.,'BTEST(integer,integer*2)')
- call c_l(BTEST(7,k2),.true.,'BTEST(integer,integer*1)')
- call c_l(BTEST(7,m2),.true.,'BTEST(integer,integer*8)')
- call c_l(BTEST(j,3),.true.,'BTEST(integer*2,integer)')
- call c_l(BTEST(j,j2),.true.,'BTEST(integer*2,integer*2)')
- call c_l(BTEST(j,k2),.true.,'BTEST(integer*2,integer*1)')
- call c_l(BTEST(j,m2),.true.,'BTEST(integer*2,integer*8)')
- call c_l(BTEST(k,3),.true.,'BTEST(integer*1,integer)')
- call c_l(BTEST(k,j2),.true.,'BTEST(integer*1,integer*2)')
- call c_l(BTEST(k,k2),.true.,'BTEST(integer*1,integer*1)')
- call c_l(BTEST(k,m2),.true.,'BTEST(integer*1,integer*8)')
- call c_l(BTEST(m,3),.true.,'BTEST(integer*8,integer)')
- call c_l(BTEST(m,j2),.true.,'BTEST(integer*8,integer*2)')
- call c_l(BTEST(m,k2),.true.,'BTEST(integer*8,integer*1)')
- call c_l(BTEST(m,m2),.true.,'BTEST(integer*8,integer*8)')
-
-c IAND - Section 13.13.40
- j = 3
- j2 = 1
- ja = 1
- k = 3
- k2 = 1
- ka = 1
- m = 3
- m2 = 1
- ma = 1
- call c_i(IAND(3,1),1,'IAND(integer,integer)')
- call c_i2(IAND(j,j2),ja,'IAND(integer*2,integer*2)')
- call c_i1(IAND(k,k2),ka,'IAND(integer*1,integer*1)')
- call c_i8(IAND(m,m2),ma,'IAND(integer*8,integer*8)')
-
-
-c IBCLR - Section 13.13.41
- j = 14
- j2 = 1
- ja = 12
- k = 14
- k2 = 1
- ka = 12
- m = 14
- m2 = 1
- ma = 12
- call c_i(IBCLR(14,1),12,'IBCLR(integer,integer)')
- call c_i(IBCLR(14,j2),12,'IBCLR(integer,integer*2)')
- call c_i(IBCLR(14,k2),12,'IBCLR(integer,integer*1)')
- call c_i(IBCLR(14,m2),12,'IBCLR(integer,integer*8)')
- call c_i2(IBCLR(j,1),ja,'IBCLR(integer*2,integer)')
- call c_i2(IBCLR(j,j2),ja,'IBCLR(integer*2,integer*2)')
- call c_i2(IBCLR(j,k2),ja,'IBCLR(integer*2,integer*1)')
- call c_i2(IBCLR(j,m2),ja,'IBCLR(integer*2,integer*8)')
- call c_i1(IBCLR(k,1),ka,'IBCLR(integer*1,integer)')
- call c_i1(IBCLR(k,j2),ka,'IBCLR(integer*1,integer*2)')
- call c_i1(IBCLR(k,k2),ka,'IBCLR(integer*1,integer*1)')
- call c_i1(IBCLR(k,m2),ka,'IBCLR(integer*1,integer*8)')
- call c_i8(IBCLR(m,1),ma,'IBCLR(integer*8,integer)')
- call c_i8(IBCLR(m,j2),ma,'IBCLR(integer*8,integer*2)')
- call c_i8(IBCLR(m,k2),ma,'IBCLR(integer*8,integer*1)')
- call c_i8(IBCLR(m,m2),ma,'IBCLR(integer*8,integer*8)')
-
-c IBSET - Section 13.13.43
- j = 12
- j2 = 1
- ja = 14
- k = 12
- k2 = 1
- ka = 14
- m = 12
- m2 = 1
- ma = 14
- call c_i(IBSET(12,1),14,'IBSET(integer,integer)')
- call c_i(IBSET(12,j2),14,'IBSET(integer,integer*2)')
- call c_i(IBSET(12,k2),14,'IBSET(integer,integer*1)')
- call c_i(IBSET(12,m2),14,'IBSET(integer,integer*8)')
- call c_i2(IBSET(j,1),ja,'IBSET(integer*2,integer)')
- call c_i2(IBSET(j,j2),ja,'IBSET(integer*2,integer*2)')
- call c_i2(IBSET(j,k2),ja,'IBSET(integer*2,integer*1)')
- call c_i2(IBSET(j,m2),ja,'IBSET(integer*2,integer*8)')
- call c_i1(IBSET(k,1),ka,'IBSET(integer*1,integer)')
- call c_i1(IBSET(k,j2),ka,'IBSET(integer*1,integer*2)')
- call c_i1(IBSET(k,k2),ka,'IBSET(integer*1,integer*1)')
- call c_i1(IBSET(k,m2),ka,'IBSET(integer*1,integer*8)')
- call c_i8(IBSET(m,1),ma,'IBSET(integer*8,integer)')
- call c_i8(IBSET(m,j2),ma,'IBSET(integer*8,integer*2)')
- call c_i8(IBSET(m,k2),ma,'IBSET(integer*8,integer*1)')
- call c_i8(IBSET(m,m2),ma,'IBSET(integer*8,integer*8)')
-
-c IEOR - Section 13.13.45
- j = 3
- j2 = 1
- ja = 2
- k = 3
- k2 = 1
- ka = 2
- m = 3
- m2 = 1
- ma = 2
- call c_i(IEOR(3,1),2,'IEOR(integer,integer)')
- call c_i2(IEOR(j,j2),ja,'IEOR(integer*2,integer*2)')
- call c_i1(IEOR(k,k2),ka,'IEOR(integer*1,integer*1)')
- call c_i8(IEOR(m,m2),ma,'IEOR(integer*8,integer*8)')
-
-c ISHFT - Section 13.13.49
- i = 3
- i2 = 1
- i3 = 0
- ia = 6
- j = 3
- j2 = 1
- j3 = 0
- ja = 6
- k = 3
- k2 = 1
- k3 = 0
- ka = 6
- m = 3
- m2 = 1
- m3 = 0
- ma = 6
- call c_i(ISHFT(i,i2),ia,'ISHFT(integer,integer)')
- call c_i(ISHFT(i,BIT_SIZE(i)),i3,'ISHFT(integer,integer) 2')
- call c_i(ISHFT(i,-BIT_SIZE(i)),i3,'ISHFT(integer,integer) 3')
- call c_i(ISHFT(i,0),i,'ISHFT(integer,integer) 4')
- call c_i2(ISHFT(j,j2),ja,'ISHFT(integer*2,integer*2)')
- call c_i2(ISHFT(j,BIT_SIZE(j)),j3,
- $ 'ISHFT(integer*2,integer*2) 2')
- call c_i2(ISHFT(j,-BIT_SIZE(j)),j3,
- $ 'ISHFT(integer*2,integer*2) 3')
- call c_i2(ISHFT(j,0),j,'ISHFT(integer*2,integer*2) 4')
- call c_i1(ISHFT(k,k2),ka,'ISHFT(integer*1,integer*1)')
- call c_i1(ISHFT(k,BIT_SIZE(k)),k3,
- $ 'ISHFT(integer*1,integer*1) 2')
- call c_i1(ISHFT(k,-BIT_SIZE(k)),k3,
- $ 'ISHFT(integer*1,integer*1) 3')
- call c_i1(ISHFT(k,0),k,'ISHFT(integer*1,integer*1) 4')
- call c_i8(ISHFT(m,m2),ma,'ISHFT(integer*8,integer*8)')
- call c_i8(ISHFT(m,BIT_SIZE(m)),m3,
- $ 'ISHFT(integer*8,integer*8) 2')
- call c_i8(ISHFT(m,-BIT_SIZE(m)),m3,
- $ 'ISHFT(integer*8,integer*8) 3')
- call c_i8(ISHFT(m,0),m,'ISHFT(integer*8,integer*8) 4')
-
-c ISHFTC - Section 13.13.50
-c The third argument is not optional in g77
- i = 3
- i2 = 2
- i3 = 3
- ia = 5
- j = 3
- j2 = 2
- j3 = 3
- ja = 5
- k = 3
- k2 = 2
- k3 = 3
- ka = 5
- m2 = 2
- m3 = 3
- ma = 5
-c test all the combinations of arguments
- call c_i(ISHFTC(i,i2,i3),5,'ISHFTC(integer,integer,integer)')
- call c_i(ISHFTC(i,i2,j3),5,'ISHFTC(integer,integer,integer*2)')
- call c_i(ISHFTC(i,i2,k3),5,'ISHFTC(integer,integer,integer*1)')
- call c_i(ISHFTC(i,i2,m3),5,'ISHFTC(integer,integer,integer*8)')
- call c_i(ISHFTC(i,j2,i3),5,'ISHFTC(integer,integer*2,integer)')
- call c_i(ISHFTC(i,j2,j3),5,'ISHFTC(integer,integer*2,integer*2)')
- call c_i(ISHFTC(i,j2,k3),5,'ISHFTC(integer,integer*2,integer*1)')
- call c_i(ISHFTC(i,j2,m3),5,'ISHFTC(integer,integer*2,integer*8)')
- call c_i(ISHFTC(i,k2,i3),5,'ISHFTC(integer,integer*1,integer)')
- call c_i(ISHFTC(i,k2,j3),5,'ISHFTC(integer,integer*1,integer*2)')
- call c_i(ISHFTC(i,k2,k3),5,'ISHFTC(integer,integer*1,integer*1)')
- call c_i(ISHFTC(i,k2,m3),5,'ISHFTC(integer,integer*1,integer*8)')
- call c_i(ISHFTC(i,m2,i3),5,'ISHFTC(integer,integer*8,integer)')
- call c_i(ISHFTC(i,m2,j3),5,'ISHFTC(integer,integer*8,integer*2)')
- call c_i(ISHFTC(i,m2,k3),5,'ISHFTC(integer,integer*8,integer*1)')
- call c_i(ISHFTC(i,m2,m3),5,'ISHFTC(integer,integer*8,integer*8)')
-
- call c_i2(ISHFTC(j,i2,i3),ja,'ISHFTC(integer*2,integer,integer)')
- call c_i2(ISHFTC(j,i2,j3),ja,
- $ 'ISHFTC(integer*2,integer,integer*2)')
- call c_i2(ISHFTC(j,i2,k3),ja,
- $ 'ISHFTC(integer*2,integer,integer*1)')
- call c_i2(ISHFTC(j,i2,m3),ja,
- $ 'ISHFTC(integer*2,integer,integer*8)')
- call c_i2(ISHFTC(j,j2,i3),ja,
- $ 'ISHFTC(integer*2,integer*2,integer)')
- call c_i2(ISHFTC(j,j2,j3),ja,
- $ 'ISHFTC(integer*2,integer*2,integer*2)')
- call c_i2(ISHFTC(j,j2,k3),ja,
- $ 'ISHFTC(integer*2,integer*2,integer*1)')
- call c_i2(ISHFTC(j,j2,m3),ja,
- $ 'ISHFTC(integer*2,integer*2,integer*8)')
- call c_i2(ISHFTC(j,k2,i3),ja,
- $ 'ISHFTC(integer*2,integer*1,integer)')
- call c_i2(ISHFTC(j,k2,j3),ja,
- $ 'ISHFTC(integer*2,integer*1,integer*2)')
- call c_i2(ISHFTC(j,k2,k3),ja,
- $ 'ISHFTC(integer*2,integer*1,integer*1)')
- call c_i2(ISHFTC(j,k2,m3),ja,
- $ 'ISHFTC(integer*2,integer*1,integer*8)')
- call c_i2(ISHFTC(j,m2,i3),ja,
- $ 'ISHFTC(integer*2,integer*8,integer)')
- call c_i2(ISHFTC(j,m2,j3),ja,
- $ 'ISHFTC(integer*2,integer*8,integer*2)')
- call c_i2(ISHFTC(j,m2,k3),ja,
- $ 'ISHFTC(integer*2,integer*8,integer*1)')
- call c_i2(ISHFTC(j,m2,m3),ja,
- $ 'ISHFTC(integer*2,integer*8,integer*8)')
-
- call c_i1(ISHFTC(k,i2,i3),ka,'ISHFTC(integer*1,integer,integer)')
- call c_i1(ISHFTC(k,i2,j3),ka,
- $ 'ISHFTC(integer*1,integer,integer*2)')
- call c_i1(ISHFTC(k,i2,k3),ka,
- $ 'ISHFTC(integer*1,integer,integer*1)')
- call c_i1(ISHFTC(k,i2,m3),ka,
- $ 'ISHFTC(integer*1,integer,integer*8)')
- call c_i1(ISHFTC(k,j2,i3),ka,
- $ 'ISHFTC(integer*1,integer*2,integer)')
- call c_i1(ISHFTC(k,j2,j3),ka,
- $ 'ISHFTC(integer*1,integer*2,integer*2)')
- call c_i1(ISHFTC(k,j2,k3),ka,
- $ 'ISHFTC(integer*1,integer*2,integer*1)')
- call c_i1(ISHFTC(k,j2,m3),ka,
- $ 'ISHFTC(integer*1,integer*2,integer*8)')
- call c_i1(ISHFTC(k,k2,i3),ka,
- $ 'ISHFTC(integer*1,integer*1,integer)')
- call c_i1(ISHFTC(k,k2,j3),ka,
- $ 'ISHFTC(integer*1,integer*1,integer*2)')
- call c_i1(ISHFTC(k,k2,k3),ka,
- $ 'ISHFTC(integer*1,integer*1,integer*1)')
- call c_i1(ISHFTC(k,k2,m3),ka,
- $ 'ISHFTC(integer*1,integer*1,integer*8)')
- call c_i1(ISHFTC(k,m2,i3),ka,
- $ 'ISHFTC(integer*1,integer*8,integer)')
- call c_i1(ISHFTC(k,m2,j3),ka,
- $ 'ISHFTC(integer*1,integer*8,integer*2)')
- call c_i1(ISHFTC(k,m2,k3),ka,
- $ 'ISHFTC(integer*1,integer*8,integer*1)')
- call c_i1(ISHFTC(k,m2,m3),ka,
- $ 'ISHFTC(integer*1,integer*8,integer*8)')
-
- call c_i8(ISHFTC(m,i2,i3),ma,'ISHFTC(integer*8,integer,integer)')
- call c_i8(ISHFTC(m,i2,j3),ma,
- $ 'ISHFTC(integer*8,integer,integer*2)')
- call c_i8(ISHFTC(m,i2,k3),ma,
- $ 'ISHFTC(integer*8,integer,integer*1)')
- call c_i8(ISHFTC(m,i2,m3),ma,
- $ 'ISHFTC(integer*8,integer,integer*8)')
- call c_i8(ISHFTC(m,j2,i3),ma,
- $ 'ISHFTC(integer*8,integer*2,integer)')
- call c_i8(ISHFTC(m,j2,j3),ma,
- $ 'ISHFTC(integer*8,integer*2,integer*2)')
- call c_i8(ISHFTC(m,j2,k3),ma,
- $ 'ISHFTC(integer*8,integer*2,integer*1)')
- call c_i8(ISHFTC(m,j2,m3),ma,
- $ 'ISHFTC(integer*8,integer*2,integer*8)')
- call c_i8(ISHFTC(m,k2,i3),ma,
- $ 'ISHFTC(integer*8,integer*1,integer)')
- call c_i8(ISHFTC(m,k2,j3),ma,
- $ 'ISHFTC(integer*1,integer*8,integer*2)')
- call c_i8(ISHFTC(m,k2,k3),ma,
- $ 'ISHFTC(integer*1,integer*8,integer*1)')
- call c_i8(ISHFTC(m,k2,m3),ma,
- $ 'ISHFTC(integer*1,integer*8,integer*8)')
- call c_i8(ISHFTC(m,m2,i3),ma,
- $ 'ISHFTC(integer*8,integer*8,integer)')
- call c_i8(ISHFTC(m,m2,j3),ma,
- $ 'ISHFTC(integer*8,integer*8,integer*2)')
- call c_i8(ISHFTC(m,m2,k3),ma,
- $ 'ISHFTC(integer*8,integer*8,integer*1)')
- call c_i8(ISHFTC(m,m2,m3),ma,
- $ 'ISHFTC(integer*8,integer*8,integer*8)')
-
-c test the corner cases
- call c_i(ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)),i,
- $ 'ISHFTC(i,BIT_SIZE(i),BIT_SIZE(i)) i = integer')
- call c_i(ISHFTC(i,0,BIT_SIZE(i)),i,
- $ 'ISHFTC(i,0,BIT_SIZE(i)) i = integer')
- call c_i(ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)),i,
- $ 'ISHFTC(i,-BIT_SIZE(i),BIT_SIZE(i)) i = integer')
- call c_i2(ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)),j,
- $ 'ISHFTC(j,BIT_SIZE(j),BIT_SIZE(j)) j = integer*2')
- call c_i2(ISHFTC(j,0,BIT_SIZE(j)),j,
- $ 'ISHFTC(j,0,BIT_SIZE(j)) j = integer*2')
- call c_i2(ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)),j,
- $ 'ISHFTC(j,-BIT_SIZE(j),BIT_SIZE(j)) j = integer*2')
- call c_i1(ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)),k,
- $ 'ISHFTC(k,BIT_SIZE(k),BIT_SIZE(k)) k = integer*1')
- call c_i1(ISHFTC(k,0,BIT_SIZE(k)),k,
- $ 'ISHFTC(k,0,BIT_SIZE(k)) k = integer*1')
- call c_i1(ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)),k,
- $ 'ISHFTC(k,-BIT_SIZE(k),BIT_SIZE(k)) k = integer*1')
- call c_i8(ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)),m,
- $ 'ISHFTC(m,BIT_SIZE(m),BIT_SIZE(m)) m = integer*8')
- call c_i8(ISHFTC(m,0,BIT_SIZE(m)),m,
- $ 'ISHFTC(m,0,BIT_SIZE(m)) m = integer*8')
- call c_i8(ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)),m,
- $ 'ISHFTC(m,-BIT_SIZE(m),BIT_SIZE(m)) m = integer*8')
-
-c MVBITS - Section 13.13.74
- i = 6
- call MVBITS(7,2,2,i,0)
- call c_i(i,5,'MVBITS 1')
- j = 6
- j2 = 7
- ja = 5
- call MVBITS(j2,2,2,j,0)
- call c_i2(j,ja,'MVBITS 2')
- k = 6
- k2 = 7
- ka = 5
- call MVBITS(k2,2,2,k,0)
- call c_i1(k,ka,'MVBITS 3')
- m = 6
- m2 = 7
- ma = 5
- call MVBITS(m2,2,2,m,0)
- call c_i8(m,ma,'MVBITS 4')
-
-c NOT - Section 13.13.77
-c Rather than assume integer sizes, mask off high bits
- j = 21
- j2 = 31
- ja = 10
- k = 21
- k2 = 31
- ka = 10
- m = 21
- m2 = 31
- ma = 10
- call c_i(IAND(NOT(21),31),10,'NOT(integer)')
- call c_i2(IAND(NOT(j),j2),ja,'NOT(integer*2)')
- call c_i1(IAND(NOT(k),k2),ka,'NOT(integer*1)')
- call c_i8(IAND(NOT(m),m2),ma,'NOT(integer*8)')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_l(i,j,label)
-c Check if LOGICAL i equals j, and fail otherwise
- logical i,j
- character*(*) label
- if ( i .eqv. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_i(i,j,label)
-c Check if INTEGER i equals j, and fail otherwise
- integer i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_i2(i,j,label)
-c Check if INTEGER*2 i equals j, and fail otherwise
- integer*2 i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_i1(i,j,label)
-c Check if INTEGER*1 i equals j, and fail otherwise
- integer*1 i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_i8(i,j,label)
-c Check if INTEGER*8 i equals j, and fail otherwise
- integer*8 i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
+++ /dev/null
-c f90-intrinsic-mathematical.f
-c
-c Test Fortran 90 intrinsic mathematical functions - Section 13.10.3 and
-c 13.13
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
-c Notes:
-c * g77 does not fully comply with F90. Noncompliances noted in comments.
-c * Section 13.12: Specific names for intrinsic functions tested in
-c intrinsic77.f
-
- logical fail
- common /flags/ fail
- fail = .false.
-
-c ACOS - Section 13.13.3
- call c_r(ACOS(0.54030231),1.0,'ACOS(real)')
- call c_d(ACOS(0.54030231d0),1.d0,'ACOS(double)')
-
-c ASIN - Section 13.13.12
- call c_r(ASIN(0.84147098),1.0,'ASIN(real)')
- call c_d(ASIN(0.84147098d0),1.d0,'ASIN(double)')
-
-c ATAN - Section 13.13.14
- call c_r(ATAN(1.5574077),1.0,'ATAN(real)')
- call c_d(ATAN(1.5574077d0),1.d0,'ATAN(double)')
-
-c ATAN2 - Section 13.13.15
- call c_r(ATAN2(1.5574077,1.),1.0,'ATAN2(real)')
- call c_d(ATAN2(1.5574077d0,1.d0),1.d0,'ATAN2(double)')
-
-c COS - Section 13.13.22
- call c_r(COS(1.0),0.54030231,'COS(real)')
- call c_d(COS(1.d0),0.54030231d0,'COS(double)')
- call c_c(COS((1.,0.)),(0.54030231,0.),'COS(complex)')
- call c_z(COS((1.d0,0.d0)),(0.54030231d0,0.d0),
- $ 'COS(double complex)')
-
-c COSH - Section 13.13.23
- call c_r(COSH(1.0),1.5430806,'COSH(real)')
- call c_d(COSH(1.d0),1.5430806d0,'COSH(double)')
-
-c EXP - Section 13.13.34
- call c_r(EXP(1.0),2.7182818,'EXP(real)')
- call c_d(EXP(1.d0),2.7182818d0,'EXP(double)')
- call c_c(EXP((1.,0.)),(2.7182818,0.),'EXP(complex)')
- call c_z(EXP((1.d0,0.d0)),(2.7182818d0,0.d0),
- $ 'EXP(double complex)')
-
-c LOG - Section 13.13.59
- call c_r(LOG(10.0),2.3025851,'LOG(real)')
- call c_d(LOG(10.d0),2.3025851d0,'LOG(double)')
- call c_c(LOG((10.,0.)),(2.3025851,0.),'LOG(complex)')
- call c_z(LOG((10.d0,0.)),(2.3025851d0,0.d0),
- $ 'LOG(double complex)')
-
-c LOG10 - Section 13.13.60
- call c_r(LOG10(10.0),1.0,'LOG10(real)')
- call c_d(LOG10(10.d0),1.d0,'LOG10(double)')
-
-c SIN - Section 13.13.97
- call c_r(SIN(1.0),0.84147098,'SIN(real)')
- call c_d(SIN(1.d0),0.84147098d0,'SIN(double)')
- call c_c(SIN((1.,0.)),(0.84147098,0.),'SIN(complex)')
- call c_z(SIN((1.d0,0.d0)),(0.84147098d0,0.d0),
- $ 'SIN(double complex)')
-
-c SINH - Section 13.13.98
- call c_r(SINH(1.0),1.175201,'SINH(real)')
- call c_d(SINH(1.d0),1.175201d0,'SINH(double)')
-
-c SQRT - Section 13.13.102
- call c_r(SQRT(4.0),2.0,'SQRT(real)')
- call c_d(SQRT(4.d0),2.d0,'SQRT(double)')
- call c_c(SQRT((4.,0.)),(2.,0.),'SQRT(complex)')
- call c_z(SQRT((4.d0,0.)),(2.d0,0.),
- $ 'SQRT(double complex)')
-
-c TAN - Section 13.13.105
- call c_r(TAN(1.0),1.5574077,'TAN(real)')
- call c_d(TAN(1.d0),1.5574077d0,'TAN(double)')
-
-c TANH - Section 13.13.106
- call c_r(TANH(1.0),0.76159416,'TANH(real)')
- call c_d(TANH(1.d0),0.76159416d0,'TANH(double)')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_r(a,b,label)
-c Check if REAL a equals b, and fail otherwise
- real a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_c(a,b,label)
-c Check if COMPLEX a equals b, and fail otherwise
- complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_z(a,b,label)
-c Check if COMPLEX a equals b, and fail otherwise
- double complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
+++ /dev/null
-c f90-intrinsic-numeric.f
-c
-c Test Fortran 90 intrinsic numeric functions - Section 13.10.2 and 13.13
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
-c Notes:
-c * g77 does not fully comply with F90. Noncompliances noted in comments.
-c * Section 13.12: Specific names for intrinsic functions tested in
-c intrinsic77.f
-
- logical fail
- integer*2 j, j2, ja
- integer*1 k, k2, ka
-
- common /flags/ fail
- fail = .false.
-
-c ABS - Section 13.13.1
- j = -9
- ja = 9
- k = j
- ka = ja
- call c_i(ABS(-7),7,'ABS(integer)')
- call c_i2(ABS(j),ja,'ABS(integer*2)')
- call c_i1(ABS(k),ka,'ABS(integer*1)')
- call c_r(ABS(-7.),7.,'ABS(real)')
- call c_d(ABS(-7.d0),7.d0,'ABS(double)')
- call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
- call c_d(ABS((3.d0,-4.d0)),5.0d0,'ABS(double complex)')
-
-c AIMAG - Section 13.13.6
- call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
-c g77: AIMAG(double complex) does not comply with F90
-c call c_d(AIMAG((2.d0,-7.d0)),-7.d0,'AIMAG(double complex)')
-
-c AINT - Section 13.13.7
- call c_r(AINT(2.783),2.0,'AINT(real) 1')
- call c_r(AINT(-2.783),-2.0,'AINT(real) 2')
- call c_d(AINT(2.783d0),2.0d0,'AINT(double precision) 1')
- call c_d(AINT(-2.783d0),-2.0d0,'AINT(double precision) 2')
-c Note: g77 does not support optional argument KIND
-
-c ANINT - Section 13.13.10
- call c_r(ANINT(2.783),3.0,'ANINT(real) 1')
- call c_r(ANINT(-2.783),-3.0,'ANINT(real) 2')
- call c_d(ANINT(2.783d0),3.0d0,'ANINT(double precision) 1')
- call c_d(ANINT(-2.783d0),-3.0d0,'ANINT(double precision) 2')
-c Note: g77 does not support optional argument KIND
-
-c CEILING - Section 13.13.18
-c Not implemented
-
-c CMPLX - Section 13.13.20
- j = 1
- ja = 2
- k = 1
- ka = 2
- call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
- call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
- call c_c(CMPLX(j),(1.,0.),'CMPLX(integer*2)')
- call c_c(CMPLX(j,ja),(1.,2.),'CMPLX(integer*2, integer*2)')
- call c_c(CMPLX(k),(1.,0.),'CMPLX(integer*1)')
- call c_c(CMPLX(k,ka),(1.,2.),'CMPLX(integer*1, integer*1)')
- call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
- call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
- call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
- call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
- call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double complex)')
-c NOTE: g77 does not support optional argument KIND
-
-c CONJG - Section 13.13.21
- call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
- call c_z(CONJG((2.d0,-7.d0)),(2.d0,7.d0),'CONJG(double complex)')
-
-c DBLE - Section 13.13.27
- j = 5
- k = 5
- call c_d(DBLE(5),5.0d0,'DBLE(integer)')
- call c_d(DBLE(j),5.0d0,'DBLE(integer*2)')
- call c_d(DBLE(k),5.0d0,'DBLE(integer*1)')
- call c_d(DBLE(5.),5.0d0,'DBLE(real)')
- call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
- call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
- call c_d(DBLE((5.0d0,0.5d0)),5.0d0,'DBLE(double complex)')
-
-c DIM - Section 13.13.29
- j = -8
- j2 = -3
- ja = 0
- k = -8
- k2 = -3
- ka = 0
- call c_i(DIM(-8,-3),0,'DIM(integer)')
- call c_i2(DIM(j,j2),ja,'DIM(integer*2)')
- call c_i1(DIM(k,k2),ka,'DIM(integer*1)')
- call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
- call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
-
-c DPROD - Section 13.13.31
- call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
-
-c FLOOR - Section 13.13.36
-c Not implemented
-
-c INT - Section 13.13.47
- j = 5
- k = 5
- call c_i(INT(5),5,'INT(integer)')
- call c_i(INT(j),5,'INT(integer*2)')
- call c_i(INT(k),5,'INT(integer*1)')
- call c_i(INT(5.01),5,'INT(real)')
- call c_i(INT(5.01d0),5,'INT(double)')
-c Note: Does not accept optional second argument KIND
-
-c MAX - Section 13.13.63
- j = 1
- j2 = 2
- ja = 2
- k = 1
- k2 = 2
- ka = 2
- call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
- call c_i2(MAX(j,j2),ja,'MAX(integer*2,integer*2)')
- call c_i1(MAX(k,k2),ka,'MAX(integer*1,integer*1)')
- call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
- call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
-
-c MIN - Section 13.13.68
- j = 1
- j2 = 2
- ja = 1
- k = 1
- k2 = 2
- ka = 1
- call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
- call c_i2(MIN(j,j2),ja,'MIN(integer*2,integer*2)')
- call c_i1(MIN(k,k2),ka,'MIN(integer*1,integer*1)')
- call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
- call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
-
-c MOD - Section 13.13.72
- call c_i(MOD(8,5),3,'MOD(integer,integer) 1')
- call c_i(MOD(-8,5),-3,'MOD(integer,integer) 2')
- call c_i(MOD(8,-5),3,'MOD(integer,integer) 3')
- call c_i(MOD(-8,-5),-3,'MOD(integer,integer) 4')
- j = 8
- j2 = 5
- ja = 3
- call c_i2(MOD(j,j2),ja,'MOD(integer*2,integer*2) 1')
- call c_i2(MOD(-j,j2),-ja,'MOD(integer*2,integer*2) 2')
- call c_i2(MOD(j,-j2),ja,'MOD(integer*2,integer*2) 3')
- call c_i2(MOD(-j,-j2),-ja,'MOD(integer*2,integer*2) 4')
- k = 8
- k2 = 5
- ka = 3
- call c_i1(MOD(k,k2),ka,'MOD(integer*1,integer*1) 1')
- call c_i1(MOD(-k,k2),-ka,'MOD(integer*1,integer*1) 2')
- call c_i1(MOD(k,-k2),ka,'MOD(integer*1,integer*1) 3')
- call c_i1(MOD(-k,-k2),-ka,'MOD(integer*1,integer*1) 4')
- call c_r(MOD(8.,5.),3.,'MOD(real,real) 1')
- call c_r(MOD(-8.,5.),-3.,'MOD(real,real) 2')
- call c_r(MOD(8.,-5.),3.,'MOD(real,real) 3')
- call c_r(MOD(-8.,-5.),-3.,'MOD(real,real) 4')
- call c_d(MOD(8.d0,5.d0),3.d0,'MOD(double,double) 1')
- call c_d(MOD(-8.d0,5.d0),-3.d0,'MOD(double,double) 2')
- call c_d(MOD(8.d0,-5.d0),3.d0,'MOD(double,double) 3')
- call c_d(MOD(-8.d0,-5.d0),-3.d0,'MOD(double,double) 4')
-
-c MODULO - Section 13.13.73
-c Not implemented
-
-c NINT - Section 13.13.76
- call c_i(NINT(2.783),3,'NINT(real)')
- call c_i(NINT(2.783d0),3,'NINT(double)')
-c Optional second argument KIND not implemented
-
-c REAL - Section 13.13.86
- j = -2
- k = -2
- call c_r(REAL(-2),-2.0,'REAL(integer)')
- call c_r(REAL(j),-2.0,'REAL(integer*2)')
- call c_r(REAL(k),-2.0,'REAL(integer*1)')
- call c_r(REAL(-2.0),-2.0,'REAL(real)')
- call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
- call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
-c REAL(double complex) not implemented
-c call c_r(REAL((-2.d0,9.d0)),-2.0,'REAL(double complex)')
-
-c SIGN - Section 13.13.96
- j = -3
- j2 = 2
- ja = 3
- k = -3
- k2 = 2
- ka = 3
- call c_i(SIGN(-3,2),3,'SIGN(integer)')
- call c_i2(SIGN(j,j2),ja,'SIGN(integer*2)')
- call c_i1(SIGN(k,k2),ka,'SIGN(integer*1)')
- call c_r(SIGN(-3.0,2.),3.,'SIGN(real,real)')
- call c_d(SIGN(-3.d0,2.d0),3.d0,'SIGN(double,double)')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_i(i,j,label)
-c Check if INTEGER i equals j, and fail otherwise
- integer i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_i2(i,j,label)
-c Check if INTEGER*2 i equals j, and fail otherwise
- integer*2 i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_i1(i,j,label)
-c Check if INTEGER*1 i equals j, and fail otherwise
- integer*1 i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_r(a,b,label)
-c Check if REAL a equals b, and fail otherwise
- real a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_c(a,b,label)
-c Check if COMPLEX a equals b, and fail otherwise
- complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_z(a,b,label)
-c Check if COMPLEX a equals b, and fail otherwise
- double complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
+++ /dev/null
- integer*1 i1, i11
- integer*2 i2, i22
- integer i, ii
- integer*4 i4, i44
- integer*8 i8, i88
- real r, rr
- real*4 r4, r44
- double precision d, dd
- real*8 r8, r88
- parameter (i1 = 1, i2 = 2, i4 = 4, i = 5, i8 = i + i4*i2 + i2*i1)
- parameter (r = 3.0, r4 = 4.0, r8 = 8.d0, d = i8*r + r4*i2 + r8*i1)
- if (i8 .ne. 15 ) call abort
- if (d .ne. 61.d0) call abort
- i11 = 1; i22 = 2; i44 = 4; ii = 5
- i88 = i + i4*i2 + i2*i1
- if (i88 .ne. i8) call abort
- rr = 3.0; r44 = 4.0; r88 = 8.0d0
- dd = i88*rr + r44*i22 + r88*i11
- if (dd .ne. d) call abort
- end
+++ /dev/null
-c intrinsic-f2c-z.f
-c
-c Test double complex intrinsics Z*.
-c These functions are f2c extensions
-c
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
- double complex z, a
- double precision x
- logical fail
- intrinsic zabs, zcos, zexp, zlog, zsin, zsqrt
- common /flags/ fail
- fail = .false.
-
-c ZABS - Absolute value
- z = (3.0d0,-4.0d0)
- x = 5.0d0
- call c_d(ZABS(z),x,'ZABS(double complex)')
- call p_d_z(ZABS,z,x,'ZABS')
-
-c ZCOS - Cosine
- z = (3.0d0,1.0d0)
- a = (-1.52763825012d0,-0.165844401919)
- call c_z(ZCOS(z),a,'ZCOS(double complex)')
- call p_z_z(ZCOS,z,a,'ZCOS')
-
-c ZEXP - Exponential
- z = (3.0d0,1.0d0)
- a = (10.8522619142d0,16.9013965352)
- call c_z(ZEXP(z),a,'ZEXP(double complex)')
- call p_z_z(ZEXP,z,a,'ZEXP')
-
-c ZLOG - Natural logarithm
- call c_z(ZLOG(a),z,'ZLOG(double complex)')
- call p_z_z(ZLOG,a,z,'ZLOG')
-
-c ZSIN - Sine
- z = (3.0d0,1.0d0)
- a = (0.217759551622d0,-1.1634403637d0)
- call c_z(ZSIN(z),a,'ZSIN(double complex)')
- call p_z_z(ZSIN,z,a,'ZSIN')
-
-c ZSQRT - Square root
- z = (0.0d0,-4.0d0)
- a = sqrt(2.0d0)*(1.0d0,-1.0d0)
- call c_z(ZSQRT(z),a,'ZSQRT(double complex)')
- call p_z_z(ZSQRT,z,a,'ZSQRT')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_z(a,b,label)
-c Check if DOUBLE COMPLEX a equals b, and fail otherwise
- double complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine p_z_z(f,x,a,label)
-c Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
- double complex f,x,a
- character*(*) label
- call c_z(f(x),a,label)
- end
-
- subroutine p_d_z(f,x,a,label)
-c Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
- double precision f,x
- double complex a
- character*(*) label
- call c_d(f(x),a,label)
- end
+++ /dev/null
-c intrinsic-unix-bessel.f
-c
-c Test Bessel function intrinsics.
-c These functions are only available if provided by system
-c
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
- real x, a
- double precision dx, da
- integer i
- integer*2 j
- integer*1 k
- integer*8 m
- logical fail
- common /flags/ fail
- fail = .false.
-
- x = 2.0
- dx = x
- i = 2
- j = i
- k = i
- m = i
-c BESJ0 - Bessel function of first kind of order zero
- a = 0.22389077
- da = a
- call c_r(BESJ0(x),a,'BESJ0(real)')
- call c_d(BESJ0(dx),da,'BESJ0(double)')
- call c_d(DBESJ0(dx),da,'DBESJ0(double)')
-
-c BESJ1 - Bessel function of first kind of order one
- a = 0.57672480
- da = a
- call c_r(BESJ1(x),a,'BESJ1(real)')
- call c_d(BESJ1(dx),da,'BESJ1(double)')
- call c_d(DBESJ1(dx),da,'DBESJ1(double)')
-
-c BESJN - Bessel function of first kind of order N
- a = 0.3528340
- da = a
- call c_r(BESJN(i,x),a,'BESJN(integer,real)')
- call c_r(BESJN(j,x),a,'BESJN(integer*2,real)')
- call c_r(BESJN(k,x),a,'BESJN(integer*1,real)')
- call c_d(BESJN(i,dx),da,'BESJN(integer,double)')
- call c_d(BESJN(j,dx),da,'BESJN(integer*2,double)')
- call c_d(BESJN(k,dx),da,'BESJN(integer*1,double)')
- call c_d(DBESJN(i,dx),da,'DBESJN(integer,double)')
- call c_d(DBESJN(j,dx),da,'DBESJN(integer*2,double)')
- call c_d(DBESJN(k,dx),da,'DBESJN(integer*1,double)')
-
-c BESY0 - Bessel function of second kind of order zero
- a = 0.51037567
- da = a
- call c_r(BESY0(x),a,'BESY0(real)')
- call c_d(BESY0(dx),da,'BESY0(double)')
- call c_d(DBESY0(dx),da,'DBESY0(double)')
-
-c BESY1 - Bessel function of second kind of order one
- a = 0.-0.1070324
- da = a
- call c_r(BESY1(x),a,'BESY1(real)')
- call c_d(BESY1(dx),da,'BESY1(double)')
- call c_d(DBESY1(dx),da,'DBESY1(double)')
-
-c BESYN - Bessel function of second kind of order N
- a = -0.6174081
- da = a
- call c_r(BESYN(i,x),a,'BESYN(integer,real)')
- call c_r(BESYN(j,x),a,'BESYN(integer*2,real)')
- call c_r(BESYN(k,x),a,'BESYN(integer*1,real)')
- call c_d(BESYN(i,dx),da,'BESYN(integer,double)')
- call c_d(BESYN(j,dx),da,'BESYN(integer*2,double)')
- call c_d(BESYN(k,dx),da,'BESYN(integer*1,double)')
- call c_d(DBESYN(i,dx),da,'DBESYN(integer,double)')
- call c_d(DBESYN(j,dx),da,'DBESYN(integer*2,double)')
- call c_d(DBESYN(k,dx),da,'DBESYN(integer*1,double)')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_r(a,b,label)
-c Check if REAL a equals b, and fail otherwise
- real a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
+++ /dev/null
-c intrinsic-unix-erf.f
-c
-c Test Bessel function intrinsics.
-c These functions are only available if provided by system
-c
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
- real x, a
- double precision dx, da
- logical fail
- common /flags/ fail
- fail = .false.
-
- x = 0.6
- dx = x
-c ERF - error function
- a = 0.6038561
- da = a
- call c_r(ERF(x),a,'ERF(real)')
- call c_d(ERF(dx),da,'ERF(double)')
- call c_d(DERF(dx),da,'DERF(double)')
-
-c ERFC - complementary error function
- a = 1.0 - a
- da = a
- call c_r(ERFC(x),a,'ERFC(real)')
- call c_d(ERFC(dx),da,'ERFC(double)')
- call c_d(DERFC(dx),da,'DERFC(double)')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_r(a,b,label)
-c Check if REAL a equals b, and fail otherwise
- real a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
+++ /dev/null
-c intrinsic-vax-cd.f
-c
-c Test double complex intrinsics CD*.
-c These functions are VAX extensions
-c
-c David Billinghurst <David.Billinghurst@riotinto.com>
-c
- double complex z, a
- double precision x
- logical fail
- intrinsic cdabs, cdcos, cdexp, cdlog, cdsin, cdsqrt
- common /flags/ fail
- fail = .false.
-
-c CDABS - Absolute value
- z = (3.0d0,-4.0d0)
- x = 5.0d0
- call c_d(CDABS(z),x,'CDABS(double complex)')
- call p_d_z(CDABS,z,x,'CDABS')
-
-c CDCOS - Cosine
- z = (3.0d0,1.0d0)
- a = (-1.52763825012d0,-0.165844401919)
- call c_z(CDCOS(z),a,'CDCOS(double complex)')
- call p_z_z(CDCOS,z,a,'CDCOS')
-
-c CDEXP - Exponential
- z = (3.0d0,1.0d0)
- a = (10.8522619142d0,16.9013965352)
- call c_z(CDEXP(z),a,'CDEXP(double complex)')
- call p_z_z(CDEXP,z,a,'CDEXP')
-
-c CDLOG - Natural logarithm
- call c_z(CDLOG(a),z,'CDLOG(double complex)')
- call p_z_z(CDLOG,a,z,'CDLOG')
-
-c CDSIN - Sine
- z = (3.0d0,1.0d0)
- a = (0.217759551622d0,-1.1634403637d0)
- call c_z(CDSIN(z),a,'CDSIN(double complex)')
- call p_z_z(CDSIN,z,a,'CDSIN')
-
-c CDSQRT - Square root
- z = (0.0d0,-4.0d0)
- a = sqrt(2.0d0)*(1.0d0,-1.0d0)
- call c_z(CDSQRT(z),a,'CDSQRT(double complex)')
- call p_z_z(CDSQRT,z,a,'CDSQRT')
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_z(a,b,label)
-c Check if DOUBLE COMPLEX a equals b, and fail otherwise
- double complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine p_z_z(f,x,a,label)
-c Check if DOUBLE COMPLEX f(x) equals a for DOUBLE COMPLEX x
- double complex f,x,a
- character*(*) label
- call c_z(f(x),a,label)
- end
-
- subroutine p_d_z(f,x,a,label)
-c Check if DOUBLE PRECISION f(x) equals a for DOUBLE COMPLEX x
- double precision f,x
- double complex a
- character*(*) label
- call c_d(f(x),a,label)
- end
+++ /dev/null
- program intrinsic77
-c
-c Test Fortran 77 intrinsic functions (ANSI X3.9-1978 Section 15.10)
-c
-c Test:
-c * specific functions
-c * generic functions with each argument type
-c * specific functions by passing as subroutine argument
-c where permiited by Section 13.12 of Fortran 90 standard
-c
- logical fail
- common /flags/ fail
-
- fail = .false.
- call type_conversion
- call truncation
- call nearest_whole_number
- call nearest_integer
- call absolute_value
- call remaindering
- call transfer_of_sign
- call positive_difference
- call double_precision_product
- call choosing_largest_value
- call choosing_smallest_value
- call length_of_character_array
- call index_of_substring
- call imaginary_part
- call complex_conjugate
- call square_root
- call exponential
- call natural_logarithm
- call common_logarithm
- call sine
- call cosine
- call tangent
- call arcsine
- call arccosine
- call arctangent
- call hyperbolic_sine
- call hyperbolic_cosine
- call hyperbolic_tangent
- call lexically_greater_than_or_equal
- call lexically_greater_than
- call lexically_less_than_or_equal
- call lexically_less_than
-
- if ( fail ) call abort()
- end
-
- subroutine failure(label)
-c Report failure and set flag
- character*(*) label
- logical fail
- common /flags/ fail
- write(6,'(a,a,a)') 'Test ',label,' FAILED'
- fail = .true.
- end
-
- subroutine c_i(i,j,label)
-c Check if INTEGER i equals j, and fail otherwise
- integer i,j
- character*(*) label
- if ( i .ne. j ) then
- call failure(label)
- write(6,*) 'Got ',i,' expected ', j
- end if
- end
-
- subroutine c_r(a,b,label)
-c Check if REAL a equals b, and fail otherwise
- real a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_d(a,b,label)
-c Check if DOUBLE PRECISION a equals b, and fail otherwise
- double precision a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0d-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_c(a,b,label)
-c Check if COMPLEX a equals b, and fail otherwise
- complex a, b
- character*(*) label
- if ( abs(a-b) .gt. 1.0e-5 ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_l(a,b,label)
-c Check if LOGICAL a equals b, and fail otherwise
- logical a, b
- character*(*) label
- if ( a .neqv. b ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine c_ch(a,b,label)
-c Check if CHARACTER a equals b, and fail otherwise
- character*(*) a, b
- character*(*) label
- if ( a .ne. b ) then
- call failure(label)
- write(6,*) 'Got ',a,' expected ', b
- end if
- end
-
- subroutine p_i_i(f,x,i,label)
-c Check if INTEGER f(x) equals i for INTEGER x
- integer f,x,i
- character*(*) label
- call c_i(f(x),i,label)
- end
-
- subroutine p_i_ii(f,x1,x2,i,label)
-c Check if INTEGER f(x1,x2) equals i for INTEGER x
- integer f,x1,x2,i
- character*(*) label
- call c_i(f(x1,x2),i,label)
- end
-
- subroutine p_i_r(f,x,i,label)
-c Check if INTEGER f(x) equals i for REAL x
- real x
- integer f,i
- character*(*) label
- call c_i(f(x),i,label)
- end
-
- subroutine p_i_d(f,x,i,label)
-c Check if INTEGER f(x) equals i for DOUBLE PRECISION x
- double precision x
- integer f,i
- character*(*) label
- call c_i(f(x),i,label)
- end
-
- subroutine p_i_ch(f,x,a,label)
-c Check if INTEGER f(x) equals a for CHARACTER x
- character*(*) x
- integer f, a
- character*(*) label
- call c_i(f(x),a,label)
- end
-
- subroutine p_i_chch(f,x1,x2,a,label)
-c Check if INTEGER f(x1,x2) equals a for CHARACTER x1 and x2
- character*(*) x1,x2
- integer f, a
- character*(*) label
- call c_i(f(x1,x2),a,label)
- end
-
- subroutine p_r_r(f,x,a,label)
-c Check if REAL f(x) equals a for REAL x
- real f,x,a
- character*(*) label
- call c_r(f(x),a,label)
- end
-
- subroutine p_r_rr(f,x1,x2,a,label)
-c Check if REAL f(x1,x2) equals a for REAL x1, x2
- real f,x1,x2,a
- character*(*) label
- call c_r(f(x1,x2),a,label)
- end
-
- subroutine p_d_d(f,x,a,label)
-c Check if DOUBLE PRECISION f(x) equals a for DOUBLE PRECISION x
- double precision f,x,a
- character*(*) label
- call c_d(f(x),a,label)
- end
-
- subroutine p_d_rr(f,x1,x2,a,label)
-c Check if DOUBLE PRECISION f(x1,x2) equals a for real x1,x2
- double precision f,a
- real x1,x2
- character*(*) label
- call c_d(f(x1,x2),a,label)
- end
-
- subroutine p_d_dd(f,x1,x2,a,label)
-c Check if DOUBLE PRECISION f(x1,x2) equals a for DOUBLE PRECISION x1,x2
- double precision f,x1,x2,a
- character*(*) label
- call c_d(f(x1,x2),a,label)
- end
-
- subroutine p_c_c(f,x,a,label)
-c Check if COMPLEX f(x) equals a for COMPLEX x
- complex f,x,a
- character*(*) label
- call c_c(f(x),a,label)
- end
-
- subroutine p_r_c(f,x,a,label)
-c Check if REAL f(x) equals a for COMPLEX x
- complex x
- real f, a
- character*(*) label
- call c_r(f(x),a,label)
- end
-
- subroutine type_conversion
- integer i
- character*1 c
-c conversion to integer
- call c_i(INT(5),5,'INT(integer)')
- call c_i(INT(5.01),5,'INT(real)')
- call c_i(INT(5.01d0),5,'INT(double)')
- call c_i(INT((5.01,-3.0)),5,'INT(complex)')
- call c_i(IFIX(5.01),5,'IFIX(real)')
- call c_i(IDINT(5.01d0),5,'IDINT(double)')
-c conversion to real
- call c_r(REAL(-2),-2.0,'REAL(integer)')
- call c_r(REAL(-2.0),-2.0,'REAL(real)')
- call c_r(REAL(-2.0d0),-2.0,'REAL(double)')
- call c_r(REAL((-2.,9.)),-2.0,'REAL(complex)')
- call c_r(FLOAT(-2),-2.0,'FLOAT(int)')
- call c_r(SNGL(-2.0d0),-2.0,'SNGL(double)')
-c conversion to double
- call c_d(DBLE(5),5.0d0,'DBLE(integer)')
- call c_d(DBLE(5.),5.0d0,'DBLE(real)')
- call c_d(DBLE(5.0d0),5.0d0,'DBLE(double)')
- call c_d(DBLE((5.0,0.5)),5.0d0,'DBLE(complex)')
-c conversion to complex
- call c_c(CMPLX(1),(1.,0.),'CMPLX(integer)')
- call c_c(CMPLX(1,2),(1.,2.),'CMPLX(integer, integer)')
- call c_c(CMPLX(1.),(1.,0.),'CMPLX(real)')
- call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(real,real)')
- call c_c(CMPLX(1.d0),(1.,0.),'CMPLX(double)')
- call c_c(CMPLX(1.d0,2.d0),(1.,2.),'CMPLX(double,double)')
- call c_c(CMPLX(1.,2.),(1.,2.),'CMPLX(complex)')
-c character conversion
- c = 'C'
- i = ichar(c)
- call c_i(ICHAR(c),i,'ICHAR')
- call c_ch(CHAR(i),c,'CHAR')
- end
-
- subroutine truncation
- intrinsic aint, dint
- call c_r(AINT(9.2),9.0,'AINT(real)')
- call c_d(AINT(9.2d0),9.0d0,'AINT(double)')
- call c_d(DINT(9.2d0),9.0d0,'DINT(double)')
- call p_r_r(AINT,9.2,9.0,'AINT')
- call p_d_d(DINT,9.2d0,9.0d0,'DINT')
- end
-
- subroutine nearest_whole_number
- intrinsic anint, dnint
- call c_r(ANINT(9.2),9.0,'ANINT(real)')
- call c_d(ANINT(9.2d0),9.0d0,'ANINT(double)')
- call c_d(DNINT(9.2d0),9.0d0,'DNINT(double)')
- call p_r_r(ANINT,9.2,9.0,'ANINT')
- call p_d_d(DNINT,9.2d0,9.0d0,'DNINT')
- end
-
- subroutine nearest_integer
- intrinsic nint, idnint
- call c_i(NINT(9.2),9,'NINT(real)')
- call c_i(NINT(9.2d0),9,'NINT(double)')
- call c_i(IDNINT(9.2d0),9,'IDNINT(double)')
- call p_i_r(NINT,9.2,9,'NINT')
- call p_i_d(IDNINT,9.2d0,9,'IDNINT')
- end
-
- subroutine absolute_value
- intrinsic iabs, abs, dabs, cabs
- call c_i(ABS(-7),7,'ABS(integer)')
- call c_r(ABS(-7.),7.,'ABS(real)')
- call c_d(ABS(-7.d0),7.d0,'ABS(double)')
- call c_r(ABS((3.,-4.)),5.0,'ABS(complex)')
- call c_i(IABS(-7),7,'IABS(integer)')
- call c_d( DABS(-7.d0),7.d0,'DABS(double)')
- call c_r( CABS((3.,-4.)),5.0,'CABS(complex)')
- call p_i_i(IABS,-7,7,'IABS')
- call p_r_r(ABS,-7.,7.,'ABS')
- call p_d_d(DABS,-7.0d0,7.0d0,'DABS')
- call p_r_c(CABS,(3.,-4.), 5.0,'CABS')
- end
-
- subroutine remaindering
- intrinsic mod, amod, dmod
- call c_i( MOD(8,3),2,'MOD(integer,integer)')
- call c_r( MOD(8.,3.),2.,'MOD(real,real)')
- call c_d( MOD(8.d0,3.d0),2.d0,'MOD(double,double)')
- call c_r( AMOD(8.,3.),2.,'AMOD(real,real)')
- call c_d( DMOD(8.d0,3.d0),2.d0,'DMOD(double,double)')
- call p_i_ii(MOD,8,3,2,'MOD')
- call p_r_rr(AMOD,8.,3.,2.,'AMOD')
- call p_d_dd(DMOD,8.d0,3.d0,2.d0,'DMOD')
- end
-
- subroutine transfer_of_sign
- intrinsic isign,sign,dsign
- call c_i(SIGN(8,-3),-8,'SIGN(integer)')
- call c_r(SIGN(8.,-3.),-8.,'SIGN(real,real)')
- call c_d(SIGN(8.d0,-3.d0),-8.d0,'SIGN(double,double)')
- call c_i(ISIGN(8,-3),-8,'ISIGN(integer)')
- call c_d(DSIGN(8.d0,-3.d0),-8.d0,'DSIGN(double,double)')
- call p_i_ii(ISIGN,8,-3,-8,'ISIGN')
- call p_r_rr(SIGN,8.,-3.,-8.,'SIGN')
- call p_d_dd(DSIGN,8.d0,-3.d0,-8.d0,'DSIGN')
- end
-
- subroutine positive_difference
- intrinsic idim, dim, ddim
- call c_i(DIM(-8,-3),0,'DIM(integer)')
- call c_r(DIM(-8.,-3.),0.,'DIM(real,real)')
- call c_d(DIM(-8.d0,-3.d0),0.d0,'DIM(double,double)')
- call c_i(IDIM(-8,-3),0,'IDIM(integer)')
- call c_d(DDIM(-8.d0,-3.d0),0.d0,'DDIM(double,double)')
- call p_i_ii(IDIM,-8,-3,0,'IDIM')
- call p_r_rr(DIM,-8.,-3.,0.,'DIM')
- call p_d_dd(DDIM,-8.d0,-3.d0,0.d0,'DDIM')
- end
-
- subroutine double_precision_product
- intrinsic dprod
- call c_d(DPROD(-8.,-3.),24.d0,'DPROD(real,real)')
- call p_d_rr(DPROD,-8.,-3.,24.d0,'DPROD')
- end
-
- subroutine choosing_largest_value
- call c_i(MAX(1,2,3),3,'MAX(integer,integer,integer)')
- call c_r(MAX(1.,2.,3.),3.,'MAX(real,real,real)')
- call c_d(MAX(1.d0,2.d0,3.d0),3.d0,'MAX(double,double,double)')
- call c_i(MAX0(1,2,3),3,'MAX0(integer,integer,integer)')
- call c_r(AMAX1(1.,2.,3.),3.,'MAX(real,real,real)')
- call c_d(DMAX1(1.d0,2.d0,3.d0),3.d0,'DMAX1(double,double,double)')
- call c_r(AMAX0(1,2,3),3.,'AMAX0(integer,integer,integer)')
- call c_i(MAX1(1.,2.,3.),3,'MAX1(real,real,real)')
- end
-
- subroutine choosing_smallest_value
- call c_i(MIN(1,2,3),1,'MIN(integer,integer,integer)')
- call c_r(MIN(1.,2.,3.),1.,'MIN(real,real,real)')
- call c_d(MIN(1.d0,2.d0,3.d0),1.d0,'MIN(double,double,double)')
- call c_i(MIN0(1,2,3),1,'MIN0(integer,integer,integer)')
- call c_r(AMIN1(1.,2.,3.),1.,'MIN(real,real,real)')
- call c_d(DMIN1(1.d0,2.d0,3.d0),1.d0,'DMIN1(double,double,double)')
- call c_r(AMIN0(1,2,3),1.,'AMIN0(integer,integer,integer)')
- call c_i(MIN1(1.,2.,3.),1,'MIN1(real,real,real)')
- end
-
- subroutine length_of_character_array
- intrinsic len
- call c_i(LEN('ABCDEF'),6,'LEN 1')
- call p_i_ch(LEN,'ABCDEF',6,'LEN 2')
- end
-
- subroutine index_of_substring
- intrinsic index
- call c_i(INDEX('ABCDEF','C'),3,'INDEX 1')
- call p_i_chch(INDEX,'ABCDEF','C',3,'INDEX 2')
- end
-
- subroutine imaginary_part
- intrinsic aimag
- call c_r(AIMAG((2.,-7.)),-7.,'AIMAG(complex)')
- call p_r_c(AIMAG,(2.,-7.),-7.,'AIMAG(complex)')
- end
-
- subroutine complex_conjugate
- intrinsic conjg
- call c_c(CONJG((2.,-7.)),(2.,7.),'CONJG(complex)')
- call p_c_c(CONJG,(2.,-7.),(2.,7.),'CONJG')
- end
-
- subroutine square_root
- intrinsic sqrt, dsqrt, csqrt
- real x, a
- x = 4.0
- a = 2.0
- call c_r(SQRT(x),a,'SQRT(real)')
- call c_d(SQRT(1.d0*x),1.d0*a,'SQRT(double)')
- call c_c(SQRT((1.,0.)*x),(1.,0.)*a,'SQRT(complex)')
- call c_d(DSQRT(1.d0*x),1.d0*a,'DSQRT(double)')
- call c_c(CSQRT((1.,0.)*x),(1.,0.)*a,'CSQRT(complex)')
- call p_r_r(SQRT,x,a,'SQRT')
- call p_d_d(DSQRT,1.d0*x,1.d0*a,'DSQRT')
- call p_c_c(CSQRT,(1.,0.)*x,(1.,0.)*a ,'CSQRT')
- end
-
- subroutine exponential
- intrinsic exp, dexp, cexp
- real x, a
- x = 0.0
- a = 1.0
- call c_r(EXP(x),a,'EXP(real)')
- call c_d(EXP(1.d0*x),1.d0*a,'EXP(double)')
- call c_c(EXP((1.,0.)*x),(1.,0.)*a,'EXP(complex)')
- call c_d(DEXP(1.d0*x),1.d0*a,'DEXP(double)')
- call c_c(CEXP((1.,0.)*x),(1.,0.)*a,'CEXP(complex)')
- call p_r_r(EXP,x,a,'EXP')
- call p_d_d(DEXP,1.d0*x,1.d0*a,'DEXP')
- call p_c_c(CEXP,(1.,0.)*x,(1.,0.)*a ,'CEXP')
- end
-
- subroutine natural_logarithm
- intrinsic alog, dlog, clog
- real x, a
- a = 1.234
- x = exp(a)
- call c_r(LOG(x),a,'LOG(real)')
- call c_d(LOG(1.d0*x),1.d0*a,'LOG(double)')
- call c_c(LOG((1.,0.)*x),(1.,0.)*a,'LOG(complex)')
- call c_r(ALOG(x),a,'ALOG(real)')
- call c_d(DLOG(1.d0*x),1.d0*a,'DLOG(double)')
- call c_c(CLOG((1.,0.)*x),(1.,0.)*a,'CLOG(complex)')
- call p_r_r(ALOG,x,a,'LOG')
- call p_d_d(DLOG,1.d0*x,1.d0*a,'DLOG')
- call p_c_c(CLOG,(1.,0.)*x,(1.,0.)*a,'CLOG')
- end
-
- subroutine common_logarithm
- intrinsic alog10, dlog10
- real x, a
- x = 100.0
- a = 2.0
- call c_r(LOG10(x),a,'LOG10(real)')
- call c_d(LOG10(1.d0*x),1.d0*a,'LOG10(double)')
- call c_r(ALOG10(x),a,'ALOG10(real)')
- call c_d(DLOG10(1.d0*x),1.d0*a,'DLOG10(double)')
- call p_r_r(ALOG10,x,a,'ALOG10')
- call p_d_d(DLOG10,1.d0*x,1.d0*a ,'DLOG10')
- end
-
- subroutine sine
- intrinsic sin, dsin, csin
- real x, a
- a = 1.0
- x = asin(a)
- call c_r(SIN(x),a,'SIN(real)')
- call c_d(SIN(1.d0*x),1.d0*a,'SIN(double)')
- call c_c(SIN((1.,0.)*x),(1.,0.)*a,'SIN(complex)')
- call c_d(DSIN(1.d0*x),1.d0*a,'DSIN(double)')
- call c_c(CSIN((1.,0.)*x),(1.,0.)*a,'CSIN(complex)')
- call p_r_r(SIN,x,a,'SIN')
- call p_d_d(DSIN,1.d0*x,1.d0*a,'DSIN')
- call p_c_c(CSIN,(1.,0.)*x,(1.,0.)*a ,'CSIN')
- end
-
- subroutine cosine
- intrinsic cos, dcos, ccos
- real x, a
- a = 0.123456
- x = acos(a)
- call c_r(COS(x),a,'COS(real)')
- call c_d(COS(1.d0*x),1.d0*a,'COS(double)')
- call c_c(COS((1.,0.)*x),(1.,0.)*a,'COS(complex)')
- call c_r(COS(x),a,'COS(real)')
- call c_d(DCOS(1.d0*x),1.d0*a,'DCOS(double)')
- call c_c(CCOS((1.,0.)*x),(1.,0.)*a,'CCOS(complex)')
- call p_r_r(COS,x,a,'COS')
- call p_d_d(DCOS,1.d0*x,1.d0*a ,'DCOS')
- call p_c_c(CCOS,(1.,0.)*x, (1.,0.)*a ,'CCOS')
- end
-
- subroutine tangent
- intrinsic tan, dtan
- real x, a
- a = 0.5
- x = atan(a)
- call c_r(TAN(x),a,'TAN(real)')
- call c_d(TAN(1.d0*x),1.d0*a,'TAN(double)')
- call c_d(DTAN(1.d0*x),1.d0*a,'DTAN(double)')
- call p_r_r(TAN,x,a,'TAN')
- call p_d_d(DTAN,1.d0*x,1.d0*a ,'DTAN')
- end
-
- subroutine arcsine
- intrinsic asin, dasin
- real x, a
- a = 0.5
- x = sin(a)
- call c_r(ASIN(x),a,'ASIN(real)')
- call c_d(ASIN(1.d0*x),1.d0*a,'ASIN(double)')
- call c_d(DASIN(1.d0*x),1.d0*a,'DASIN(double)')
- call p_r_r(ASIN,x,a,'ASIN')
- call p_d_d(DASIN,1.d0*x,1.d0*a ,'DASIN')
- end
-
- subroutine arccosine
- intrinsic acos, dacos
- real x, a
- x = 0.70710678
- a = 0.785398
- call c_r(ACOS(x),a,'ACOS(real)')
- call c_d(ACOS(1.d0*x),1.d0*a,'ACOS(double)')
- call c_d(DACOS(1.d0*x),1.d0*a,'DACOS(double)')
- call p_r_r(ACOS,x,a,'ACOS')
- call p_d_d(DACOS,1.d0*x,1.d0*a ,'DACOS')
- end
-
- subroutine arctangent
- intrinsic atan, atan2, datan, datan2
- real x1, x2, a
- a = 0.75
- x1 = tan(a)
- x2 = 1.0
- call c_r(ATAN(x1),a,'ATAN(real)')
- call c_d(ATAN(1.d0*x1),1.d0*a,'ATAN(double)')
- call c_d(DATAN(1.d0*x1),1.d0*a,'DATAN(double)')
- call c_r(ATAN2(x1,x2),a,'ATAN2(real)')
- call c_d(ATAN2(1.d0*x1,1.d0*x2),1.d0*a,'ATAN2(double)')
- call c_d(DATAN2(1.d0*x1,1.d0*x2),1.0d0*a,'DATAN2(double)')
- call p_r_r(ATAN,x1,a,'ATAN')
- call p_d_d(DATAN,1.d0*x1,1.d0*a,'DATAN')
- call p_r_rr(ATAN2,x1,x2,a,'ATAN2')
- call p_d_dd(DATAN2,1.d0*x1,1.d0*x2,1.d0*a,'DATAN2')
- end
-
- subroutine hyperbolic_sine
- intrinsic sinh, dsinh
- real x, a
- x = 1.0
- a = 1.1752012
- call c_r(SINH(x),a,'SINH(real)')
- call c_d(SINH(1.d0*x),1.d0*a,'SINH(double)')
- call c_d(DSINH(1.d0*x),1.d0*a,'DSINH(double)')
- call p_r_r(SINH,x,a,'SINH')
- call p_d_d(DSINH,1.d0*x,1.d0*a ,'DSINH')
- end
-
- subroutine hyperbolic_cosine
- intrinsic cosh, dcosh
- real x, a
- x = 1.0
- a = 1.5430806
- call c_r(COSH(x),a,'COSH(real)')
- call c_d(COSH(1.d0*x),1.d0*a,'COSH(double)')
- call c_d(DCOSH(1.d0*x),1.d0*a,'DCOSH(double)')
- call p_r_r(COSH,x,a,'COSH')
- call p_d_d(DCOSH,1.d0*x,1.d0*a ,'DCOSH')
- end
-
- subroutine hyperbolic_tangent
- intrinsic tanh, dtanh
- real x, a
- x = 1.0
- a = 0.76159416
- call c_r(TANH(x),a,'TANH(real)')
- call c_d(TANH(1.d0*x),1.d0*a,'TANH(double)')
- call c_d(DTANH(1.d0*x),1.d0*a,'DTANH(double)')
- call p_r_r(TANH,x,a,'TANH')
- call p_d_d(DTANH,1.d0*x,1.d0*a ,'DTANH')
- end
-
- subroutine lexically_greater_than_or_equal
- call c_l(LGE('A','B'),.FALSE.,'LGE(character,character) 1')
- call c_l(LGE('B','A'),.TRUE.,'LGE(character,character) 2')
- call c_l(LGE('A','A'),.TRUE.,'LGE(character,character) 3')
- end
-
- subroutine lexically_greater_than
- call c_l(LGT('A','B'),.FALSE.,'LGT(character,character) 1')
- call c_l(LGT('B','A'),.TRUE.,'LGT(character,character) 2')
- call c_l(LGT('A','A'),.FALSE.,'LGT(character,character) 3')
- end
-
- subroutine lexically_less_than_or_equal
- call c_l(LLE('A','B'),.TRUE.,'LLE(character,character) 1')
- call c_l(LLE('B','A'),.FALSE.,'LLE(character,character) 2')
- call c_l(LLE('A','A'),.TRUE.,'LLE(character,character) 3')
- end
-
- subroutine lexically_less_than
- call c_l(LLT('A','B'),.TRUE.,'LLT(character,character) 1')
- call c_l(LLT('B','A'),.FALSE.,'LLT(character,character) 2')
- call c_l(LLT('A','A'),.FALSE.,'LLT(character,character) 3')
- end
+++ /dev/null
-* Preliminary tests for a few things in the i/o library.
-* Thrown together by Dave Love not from specific bug reports --
-* other ideas welcome.
-
- character *(*) fmt
- parameter (fmt='(1x,i3,f5.1)')
-* Scratch file makes sure we can use one and avoids dealing with
-* explicit i/o in the testsuite.
- open(90, status='scratch') ! try a biggish unit number
- write(90, '()') ! extra record for interest
-* Formatted i/o can go wild (endless loop AFAIR) if we're wrongly
-* assuming an ANSI sprintf.
- write(90, fmt) 123, 123.0
- backspace 90 ! backspace problems reported on DOSish systems
- read(90, fmt) i, r
- endfile 90
- if (i/=123 .or. nint(r)/=123) call abort
- rewind 90 ! make sure we can rewind too
- read(90, '()')
- read(90, fmt) i, r
- if (i/=123 .or. nint(r)/=123) call abort
- close(90)
-* Make sure we can do unformatted i/o OK. This might be
-* problematic on DOS-like systems if we've done an fopen in text
-* mode, not binary.
- open(90, status='scratch', access='direct', form='unformatted',
- + recl=8)
- write(90, rec=1) 123, 123.0
- read(90, rec=1) i, r
- if (i/=123 .or. nint(r)/=123) call abort
- close(90)
- open(90, status='scratch', form='unformatted')
- write(90) 123, 123.0
- backspace 90
- read(90) i, r
- if (i/=123 .or. nint(r)/=123) call abort
- close(90)
-* Fails at 1998-09-01 on spurious recursive i/o check (fixed by
-* 1998-09-06 libI77 change):
- open(90, status='scratch', form='formatted', recl=16,
- + access='direct')
- write(90, '(i8,f8.1)',rec=1) 123, 123.0
- read(90, '(i8,f8.1)', rec=1) i, r
- if (i/=123 .or. nint(r)/=123) call abort
- close(90)
- 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
-* Fixed by 1998-09-28 libI77/open.c change.
- open(90,status='scratch')
- write(90, '(1X, I1 / 1X, I1)') 1, 2
- rewind 90
- write(90, '(1X, I1)') 1
- rewind 90 ! implicit ENDFILE expected
- read(90, *) i
- read(90, *, end=10) j
- call abort()
- 10 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
- PROGRAM LABUG1
-
-* This program core dumps on mips-sgi-irix6.2 when compiled
-* with egcs-19981101, egcs-19981109 and egcs-19981122 snapshots
-* with -O2
-*
-* Originally derived from LAPACK test suite.
-* Almost any change allows it to run.
-*
-* David Billinghurst, (David.Billinghurst@riotinto.com.au)
-* 25 November 1998
-*
-* .. Parameters ..
- INTEGER LDA, LDE
- PARAMETER ( LDA = 2500, LDE = 50 )
- COMPLEX CZERO
- PARAMETER ( CZERO = ( 0.0E+0, 0.0E+0 ) )
-
- INTEGER I, J, M, N
- REAL V
- COMPLEX A(LDA),B(LDA),C(LDA),E(LDE,LDE),F(LDE,LDE)
- COMPLEX Z
-
- N=2
- M=1
-*
- do i = 1, m
- do j = 1, n
- e(i,j) = czero
- f(i,j) = czero
- end do
- end do
-*
- DO J = 1, N
- DO I = 1, M
- V = ABS( E(I,J) - F(I,J) )
- END DO
- END DO
-
- CALL SUB2(M,Z)
-
- END
-
- subroutine SUB2(I,A)
- integer i
- complex a
- end
-
-
-
-
-
-
-
-
-
-
+++ /dev/null
- parameter (nmax=165000)
- double precision x(nmax)
- end
+++ /dev/null
- program fool
-
- real foo
- integer n
- logical t
-
- foo = 2.5
- n = 5
-
- t = (n > foo)
- if (t .neqv. .true.) call abort
- t = (n >= foo)
- if (t .neqv. .true.) call abort
- t = (n < foo)
- if (t .neqv. .false.) call abort
- t = (n <= 5)
- if (t .neqv. .true.) call abort
- t = (n >= 5 )
- if (t .neqv. .true.) call abort
- t = (n == 5)
- if (t .neqv. .true.) call abort
- t = (n /= 5)
- if (t .neqv. .false.) call abort
- t = (n /= foo)
- if (t .neqv. .true.) call abort
- t = (n == foo)
- if (t .neqv. .false.) call abort
-
- end
+++ /dev/null
-C integer byte case with integer byte parameters as case(s)
- subroutine ib
- integer *1 a /1/
- integer *1 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal ib'
- end
-C integer halfword case with integer halfword parameters
- subroutine ih
- integer *2 a /1/
- integer *2 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal ih'
- end
-C integer case with integer parameters
- subroutine iw
- integer *4 a /1/
- integer *4 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal iw'
- end
-C integer double case with integer double parameters
- subroutine id
- integer *8 a /1/
- integer *8 one,two,three
- parameter (one=1,two=2,three=3)
- select case (a)
- case (one)
- case (two)
- call abort
- case (three)
- call abort
- case default
- call abort
- end select
- print*,'normal id'
- end
-C integer byte select with integer case
- subroutine ib_mixed
- integer*1 s /1/
- select case (s)
- case (1)
- case (2)
- call abort
- end select
- print*,'ib ok'
- end
-C integer halfword with integer case
- subroutine ih_mixed
- integer*2 s /1/
- select case (s)
- case (1)
- case default
- call abort
- end select
- print*,'ih ok'
- end
-C integer word with integer case
- subroutine iw_mixed
- integer s /5/
- select case (s)
- case (1)
- call abort
- case (2)
- call abort
- case (3)
- call abort
- case (4)
- call abort
- case (5)
-C
- case (6)
- call abort
- case default
- call abort
- end select
- print*,'iw ok'
- end
-C integer doubleword with integer case
- subroutine id_mixed
- integer *8 s /1024/
- select case (s)
- case (1)
- call abort
- case (1023)
- call abort
- case (1025)
- call abort
- case (1024)
-C
- end select
- print*,'i8 ok'
- end
- subroutine l1_mixed
- logical*1 s /.TRUE./
- select case (s)
- case (.TRUE.)
- case (.FALSE.)
- call abort
- end select
- print*,'l1 ok'
- end
- subroutine l2_mixed
- logical*2 s /.FALSE./
- select case (s)
- case (.TRUE.)
- call abort
- case (.FALSE.)
- end select
- print*,'lh ok'
- end
- subroutine l4_mixed
- logical*4 s /.TRUE./
- select case (s)
- case (.FALSE.)
- call abort
- case (.TRUE.)
- end select
- print*,'lw ok'
- end
- subroutine l8_mixed
- logical*8 s /.TRUE./
- select case (s)
- case (.TRUE.)
- case (.FALSE.)
- call abort
- end select
- print*,'ld ok'
- end
-C main
-C -- regression cases
- call ib
- call ih
- call iw
- call id
-C -- new functionality
- call ib_mixed
- call ih_mixed
- call iw_mixed
- call id_mixed
- end
-
-
-
-
-
+++ /dev/null
- program short
-
- parameter ( N=2 )
- common /chb/ pi,sig(0:N)
- common /parm/ h(2,2)
-
-c initialize some variables
- h(2,2) = 1117
- h(2,1) = 1178
- h(1,2) = 1568
- h(1,1) = 1621
- sig(0) = -1.
- sig(1) = 0.
- sig(2) = 1.
-
- call printout
- stop
- end
-
-c ******************************************************************
-
- subroutine printout
- parameter ( N=2 )
- common /chb/ pi,sig(0:N)
- common /parm/ h(2,2)
- dimension yzin1(0:N), yzin2(0:N)
-
-c function subprograms
- z(i,j,k) = 0.5*h(i,j)*(sig(k)-1.)
-
-c a four-way average of rhobar
- do 260 k=0,N
- yzin1(k) = 0.25 *
- & ( z(2,2,k) + z(1,2,k) +
- & z(2,1,k) + z(1,1,k) )
- 260 continue
-
-c another four-way average of rhobar
- do 270 k=0,N
- rtmp1 = z(2,2,k)
- rtmp2 = z(1,2,k)
- rtmp3 = z(2,1,k)
- rtmp4 = z(1,1,k)
- yzin2(k) = 0.25 *
- & ( rtmp1 + rtmp2 + rtmp3 + rtmp4 )
- 270 continue
-
- do k=0,N
- if (yzin1(k) .ne. yzin2(k)) call abort
- enddo
- if (yzin1(0) .ne. -1371.) call abort
- if (yzin1(1) .ne. -685.5) call abort
- if (yzin1(2) .ne. 0.) call abort
-
- return
- end
-
+++ /dev/null
-*** Some random stuff for testing libU77. Should be done better. It's
-* hard to test things where you can't guarantee the result. Have a
-* good squint at what it prints, though detected errors will cause
-* starred messages.
-*
-* Currently not tested:
-* ALARM
-* CHDIR (func)
-* CHMOD (func)
-* FGET (func/subr)
-* FGETC (func)
-* FPUT (func/subr)
-* FPUTC (func)
-* FSTAT (subr)
-* GETCWD (subr)
-* HOSTNM (subr)
-* IRAND
-* KILL
-* LINK (func)
-* LSTAT (subr)
-* RENAME (func/subr)
-* SIGNAL (subr)
-* SRAND
-* STAT (subr)
-* SYMLNK (func/subr)
-* UMASK (func)
-* UNLINK (func)
-*
-* NOTE! This is the testsuite version, so it should compile and
-* execute on all targets, and either run to completion (with
-* success status) or fail (by calling abort). The *other* version,
-* which is a bit more interactive and tests a couple of things
-* this one cannot, should be generally the same, and is in
-* libf2c/libU77/u77-test.f. Please keep it up-to-date.
-
- implicit none
-
- external hostnm
-* intrinsic hostnm
- integer hostnm
-
- integer i, j, k, ltarray (9), idat (3), count, rate, count_max,
- + pid, mask
- real tarray1(2), tarray2(2), r1, r2
- double precision d1
- integer(kind=2) bigi
- logical issum
- intrinsic getpid, getuid, getgid, ierrno, gerror, time8,
- + fnum, isatty, getarg, access, unlink, fstat, iargc,
- + stat, lstat, getcwd, gmtime, etime, chmod, itime, date,
- + chdir, fgetc, fputc, system_clock, second, idate, secnds,
- + time, ctime, fdate, ttynam, date_and_time, mclock, mclock8,
- + cpu_time, dtime, ftell, abort
- external lenstr, ctrlc
- integer lenstr
- logical l
- character gerr*80, c*1
- character ctim*25, line*80, lognam*20, wd*1000, line2*80,
- + ddate*8, ttime*10, zone*5, ctim2*25
- integer fstatb (13), statb (13)
- integer *2 i2zero
- integer values(8)
- integer(kind=7) sigret
-
- i = time ()
- ctim = ctime (i)
- WRITE (6,'(A/)') '1 GNU libU77 test at: ' // ctim(:lenstr (ctim))
- write (6,'(A,I3,'', '',I3)')
- + ' Logical units 5 and 6 correspond (FNUM) to'
- + // ' Unix i/o units ', fnum(5), fnum(6)
- if (lnblnk('foo ').ne.3 .or. len_trim('foo ').ne.3) then
- print *, 'LNBLNK or LEN_TRIM failed'
- call abort
- end if
-
- bigi = time8 ()
-
- call ctime (i, ctim2)
- if (ctim .ne. ctim2) then
- write (6, *) '*** CALL CTIME disagrees with CTIME(): ',
- + ctim2(:lenstr (ctim2)), ' vs. ', ctim(:lenstr (ctim))
- call doabort
- end if
-
- j = time ()
- if (i .gt. bigi .or. bigi .gt. j) then
- write (6, *) '*** TIME/TIME8/TIME sequence failures: ',
- + i, bigi, j
- call doabort
- end if
-
- print *, 'Command-line arguments: ', iargc ()
- do i = 0, iargc ()
- call getarg (i, line)
- print *, 'Arg ', i, ' is: ', line(:lenstr (line))
- end do
-
- l= isatty(6)
- line2 = ttynam(6)
- if (l) then
- line = 'and 6 is a tty device (ISATTY) named '//line2
- else
- line = 'and 6 isn''t a tty device (ISATTY)'
- end if
- write (6,'(1X,A)') line(:lenstr(line))
- call ttynam (6, line)
- if (line .ne. line2) then
- print *, '*** CALL TTYNAM disagrees with TTYNAM: ',
- + line(:lenstr (line))
- call doabort
- end if
-
-* regression test for compiler crash fixed by JCB 1998-08-04 com.c
- sigret = signal(2, ctrlc)
-
- pid = getpid()
- WRITE (6,'(A,I10)') ' Process id (GETPID): ', pid
- WRITE (6,'(A,I10)') ' User id (GETUID): ', GETUID ()
- WRITE (6,'(A,I10)') ' Group id (GETGID): ', GETGID ()
- WRITE (6, *) 'If you have the `id'' program, the following call'
- write (6, *) 'of SYSTEM should agree with the above:'
- call flush(6)
- CALL SYSTEM ('echo " " `id`')
- call flush
-
- lognam = 'blahblahblah'
- call getlog (lognam)
- write (6,*) 'Login name (GETLOG): ', lognam(:lenstr (lognam))
-
- wd = 'blahblahblah'
- call getenv ('LOGNAME', wd)
- write (6,*) 'Login name (GETENV of LOGNAME): ', wd(:lenstr (wd))
-
- call umask(0, mask)
- write(6,*) 'UMASK returns', mask
- call umask(mask)
-
- ctim = fdate()
- write (6,*) 'FDATE returns: ', ctim(:lenstr (ctim))
- call fdate (ctim)
- write (6,*) 'CALL FDATE returns: ', ctim(:lenstr (ctim))
-
- j=time()
- call ltime (j, ltarray)
- write (6,'(1x,a,9i4)') 'LTIME returns:', ltarray
- call gmtime (j, ltarray)
- write (6,'(1x,a,9i4)') 'GMTIME returns:', ltarray
-
- call system_clock(count) ! omitting optional args
- call system_clock(count, rate, count_max)
- write(6,*) 'SYSTEM_CLOCK returns: ', count, rate, count_max
-
- call date_and_time(ddate) ! omitting optional args
- call date_and_time(ddate, ttime, zone, values)
- write(6, *) 'DATE_AND_TIME returns: ', ddate, ' ', ttime, ' ',
- + zone, ' ', values
-
- write (6,*) 'Sleeping for 1 second (SLEEP) ...'
- call sleep (1)
-
-c consistency-check etime vs. dtime for first call
- r1 = etime (tarray1)
- r2 = dtime (tarray2)
- if (abs (r1-r2).gt.1.0) then
- write (6,*)
- + 'Results of ETIME and DTIME differ by more than a second:',
- + r1, r2
- call doabort
- end if
- if (.not. issum (r1, tarray1(1), tarray1(2))) then
- write (6,*) '*** ETIME didn''t return sum of the array: ',
- + r1, ' /= ', tarray1(1), '+', tarray1(2)
- call doabort
- end if
- if (.not. issum (r2, tarray2(1), tarray2(2))) then
- write (6,*) '*** DTIME didn''t return sum of the array: ',
- + r2, ' /= ', tarray2(1), '+', tarray2(2)
- call doabort
- end if
- write (6, '(A,3F10.3)')
- + ' Elapsed total, user, system time (ETIME): ',
- + r1, tarray1
-
-c now try to get times to change enough to see in etime/dtime
- write (6,*) 'Looping until clock ticks at least once...'
- do i = 1,1000
- do j = 1,1000
- end do
- call dtime (tarray2, r2)
- if (tarray2(1) .ne. 0. .or. tarray2(2) .ne. 0.) exit
- end do
- call etime (tarray1, r1)
- if (.not. issum (r1, tarray1(1), tarray1(2))) then
- write (6,*) '*** ETIME didn''t return sum of the array: ',
- + r1, ' /= ', tarray1(1), '+', tarray1(2)
- call doabort
- end if
- if (.not. issum (r2, tarray2(1), tarray2(2))) then
- write (6,*) '*** DTIME didn''t return sum of the array: ',
- + r2, ' /= ', tarray2(1), '+', tarray2(2)
- call doabort
- end if
- write (6, '(A,3F10.3)')
- + ' Differences in total, user, system time (DTIME): ',
- + r2, tarray2
- write (6, '(A,3F10.3)')
- + ' Elapsed total, user, system time (ETIME): ',
- + r1, tarray1
- write (6, *) '(Clock-tick detected after ', i, ' 1K loops.)'
-
- call idate (i,j,k)
- call idate (idat)
- write (6,*) 'IDATE (date,month,year): ',idat
- print *, '... and the VXT version (month,date,year): ', i,j,k
- if (i/=idat(2) .or. j/=idat(1) .or. k/=mod(idat(3),100)) then
- print *, '*** VXT and U77 versions don''t agree'
- call doabort
- end if
-
- call date (ctim)
- write (6,*) 'DATE (dd-mmm-yy): ', ctim(:lenstr (ctim))
-
- call itime (idat)
- write (6,*) 'ITIME (hour,minutes,seconds): ', idat
-
- call time(line(:8))
- print *, 'TIME: ', line(:8)
-
- write (6,*) 'SECNDS(0.0) returns: ',secnds(0.0)
-
- write (6,*) 'SECOND returns: ', second()
- call dumdum(r1)
- call second(r1)
- write (6,*) 'CALL SECOND returns: ', r1
-
-* compiler crash fixed by 1998-10-01 com.c change
- if (rand(0).lt.0.0 .or. rand(0).gt.1.0) then
- write (6,*) '*** rand(0) error'
- call doabort()
- end if
-
- i = getcwd(wd)
- if (i.ne.0) then
- call perror ('*** getcwd')
- call doabort
- else
- write (6,*) 'Current directory is "'//wd(:lenstr(wd))//'"'
- end if
- call chdir ('.',i)
- if (i.ne.0) then
- write (6,*) '***CHDIR to ".": ', i
- call doabort
- end if
-
- i=hostnm(wd)
- if(i.ne.0) then
- call perror ('*** hostnm')
- call doabort
- else
- write (6,*) 'Host name is ', wd(:lenstr(wd))
- end if
-
- i = access('/dev/null ', 'rw')
- if (i.ne.0) write (6,*) '***Read/write ACCESS to /dev/null: ', i
- write (6,*) 'Creating file "foo" for testing...'
- open (3,file='foo',status='UNKNOWN')
- rewind 3
- call fputc(3, 'c',i)
- call fputc(3, 'd',j)
- if (i+j.ne.0) write(6,*) '***FPUTC: ', i
-C why is it necessary to reopen? (who wrote this?)
-C the better to test with, my dear! (-- burley)
- close(3)
- open(3,file='foo',status='old')
- call fseek(3,0,0,*10)
- go to 20
- 10 write(6,*) '***FSEEK failed'
- call doabort
- 20 call fgetc(3, c,i)
- if (i.ne.0) then
- write(6,*) '***FGETC: ', i
- call doabort
- end if
- if (c.ne.'c') then
- write(6,*) '***FGETC read the wrong thing: ', ichar(c)
- call doabort
- end if
- i= ftell(3)
- if (i.ne.1) then
- write(6,*) '***FTELL offset: ', i
- call doabort
- end if
- call ftell(3, i)
- if (i.ne.1) then
- write(6,*) '***CALL FTELL offset: ', i
- call doabort
- end if
- call chmod ('foo', 'a+w',i)
- if (i.ne.0) then
- write (6,*) '***CHMOD of "foo": ', i
- call doabort
- end if
- i = fstat (3, fstatb)
- if (i.ne.0) then
- write (6,*) '***FSTAT of "foo": ', i
- call doabort
- end if
- i = stat ('foo', statb)
- if (i.ne.0) then
- write (6,*) '***STAT of "foo": ', i
- call doabort
- end if
- write (6,*) ' with stat array ', statb
- if (statb(6) .ne. getgid ()) then
- write (6,*) 'Note: FSTAT gid wrong (happens on some systems).'
- end if
- if (statb(5) .ne. getuid () .or. statb(4) .ne. 1) then
- write (6,*) '*** FSTAT uid or nlink is wrong'
- call doabort
- end if
- do i=1,13
- if (fstatb (i) .ne. statb (i)) then
- write (6,*) '*** FSTAT and STAT don''t agree on '// '
- + array element ', i, ' value ', fstatb (i), statb (i)
- call abort
- end if
- end do
- i = lstat ('foo', fstatb)
- do i=1,13
- if (fstatb (i) .ne. statb (i)) then
- write (6,*) '*** LSTAT and STAT don''t agree on '//
- + 'array element ', i, ' value ', fstatb (i), statb (i)
- call abort
- end if
- end do
-
-C in case it exists already:
- call unlink ('bar',i)
- call link ('foo ', 'bar ',i)
- if (i.ne.0) then
- write (6,*) '***LINK "foo" to "bar" failed: ', i
- call doabort
- end if
- call unlink ('foo',i)
- if (i.ne.0) then
- write (6,*) '***UNLINK "foo" failed: ', i
- call doabort
- end if
- call unlink ('foo',i)
- if (i.eq.0) then
- write (6,*) '***UNLINK "foo" again: ', i
- call doabort
- end if
-
- call gerror (gerr)
- i = ierrno()
- write (6,'(A,I3,A/1X,A)') ' The current error number is: ',
- + i,
- + ' and the corresponding message is:', gerr(:lenstr(gerr))
- write (6,*) 'This is sent to stderr prefixed by the program name'
- call getarg (0, line)
- call perror (line (:lenstr (line)))
- call unlink ('bar')
-
- print *, 'MCLOCK returns ', mclock ()
- print *, 'MCLOCK8 returns ', mclock8 ()
-
- call cpu_time (d1)
- print *, 'CPU_TIME returns ', d1
-
-C WRITE (6,*) 'You should see exit status 1'
- CALL EXIT(0)
- 99 END
-
-* Return length of STR not including trailing blanks, but always > 0.
- integer function lenstr (str)
- character*(*) str
- if (str.eq.' ') then
- lenstr=1
- else
- lenstr = lnblnk (str)
- end if
- end
-
-* Just make sure SECOND() doesn't "magically" work the second time.
- subroutine dumdum(r)
- r = 3.14159
- end
-
-* Test whether sum is approximately left+right.
- logical function issum (sum, left, right)
- implicit none
- real sum, left, right
- real mysum, delta, width
- mysum = left + right
- delta = abs (mysum - sum)
- width = abs (left) + abs (right)
- issum = (delta .le. .0001 * width)
- end
-
-* Signal handler
- subroutine ctrlc
- print *, 'Got ^C'
- call doabort
- end
-
-* A problem has been noticed, so maybe abort the test.
- subroutine doabort
-* For this version, call the ABORT intrinsic.
- intrinsic abort
- call abort
- end
-
-* Testsuite version only.
-* Don't actually reference the HOSTNM intrinsic, because some targets
-* need -lsocket, which we don't have a mechanism for supplying.
- integer function hostnm(nm)
- character*(*) nm
- nm = 'not determined by this version of u77-test.f'
- hostnm = 0
- end
+++ /dev/null
-# Various intrinsics not implemented and not implementable; will fail at
-# link time.
-
-if { [istarget "mmix-knuth-mmixware"]
- || [istarget "arm*-*-elf"]
- || [istarget "strongarm*-*-elf"]
- || [istarget "xscale*-*-elf"]
- || [istarget "cris-*-elf"] } {
- set torture_compile_xfail [istarget]
-}
-
-return 0
+++ /dev/null
-* Resent-From: Craig Burley <burley@gnu.org>
-* Resent-To: craig@jcb-sc.com
-* X-Delivered: at request of burley on mescaline.gnu.org
-* Date: Wed, 16 Dec 1998 18:31:24 +0100
-* From: Dieter Stueken <stueken@conterra.de>
-* Organization: con terra GmbH
-* To: fortran@gnu.org
-* Subject: possible bug
-* Content-Type: text/plain; charset=iso-8859-1
-* X-Mime-Autoconverted: from 8bit to quoted-printable by mescaline.gnu.org id KAA09085
-* X-UIDL: 72293bf7f9fac8378ec7feca2bccbce2
-*
-* Hi,
-*
-* I'm about to compile a very old, very ugly Fortran program.
-* For one part I got:
-*
-* f77: Internal compiler error: program f771 got fatal signal 6
-*
-* instead of any detailed error message. I was able to break down the
-* problem to the following source fragment:
-*
-* -------------------------------------------
- PROGRAM WAP
-
- integer*2 ios
- character*80 name
-
- name = 'blah'
- open(unit=8,status='unknown',file=name,form='formatted',
- F iostat=ios)
-
- END
-* -------------------------------------------
-*
-* The problem seems to be caused by the "integer*2 ios" declaration.
-* So far I solved it by simply using a plain integer instead.
-*
-* I'm running gcc on a Linux system compiled/installed
-* with no special options:
-*
-* -> g77 -v
-* g77 version 0.5.23
-* Driving: g77 -v -c -xf77-version /dev/null -xnone
-* Reading specs from /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/specs
-* gcc version 2.8.1
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/cpp -lang-c -v -undef
-* -D__GNUC__=2 -D__GNUC_MINOR__=8 -D__ELF__ -D__unix__ -D__linux__
-* -D__unix -D__linux -Asystem(posix) -D_LANGUAGE_FORTRAN -traditional
-* -Di386 -Di686 -Asystem(unix) -Acpu(i386) -Amachine(i386) -D__i386__
-* -D__i686__ -Asystem(unix) -Acpu(i386) -Amachine(i386) /dev/null
-* /dev/null
-* GNU CPP version 2.8.1 (i386 GNU/Linux with ELF)
-* #include "..." search starts here:
-* #include <...> search starts here:
-* /usr/local/include
-* /usr/i686-pc-linux-gnulibc1/include
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/include
-* /usr/include
-* End of search list.
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/f771 -fnull-version
-* -quiet -dumpbase g77-version.f -version -fversion -o /tmp/cca24911.s
-* /dev/null
-* GNU F77 version 2.8.1 (i686-pc-linux-gnulibc1) compiled by GNU C version
-* 2.8.1.
-* GNU Fortran Front End version 0.5.23
-* as -V -Qy -o /tmp/cca24911.o /tmp/cca24911.s
-* GNU assembler version 2.8.1 (i486-linux), using BFD version 2.8.1
-* ld -m elf_i386 -dynamic-linker /lib/ld-linux.so.1 -o /tmp/cca24911
-* /tmp/cca24911.o /usr/lib/crt1.o /usr/lib/crti.o
-* /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtbegin.o
-* -L/usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1 -L/usr -lg2c -lm -lgcc
-* -lc -lgcc /usr/lib/gcc-lib/i686-pc-linux-gnulibc1/2.8.1/crtend.o
-* /usr/lib/crtn.o
-* /tmp/cca24911
-* __G77_LIBF77_VERSION__: 0.5.23
-* @(#)LIBF77 VERSION 19970919
-* __G77_LIBI77_VERSION__: 0.5.23
-* @(#) LIBI77 VERSION pjw,dmg-mods 19980405
-* __G77_LIBU77_VERSION__: 0.5.23
-* @(#) LIBU77 VERSION 19970919
-*
-*
-* Regards, Dieter.
-* --
-* Dieter Stüken, con terra GmbH, Münster
-* stueken@conterra.de stueken@qgp.uni-muenster.de
-* http://www.conterra.de/ http://qgp.uni-muenster.de/~stueken
-* (0)251-980-2027 (0)251-83-334974
+++ /dev/null
- double precision function fun(a,b)
- double precision a,b
- print*,'in sub: a,b=',a,b
- fun=a*b
- print*,'in sub: fun=',fun
- return
- end
- program test
- double precision a,b,c
- data a,b/1.0d-46,1.0d0/
- c=fun(a,b)
- print*,'in main: fun=',c
- end
+++ /dev/null
-* Culled from 970528-1.f in Burley's g77 test suite. Copyright
-* status not clear. Feel free to chop down if the bug is still
-* reproducible (see end of test case for how bug shows up in gdb
-* run of f771). No particular reason it should be a noncompile
-* case, other than that I didn't want to spend time "fixing" it
-* to compile cleanly (with -O0, which works) while making sure the
-* ICE remained reproducible. -- burley 1999-08-26
-
-* Date: Mon, 26 May 1997 13:00:19 +0200 (GMT+0200)
-* From: "D. O'Donoghue" <dod@da.saao.ac.za>
-* To: Craig Burley <burley@gnu.ai.mit.edu>
-* Cc: fortran@gnu.ai.mit.edu
-* Subject: Re: g77 problems
-
- program dophot
- parameter (napple = 4)
- common /window/nwindo,ixwin(50),iywin(50),iboxwin(50),itype(50)
- common/io/luout,ludebg
- common/search/nstot,thresh
- common /fitparms / acc(npmax),alim(npmax),mit,mpar,mfit1,
- + mfit2,ind(npmax)
- common /starlist/ starpar(npmax,nsmax), imtype(nsmax),
- 1shadow(npmax,nsmax),shaderr(npmax,nsmax),idstr(nsmax)
- common /aperlist/ apple(napple ,nsmax)
- common /parpred / ava(npmax)
- common /unitize / ufactor
- common /undergnd/ nfast, nslow
- common/bzero/ scale,zero
- common /ctimes / chiimp, apertime, filltime, addtime
- common / drfake / needit
- common /mfit/ psfpar(npmax),starx(nfmax),stary(nfmax),xlim,ylim
- common /vers/ version
- logical needit,screen,isub,loop,comd,burn,wrtres,fixedxy
- logical fixed,piped,debug,ex,clinfo
- character header*5760,rhead*2880
- character yn*1,version*40,ccd*4,infile*20
- character*30 numf,odir,record*80
- integer*2 instr(8)
- character*800 line
- external pseud0d, pseud2d, pseud4d, pseudmd, shape
-C
-C Initialization
- data burn, fixedxy,fixed, piped
- + /.false.,.false.,.false.,.false./
- data needit,screen,comd,isub
- + /.true.,.false.,.true.,.false. /
- data acc / .01, -.03, -.03, .01, .03, .1, .03 /
- data alim / -1.0e8, 2*-1.0e3, -1.0e8, 3*-1.0e3 /
-C
- version = 'DoPHOT Version 1.0 LINUX May 97 '
- debug=.false.
- clinfo=.false.
- line(1:800) = ' '
- odir = ' '
-C
-C
-C Read default tuneable parameters
- call tuneup ( nccd, ccd, piped, debug )
- version(33:36) = ccd(1:4)
-C
-
- ludebg=6
- if(piped)then
- yn='n'
- else
- write(*,'(''****************************************'')')
- write(*,1000) version
- write(*,'(''****************************************''//)')
-C
- write(*,'(''Screen output (y/[n])? '',$)')
- read(*,1000) yn
- end if
- if(yn.eq.'y'.or.yn.eq.'Y') then
- screen=.true.
- luout=6
- else
- luout=2
- end if
-C
- if(piped)then
- yn='y'
- else
- write(*,'(''Batch mode ([y]/n)? '',$)')
- read(*,1000) yn
- end if
- if(yn.eq.'n'.or.yn.eq.'N') comd = .false.
-C
- if(.not.comd) then
- write(*,
- * '(''Do you want windowing ([y]/n)? '',$)')
- read(*,1000)yn
- iwindo=1
- if(yn.eq.'n'.or.yn.eq.'N')then
- nwindo=0
- iwindo=0
- end if
-C
- write(*,
- * '(''Star classification info (y/[n]) ?'',$)')
- read(*,1000)yn
- clinfo=.false.
- if(yn.eq.'y'.or.yn.eq.'Y')clinfo=.true.
-C
- write(*,
- * '(''Create a star-subtracted frame (y/[n])? '',$)')
- read(*,1000) yn
- if(yn.eq.'y'.or.yn.eq.'Y') isub = .true.
-C
- write(*,'(''Apply after-burner (y/[n])? '',$)')
- read(*,1000) yn
- if ( yn.eq.'y'.or.yn.eq.'Y' ) burn = .true.
- wrtres = burn
-C
- write(*,'(''Read from fixed (X,Y) list (y/[n])? '',$)')
- read(*,1000) yn
- if ( yn.eq.'y'.or.yn.eq.'Y' ) then
- fixedxy = .true.
- fixed = .true.
- burn = .true.
- wrtres = .true.
- endif
- endif
- iopen=0
-C
-C This is the start of the loop over the input files
-c
- iframe=0
- open(10,file='timing',status='unknown',access='append')
-
-1 ifit = 0
- iapr = 0
- itmn = 0
- model = 1
- xc = 0.0
- yc = 0.0
- rc = 0.0
- ibr = 0
- ixy = 0
-C
- iframe=iframe+1
- tgetpar=0.0
- tsearch=0.0
- tshape=0.0
- timprove=0.0
-C
-C Batch mode ...
-
- if ( comd ) then
- if(iopen.eq.0)then
- iopen=1
- open(11,file='dophot.bat',status='old',err=995)
- end if
- read(11,1000,end=999)infile
-c now read in the parameter instructions. these are:
-c instr(1) : if 1, specifies uncrowded field, otherwise crowded
-c instr(2) : if 1, specifies sequential frames of same field
-c with a window around the stars of interest -
-c all other objects are ignored
-c instr(3) : if 0, takes cmin from dophot.inp (via tuneup)
-c if>0, sets cmin=instr(3)
-c instr(4) : if 0, does nothing
-c if 1, then opens a file called classifications
-c sets clinfo to .true. and writes out the star
-c typing info to this file
-c instr(5) : Delete the shd.nnnnnnn file
-c instr(6) : Delete the out.nnnnnnn file
-c instr(7) : Delete the input frame
-c instr(8) : Create a star-subtracted frame
- read(11,*)instr
- read(11,*)ifit,iapr,tmn,model,xc,yc,rc,ibr,ixy
- nocrwd = instr(1)
- iwindo=instr(2)
- if(iwindo.eq.0)nwindo=0
- itmn=tmn
- if ( instr(3).gt.0 ) cmin=instr(3)
- clinfo=.false.
- if ( instr(4).gt.0 )then
- clinfo=.true.
- open(12,file='classifications',status='unknown')
- ludebg=12
- end if
- if ( instr(8).ne.0 ) then
- isub = .true.
- else
- isub = .false.
- endif
-C
- if(ibr.ne.0) burn = .true.
- if(ixy.ne.0) then
- fixedxy = .true.
- fixed = .true.
- burn = .true.
- goto 20
- endif
- if(iwindo.eq.0)then
- write(6,10)iframe,infile(1:15)
- 10 format(' ***** DoPHOT-ing frame ',i4,': ',a)
- if(ludebg.eq.12)write(ludebg,11)iframe,infile(1:15)
- 11 format(////' ',62('*')/
- * ' * DoPHOT-ing frame ',i4,': ',a,
- * ' *'/' ',62('*'))
- end if
- if(iwindo.eq.1)then
- write(6,12)iframe,infile(1:15)
- 12 format(' ***** DoPHOT-ing frame ',i4,': ',a,
- * ' - Windowed *****')
- if(ludebg.eq.12)write(ludebg,13)iframe,infile(1:15)
- 13 format(////' ',62('*')/
- * ' * DoPHOT-ing frame ',i4,': ',a,
- * ' - Windowed *'/2x,62('*'))
- end if
-C
-C Interactive...
- else
- write(*,'(''Image name: '',$)')
- read(*,1000) infile
- if(infile(1:1).eq.' ') goto 999
-1000 format(a)
- write(*,'(''Crowded field mode ([y]/n) ? '',$)')
- read(*,1000)yn
- nocrwd=0
- if(yn.eq.'n'.or.yn.eq.'N')nocrwd=1
- if(.not.fixed) then
- write(*,1001)
-1001 format('Sky model ([1]=Plane, 2=Power, 3=Hubble)? ',$)
- read(*,1000)record
- if(record.ne.' ')then
- read(record,*) model
- else
- model=1
- end if
- else
- burn=.true.
- goto 20
- endif
- endif
-C
-C if windowing, open the file and read the window
- if(iwindo.eq.1)then
- inquire(file='windows',exist=ex)
- if(.not.ex)go to 997
- if(iframe.eq.1)open(9,file='windows',status='old')
- nwindo=0
- 2 read(9,*,end=3)intype,inx,iny,inbox
- nwindo=nwindo+1
- if(nwindo.gt.50)then
- print *,'too many windows - max = 50'
- stop
- end if
- ixwin(nwindo)=inx
- iywin(nwindo)=iny
- iboxwin(nwindo)=inbox
- itype(nwindo)=intype
- go to 2
-
- 3 rewind 9
- if(screen)print 4,(itype(j),ixwin(j),iywin(j),iboxwin(j),
- * j=1,nwindo)
- 4 format(' Windows: Type X Y Size'/
- * (I13,i6,i5,i5))
- end if
-
- t1 = cputime(0.0)
-C
-C Read FITS frame.
- call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line,ccd)
-C
-C Ignore frame if not the correct chip
- if(nc.lt.0) goto 900
-C
-C Estimate starting PSF parameters.
- 15 call getparams(nfast,nslow,gxwid,gywid,skyval,tmin,tmax,
- * iframe)
- tgetpar = cputime(t1) + tgetpar
- if(debug)write(ludebg,16)iframe,skyval,gxwid,gywid,tmin,tmax
- 16 format(' Getparams on frame ',i4,' sky ',f6.1,' gxwid ',f5.1,
- * ' gywid ',f5.1,' tmin ',f5.1,' tmax ',f5.1)
-C
-C Initialize
- do j=1,nsmax
- imtype(j) = 0
- do i=1,npmax
- shadow(i,j)=0.
- shaderr(i,j)=0.
- enddo
- enddo
-C
- skyguess=skyval
- tfac = 1.0
-C Use 4.5 X SD as fitting width
- fitr=fitfac*(gxwid*asprat*gywid)**0.25 + 0.5
- i=fitr
- irect(1)=i
- irect(2)=fitr/asprat
-C Use 4/3 X FitFac X SD as aperture width
- gmax = asprat*gywid
- if(gxwid.gt.gmax) gmax=gxwid
- aprw = 1.33*fitfac*sqrt(gmax) + 0.5
- i = aprw
- arect(1) = i
- i = aprw/asprat + 0.1
- arect(2) = i
-C
- if(irect(1).gt.50) irect(1)=50
- if(irect(2).gt.50) irect(2)=50
- if(arect(1).gt.45.) arect(1)=45.
- if(arect(2).gt.45.) arect(2)=45.
-C
- if (screen) call htype(line,skyval,.false.,fitr,ngr,ncon)
-C
-C Prompt for further information
- if ( .not.comd ) then
- write(*,1002)
- 1002 format(/'The above are the inital parameters DoPHOT'/
- * 'has found. You can change them now or accept'/
- * 'the values in [ ] by pressing enter'/)
-
- write(*,1004)tmin
- 1004 format('Enter Tmin: threshold for star detection',
- * ' [',f5.1,'] ',$)
- read(*,1000)record
- if(record.ne.' ')read(record,*)tmin
-
- write(*,1005)cmin
- 1005 format('Enter Cmin: threshold for PSF stars',
- * ' [',f5.1,'] ',$)
- read(*,1000)record
- if(record.ne.' ')read(record,*)cmin
-
- write(*,1006)
- 1006 format('Do you want to fix the aperture mag size ?',
- * ' (y/[n]) ')
- read(*,1000)record
- if(record.eq.'y'.or.record.eq.'Y')then
- write(*,1007)
- 1007 format('Enter the size in pixels: ',$)
- read(*,*)iapr
- if(iapr.gt.0) then
- arect(1)=iapr
- i = iapr/asprat + 0.1
- arect(2)=i
- end if
- endif
-C
- write(*,1008)
- 1008 format('Satisfied with other input parameters ? ([y]/n)?',$)
- read(*,1000) yn
- if(yn.eq.'n'.or.yn.eq.'N')then
- yn='n'
- else
- yn='y'
- end if
- if(.not.(yn.eq.'y'.or.yn.eq.'Y') ) call input
- else
- if ( ifit.ne.0 ) then
- irect(1)=ifit
- irect(2)=(ifit/asprat + 0.1)
- endif
- if ( iapr.ne.0 ) then
- arect(1)=iapr
- i = iapr/asprat + 0.1
- arect(2)=i
- endif
- if ( itmn.ne.0 ) tmin = itmn
- if ( .not.(xc.eq.0.0.and.yc.eq.0.0) ) then
- xcen = xc
- ycen = yc
- endif
- endif
-C
-C--------------------------------
-C
-C
- call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
- +nfast, nslow )
-C
-C if the uncrowded field option has been chosen, jump
-C straight to the minimum threshold
-C
- if(nocrwd.eq.1)tmax=tmin
-C
-C Adjust tfac so that thresh ends precisely on Tmin.
- if(tmin/tmax .gt. 0.999) then
- thresh = tmin
- tfac = 1.
- else
- thresh = tmax
- xnum = alog10(tmax/tmin)/alog10(2.**tfac)
- if(xnum.gt.1.5) then
- xnum = float(nint(xnum))
- else if(xnum.ge.1) then
- xnum = 2.0
- else
- xnum = 1.0
- endif
- tfac = alog10(tmax/tmin)/alog10(2.)/xnum
- endif
-C
-C------------------------------------------------------------------------
-C
-C This is the BIG LOOP which searches the frame for stars
-C with intensities > thresh.
-C
-C-----------------------------------------------------------------------
-C
- loop = .true.
- nstot = 0
- do while ( loop )
- loop = thresh/tmin .ge. 1.01
- write(luout,1050) thresh
-1050 format(/20('-')/'THRESHOLD: ', f10.3)
- if(ludebg.eq.12)write(ludebg,1050) thresh
-C
-C Fit given model to sky values.
-C
- call varipar(nstot, nfast, nslow )
- t1 = cputime(0.0)
-C
-C Identifies potential objects in cleaned array IMG
- nstar = isearch( pseud2d, nfast, nslow , clinfo)
- tsearch = cputime(t1) + tsearch
-C
- if ( (nstar .ne. 0).or.(xnum.lt.1.5) ) then
-C
-C Performs 7-parameter PSF fit and determines nature of object.
- t1 = cputime(0.0)
- call shape(pseud2d,pseud4d,nfast,nslow,clinfo)
- tshape = cputime(t1) + tshape
-C
-C Computes average sky values etc from star list
- call paravg
- t1 = cputime(0.0)
-C
-C Computes 4-parameter fits for all stellar objects using
-C new average shape parameters.
- call improve(pseud2d,nfast,nslow,clinfo)
- timprove = cputime(t1) + timprove
- end if
-C
-C Calculate aperture photometry on last pass.
- if(.not.loop) call aper ( pseud2d, nstot, nfast, nslow )
-C
- totaltime = (tgetpar+tsearch+tshape+timprove)
- write(3,1060) totaltime
- write(4,1060) totaltime
- write(luout,1060) totaltime
-1060 format('Total CPU time consumed:',F10.2,' seconds.')
- write(10,1070)infile,tgetpar,tsearch,tshape,timprove,
- * totaltime
-1070 format(a20,' T(getp/f)',f5.1,' T(search)',f5.1,
- * ' T(shape)',f5.1,' T(improve)',f5.1,
- * ' Total',f6.1)
- call title (line,skyval,.false.,fitr,ngr,ncon,strint,ztot,nums)
- rewind(2)
- rewind(3)
- rewind(4)
-C
- call output ( line )
-C
-C Now reduce the threshold and loop back
-C
- thresh = thresh/2.**tfac
- end do
-C
-C--------- END OF BIG LOOP ---------------------------------------
-C
-C If after-burner required, residuals from analytic PSF are computed
-C and stored in RES.
-C
-20 if ( burn ) then
-C
-C If using a fixed (X,Y) coordinate list, read it.
- if (fixed) then
-C Read the image frame
- call getfits(1,infile,header,nhead,nfast,nslow,numf,nc,line)
-C
-C Initialize arrays, open files etc.
- call setup ( numf,nc,screen,line,skyval,fitr,ngr,ncon,
- +nfast, nslow )
-C
-C Read the XY list
- write(luout,'(''Reading XY list ...'')')
- call xylist(numf, nc, ios )
- if(ios.ne.0) then
- fixed = .false.
- write(luout,'(''SXY file absent or incorrect...'')')
- goto 15
- endif
-C
- call htype(line,skyval,.false.,fitr,ngr,ncon)
-C
-C Remove good stars
- write(luout,'(''Cleaning frame of stars: '',i8)') nstot
- call clean ( pseud2d, nstot, nfast, nslow, -1)
-C
-C Calculate aperture photometry
-C call aper ( pseud2d, nstot, nfast, nslow )
- else
- rewind(3)
- rewind(4)
- endif
-C
-C-----------------------
-C Flag all stars close together in groups. Keep making the distance
-C criterion FITR smaller until the maximum number in a group is less
-C than NFMAX
-C
- fitr = amax1(arect(1),arect(2))
- fitr = fitr + 2.0
- nmax = 10000
- write(*,'(''Regrouping ...'')')
-C
- do while ( nmax.gt.nfmax )
- fitr = fitr - 1.0
- write(luout,'(''Min distance ='',f8.1)') fitr
- call regroup( fitr, ngr, nmax )
- enddo
-C
- xlim = irect(1)/2
- ylim = irect(2)/2
-C
-C Calculate normalized PSF residual from PSEUD2D
- call getres (pseud0d,pseud2d,strint,rmn,rmx,nfast,nslow,irect,
- +arect,ztot,nums)
- if(nums.eq.0) then
- write(luout,'(''No suitable PSF stars!'')')
- goto 30
- endif
-C
- write(luout,'(/''AFTERBURNER tuned ON!'')')
-C
-C Fit multiple stars in a group with enhanced PSF using box size IRECT.
- call mulfit( pseud2d,pseudmd,ngr,ncon,nfast,nslow,irect )
-C
-C Re-calculate aperture photometry
- call aperm ( pseudmd, nstot, nfast, nslow )
-C
- call skyadj ( nstot )
-C
- call title (line,skyval,.true.,fitr,ngr,ncon,strint,ztot,nums)
- call output ( line )
- endif
-C---------------------
-C
-C----- This section skipped if PSF residual not written out ------
-C
-30 if( isub ) then
-C
-C Write final Cleaned array.
- infile = 'x'//numf(1:nc)//'.fits'
- call putfits(2,infile,header,nhead,nfast,nslow)
- close(2)
-C
-C If afterburner used, then residual array also written out.
-C Find suitable scale for writing residual PSF to FITS "R" file.
-C
- if ( wrtres ) then
- scale=20000.0/(rmx-rmn)
- zero=-scale*rmn
- do j=-nres,nres
- jj=nres+j+1
- do i=-nres,nres
- ii=nres+i+1
- big(ii,jj)=scale*res(i,j)+zero
- enddo
- enddo
- nx=2*nres+1
-C
- infile = 'r'//numf(1:nc)//'.fits'
- zer=-zero/scale
- scl=1.0/scale
-C
-C Create a FITS header for the normalized PSF residual image
- call sethead(rhead,numf,nx,nx,zer,scl)
- scale=1.0
- zero=0.0
-C Write the normalized PSF residual image
- call putfits(2,infile,rhead,1,nx,nx)
- close(2)
- endif
-C
- end if
-C
-C
-900 close(1)
- close(3)
- close(4)
- if ( .not.screen ) close(luout)
- if(comd) then
- if(instr(5).eq.1)call system('rm shd.'//numf(1:nc))
- if(instr(6).eq.1)call system('rm out.'//numf(1:nc))
- n=1
- do while(infile(n:n).ne.' ')
- n=n+1
- end do
- if(instr(7).eq.1)call system('rm '//infile(1:n-1))
- end if
- fixed = fixedxy
- goto 1
-C
-995 print 996
-996 format(/'*** Fatal error ***'/
- * 'You asked for batch processing but'/
- * 'I cant open the "dophot.bat" file.'/
- * 'Please make one (using batchdophot)'/
- * 'and restart DoPHOT'/)
- go to 999
-
-C
-997 print 998
-998 format(/'*** Fatal error ***'/
- * 'You asked for "windowed" processing'/
- * 'but I cant open the "windows" file.'/
- * 'Please make one and restart DoPHOT'/)
-
-999 call exit(0)
- end
-
-* (gdb) r
-* Starting program: /home3/craig/gnu/f77-e/gcc/f771 -quiet < ../../play/19990826-4.f -O
-* [...]
-* Breakpoint 2, fancy_abort (
-* file=0x8285220 "../../g77-e/gcc/config/i386/i386.c", line=4399,
-* function=0x82860df "output_fp_cc0_set") at ../../g77-e/gcc/rtl.c:1010
-* (gdb) up
-* #1 0x8222fab in output_fp_cc0_set (insn=0x8382324)
-* at ../../g77-e/gcc/config/i386/i386.c:4399
-* (gdb) p insn
-* $1 = 0x3a
-* (gdb) up
-* #2 0x8222b81 in output_float_compare (insn=0x8382324, operands=0x82acc60)
-* at ../../g77-e/gcc/config/i386/i386.c:4205
-* (gdb) p insn
-* $2 = 0x8382324
-* (gdb) whatis insn
-* type = rtx
-* (gdb) pr
-* (insn 2181 2180 2191 (parallel[
-* (set (cc0)
-* (compare (reg:SF 8 %st(0))
-* (mem:SF (plus:SI (reg:SI 6 %ebp)
-* (const_int -9948 [0xffffd924])) 0)))
-* (clobber (reg:HI 0 %ax))
-* ] ) 29 {*cmpsf_cc_1} (insn_list 2173 (insn_list 2173 (nil)))
-* (expr_list:REG_DEAD (reg:DF 8 %st(0))
-* (expr_list:REG_UNUSED (reg:HI 0 %ax)
-* (nil))))
-* (gdb)
+++ /dev/null
-* =foo7.f in Burley's g77 test suite.
- subroutine x
- real a(n)
- common /foo/n
- continue
- entry y(a)
- call foo(a(1))
- end
+++ /dev/null
- PARAMETER (Q=1)
- PARAMETER (P=10)
- INTEGER C(10),D(10),E(10),F(10)
- DATA (C(I),I=1,P) /10*10/ ! TERMINAL NOT INTEGER
- DATA (D(I),I=Q,10) /10*10/ ! START NOT INTEGER
- DATA (E(I),I=1,10,Q) /10*10/ ! INCREMENT NOT INTEGER
- END
+++ /dev/null
- SUBROUTINE A(A,ALPHA,IA)
- COMPLEX A(IA,*), ALPHA(*)
- ALPHA(I)=A(I,I).ZERO)
- END
+++ /dev/null
-* Fixed by JCB 1998-07-25 change to stc.c.
-
-* Date: Thu, 11 Jun 1998 22:35:20 -0500
-* From: Ian A Watson <WATSON_IAN_A@lilly.com>
-* Subject: crash
-*
- CaLL foo(W)
- END
- SUBROUTINE foo(W)
- yy(I)=A(I)Q(X)
+++ /dev/null
-* Fixed by 1998-07-11 equiv.c change.
-* ../../gcc/f/equiv.c:666: failed assertion `ffebld_op (subscript) == FFEBLD_opCONTER'
-
-* Date: Mon, 15 Jun 1998 21:54:32 -0500
-* From: Ian A Watson <WATSON_IAN_A@lilly.com>
-* Subject: Mangler Crash
- EQUIVALENCE(I,glerf(P))
- COMMON /foo/ glerf(3)
+++ /dev/null
-CCC Abort fixed by:
-CCC1998-04-21 Jim Wilson <wilson@cygnus.com>
-CCC
-CCC * stmt.c (check_seenlabel): When search for line number note for
-CCC warning, handle case where there is no such note.
- logical l(10)
- integer i(10)
- goto (10,20),l
- goto (10,20),i
- 10 stop
- 20 end
+++ /dev/null
-# Copyright (C) 1988, 90, 91, 92, 97, 1998 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.
-
-# This file was written by Jeff Law. (law@cs.utah.edu)
-
-#
-# These tests come from Torbjorn Granlund (tege@cygnus.com)
-# C torture test suite.
-#
-
-load_lib mike-g77.exp
-
-# Test check0.f
-prebase
-
-set src_code check0.f
-# Not really sure what the error should be here...
-set compiler_output ".*:8.*:9"
-
-set groups {passed gcc-noncompile}
-
-postbase $src_code $run $groups
-
+++ /dev/null
- integer*1 one
- integer*2 two
- parameter (one=1)
- parameter (two=2)
- select case (I)
- case (one)
- case (two)
- end select
- end
-
projects / gcc.git / commitdiff