* Internal compiler error
@ 2018-01-14 4:09 William Clodius
2018-01-14 5:19 ` Steve Kargl
0 siblings, 1 reply; 25+ messages in thread
From: William Clodius @ 2018-01-14 4:09 UTC (permalink / raw)
To: fortran
I have the following two codes that when compiled with
gfortran -shared -fPIC -o test.so character_codes.f90 ucs_encodings.f90
with
gfortran --version
GNU Fortran (GCC) 7.1.0
Copyright (C) 2017 Free Software Foundation, Inc.
This is free software; see the source for copying conditions. There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
on Mac OS X High Sierra
produces
f951: internal compiler error: Segmentation fault: 11
f951: internal compiler error: Abort trap: 6
gfortran: internal compiler error: Abort trap: 6 (program f951)
Please submit a full bug report,
with preprocessed source if appropriate.
See <https://gcc.gnu.org/bugs/> for instructions.
! [The "BSD licence"]
! Copyright (c) 2014-2018 William B. Clodius
! All rights reserved.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
! 3. The name of the author may not be used to endorse or promote products
! derived from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
! WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
! EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, & INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, & DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
submodule(character_codes) ucs_encodings
implicit none
contains
function encoding_bytes( ucs, encoding )
!
! ENCODING_BYTES returns the number of bytes needed by ENCODING to
! represent the UCS code. If UCS is outside the range Z'0000' to
! Z'10FFFF' or in the UTF-16 extension code range Z'D800' to Z'DFFF'
! UCS will be REPLACEMENT.
!
integer :: encoding_bytes
integer(int32), intent(in) :: ucs
type(encodings_enum), optional, intent(in) :: encoding
select case( encoding % value )
! 8-bit characte codes
case( koi8_r % value, &
koi8_u % value, &
latin_1 % value, &
latin_2 % value, &
latin_3 % value, &
latin_4 % value, &
latin_5 % value, &
latin_6 % value, &
latin_7 % value, &
latin_8 % value, &
latin_9 % value, &
latin_10 % value, &
latin_cyrillic % value, &
w1251 % value, &
w1252 % value )
encoding_bytes = 1
case( utf8 % value )
select case ( ucs )
case ( :-1 )
! will be replacement code
encoding_bytes = 3
case( high_surrog(1):low_surrog(2) )
! will be replacement code
encoding_bytes = 3
case ( ascii(1):ascii(2) )
encoding_bytes = 1
case ( ucs_2_byte(1):high_surrog(1)-1 )
encoding_bytes = 2
case(low_surrog+1:ucs_2_byte(2) )
encoding_bytes = 2
case ( ucs_3_byte(1):ucs_3_byte(2) )
encoding_bytes = 3
case ( ucs_4_byte(1):ucs_4_byte(2) )
encoding_bytes = 4
case default
! will be replacement code
encoding_bytes = 3
end select
case( utf16_be % value, utf16_le % value )
select case ( ucs )
case ( :-1 ) ! will be replacement code
encoding_bytes = 2
case ( 0:plane_size-1 )
encoding_bytes = 2
case ( plane_size:17*plane_size-1 )
encoding_bytes = 4
case default
encoding_bytes = 2
end select
case( utf32_be % value, utf32_le % value )
encoding_bytes = 4
case default ! invalid
encoding_bytes = -1
end select
return
end function encoding_bytes
end submodule ucs_encodings
! [The "BSD licence"]
! Copyright (c) 2017-2018 William B. Clodius
! All rights reserved.
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
! 3. The name of the author may not be used to endorse or promote products
! derived from this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR IMPLIED
! WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
! EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, & INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, & DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
module character_codes
use, intrinsic:: iso_fortran_env, only: &
int8, &
int16, &
int32, &
int64
implicit none
private
! Public derived types
public :: &
encodings_enum ! Enumeration of handled character encodings
! Public procedures
public :: &
encoding_bytes ! Function to find # of bytes for a UCS code
! Public constants and variables
public :: &
bocu1, & ! BOCU-1 encoding
gb_18030, & ! GB-18030 encoding
koi8_r, & ! KOI8-Russian encoding
koi8_u, & ! KOI8-Ukranian encoding
latin_1, & ! Latin-1 encoding
latin_2, & ! Latin-2 encoding
latin_3, & ! Latin-3 encoding
latin_4, & ! Latin-4 encoding
latin_5, & ! Latin-5 encoding
latin_6, & ! Latin-6 encoding
latin_7, & ! Latin-7 encoding
latin_8, & ! Latin-8 encoding
latin_9, & ! Latin-9 encoding
latin_10, & ! Latin-10 encoding
latin_cyrillic, & ! Latin-Cyrillic encoding
scsu, & ! SCSU encoding
utf1, & ! UTF-1 encoding
utf7, & ! Identifiees UTF-7 encoding
utf8, & ! UTF-8 encoding
utf16_be, & ! UTF-16 big endian encoding
utf16_le, & ! UTF-16 little endian encoding
utf32_be, & ! UTF-32 big endian encoding
utf32_le, & ! UTF-32 little endian encoding
utfebcdic, & ! UTF-EBCDIC encoding
w1251, & ! W 1251 encoding
w1252 ! W 1252 encoding
! Defines an enumeration of all the encodings handlee by the current codes
type :: encodings_enum
private
integer :: value
end type encodings_enum
type(encodings_enum), parameter :: &
unhandled = encodings_enum(value = -2), &
unknown = encodings_enum(value = -1), &
w1252 = encodings_enum(value = 0), &
latin_1 = encodings_enum(value = 1), &
latin_2 = encodings_enum(value = 2), &
latin_3 = encodings_enum(value = 3), &
latin_4 = encodings_enum(value = 4), &
latin_5 = encodings_enum(value = 5), &
latin_6 = encodings_enum(value = 6), &
latin_7 = encodings_enum(value = 7), &
latin_8 = encodings_enum(value = 8), &
latin_9 = encodings_enum(value = 9), &
latin_10 = encodings_enum(value = 10), &
latin_cyrillic = encodings_enum(value = 11), &
w1251 = encodings_enum(value = 12), &
koi8_r = encodings_enum(value = 13), &
koi8_u = encodings_enum(value = 14), &
utf8 = encodings_enum(value = 15), &
utf16_be = encodings_enum(value = 16), &
utf16_le = encodings_enum(value = 17), &
utf32_be = encodings_enum(value = 18), &
utf32_le = encodings_enum(value = 19), &
utf7 = encodings_enum(value = 20), &
utf1 = encodings_enum(value = 21), &
utfebcdic = encodings_enum(value = 22), &
scsu = encodings_enum(value = 23), &
bocu1 = encodings_enum(value = 24), &
gb_18030 = encodings_enum(value = 25)
integer(int32), private, parameter :: &
ascii(2) = [ int(B'00000000'), int(B'01111111') ], &
utf8_2_byte(2) = [ int(B'11000000'), int(B'11011111') ], &
utf8_3_byte(2) = [ int(B'11100000'), int(B'11101111') ], &
utf8_4_byte(2) = [ int(B'11110000'), int(B'11110111') ], &
utf8_5_byte(2) = [ int(B'11111000'), int(B'11111011') ], &
utf8_6_byte(2) = [ int(B'11111100'), int(B'11111101') ], &
utf8_illegal(2) = [ int(B'11111110'), int(B'11111111') ], &
utf8_contin(2) = [ int(B'10000000'), int(B'10111111') ], &
ucs_2_byte(2) = [ int( Z'0080'), int( Z'07FF') ], &
ucs_3_byte(2) = [ int( Z'0800'), int( Z'FFFF') ], &
ucs_4_byte(2) = [ int(Z'10000'), int(Z'10FFFF') ], &
high_surrog(2) = [ int( Z'D800'), int( Z'DBFF') ], &
low_surrog(2) = [ int( Z'DC00'), int( Z'DFFF') ], &
plane_size = 2**16
! Procedures defined in the UCS_ENCODING submodule for convererting UCS
! codepoints to and from UTF-8 and UTF-16
interface
module function encoding_bytes( ucs, encoding )
integer :: encoding_bytes
integer(int32), intent(in) :: ucs
type(encodings_enum), optional, intent(in) :: encoding
end function encoding_bytes
end interface
end module character_codes
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal compiler error
2018-01-14 4:09 Internal compiler error William Clodius
@ 2018-01-14 5:19 ` Steve Kargl
0 siblings, 0 replies; 25+ messages in thread
From: Steve Kargl @ 2018-01-14 5:19 UTC (permalink / raw)
To: William Clodius; +Cc: fortran
On Sat, Jan 13, 2018 at 09:08:01PM -0700, William Clodius wrote:
> I have the following two codes that when compiled with
> gfortran -shared -fPIC -o test.so character_codes.f90 ucs_encodings.f90
> with
> gfortran --version
> GNU Fortran (GCC) 7.1.0
> Copyright (C) 2017 Free Software Foundation, Inc.
> This is free software; see the source for copying conditions. There is NO
> warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
> on Mac OS X High Sierra
> produces
> f951: internal compiler error: Segmentation fault: 11
>
With trunk, I get
gfcx -c n2.f90 n1.f90
n1.f90:80:17:
case(low_surrog+1:ucs_2_byte(2) )
1
Warning: Expression in CASE statement at (1) is not in the range of INTEGER(4)
n1.f90:80:17:
case(low_surrog+1:ucs_2_byte(2) )
1
Error: Expression in CASE statement at (1) must be scalar
n1.f90:77:18:
case ( ucs_2_byte(1):high_surrog(1)-1 )
1
n1.f90:83:18:
case ( ucs_3_byte(1):ucs_3_byte(2) )
2
Error: CASE label at (1) overlaps with CASE label at (2)
n1.f90:70:17:
case( high_surrog(1):low_surrog(2) )
1
n1.f90:83:18:
case ( ucs_3_byte(1):ucs_3_byte(2) )
2
Error: CASE label at (1) overlaps with CASE label at (2)
--
Steve
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal compiler error
2011-07-09 20:02 ` Daniel Carrera
@ 2011-07-09 21:22 ` Tobias Burnus
0 siblings, 0 replies; 25+ messages in thread
From: Tobias Burnus @ 2011-07-09 21:22 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gfortran
Daniel Carrera wrote:
>> I tried to compile your patch; however, it fails with:
>
> On my systems those unused variables only give "warnings", so I didn't
> notice them until after I set the patch. How do you compile GCC? You
> must have some extra flag that tells is to stop compiling when it
> encounters unused variables. This is how I compile GCC:
>
> ../configure --enable-languages=c,fortran --disable-bootstrap
The special compile flag is -Werror, i.e. warning are treated as errors.
I think -Werror is the default (for parts of the compiler) when
bootstapping - but seemingly not with --disable-bootstrap.
Thus, one seemingly needs to check manually whether there are warning,
if one does not bootstrap. - Otherwise, one might break bootstrapping.
(If one breaks bootstrapping, one blocks others. Thus, no patch should
break bootstrapping. It still happens occasionally and a unused-variable
warning can also easily be fixed (by others), but, nevertheless, one
should try hard to avoid it.)
Note: Not all files of the compiler are compiled with -Werror, e.g.
libgfortran is not. (Otherwise, it fails to build on some systems).
Thus, one should - from time to time - manually check whether there is a
warning - as warnings usually point to a real problem.
Tobias
PS: For completeness, I usually configure with:
--enable-gold --with-plugin-ld=/usr/bin/gold
--enable-languages=c,fortran,c++
That uses /usr/bin/ld by default, but with LTO (LD plugin) one uses
GOLD, which allows for some additional link-time optimizations by
including symbols from .a (static libraries) in the LTO optimization. (I
forgot whether the normal GNU binutils's "ld" can now also be used for
this; I think it at least supports linker plugins by now.)
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal compiler error
2011-07-09 19:46 ` Tobias Burnus
@ 2011-07-09 20:02 ` Daniel Carrera
2011-07-09 21:22 ` Tobias Burnus
0 siblings, 1 reply; 25+ messages in thread
From: Daniel Carrera @ 2011-07-09 20:02 UTC (permalink / raw)
To: Tobias Burnus; +Cc: gfortran
On 07/09/2011 09:45 PM, Tobias Burnus wrote:
> For segmentation faults, I recommend to run the compile command through
> "valgrind"; for other issues, using a debugger helps.
>
...
>
> To debug the actual compiler, one can use:
>
> valgrind `gfortran -v test.f90 2>&1 | grep f951`
> or
> gdb --quiet --args `gfortran -v test.f90 2>&1 | grep f951`
Ok. I'll install valgrind and try to learn how to use it. I'm sure it'll
be useful next time I have a similar problem. This time I found the bug
by commenting blocks of code and recompiling over and over.
> I tried to compile your patch; however, it fails with:
On my systems those unused variables only give "warnings", so I didn't
notice them until after I set the patch. How do you compile GCC? You
must have some extra flag that tells is to stop compiling when it
encounters unused variables. This is how I compile GCC:
../configure --enable-languages=c,fortran --disable-bootstrap
make
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal compiler error
2011-07-09 19:02 Daniel Carrera
2011-07-09 19:41 ` Daniel Carrera
@ 2011-07-09 19:46 ` Tobias Burnus
2011-07-09 20:02 ` Daniel Carrera
1 sibling, 1 reply; 25+ messages in thread
From: Tobias Burnus @ 2011-07-09 19:46 UTC (permalink / raw)
To: Daniel Carrera; +Cc: gfortran
Daniel Carrera wrote:
> Does anyone have any tips for how to trace an internal compiler error?
For segmentation faults, I recommend to run the compile command through
"valgrind"; for other issues, using a debugger helps.
Note: "valgrind gfortran test.f90" will run the compiler *driver*
(gfortran, gcc, g++ etc.) through valgrind - which is usually not what
one wants. The driver handles calles the proper compiler (.c -> cc1,
.f90 -> f951, etc.) - such that "gfortran foo.c bar.f90" works, it also
calls the assembler and links the program. To see what the driver does,
invoke it with "-v"
To debug the actual compiler, one can use:
valgrind `gfortran -v test.f90 2>&1 | grep f951`
or
gdb --quiet --args `gfortran -v test.f90 2>&1 | grep f951`
Then, one steps through as usual. When debugging a tree, one can use in gdb:
(gdb) p debug_tree(decl)
which prints the tree in some readable format - though for not
middle-end developers, it might be less readable ...
* * *
I tried to compile your patch; however, it fails with:
gcc/fortran/trans.c: In function 'gfc_allocate_using_malloc':
/home/tob/projects/gcc-git/gcc/gcc/fortran/trans.c:592:23: error: unused
variable 'cond' [-Werror=unused-variable]
gcc/fortran/trans.c:592:18: error: unused variable 'msg'
[-Werror=unused-variable]
gcc/fortran/trans.c: In function 'gfc_allocate_using_lib':
gcc/fortran/trans.c:665:23: error: unused variable 'cond'
[-Werror=unused-variable]
gcc/fortran/trans.c:665:18: error: unused variable 'msg'
[-Werror=unused-variable]
Tobias
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal compiler error
2011-07-09 19:02 Daniel Carrera
@ 2011-07-09 19:41 ` Daniel Carrera
2011-07-09 19:46 ` Tobias Burnus
1 sibling, 0 replies; 25+ messages in thread
From: Daniel Carrera @ 2011-07-09 19:41 UTC (permalink / raw)
To: gfortran
Yay! I found the problem. There was a place where I was calling the
wrong function:
- tmp = gfc_allocate_using_lib (&set_status_block, size, status);
+ tmp = gfc_allocate_using_malloc (&set_status_block, size, status);
So of course the compiler would fail. The coarray lib is not even
compiled by default.
Ok, back to work...
Cheers,
Daniel.
On 07/09/2011 09:01 PM, Daniel Carrera wrote:
> Hello,
>
> Does anyone have any tips for how to trace an internal compiler error?
>
> I am making a patch that involves changing function parameters and
> clearly I've made some mistake in building the GIMPLE tree, but I'm
> having a hard time figuring out where it is.
>
> Currently SVN has something like this:
>
> stat = gfc_create_var (gfc_int4_type_node, "stat");
> pstat = gfc_build_addr_expr (NULL_TREE, stat);
> ...
> gfc_allocate_allocatable (... pstat);
>
>
> It turns out that the pointer is not needed, so I am changing the above
> to this:
>
> stat = gfc_create_var (gfc_int4_type_node, "stat");
> ...
> gfc_allocate_allocatable (... stat);
>
>
> I thought I had made all the correct changes inside the allocate
> function. For example:
>
>
> 1) The line:
>
> tree status_type = status ? TREE_TYPE( TREE_TYPE (status)) : NULL_TREE;
>
> Becomes:
>
> tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
>
>
> 2) The line:
>
> on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
> fold_build1_loc (input_location, INDIRECT_REF,
> status_type, status),
> build_int_cst (status_type, LIBERROR_ALLOCATION));
>
>
> Becomes:
>
> on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
> status,
> build_int_cst (status_type, LIBERROR_ALLOCATION));
>
>
> And I think those are mainly the changes. Btw, for completeness my
> current non-functioning patch is attached and a very simple program that
> gives a segfault is below:
>
> program main
>
> implicit none
>
> real,allocatable :: mol
> integer :: i
>
> ! allocate (mol) ! This works.
> allocate (mol, stat=i) ! This fails.
>
> end program main
>
>
> Cheers,
> Daniel.
--
I'm not overweight, I'm undertall.
^ permalink raw reply [flat|nested] 25+ messages in thread
* Internal compiler error
@ 2011-07-09 19:02 Daniel Carrera
2011-07-09 19:41 ` Daniel Carrera
2011-07-09 19:46 ` Tobias Burnus
0 siblings, 2 replies; 25+ messages in thread
From: Daniel Carrera @ 2011-07-09 19:02 UTC (permalink / raw)
To: gfortran
[-- Attachment #1: Type: text/plain, Size: 1629 bytes --]
Hello,
Does anyone have any tips for how to trace an internal compiler error?
I am making a patch that involves changing function parameters and
clearly I've made some mistake in building the GIMPLE tree, but I'm
having a hard time figuring out where it is.
Currently SVN has something like this:
stat = gfc_create_var (gfc_int4_type_node, "stat");
pstat = gfc_build_addr_expr (NULL_TREE, stat);
...
gfc_allocate_allocatable (... pstat);
It turns out that the pointer is not needed, so I am changing the above
to this:
stat = gfc_create_var (gfc_int4_type_node, "stat");
...
gfc_allocate_allocatable (... stat);
I thought I had made all the correct changes inside the allocate
function. For example:
1) The line:
tree status_type = status ? TREE_TYPE( TREE_TYPE (status)) : NULL_TREE;
Becomes:
tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
2) The line:
on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
fold_build1_loc (input_location, INDIRECT_REF,
status_type, status),
build_int_cst (status_type, LIBERROR_ALLOCATION));
Becomes:
on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
status,
build_int_cst (status_type, LIBERROR_ALLOCATION));
And I think those are mainly the changes. Btw, for completeness my
current non-functioning patch is attached and a very simple program that
gives a segfault is below:
program main
implicit none
real,allocatable :: mol
integer :: i
! allocate (mol) ! This works.
allocate (mol, stat=i) ! This fails.
end program main
Cheers,
Daniel.
--
I'm not overweight, I'm undertall.
[-- Attachment #2: allocate-stat=s-patch-v2.diff --]
[-- Type: text/x-patch, Size: 18793 bytes --]
Index: gcc/fortran/trans-array.c
===================================================================
--- gcc/fortran/trans-array.c (revision 176054)
+++ gcc/fortran/trans-array.c (working copy)
@@ -4366,7 +4366,7 @@ gfc_array_init_size (tree descriptor, in
/*GCC ARRAYS*/
bool
-gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree pstat)
+gfc_array_allocate (gfc_se * se, gfc_expr * expr, tree status)
{
tree tmp;
tree pointer;
@@ -4460,22 +4460,16 @@ gfc_array_allocate (gfc_se * se, gfc_exp
error = build_call_expr_loc (input_location,
gfor_fndecl_runtime_error, 1, msg);
- if (pstat != NULL_TREE && !integer_zerop (pstat))
+ if (status != NULL_TREE && !integer_zerop (status))
{
- /* Set the status variable if it's present. */
+ /* FIXME: Ok that I changed "TREE_TYPE (TREE_TYPE" -> "TREE_TYPE" ? */
+ tree status_type = TREE_TYPE (status);
stmtblock_t set_status_block;
- tree status_type = pstat ? TREE_TYPE (TREE_TYPE (pstat)) : NULL_TREE;
gfc_start_block (&set_status_block);
- gfc_add_modify (&set_status_block,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, pstat),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- pstat, build_int_cst (TREE_TYPE (pstat), 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
+ gfc_add_modify (&set_status_block, status,
+ build_int_cst (status_type, LIBERROR_ALLOCATION));
+ error = gfc_finish_block (&set_status_block);
}
gfc_start_block (&elseblock);
@@ -4484,14 +4478,15 @@ gfc_array_allocate (gfc_se * se, gfc_exp
pointer = gfc_conv_descriptor_data_get (se->expr);
STRIP_NOPS (pointer);
- /* The allocate_array variants take the old pointer as first argument. */
+ /* The allocatable variant takes the old pointer as first argument. */
if (allocatable)
- tmp = gfc_allocate_allocatable_with_status (&elseblock,
- pointer, size, pstat, expr);
+ tmp = gfc_allocate_allocatable (&elseblock, pointer,
+ size, status, expr);
else
- tmp = gfc_allocate_with_status (&elseblock, size, pstat, false);
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, pointer,
- tmp);
+ tmp = gfc_allocate_using_malloc (&elseblock, size, status);
+
+ tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
+ pointer, tmp);
gfc_add_expr_to_block (&elseblock, tmp);
Index: gcc/fortran/trans-openmp.c
===================================================================
--- gcc/fortran/trans-openmp.c (revision 176054)
+++ gcc/fortran/trans-openmp.c (working copy)
@@ -188,9 +188,9 @@ gfc_omp_clause_default_ctor (tree clause
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &cond_block);
- ptr = gfc_allocate_allocatable_with_status (&cond_block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ ptr = gfc_allocate_allocatable (&cond_block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL_TREE, NULL);
gfc_conv_descriptor_data_set (&cond_block, decl, ptr);
then_b = gfc_finish_block (&cond_block);
@@ -241,9 +241,9 @@ gfc_omp_clause_copy_ctor (tree clause, t
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
- ptr = gfc_allocate_allocatable_with_status (&block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ ptr = gfc_allocate_allocatable (&block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL_TREE, NULL);
gfc_conv_descriptor_data_set (&block, dest, ptr);
call = build_call_expr_loc (input_location,
built_in_decls[BUILT_IN_MEMCPY], 3, ptr,
@@ -663,9 +663,9 @@ gfc_trans_omp_array_reduction (tree c, g
size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type,
size, esize);
size = gfc_evaluate_now (fold_convert (size_type_node, size), &block);
- ptr = gfc_allocate_allocatable_with_status (&block,
- build_int_cst (pvoid_type_node, 0),
- size, NULL, NULL);
+ ptr = gfc_allocate_allocatable (&block,
+ build_int_cst (pvoid_type_node, 0),
+ size, NULL_TREE, NULL);
gfc_conv_descriptor_data_set (&block, decl, ptr);
gfc_add_expr_to_block (&block, gfc_trans_assignment (e1, e2, false,
false));
Index: gcc/fortran/trans-stmt.c
===================================================================
--- gcc/fortran/trans-stmt.c (revision 176054)
+++ gcc/fortran/trans-stmt.c (working copy)
@@ -4686,7 +4686,6 @@ gfc_trans_allocate (gfc_code * code)
tree tmp;
tree parm;
tree stat;
- tree pstat;
tree error_label;
tree memsz;
tree expr3;
@@ -4699,7 +4698,7 @@ gfc_trans_allocate (gfc_code * code)
if (!code->ext.alloc.list)
return NULL_TREE;
- pstat = stat = error_label = tmp = memsz = NULL_TREE;
+ stat = error_label = tmp = memsz = NULL_TREE;
gfc_init_block (&block);
gfc_init_block (&post);
@@ -4710,7 +4709,6 @@ gfc_trans_allocate (gfc_code * code)
tree gfc_int4_type_node = gfc_get_int_type (4);
stat = gfc_create_var (gfc_int4_type_node, "stat");
- pstat = gfc_build_addr_expr (NULL_TREE, stat);
error_label = gfc_build_label_decl (NULL_TREE);
TREE_USED (error_label) = 1;
@@ -4732,7 +4730,7 @@ gfc_trans_allocate (gfc_code * code)
se.descriptor_only = 1;
gfc_conv_expr (&se, expr);
- if (!gfc_array_allocate (&se, expr, pstat))
+ if (!gfc_array_allocate (&se, expr, stat))
{
/* A scalar or derived type. */
@@ -4847,10 +4845,10 @@ gfc_trans_allocate (gfc_code * code)
/* Allocate - for non-pointers with re-alloc checking. */
if (gfc_expr_attr (expr).allocatable)
- tmp = gfc_allocate_allocatable_with_status (&se.pre, se.expr, memsz,
- pstat, expr);
+ tmp = gfc_allocate_allocatable (&se.pre, se.expr, memsz,
+ stat, expr);
else
- tmp = gfc_allocate_with_status (&se.pre, memsz, pstat, false);
+ tmp = gfc_allocate_using_malloc (&se.pre, memsz, stat);
tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node,
se.expr,
Index: gcc/fortran/trans.c
===================================================================
--- gcc/fortran/trans.c (revision 176054)
+++ gcc/fortran/trans.c (working copy)
@@ -567,30 +567,30 @@ gfc_call_malloc (stmtblock_t * block, tr
This function follows the following pseudo-code:
void *
- allocate (size_t size, integer_type* stat)
+ allocate (size_t size, integer_type stat)
{
void *newmem;
- if (stat)
- *stat = 0;
+ if (stat requested)
+ stat = 0;
newmem = malloc (MAX (size, 1));
if (newmem == NULL)
{
- if (stat)
- *stat = LIBERROR_ALLOCATION;
+ if (stat requested)
+ stat = LIBERROR_ALLOCATION;
else
runtime_error ("Allocation would exceed memory limit");
}
return newmem;
} */
tree
-gfc_allocate_with_status (stmtblock_t * block, tree size, tree status,
- bool coarray_lib)
+gfc_allocate_using_malloc (stmtblock_t * block, tree size, tree status)
{
+ /* FIXME: Ok that I changed "TREE_TYPE (TREE_TYPE" -> "TREE_TYPE" ? */
stmtblock_t alloc_block;
- tree res, tmp, msg, cond;
- tree status_type = status ? TREE_TYPE (TREE_TYPE (status)) : NULL_TREE;
+ tree res, tmp, msg, cond, on_error;
+ tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
/* Evaluate size only once, and make sure it has the right type. */
size = gfc_evaluate_now (size, block);
@@ -602,73 +602,118 @@ gfc_allocate_with_status (stmtblock_t *
/* Set the optional status variable to zero. */
if (status != NULL_TREE && !integer_zerop (status))
- {
- tmp = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, 0));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
- fold_build2_loc (input_location, NE_EXPR,
- boolean_type_node, status,
- build_int_cst (TREE_TYPE (status), 0)),
- tmp, build_empty_stmt (input_location));
- gfc_add_expr_to_block (block, tmp);
- }
+ gfc_add_expr_to_block (block,
+ fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, 0)));
/* The allocation itself. */
gfc_start_block (&alloc_block);
- if (coarray_lib)
- {
- gfc_add_modify (&alloc_block, res,
- fold_convert (prvoid_type_node,
- build_call_expr_loc (input_location,
- gfor_fndecl_caf_register, 6,
- fold_build2_loc (input_location,
- MAX_EXPR, size_type_node, size,
- build_int_cst (size_type_node, 1)),
- build_int_cst (integer_type_node,
- GFC_CAF_COARRAY_ALLOC),
- null_pointer_node, /* token */
- null_pointer_node, /* stat */
- null_pointer_node, /* errmsg, errmsg_len */
- build_int_cst (integer_type_node, 0))));
- }
+ gfc_add_modify (&alloc_block, res,
+ fold_convert (prvoid_type_node,
+ build_call_expr_loc (input_location,
+ built_in_decls[BUILT_IN_MALLOC], 1,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)))));
+
+ /* What to do in case of error. */
+ if (status != NULL_TREE && !integer_zerop (status))
+ on_error = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, LIBERROR_ALLOCATION));
else
+ on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const
+ ("Allocation would exceed memory limit")));
+
+ tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+ fold_build2_loc (input_location, EQ_EXPR,
+ boolean_type_node, res,
+ build_int_cst (prvoid_type_node, 0)),
+ on_error, build_empty_stmt (input_location));
+ gfc_add_expr_to_block (&alloc_block, tmp);
+ gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
+
+ return res;
+}
+
+/* Allocate memory, using an optional status argument.
+
+ This function follows the following pseudo-code:
+
+ void *
+ allocate (size_t size, integer_type stat)
{
- gfc_add_modify (&alloc_block, res,
- fold_convert (prvoid_type_node,
- build_call_expr_loc (input_location,
- built_in_decls[BUILT_IN_MALLOC], 1,
- fold_build2_loc (input_location,
- MAX_EXPR, size_type_node, size,
- build_int_cst (size_type_node, 1)))));
- }
+ void *newmem;
+
+ if (stat requested)
+ stat = 0;
- msg = gfc_build_addr_expr (pchar_type_node, gfc_build_localized_cstring_const
- ("Allocation would exceed memory limit"));
- tmp = build_call_expr_loc (input_location,
- gfor_fndecl_os_error, 1, msg);
+ newmem = _caf_register ( size, regtype, NULL, &stat, NULL, NULL);
+ if (newmem == NULL)
+ {
+ if (!stat requested)
+ runtime_error ("Allocation would exceed memory limit");
+ }
+ return newmem;
+ } */
+tree
+gfc_allocate_using_lib (stmtblock_t * block, tree size, tree status)
+{
+ /* FIXME: Ok that I changed "TREE_TYPE (TREE_TYPE" -> "TREE_TYPE" ? */
+ stmtblock_t alloc_block;
+ tree res, tmp, msg, cond, pstat, on_error;
+ tree status_type = status ? TREE_TYPE (status) : NULL_TREE;
+
+ /* Evaluate size only once, and make sure it has the right type. */
+ size = gfc_evaluate_now (size, block);
+ if (TREE_TYPE (size) != TREE_TYPE (size_type_node))
+ size = fold_convert (size_type_node, size);
+
+ /* Create a variable to hold the result. */
+ res = gfc_create_var (prvoid_type_node, NULL);
+ /* Set the optional status variable to zero. */
if (status != NULL_TREE && !integer_zerop (status))
- {
- /* Set the status variable if it's present. */
- tree tmp2;
+ gfc_add_expr_to_block (block,
+ fold_build2_loc (input_location, MODIFY_EXPR, status_type,
+ status, build_int_cst (status_type, 0)));
- cond = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (TREE_TYPE (status), 0));
- tmp2 = fold_build2_loc (input_location, MODIFY_EXPR, status_type,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
- tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, cond,
- tmp, tmp2);
- }
+ /* The allocation itself. */
+ if (status != NULL_TREE && !integer_zerop (status))
+ pstat = gfc_build_addr_expr (NULL_TREE, status);
+ else
+ pstat = null_pointer_node;
+
+ gfc_start_block (&alloc_block);
+ gfc_add_modify (&alloc_block, res,
+ fold_convert (prvoid_type_node,
+ build_call_expr_loc (input_location,
+ gfor_fndecl_caf_register, 6,
+ fold_build2_loc (input_location,
+ MAX_EXPR, size_type_node, size,
+ build_int_cst (size_type_node, 1)),
+ build_int_cst (integer_type_node,
+ GFC_CAF_COARRAY_ALLOC),
+ null_pointer_node, /* token */
+ pstat, /* status */
+ null_pointer_node, /* errmsg, errmsg_len */
+ build_int_cst (integer_type_node, 0))));
+
+ /* What to do in case of error -- library has already set status. */
+ if (status != NULL_TREE && !integer_zerop (status))
+ on_error = build_empty_stmt (input_location);
+ else
+ on_error = build_call_expr_loc (input_location, gfor_fndecl_os_error, 1,
+ gfc_build_addr_expr (pchar_type_node,
+ gfc_build_localized_cstring_const
+ ("Allocation would exceed memory limit")));
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node,
fold_build2_loc (input_location, EQ_EXPR,
boolean_type_node, res,
build_int_cst (prvoid_type_node, 0)),
- tmp, build_empty_stmt (input_location));
+ on_error, build_empty_stmt (input_location));
gfc_add_expr_to_block (&alloc_block, tmp);
gfc_add_expr_to_block (block, gfc_finish_block (&alloc_block));
@@ -683,7 +728,7 @@ gfc_allocate_with_status (stmtblock_t *
This function follows the following pseudo-code:
void *
- allocate_allocatable (void *mem, size_t size, integer_type *stat)
+ allocate_allocatable (void *mem, size_t size, integer_type stat)
{
if (mem == NULL)
return allocate (size, stat);
@@ -693,7 +738,7 @@ gfc_allocate_with_status (stmtblock_t *
{
free (mem);
mem = allocate (size, stat);
- *stat = LIBERROR_ALLOCATION;
+ stat = LIBERROR_ALLOCATION;
return mem;
}
else
@@ -704,8 +749,8 @@ gfc_allocate_with_status (stmtblock_t *
expr must be set to the original expression being allocated for its locus
and variable name in case a runtime error has to be printed. */
tree
-gfc_allocate_allocatable_with_status (stmtblock_t * block, tree mem, tree size,
- tree status, gfc_expr* expr)
+gfc_allocate_allocatable (stmtblock_t * block, tree mem, tree size, tree status,
+ gfc_expr* expr)
{
stmtblock_t alloc_block;
tree res, tmp, null_mem, alloc, error;
@@ -720,11 +765,16 @@ gfc_allocate_allocatable_with_status (st
boolean_type_node, mem,
build_int_cst (type, 0)));
- /* If mem is NULL, we call gfc_allocate_with_status. */
+ /* If mem is NULL, we call gfc_allocate_using_malloc or
+ gfc_allocate_using_lib. */
gfc_start_block (&alloc_block);
- tmp = gfc_allocate_with_status (&alloc_block, size, status,
- gfc_option.coarray == GFC_FCOARRAY_LIB
- && gfc_expr_attr (expr).codimension);
+
+ if (gfc_option.coarray == GFC_FCOARRAY_LIB
+ && gfc_expr_attr (expr).codimension)
+ tmp = gfc_allocate_using_lib (&alloc_block, size, status);
+ else
+ tmp = gfc_allocate_using_malloc (&alloc_block, size, status);
+
gfc_add_modify (&alloc_block, res, fold_convert (type, tmp));
alloc = gfc_finish_block (&alloc_block);
@@ -751,7 +801,8 @@ gfc_allocate_allocatable_with_status (st
if (status != NULL_TREE && !integer_zerop (status))
{
- tree status_type = TREE_TYPE (TREE_TYPE (status));
+ /* FIXME: Ok that I changed "TREE_TYPE (TREE_TYPE" -> "TREE_TYPE" ? */
+ tree status_type = TREE_TYPE (status);
stmtblock_t set_status_block;
gfc_start_block (&set_status_block);
@@ -760,18 +811,12 @@ gfc_allocate_allocatable_with_status (st
fold_convert (pvoid_type_node, mem));
gfc_add_expr_to_block (&set_status_block, tmp);
- tmp = gfc_allocate_with_status (&set_status_block, size, status, false);
+ tmp = gfc_allocate_using_lib (&set_status_block, size, status);
gfc_add_modify (&set_status_block, res, fold_convert (type, tmp));
- gfc_add_modify (&set_status_block,
- fold_build1_loc (input_location, INDIRECT_REF,
- status_type, status),
- build_int_cst (status_type, LIBERROR_ALLOCATION));
-
- tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node,
- status, build_int_cst (status_type, 0));
- error = fold_build3_loc (input_location, COND_EXPR, void_type_node, tmp,
- error, gfc_finish_block (&set_status_block));
+ gfc_add_modify (&set_status_block, status,
+ build_int_cst (status_type, LIBERROR_ALLOCATION));
+ error = gfc_finish_block (&set_status_block);
}
tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, null_mem,
Index: gcc/fortran/trans.h
===================================================================
--- gcc/fortran/trans.h (revision 176054)
+++ gcc/fortran/trans.h (working copy)
@@ -541,11 +541,12 @@ tree gfc_call_malloc (stmtblock_t *, tre
tree gfc_build_memcpy_call (tree, tree, tree);
/* Allocate memory for allocatable variables, with optional status variable. */
-tree gfc_allocate_allocatable_with_status (stmtblock_t*,
- tree, tree, tree, gfc_expr*);
+tree gfc_allocate_allocatable (stmtblock_t*,
+ tree, tree, tree, gfc_expr*);
/* Allocate memory, with optional status variable. */
-tree gfc_allocate_with_status (stmtblock_t *, tree, tree, bool);
+tree gfc_allocate_using_malloc (stmtblock_t *, tree, tree);
+tree gfc_allocate_using_lib (stmtblock_t *, tree, tree);
/* Generate code to deallocate an array. */
tree gfc_deallocate_with_status (tree, tree, bool, gfc_expr*);
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: internal compiler error
2009-11-06 4:26 internal " Hans Horn
@ 2009-11-06 8:35 ` Thomas Koenig
0 siblings, 0 replies; 25+ messages in thread
From: Thomas Koenig @ 2009-11-06 8:35 UTC (permalink / raw)
To: Hans Horn; +Cc: fortran
On Thu, 2009-11-05 at 12:29 -0800, Hans Horn wrote:
> Behaves when I remove '-ftree-loop-linear'
This is now
http://gcc.gnu.org/bugzilla/show_bug.cgi?id=41957
Thanks a lot!
Thomas
^ permalink raw reply [flat|nested] 25+ messages in thread
* internal compiler error
@ 2009-11-06 4:26 Hans Horn
2009-11-06 8:35 ` Thomas Koenig
0 siblings, 1 reply; 25+ messages in thread
From: Hans Horn @ 2009-11-06 4:26 UTC (permalink / raw)
To: fortran
[-- Attachment #1: Type: text/plain, Size: 893 bytes --]
Folks,
while playing with optimization options I ran into this one:
atamul.f: In function ‘atamul’:
atamul.f:6:0: internal compiler error: in initialize_matrix_A, at
tree-data-ref.c:1912
Please submit a full bug report,
with preprocessed source if appropriate.
See <http://gcc.gnu.org/bugs.html> for instructions.
source attached.
command line:
gfc -c -Wall -Wextra -Wuninitialized -Wunused-label -fno-underscoring
-O3 -fno-strict-aliasing -Winline -fexpensive-optimizations \
-finline-functions -finline-limit=500000 -fstrength-reduce -fgcse
-fgcse-lm -fgcse-sm -funroll-loops -fforce-addr -fomit-frame-pointer
-ftree-vectorize \
-ftree-loop-linear -mfpmath=sse -msse3 -march=pentium4 -pipe -o atamul.o
atamul.f
(GNU Fortran (GCC) 4.5.0 20091014 (experimental) [trunk revision 152402])
Intel core duo cygwin/WinXP 32 bit
Behaves when I remove '-ftree-loop-linear'
H.
[-- Attachment #2: atamul.f --]
[-- Type: text/plain, Size: 1116 bytes --]
c AtAMul: Left-multiplies matrix AMat by its transpose ----------------
c AtAMat = transpose(AMat) * AMat
c k,k k,n n,k
c the resultant matrix AtAMat is returned in lower triangle form
c ---------------------------------------------------------------------
Subroutine AtAmul(AMat,AtAMat,kDim,nDim)
IMPLICIT NONE
c Input: Output: Local:
Integer kDim,nDim, i, j, ij, n
Real*8 AMat(kDim,nDim), AtAMat(kDim*(kDim+1)/2), Ai1, Ain
c initialization loop n=1 :
ij = 0
do i = 1, kDim
Ai1 = AMat(i,1)
do j = 1, i-1
AtAMat(ij+j) = Ai1 * AMat(j,1)
enddo
ij = ij + i
AtAMat(ij) = Ai1 * Ai1
enddo
c accumulation loop n=2,nDim :
do n = 2, nDim
ij = 0
do i = 1, kDim
Ain = AMat(i,n)
do j = 1, i-1
AtAMat(ij+j) = AtAMat(ij+j) + Ain * AMat(j,n)
enddo
ij = ij + i
AtAMat(ij) = AtAMat(ij) + Ain * Ain
enddo
enddo
end
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: internal compiler error
2007-07-02 9:02 Virginie Trinite
@ 2007-07-02 9:19 ` FX Coudert
0 siblings, 0 replies; 25+ messages in thread
From: FX Coudert @ 2007-07-02 9:19 UTC (permalink / raw)
To: Virginie Trinite; +Cc: fortran
Hello,
> When compiling with gfortran using gfortran-windows.exe (version
> 4.3.0)
> I have the following error:
> In function 'splie2':
> internal compiler error: Segmentation fault
>
>
> However when I compile the same piece of code with gfortran under
> linux (version 4.1.1), I have no error
We'd need a testcase to reproduce the error in order to fix it. Can
you reduce the code that triggers the error to something of
reasonable size (and possibly unencumbered by copyright)?
Thanks,
FX
^ permalink raw reply [flat|nested] 25+ messages in thread
* internal compiler error
@ 2007-07-02 9:02 Virginie Trinite
2007-07-02 9:19 ` FX Coudert
0 siblings, 1 reply; 25+ messages in thread
From: Virginie Trinite @ 2007-07-02 9:02 UTC (permalink / raw)
To: fortran
Hello
When compiling with gfortran using gfortran-windows.exe (version 4.3.0)
I have the following error:
In function 'splie2':
internal compiler error: Segmentation fault
However when I compile the same piece of code with gfortran under linux
(version 4.1.1), I have no error
Thanks for your attention
Virginie trinité
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal Compiler Error
2006-07-14 20:00 ` Paul Thomas
@ 2006-07-14 20:05 ` Steve Kargl
0 siblings, 0 replies; 25+ messages in thread
From: Steve Kargl @ 2006-07-14 20:05 UTC (permalink / raw)
To: Paul Thomas; +Cc: Ray Nachlinger, fortran
On Fri, Jul 14, 2006 at 09:46:57PM +0200, Paul Thomas wrote:
> Ray,
>
> This has been posted, together with a fix, as PR28384. I propose to
> commit the patch as 'obvious' on Sunday night, since it consists of the
> following:
>
> Index: gcc/fortran/trans-common.c
> ===================================================================
> *** gcc/fortran/trans-common.c (revision 115409)
> --- gcc/fortran/trans-common.c (working copy)
> *************** translate_common (gfc_common_head *commo
> *** 962,967 ****
> --- 962,974 ----
> current_offset += s->length;
> }
>
> + if (common_segment == NULL)
> + {
> + gfc_error ("COMMON '%s' at %L does not exist",
> + common->name, &common->where);
> + return;
> + }
> +
> if (common_segment->offset != 0)
> {
> gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
>
>
> ie. a test for a structure, whose component is referenced. Since this
> will always cause an ICE, nothing but good can come of it!
>
Looks ok to me. Of course, you need a ChangeLog entry.
--
Steve
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal Compiler Error
2006-07-14 18:00 ` Internal Compiler Error Ray Nachlinger
@ 2006-07-14 20:00 ` Paul Thomas
2006-07-14 20:05 ` Steve Kargl
0 siblings, 1 reply; 25+ messages in thread
From: Paul Thomas @ 2006-07-14 20:00 UTC (permalink / raw)
To: Ray Nachlinger; +Cc: fortran
Ray,
This has been posted, together with a fix, as PR28384. I propose to
commit the patch as 'obvious' on Sunday night, since it consists of the
following:
Index: gcc/fortran/trans-common.c
===================================================================
*** gcc/fortran/trans-common.c (revision 115409)
--- gcc/fortran/trans-common.c (working copy)
*************** translate_common (gfc_common_head *commo
*** 962,967 ****
--- 962,974 ----
current_offset += s->length;
}
+ if (common_segment == NULL)
+ {
+ gfc_error ("COMMON '%s' at %L does not exist",
+ common->name, &common->where);
+ return;
+ }
+
if (common_segment->offset != 0)
{
gfc_warning ("COMMON '%s' at %L requires %d bytes of padding at start",
ie. a test for a structure, whose component is referenced. Since this
will always cause an ICE, nothing but good can come of it!
Paul
^ permalink raw reply [flat|nested] 25+ messages in thread
* Internal Compiler Error
2006-07-14 17:34 ` Paul Thomas
@ 2006-07-14 18:00 ` Ray Nachlinger
2006-07-14 20:00 ` Paul Thomas
0 siblings, 1 reply; 25+ messages in thread
From: Ray Nachlinger @ 2006-07-14 18:00 UTC (permalink / raw)
To: fortran
The "program"
save /rbuf_char/
end
produces an Internal Compiler Error.
Thanks,
Ray
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: internal compiler error
2006-06-24 21:34 ` Steve Kargl
@ 2006-06-24 21:41 ` FX Coudert
0 siblings, 0 replies; 25+ messages in thread
From: FX Coudert @ 2006-06-24 21:41 UTC (permalink / raw)
To: Steve Kargl; +Cc: Ron Young, fortran
> Seems FX beat me to a reduce testcase, and richi
> has even produced a tentative patch. How's that
> for service? ;-)
And this is now known as PR 28158
(http://gcc.gnu.org/bugzilla/show_bug.cgi?id=28158)
FX
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: internal compiler error
2006-06-24 21:27 ` Steve Kargl
@ 2006-06-24 21:34 ` Steve Kargl
2006-06-24 21:41 ` FX Coudert
0 siblings, 1 reply; 25+ messages in thread
From: Steve Kargl @ 2006-06-24 21:34 UTC (permalink / raw)
To: Ron Young; +Cc: fortran
On Sat, Jun 24, 2006 at 02:25:51PM -0700, Steve Kargl wrote:
> On Sat, Jun 24, 2006 at 02:01:05PM -0700, Ron Young wrote:
> > This could be already known.
> >
> > Ron Young
> >
>
> I have not seen this problem. Here's reduced test.
>
Seems FX beat me to a reduce testcase, and richi
has even produced a tentative patch. How's that
for service? ;-)
--
Steve
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: internal compiler error
2006-06-24 21:01 internal compiler error Ron Young
@ 2006-06-24 21:27 ` Steve Kargl
2006-06-24 21:34 ` Steve Kargl
0 siblings, 1 reply; 25+ messages in thread
From: Steve Kargl @ 2006-06-24 21:27 UTC (permalink / raw)
To: Ron Young; +Cc: fortran
On Sat, Jun 24, 2006 at 02:01:05PM -0700, Ron Young wrote:
> This could be already known.
>
> Ron Young
>
I have not seen this problem. Here's reduced test.
subroutine yhalf(z, b)
complex*16 z,b
complex*16 cdexpj
complex*16 jz,y0,expp,expm
jz =(0.d0,1.d0)*z
expp =cdexpj(b+jz)
expm =cdexpj(b-jz)
y0 =(0.d0,-1.d0)*(expp+expm)/(jz+jz)
end
laptop:kargl[203] gfc -c -msse -mfpmath=sse ron.f
ron.f: In function 'yhalf':
ron.f:9: error: unrecognizable insn:
(insn 83 82 84 3 (set (reg:DF 92 [ D.1111 ])
(neg:DF (reg:DF 94 [ D.1109 ]))) -1 (nil)
(nil))
ron.f:9: internal compiler error: in extract_insn, at recog.c:2077
Please submit a full bug report,
with preprocessed source if appropriate.
See <URL:http://gcc.gnu.org/bugs.html> for instructions.
I'll submit a bug report.
--
Steve
^ permalink raw reply [flat|nested] 25+ messages in thread
* internal compiler error
@ 2006-06-24 21:01 Ron Young
2006-06-24 21:27 ` Steve Kargl
0 siblings, 1 reply; 25+ messages in thread
From: Ron Young @ 2006-06-24 21:01 UTC (permalink / raw)
To: fortran
This could be already known.
Ron Young
gfc -c -O3 -msse -mfpmath=sse -ipa -mtune=pentium3 yhalf. for
yhalf.for: In function 'yhalf':
yhalf.for:156: error: unrecognizable insn:
(insn 29 28 31 3 (set (reg:DF 175 [ jz$real ])
(neg:DF (reg:DF 194))) -1 (nil)
(expr_list:REG_EQUAL (neg:DF (mem:DF (plus:SI (reg/v/f:SI 188 [ z ])
(const_int 8 [0x8])) [2 (* z) S8 A64]))
(nil)))
yhalf.for:156: internal compiler error: in extract_insn, at recog.c:2077
Please submit a full bug report,
with preprocessed source if appropriate.
See <URL:http://gcc.gnu.org/bugs.html> for instructions.
[root@myhost bench]# gfc -c -O3 -msse -mfpmath=sse yhalf.for yhalf.for:
In function 'yhalf':
yhalf.for:156: error: unrecognizable insn:
(insn 30 29 32 3 (set (reg:DF 175 [ jz$real ])
(neg:DF (reg:DF 194))) -1 (nil)
(expr_list:REG_EQUAL (neg:DF (mem:DF (plus:SI (reg/v/f:SI 188 [ z ])
(const_int 8 [0x8])) [2 (* z) S8 A64]))
(nil)))
yhalf.for:156: internal compiler error: in extract_insn, at recog.c:2077
Please submit a full bug report,
with preprocessed source if appropriate.
See <URL:http://gcc.gnu.org/bugs.html> for instructions.
subroutine yhalf(z,n,b,nback,yw,yv)
c
c ------------------------- DESCRIPTION --------------------------------
c This routine calculates scaled values of the spherical Neumann
c Functions with complex argument.
c
c This routine calculates the
c
c b Y(i+1/2)(z)
c yv(i) = e ----------------- for i=0..n
c (2 z/pi)**(1/2)
c
c IT IS ASSUMED THAT n >= 0
c
c The algorithm used is a modified form of the algorithm for the
c computation of the integer order Neumann functions as outlined in
c "The Numerical Computation of Bessel Functions of First and Second
c Kind for Integer Orders and Complex Arguments" by C.F. Du Toit
c IEEE Transactions on Antennas and Propagation Vol 38. No 9 Sep 1990
c
c The modification of the algorithm lies in the calculation of
c y0 and y1 as opposed to Y0 and Y1. In the former, there are simple
c closed form formulae. In the latter, the Bessel functions of the first
c kind are used to calculate Y0 and Y1.
c
c ----------------------- SUBROUTINES and FUNCTIONS --------------------
c
c CALLS : yback
c
c ------------------------- VARIABLE DESCRIPTION -----------------------
c IN (args)
c z : argument of the Bessel functions
c n : see description
c b : exponent of multiplier (see description)
c
c WORKSPACE (args)
c yw : workspace
c
c OUT (args)
c nback : value used for the start of the backwards recursion (if
c : needed)
c yv : vector of bessel functions
c
c LOCAL VARIABLES AND LOCAL PARAMETERS
c alpha : variable used to appropriately scale one of the sets of
c : values found in the backwards recursion.
c beta : variable used to appropriately scale the other set of
c : values found by backwards recursion.
c det : temporary variable used in the calculation of alpha and beta
c y0 : scaled spherical Neumann function of order 0
c y1 : scaled spherical Neumann function of order 1
c expp : exp(b+j*z)
c expm : exp(b-j*z)
c jz : j*z
c zabs : |z|
c q : order of the Newmann functions
c i : loop index
c v : order at which the backwards recursion is to start
c
c ------------------------- DECLARATIONS -------------------------------
c INPUTS:
integer n
complex*16 z,b
c
c WORKSPACE:
complex*16 yw(0:n)
c
c OUTPUTS:
integer nback
complex*16 yv(0:n)
c
c PARAMETERS:
real*8 SMALL
parameter (SMALL=1.d-300)
c
c FUNCTIONS :
real*8 cdabsj,yback
complex*16 cdexpj
c
c LOCALS:
integer i,q
real*8 zabs,v
complex*16 jz,y0,y1,expp,expm,alpha,beta,det
c
c ---------------------------- CODE ------------------------------------
c
c y0= -cos(z)/z
c y1= -cos(z)/(z*z) - sin(z)/z
c
c calculate the first two in the sequence * exp(b)
c
c
zabs=cdabsj(z)
jz =(0.d0,1.d0)*z
expp =cdexpj(b+jz)
expm =cdexpj(b-jz)
y0 =(0.d0,-1.d0)*(expp+expm)/(jz+jz)
y1 =(y0 + (expp-expm)*(0.d0,0.5d0))/z
c
c check if we need to use backward recurrence
c
if(dimag(z).eq.0.d0)then
v=1.d0
else
v=yback(z)
endif
c
c if v > 1, then use backwards recurrence with two starting points
c
nback=idint(v)
if(nback.gt.1.and.n.gt.1)then
if(nback.gt.n)nback=n
yv(nback) =(0.d0,0.d0)
yv(nback-1)=(1.d0,0.d0)
yw(nback) =(1.d0,0.d0)
yw(nback-1)=(0.d0,0.d0)
q =nback
do 20 i=1,nback-1,1
yv(q-2)=dfloat(q+q-1)*yv(q-1)/z - yv(q)
yw(q-2)=dfloat(q+q-1)*yw(q-1)/z - yw(q)
q =q-1
20 continue
c
c now use y0 and y1 to determine the right combination of the two
c solutions
c
c y0 = alpha*yv(0) + beta*yw(0)
c y1 = alpha*yv(1) + beta*yw(1)
c
det =yv(0)*yw(1)-yw(0)*yv(1)
alpha=(yw(1)*y0 - yw(0)*y1)/det
beta =(yv(0)*y1 - yv(1)*y0)/det
c
c go back and recontruct the right values for the rest of the sequence
c
do 30 i=2,nback,1
yv(i)=alpha*yv(i)+beta*yw(i)
30 continue
else
nback=1
endif
c
c set up the first two Newmann functions
c
yv(0)=y0
if(n.gt.0)then
yv(1)=y1
c
c finish off the sequence by using forward recursion
c
do 40 q=nback+1,n,1
yv(q)=dfloat(q+q-1)*yv(q-1)/z - yv(q-2)
40 continue
endif
c
return
end
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal Compiler Error
2004-11-14 2:58 ` Steve Kargl
@ 2004-11-14 3:04 ` Andrew Pinski
0 siblings, 0 replies; 25+ messages in thread
From: Andrew Pinski @ 2004-11-14 3:04 UTC (permalink / raw)
To: Steve Kargl; +Cc: fortran, Matthew Kettlewell
On Nov 13, 2004, at 9:58 PM, Steve Kargl wrote:
> On Sat, Nov 13, 2004 at 07:09:33PM -0700, Matthew Kettlewell wrote:
>>
>>
>> If this is a known issue, is this something that is actively being
>> worked,
>> or is there a known workaround?
>>
>> module test_mod
>>
>> INTEGER IPT(36)
>> INTEGER L(3,12)
>> equivalence (L,IPT)
>>
>> end module
>>
>>
>> $ gfortran test.f90
>> test.f90:0: internal compiler error: backend decl for module variable
>> ipt
>> already exists
>
> I don't recall seeing this type of problem reported. Can
> you go to http://gcc.gnu.org/ and look at the bug reports?
This is PR 17917.
Thanks,
Andrew Pinski
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal Compiler Error
2004-11-14 2:09 Internal Compiler Error Matthew Kettlewell
@ 2004-11-14 2:58 ` Steve Kargl
2004-11-14 3:04 ` Andrew Pinski
0 siblings, 1 reply; 25+ messages in thread
From: Steve Kargl @ 2004-11-14 2:58 UTC (permalink / raw)
To: Matthew Kettlewell; +Cc: fortran
On Sat, Nov 13, 2004 at 07:09:33PM -0700, Matthew Kettlewell wrote:
>
>
> If this is a known issue, is this something that is actively being worked,
> or is there a known workaround?
>
> module test_mod
>
> INTEGER IPT(36)
> INTEGER L(3,12)
> equivalence (L,IPT)
>
> end module
>
>
> $ gfortran test.f90
> test.f90:0: internal compiler error: backend decl for module variable ipt
> already exists
I don't recall seeing this type of problem reported. Can
you go to http://gcc.gnu.org/ and look at the bug reports?
Search on the keyword fortran. If you don't see a bug
report, please file one.
--
Steve
^ permalink raw reply [flat|nested] 25+ messages in thread
* Internal Compiler Error
@ 2004-11-14 2:09 Matthew Kettlewell
2004-11-14 2:58 ` Steve Kargl
0 siblings, 1 reply; 25+ messages in thread
From: Matthew Kettlewell @ 2004-11-14 2:09 UTC (permalink / raw)
To: fortran
All,
I've simplified the piece of code that is giving me an internal compiler
error down to just a few lines. Is this a known issue? I'm not a Fortran
programmer, so I really don't know a whole lot about what I'm looking at.
I'm trying to help my wife get some code compiling under gfortran that
runs on Suns Forte F90 tools.
If this is a known issue, is this something that is actively being worked,
or is there a known workaround?
Thanks
Matt
module test_mod
INTEGER IPT(36)
INTEGER L(3,12)
equivalence (L,IPT)
end module
$ gfortran test.f90
test.f90:0: internal compiler error: backend decl for module variable ipt
already exists
^ permalink raw reply [flat|nested] 25+ messages in thread
* internal compiler error
2004-11-08 10:47 bug in MODULE PROCEDURE's? Martin Reinecke
@ 2004-11-08 12:19 ` Vivek Rao
0 siblings, 0 replies; 25+ messages in thread
From: Vivek Rao @ 2004-11-08 12:19 UTC (permalink / raw)
To: fortran
If I download the Fortran codes at
http://romo661.free.fr/fastTranspose.f90 and
http://romo661.free.fr/bffft.f90 and then compile with
gfort -c -v -Wall fasttranspose.f90 bffft.f90
I trigger an internal compiler error:
C:\fortran\all>gfort -c -v -Wall fasttranspose.f90
bffft.f90
Reading specs from
/cygdrive/c/gfortran/oct_2004/irun/bin/../lib/gcc/i686-pc-cygwin/4.0.0/specs
Configured with: ../gcc-4.0-20040912/configure
--with-mpfr=/usr/local/gmp --with-gmp=/usr/local/gmp
--enable-languages=c,c++,f95 --prefix=/irun
Thread model: single
gcc version 4.0.0 20040912 (experimental)
/cygdrive/c/gfortran/oct_2004/irun/bin/../libexec/gcc/i686-pc-cygwin/4.0.0/f951.exe
fasttranspose.f90 -quiet -dumpbase fasttranspose.f90
-mtune=pentiumpro -auxbase fasttranspose -Wall
-version -o
/cygdrive/c/DOCUME~1/ADMINI~1/LOCALS~1/Temp/ccApsBCn.s
GNU F95 version 4.0.0 20040912 (experimental)
(i686-pc-cygwin)
compiled by GNU C version 3.2 20020927 (prerelease).
GGC heuristics: --param ggc-min-expand=30 --param
ggc-min-heapsize=4096
as -o fasttranspose.o
/cygdrive/c/DOCUME~1/ADMINI~1/LOCALS~1/Temp/ccApsBCn.s
/cygdrive/c/gfortran/oct_2004/irun/bin/../libexec/gcc/i686-pc-cygwin/4.0.0/f951.exe
bffft.f90 -quiet -dumpbase bffft.f90 -mtune=pentiumpro
-auxbase bffft -Wall -version -o
/cygdrive/c/DOCUME~1/ADMINI~1/LOCALS~1/Temp/ccApsBCn.s
GNU F95 version 4.0.0 20040912 (experimental)
(i686-pc-cygwin)
compiled by GNU C version 3.2 20020927 (prerelease).
GGC heuristics: --param ggc-min-expand=30 --param
ggc-min-heapsize=4096
In file bffft.f90:640
200 CONTINUE
1
Warning: Label 200 at (1) defined but not used
In file bffft.f90:442
200 CONTINUE
1
Warning: Label 200 at (1) defined but not used
bffft.f90: In function `vsinqi':
bffft.f90:2215: internal compiler error: in
gfc_finish_var_decl, at fortran/trans-decl.c:416
Please submit a full bug report,
with preprocessed source if appropriate.
See <URL:http://gcc.gnu.org/bugs.html> for
instructions.
Sorry for not simplifying the code, but it is not
mine. The code does compile with Compaq Visual
Fortran, Lahey/Fujitsu Fortran 95, and (the other)
g95.
^ permalink raw reply [flat|nested] 25+ messages in thread
* Re: Internal compiler error
2003-11-21 14:14 Erik Schnetter
@ 2003-11-24 22:32 ` Paul Brook
0 siblings, 0 replies; 25+ messages in thread
From: Paul Brook @ 2003-11-24 22:32 UTC (permalink / raw)
To: Erik Schnetter, fortran
On Friday 21 November 2003 2:14 pm, Erik Schnetter wrote:
> I receive the following internal compiler error for the enclosed
> routine:
>
> /home/eschnett/Calpha/Cactus/configs/einstein-debug-gfortran/build/
> DriftCorrect2/driftcorrect.f90:63: internal compiler error: in
> gfc_typenode_for_spec, at fortran/trans-types.c:307
Fixed.
Paul
^ permalink raw reply [flat|nested] 25+ messages in thread
* Internal compiler error
@ 2003-11-21 15:33 Erik Schnetter
0 siblings, 0 replies; 25+ messages in thread
From: Erik Schnetter @ 2003-11-21 15:33 UTC (permalink / raw)
To: fortran
[-- Attachment #1: clearsigned data --]
[-- Type: Text/Plain, Size: 957 bytes --]
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
The enclosed file gives the following internal compiler error:
/home/eschnett/Calpha/Cactus/configs/einstein-debug-gfortran/build/
TGRapparentHorizon2D/ah2d_boundary.f90:0: internal compiler error: in
gfc_typenode_for_spec, at fortran/trans-types.c:307
I used the compiler options
/home/eschnett/gcc-3.4/bin/gfortran -march=pentium3 -malign-double
- -m128bit-long-double -x f95 -g -Wall -c -o $current_wd/
ah2d_boundary.F90.o $current_wd/ah2d_boundary.f90
- -erik
- --
Erik Schnetter <schnetter@aei.mpg.de> http://www.aei.mpg.de/~eschnett/
My email is as private as my paper mail. I therefore support encrypting
and signing email messages. Get my PGP key from www.keyserver.net.
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.3 (GNU/Linux)
iD8DBQE/vjAkm3uiSwno3f0RAktIAKCf3lBC0VTaBAUYH7e3/Y0sCnyiDwCdHovN
+dVktR9wvgwyHUsw/lnsClM=
=715d
-----END PGP SIGNATURE-----
[-- Attachment #2: ah2d_boundary.f90 --]
[-- Type: text/plain, Size: 14088 bytes --]
! $Header: /arrangements/TAT/TGRapparentHorizon2D/src/ah2d_boundary.F90,v 1.4 2003/10/04 14:14:12 schnetter Exp $
module ah2d_boundary
!!$ use cactus
implicit none
INTEGER*4 fisheye_active
COMMON /cctk_params_global/fisheye_active
REAL*8 ah1_coeff
REAL*8 ah1_initial_eccentricity_x
REAL*8 ah1_initial_eccentricity_y
REAL*8 ah1_initial_eccentricity_z
REAL*8 ah1_initial_offset_x
REAL*8 ah1_initial_offset_y
REAL*8 ah1_initial_offset_z
REAL*8 ah1_initial_radius
REAL*8 ah1_invariant_radius
REAL*8 ah1_level
REAL*8 ah1_maxerr
REAL*8 ah1_position_x
REAL*8 ah1_position_y
REAL*8 ah1_position_z
REAL*8 ah2_coeff
REAL*8 ah2_initial_eccentricity_x
REAL*8 ah2_initial_eccentricity_y
REAL*8 ah2_initial_eccentricity_z
REAL*8 ah2_initial_offset_x
REAL*8 ah2_initial_offset_y
REAL*8 ah2_initial_offset_z
REAL*8 ah2_initial_radius
REAL*8 ah2_invariant_radius
REAL*8 ah2_level
REAL*8 ah2_maxerr
REAL*8 ah2_position_x
REAL*8 ah2_position_y
REAL*8 ah2_position_z
REAL*8 ah3_coeff
REAL*8 ah3_initial_eccentricity_x
REAL*8 ah3_initial_eccentricity_y
REAL*8 ah3_initial_eccentricity_z
REAL*8 ah3_initial_offset_x
REAL*8 ah3_initial_offset_y
REAL*8 ah3_initial_offset_z
REAL*8 ah3_initial_radius
REAL*8 ah3_invariant_radius
REAL*8 ah3_level
REAL*8 ah3_maxerr
REAL*8 ah3_position_x
REAL*8 ah3_position_y
REAL*8 ah3_position_z
integer*4 ah1_enforce_radius_method
integer*4 ah1_interpolator
integer*4 ah1_interpolator_options
integer*4 ah1_method
integer*4 ah1_options
integer*4 ah1_solver
integer*4 ah2_enforce_radius_method
integer*4 ah2_interpolator
integer*4 ah2_interpolator_options
integer*4 ah2_method
integer*4 ah2_options
integer*4 ah2_solver
integer*4 ah3_enforce_radius_method
integer*4 ah3_interpolator
integer*4 ah3_interpolator_options
integer*4 ah3_method
integer*4 ah3_options
integer*4 ah3_solver
INTEGER*4 ah1_locate_every
INTEGER*4 ah1_maxiter
INTEGER*4 ah1_noutinfo
INTEGER*4 ah1_symmetry_x
INTEGER*4 ah1_symmetry_y
INTEGER*4 ah1_symmetry_z
INTEGER*4 ah2_locate_every
INTEGER*4 ah2_maxiter
INTEGER*4 ah2_noutinfo
INTEGER*4 ah2_symmetry_x
INTEGER*4 ah2_symmetry_y
INTEGER*4 ah2_symmetry_z
INTEGER*4 ah3_locate_every
INTEGER*4 ah3_maxiter
INTEGER*4 ah3_noutinfo
INTEGER*4 ah3_symmetry_x
INTEGER*4 ah3_symmetry_y
INTEGER*4 ah3_symmetry_z
INTEGER*4 nphi
INTEGER*4 ntheta
INTEGER*4 num_horizons
INTEGER*4 use_old_interpolators
COMMON /TGRapparentHorizon2Drest/ah1_coeff,ah1_initial_eccentricity_x,ah&
&1_initial_eccentricity_y,ah1_initial_eccentricity_z,ah1_initial_offset_x,a&
&h1_initial_offset_y,ah1_initial_offset_z,ah1_initial_radius,ah1_invariant_&
&radius,ah1_level,ah1_maxerr,ah1_position_x,ah1_position_y,ah1_position_z,a&
&h2_coeff,ah2_initial_eccentricity_x,ah2_initial_eccentricity_y,ah2_initial&
&_eccentricity_z,ah2_initial_offset_x,ah2_initial_offset_y,ah2_initial_offs&
&et_z,ah2_initial_radius,ah2_invariant_radius,ah2_level,ah2_maxerr,ah2_posi&
&tion_x,ah2_position_y,ah2_position_z,ah3_coeff,ah3_initial_eccentricity_x,&
&ah3_initial_eccentricity_y,ah3_initial_eccentricity_z,ah3_initial_offset_x&
&,ah3_initial_offset_y,ah3_initial_offset_z,ah3_initial_radius,ah3_invarian&
&t_radius,ah3_level,ah3_maxerr,ah3_position_x,ah3_position_y,ah3_position_z&
&,ah1_enforce_radius_method,ah1_interpolator,ah1_interpolator_options,ah1_m&
ðod,ah1_options,ah1_solver,ah2_enforce_radius_method,ah2_interpolator,ah&
&2_interpolator_options,ah2_method,ah2_options,ah2_solver,ah3_enforce_radiu&
&s_method,ah3_interpolator,ah3_interpolator_options,ah3_method,ah3_options,&
&ah3_solver,ah1_locate_every,ah1_maxiter,ah1_noutinfo,ah1_symmetry_x,ah1_sy&
&mmetry_y,ah1_symmetry_z,ah2_locate_every,ah2_maxiter,ah2_noutinfo,ah2_symm&
&etry_x,ah2_symmetry_y,ah2_symmetry_z,ah3_locate_every,ah3_maxiter,ah3_nout&
&info,ah3_symmetry_x,ah3_symmetry_y,ah3_symmetry_z,nphi,ntheta,num_horizons&
&,use_old_interpolators
INTEGER*4 verbose
INTEGER*4 veryverbose
COMMON /TGRapparentHorizon2Dpriv/verbose,veryverbose
integer*4 CCTKH0
integer*4 CCTKH1
integer*4 CCTKH2
integer*4 CCTKH3
integer*4 CCTKH4
integer*4 metric_type
integer*4 CCTKH5
COMMON /ADMBASErest/CCTKH0,CCTKH1,CCTKH2,CCTKH3,CCTKH4,metric_type,CCTKH5
INTEGER*4 use_mask
COMMON /SPACEMASKrest/use_mask
private
public set_boundary
public set_boundary_complex
interface
subroutine ah2d_get_descriptors (cctkgh, gsh, lsh, lbnd, ubnd, bboxlo, bb&
&oxhi, nghostzones, symmetry_x, symmetry_y, symmetry_z)
implicit none
integer*4 cctkgh
INTEGER*4 gsh(2), lsh(2), lbnd(2), ubnd(2), bboxlo(2), bboxhi(2), n&
&ghostzones(2), symmetry_x, symmetry_y, symmetry_z
end subroutine ah2d_get_descriptors
end interface
contains
subroutine set_boundary (cctkgh, f, parity)
integer*4, intent(in) :: cctkgh
REAL*8 :: f(:,:)
integer, intent(in) :: parity
REAL*8, parameter :: poison = -42d42
INTEGER*4 :: gsh(2), lsh(2), lbnd(2), ubnd(2), bboxlo(2), bboxhi(2), nghos&
&tzones(2), symmetry_x, symmetry_y, symmetry_z
REAL*8, allocatable :: ff(:,:)
integer :: ffshape(2)
integer :: i, j, jj
integer :: ierr
if (abs(parity) /= 1) then
call CCTK_Warn(0,46,"ah2d_boundary.F90","TGRapparentHorizon2D", "Parity&
& must be +1 or -1")
end if
call ah2d_get_descriptors (cctkgh, gsh, lsh, lbnd, ubnd, bboxlo, bboxhi, n&
&ghostzones, symmetry_x, symmetry_y, symmetry_z)
if (any(nghostzones > lsh - 2*nghostzones)) then
call CCTK_Warn(0,52,"ah2d_boundary.F90","TGRapparentHorizon2D", "The gr&
&id is too small for that many ghost zones")
end if
if (symmetry_x==0 .and. symmetry_y==0 .and. mod(int(gsh(2)),2) /= 0) then
call CCTK_Warn(0,56,"ah2d_boundary.F90","TGRapparentHorizon2D", "Cannot&
& apply polar boundary condition with odd number of points in phi direction&
&")
end if
! poison f
if (bboxlo(1)/=0) f(:nghostzones(1),:) = poison
if (bboxlo(2)/=0) f(:,:nghostzones(2)) = poison
if (bboxhi(1)/=0) f(lsh(1)-nghostzones(1)+1:,:) = poison
if (bboxhi(2)/=0) f(:,lsh(2)-nghostzones(2)+1:) = poison
allocate (ff(nghostzones(1),gsh(2)))
! lower theta
call slab_transfer (ierr, cctkgh, 2,&
gsh, lbnd, lsh,&
bboxlo, bboxhi, nghostzones,&
(/nghostzones(1),0/), (/1,1/), (/nghostzones(1),gsh(2)/),&
(/nghostzones(1),gsh(2)/), (/0,0/), (/nghostzones(1),gsh(2)/),&
(/1,1/), (/1,1/), nghostzones,&
(/0,0/), (/1,1/), (/nghostzones(1),gsh(2)/),&
(/0,1/), (/0,0/),&
-1,&
107, f,&
107, ff)
if (ierr/=0) call CCTK_Warn(0,83,"ah2d_boundary.F90","TGRapparentHorizon2D&
&", "internal error")
if (bboxlo(1)/=0) then
! polar boundary condition at north pole
if (symmetry_x==0 .and. symmetry_y==0) then
do j = max(lbnd(2)+1,1), min(lbnd(2)+lsh(2),gsh(2)/2)
do i=1,nghostzones(1)
jj = j + (gsh(2)-2*nghostzones(2)) / 2
f(i,j-lbnd(2)) = parity * ff(nghostzones(1)-i+1,jj)
end do
end do
do j = max(lbnd(2)+1,gsh(2)/2+1), min(lbnd(2)+lsh(2),gsh(2))
do i=1,nghostzones(1)
jj = j - (gsh(2)-2*nghostzones(2)) / 2
f(i,j-lbnd(2)) = parity * ff(nghostzones(1)-i+1,jj)
end do
end do
else if (symmetry_x==0 .and. symmetry_y/=0) then
do j = max(lbnd(2)+1,1), min(lbnd(2)+lsh(2),gsh(2))
do i=1,nghostzones(1)
jj = gsh(2) - j + 1
f(i,j-lbnd(2)) = parity * ff(nghostzones(1)-i+1,jj)
end do
end do
else if (symmetry_x/=0 .and. symmetry_y==0) then
do j = max(lbnd(2)+1,1), min(lbnd(2)+lsh(2),gsh(2))
do i=1,nghostzones(1)
jj = gsh(2) - j + 1
f(i,j-lbnd(2)) = parity * ff(nghostzones(1)-i+1,jj)
end do
end do
else if (symmetry_x/=0 .and. symmetry_y/=0) then
do j=1,lsh(2)
do i=1,nghostzones(1)
f(i,j) = parity * f(2*nghostzones(1)-i+1,j)
end do
end do
else
call CCTK_Warn(0,121,"ah2d_boundary.F90","TGRapparentHorizon2D", "in&
&ternal error")
end if
end if
! upper theta
call slab_transfer (ierr, cctkgh, 2,&
gsh, lbnd, lsh,&
bboxlo, bboxhi, nghostzones,&
(/gsh(1)-2*nghostzones(1),0/), (/1,1/), (/nghostzones(1),gsh(2)/),&
(/nghostzones(1),gsh(2)/), (/0,0/), (/nghostzones(1),gsh(2)/),&
(/1,1/), (/1,1/), nghostzones,&
(/0,0/), (/1,1/), (/nghostzones(1),gsh(2)/),&
(/0,1/), (/0,0/),&
-1,&
107, f,&
107, ff)
if (ierr/=0) call CCTK_Warn(0,137,"ah2d_boundary.F90","TGRapparentHorizon2&
&D", "internal error")
if (bboxhi(1)/=0) then
if (symmetry_z==0) then
! polar boundary condition at south pole
if (symmetry_x==0 .and. symmetry_y==0) then
do j = max(lbnd(2)+1,1), min(lbnd(2)+lsh(2),gsh(2)/2)
do i=1,nghostzones(1)
jj = j + (gsh(2)-2*nghostzones(2)) / 2
f(lsh(1)-i+1,j-lbnd(2)) = parity * ff(i,jj)
end do
end do
do j = max(lbnd(2)+1,gsh(2)/2+1), min(lbnd(2)+lsh(2),gsh(2))
do i=1,nghostzones(1)
jj = j - (gsh(2)-2*nghostzones(2)) / 2
f(lsh(1)-i+1,j-lbnd(2)) = parity * ff(i,jj)
end do
end do
else if (symmetry_x==0 .and. symmetry_y/=0) then
do j = max(lbnd(2)+1,1), min(lbnd(2)+lsh(2),gsh(2))
do i=1,nghostzones(1)
jj = gsh(2) - j + 1
f(lsh(1)-i+1,j-lbnd(2)) = parity * ff(i,jj)
end do
end do
else if (symmetry_x/=0 .and. symmetry_y==0) then
do j = max(lbnd(2)+1,1), min(lbnd(2)+lsh(2),gsh(2))
do i=1,nghostzones(1)
jj = gsh(2) - j + 1
f(lsh(1)-i+1,j-lbnd(2)) = parity * ff(i,jj)
end do
end do
else if (symmetry_x/=0 .and. symmetry_y/=0) then
do j=1,lsh(2)
do i=1,nghostzones(1)
f(lsh(1)-i+1,j) = parity * f(lsh(1)-2*nghostzones(1)+i,j)
end do
end do
else
call CCTK_Warn(0,176,"ah2d_boundary.F90","TGRapparentHorizon2D", &
&"internal error")
end if
else
! symmetry boundary condition at equator
do j=1,lsh(2)
do i=1,nghostzones(1)
f(lsh(1)-i+1,j) = f(lsh(1)-2*nghostzones(1)+i-1,j)
end do
end do
end if
end if
deallocate (ff)
allocate (ff(lsh(1),nghostzones(2)))
! lower phi
call slab_transfer (ierr, cctkgh, 2,&
gsh, lbnd, lsh,&
bboxlo, bboxhi, nghostzones,&
(/0,gsh(2)-2*nghostzones(2)/), (/1,1/), (/gsh(1),nghostzones(2)/),&
(/gsh(1),nghostzones(2)/), (/lbnd(1),0/), (/lsh(1),nghostzones(2)/),&
(/bboxlo(1),1/), (/bboxhi(1),1/), nghostzones,&
(/0,0/), (/1,1/), (/gsh(1),nghostzones(2)/),&
(/0,1/), (/0,0/),&
-1,&
107, f,&
107, ff)
if (ierr/=0) call CCTK_Warn(0,206,"ah2d_boundary.F90","TGRapparentHorizon2&
&D", "internal error")
if (bboxlo(2)/=0) then
if (symmetry_x==0 .and. symmetry_y==0) then
! periodic boundary at null meridian
do j=1,nghostzones(2)
do i=1,lsh(1)
f(i,j) = ff(i,j)
end do
end do
else
! symmetry boundary
do j=1,nghostzones(2)
do i=1,lsh(1)
f(i,j) = f(i,2*nghostzones(2)-j+2)
end do
end do
end if
end if
! upper phi
call slab_transfer (ierr, cctkgh, 2,&
gsh, lbnd, lsh,&
bboxlo, bboxhi, nghostzones,&
(/0,nghostzones(2)/), (/1,1/), (/gsh(1),nghostzones(2)/),&
(/gsh(1),nghostzones(2)/), (/lbnd(1),0/), (/lsh(1),nghostzones(2)/),&
(/bboxlo(1),1/), (/bboxhi(1),1/), nghostzones,&
(/0,0/), (/1,1/), (/gsh(1),nghostzones(2)/),&
(/0,1/), (/0,0/),&
-1,&
107, f,&
107, ff)
if (ierr/=0) call CCTK_Warn(0,238,"ah2d_boundary.F90","TGRapparentHorizon2&
&D", "internal error")
if (bboxhi(2)/=0) then
if (symmetry_x==0 .and. symmetry_y==0) then
! periodic boundary at null meridian
do j=1,nghostzones(2)
do i=1,lsh(1)
f(i,lsh(2)-j+1) = ff(i,nghostzones(2)-j+1)
end do
end do
else
! symmetry boundary
do j=1,nghostzones(2)
do i=1,lsh(1)
f(i,lsh(2)-j+1) = f(i,lsh(2)-2*nghostzones(2)+j-1)
end do
end do
end if
end if
deallocate (ff)
end subroutine set_boundary
subroutine set_boundary_complex (cctkgh, f, parity)
integer*4, intent(in) :: cctkgh
COMPLEX*16 :: f(:,:)
integer, intent(in) :: parity
REAL*8 :: fre(size(f,1),size(f,2))
REAL*8 :: fim(size(f,1),size(f,2))
fre = real(f)
fim = aimag(f)
call set_boundary (cctkgh, fre, parity)
call set_boundary (cctkgh, fim, parity)
f = cmplx(fre, fim, kind(f))
end subroutine set_boundary_complex
end module ah2d_boundary
^ permalink raw reply [flat|nested] 25+ messages in thread
* Internal compiler error
@ 2003-11-21 14:14 Erik Schnetter
2003-11-24 22:32 ` Paul Brook
0 siblings, 1 reply; 25+ messages in thread
From: Erik Schnetter @ 2003-11-21 14:14 UTC (permalink / raw)
To: fortran
[-- Attachment #1: clearsigned data --]
[-- Type: Text/Plain, Size: 1013 bytes --]
-----BEGIN PGP SIGNED MESSAGE-----
Hash: SHA1
I receive the following internal compiler error for the enclosed
routine:
/home/eschnett/Calpha/Cactus/configs/einstein-debug-gfortran/build/
DriftCorrect2/driftcorrect.f90:63: internal compiler error: in
gfc_typenode_for_spec, at fortran/trans-types.c:307
This is on an i386 with the compiler options
/home/eschnett/gcc-3.4/bin/gfortran -march=pentium3 -malign-double
- -m128bit-long-double -x f95 -g -Wall -c -o $current_wd/
driftcorrect.F90.o $current_wd/driftcorrect.f90
with a checkout from yesterday.
- -erik
- --
Erik Schnetter <schnetter@aei.mpg.de> http://www.aei.mpg.de/~eschnett/
My email is as private as my paper mail. I therefore support encrypting
and signing email messages. Get my PGP key from www.keyserver.net.
-----BEGIN PGP SIGNATURE-----
Version: GnuPG v1.2.3 (GNU/Linux)
iD8DBQE/vh3Wm3uiSwno3f0RAq3AAJ4+WsLZQcttKtOx3rrr2UB1Y8KQngCfbGNU
uoWhUBvHlsRK1VbUew6B+7A=
=kAfW
-----END PGP SIGNATURE-----
[-- Attachment #2: driftcorrect.f90 --]
[-- Type: text/plain, Size: 27132 bytes --]
! $Header: /numrelcvs/SchnetterCVS/DriftCorrect2/src/driftcorrect.F90,v 1.1 2003/11/17 16:39:04 schnetter Exp $
function dc2_metric_value (rad) result (grr)
implicit none
INTEGER*4 fisheye_active
COMMON /cctk_params_global/fisheye_active
REAL*8 correction_width
REAL*8 dipole_factor
REAL*8 grr_factor
REAL*8 grr_offset
REAL*8 monopole_factor
REAL*8 position(3)
REAL*8 predictor_coeff
REAL*8 quadrupole_factor
INTEGER*4 grr_exponent
INTEGER*4 verbose
COMMON /DriftCorrect2priv/correction_width,dipole_factor,grr_factor,grr_&
&offset,monopole_factor,position,predictor_coeff,quadrupole_factor,grr_expo&
&nent,verbose
integer*4 CCTKH0
integer*4 CCTKH1
integer*4 CCTKH2
integer*4 CCTKH3
integer*4 CCTKH4
integer*4 metric_type
integer*4 CCTKH5
COMMON /ADMBASErest/CCTKH0,CCTKH1,CCTKH2,CCTKH3,CCTKH4,metric_type,CCTKH5
INTEGER*4 use_mask
COMMON /SPACEMASKrest/use_mask
REAL*8 :: grr
REAL*8 :: rad
grr = grr_offset + grr_factor * rad ** grr_exponent
end function dc2_metric_value
subroutine dc2_init_drift (cctk_dim, cctk_gsh, cctk_lsh, cctk_lbnd, &
& cctk_ubnd, cctk_lssh, cctk_from, cctk_to, cctk_bbox, &
& cctk_delta_time, cctk_time, cctk_delta_space, &
& cctk_origin_space, cctk_levfac, &
&cctk_levoff, cctk_levoffdenom, cctk_timefac, cct&
&k_convlevel, cctk_nghostzones, cctk_iteration, cc&
&tkGH, Xdc2_dipole_difference0,Xdc2_quadrupole_difference0,Xdc2_quadrupole_&
&difference1,dc2_difference_is_valid,dc2_dipole_difference,dc2_monopole_dif&
&ference,dc2_quadrupole_difference, Xconfac0,Xconfac1,Xconfac2,Xconfac_1der&
&ivs0,Xconfac_1derivs1,Xconfac_1derivs2,Xconfac_2derivs0,Xconfac_2derivs1,X&
&confac_2derivs2,Xcoordinates0,Xcoordinates1,Xcoordinates2,Xcurv0,Xcurv1,Xc&
&urv2,Xlapse0,Xlapse1,Xlapse2,Xmask0,Xmask1,Xmask2,Xmetric0,Xmetric1,Xmetri&
&c2,Xshift0,Xshift1,Xshift2,Xspace_mask_group0,Xspace_mask_group1,Xspace_ma&
&sk_group2,alp,alp_p,alp_p_p,betax,betax_p,betax_p_p,betay,betay_p,betay_p_&
&p,betaz,betaz_p,betaz_p_p,coarse_dx,coarse_dy,coarse_dz,conformal_state,em&
&ask,gxx,gxx_p,gxx_p_p,gxy,gxy_p,gxy_p_p,gxz,gxz_p,gxz_p_p,gyy,gyy_p,gyy_p_&
&p,gyz,gyz_p,gyz_p_p,gzz,gzz_p,gzz_p_p,kxx,kxx_p,kxx_p_p,kxy,kxy_p,kxy_p_p,&
&kxz,kxz_p,kxz_p_p,kyy,kyy_p,kyy_p_p,kyz,kyz_p,kyz_p_p,kzz,kzz_p,kzz_p_p,ps&
&i,psix,psixx,psixy,psixz,psiy,psiyy,psiyz,psiz,psizz,r,shift_state,space_m&
&ask,x,y,z)
implicit none
INTEGER cctk_dim
INTEGER cctk_gsh(cctk_dim),cctk_lsh(cctk_dim)
INTEGER cctk_lbnd(cctk_dim),cctk_ubnd(cctk_dim)
INTEGER cctk_lssh(3*cctk_dim)
INTEGER cctk_from(cctk_dim),cctk_to(cctk_dim)
INTEGER cctk_bbox(2*cctk_dim)
REAL*8 cctk_delta_time, cctk_time
REAL*8 cctk_delta_space(cctk_dim)
REAL*8 cctk_origin_space(cctk_dim)
INTEGER cctk_levfac(cctk_dim)
INTEGER cctk_levoff(cctk_dim)
INTEGER cctk_levoffdenom(cctk_dim)
INTEGER cctk_timefac
INTEGER cctk_convlevel
INTEGER cctk_nghostzones(cctk_dim)
INTEGER cctk_iteration
integer*4 cctkGH
INTEGER Xdc2_dipole_difference0
INTEGER Xdc2_quadrupole_difference0
INTEGER Xdc2_quadrupole_difference1
INTEGER*4 dc2_difference_is_valid
REAL*8 dc2_dipole_difference(Xdc2_dipole_difference0)
REAL*8 dc2_monopole_difference
REAL*8 dc2_quadrupole_difference(Xdc2_quadrupole_difference0,Xdc2_quadru&
&pole_difference1)
INTEGER Xconfac0
INTEGER Xconfac1
INTEGER Xconfac2
INTEGER Xconfac_1derivs0
INTEGER Xconfac_1derivs1
INTEGER Xconfac_1derivs2
INTEGER Xconfac_2derivs0
INTEGER Xconfac_2derivs1
INTEGER Xconfac_2derivs2
INTEGER Xcoordinates0
INTEGER Xcoordinates1
INTEGER Xcoordinates2
INTEGER Xcurv0
INTEGER Xcurv1
INTEGER Xcurv2
INTEGER Xlapse0
INTEGER Xlapse1
INTEGER Xlapse2
INTEGER Xmask0
INTEGER Xmask1
INTEGER Xmask2
INTEGER Xmetric0
INTEGER Xmetric1
INTEGER Xmetric2
INTEGER Xshift0
INTEGER Xshift1
INTEGER Xshift2
INTEGER Xspace_mask_group0
INTEGER Xspace_mask_group1
INTEGER Xspace_mask_group2
REAL*8 alp(Xlapse0,Xlapse1,Xlapse2)
REAL*8 alp_p(Xlapse0,Xlapse1,Xlapse2)
REAL*8 alp_p_p(Xlapse0,Xlapse1,Xlapse2)
REAL*8 betax(Xshift0,Xshift1,Xshift2)
REAL*8 betax_p(Xshift0,Xshift1,Xshift2)
REAL*8 betax_p_p(Xshift0,Xshift1,Xshift2)
REAL*8 betay(Xshift0,Xshift1,Xshift2)
REAL*8 betay_p(Xshift0,Xshift1,Xshift2)
REAL*8 betay_p_p(Xshift0,Xshift1,Xshift2)
REAL*8 betaz(Xshift0,Xshift1,Xshift2)
REAL*8 betaz_p(Xshift0,Xshift1,Xshift2)
REAL*8 betaz_p_p(Xshift0,Xshift1,Xshift2)
REAL*8 coarse_dx
REAL*8 coarse_dy
REAL*8 coarse_dz
INTEGER*4 conformal_state
REAL*8 emask(Xmask0,Xmask1,Xmask2)
REAL*8 gxx(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxx_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxx_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxy(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxy_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxy_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxz(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxz_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxz_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyy(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyy_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyy_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyz(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyz_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyz_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gzz(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gzz_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gzz_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 kxx(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxx_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxx_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxy(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxy_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxy_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxz(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxz_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxz_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyy(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyy_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyy_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyz(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyz_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyz_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kzz(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kzz_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kzz_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 psi(Xconfac0,Xconfac1,Xconfac2)
REAL*8 psix(Xconfac_1derivs0,Xconfac_1derivs1,Xconfac_1derivs2)
REAL*8 psixx(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psixy(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psixz(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psiy(Xconfac_1derivs0,Xconfac_1derivs1,Xconfac_1derivs2)
REAL*8 psiyy(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psiyz(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psiz(Xconfac_1derivs0,Xconfac_1derivs1,Xconfac_1derivs2)
REAL*8 psizz(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 r(Xcoordinates0,Xcoordinates1,Xcoordinates2)
INTEGER*4 shift_state
INTEGER*4 space_mask(Xspace_mask_group0,Xspace_mask_group1,Xspace_mask_g&
&roup2)
REAL*8 x(Xcoordinates0,Xcoordinates1,Xcoordinates2)
REAL*8 y(Xcoordinates0,Xcoordinates1,Xcoordinates2)
REAL*8 z(Xcoordinates0,Xcoordinates1,Xcoordinates2)
INTEGER*4 fisheye_active
COMMON /cctk_params_global/fisheye_active
REAL*8 correction_width
REAL*8 dipole_factor
REAL*8 grr_factor
REAL*8 grr_offset
REAL*8 monopole_factor
REAL*8 position(3)
REAL*8 predictor_coeff
REAL*8 quadrupole_factor
INTEGER*4 grr_exponent
INTEGER*4 verbose
COMMON /DriftCorrect2priv/correction_width,dipole_factor,grr_factor,grr_&
&offset,monopole_factor,position,predictor_coeff,quadrupole_factor,grr_expo&
&nent,verbose
integer*4 CCTKH0
integer*4 CCTKH1
integer*4 CCTKH2
integer*4 CCTKH3
integer*4 CCTKH4
integer*4 metric_type
integer*4 CCTKH5
COMMON /ADMBASErest/CCTKH0,CCTKH1,CCTKH2,CCTKH3,CCTKH4,metric_type,CCTKH5
INTEGER*4 use_mask
COMMON /SPACEMASKrest/use_mask
dc2_difference_is_valid = 0
dc2_monopole_difference = 0
dc2_dipole_difference = 0
dc2_quadrupole_difference = 0
end subroutine dc2_init_drift
subroutine dc2_correct_drift (cctk_dim, cctk_gsh, cctk_lsh, cctk_lbnd, &
& cctk_ubnd, cctk_lssh, cctk_from, cctk_to, cctk_bbox, &
& cctk_delta_time, cctk_time, cctk_delta_space, &
& cctk_origin_space, cctk_levfac, &
& cctk_levoff, cctk_levoffdenom, cctk_timefac, &
&cctk_convlevel, cctk_nghostzones, cctk_iteration,&
& cctkGH, Xdc2_dipole_difference0,Xdc2_quadrupole_difference0,Xdc2_quadrupo&
&le_difference1,dc2_difference_is_valid,dc2_dipole_difference,dc2_monopole_&
&difference,dc2_quadrupole_difference, Xconfac0,Xconfac1,Xconfac2,Xconfac_1&
&derivs0,Xconfac_1derivs1,Xconfac_1derivs2,Xconfac_2derivs0,Xconfac_2derivs&
&1,Xconfac_2derivs2,Xcoordinates0,Xcoordinates1,Xcoordinates2,Xcurv0,Xcurv1&
&,Xcurv2,Xlapse0,Xlapse1,Xlapse2,Xmask0,Xmask1,Xmask2,Xmetric0,Xmetric1,Xme&
&tric2,Xshift0,Xshift1,Xshift2,Xspace_mask_group0,Xspace_mask_group1,Xspace&
&_mask_group2,alp,alp_p,alp_p_p,betax,betax_p,betax_p_p,betay,betay_p,betay&
&_p_p,betaz,betaz_p,betaz_p_p,coarse_dx,coarse_dy,coarse_dz,conformal_state&
&,emask,gxx,gxx_p,gxx_p_p,gxy,gxy_p,gxy_p_p,gxz,gxz_p,gxz_p_p,gyy,gyy_p,gyy&
&_p_p,gyz,gyz_p,gyz_p_p,gzz,gzz_p,gzz_p_p,kxx,kxx_p,kxx_p_p,kxy,kxy_p,kxy_p&
&_p,kxz,kxz_p,kxz_p_p,kyy,kyy_p,kyy_p_p,kyz,kyz_p,kyz_p_p,kzz,kzz_p,kzz_p_p&
&,psi,psix,psixx,psixy,psixz,psiy,psiyy,psiyz,psiz,psizz,r,shift_state,spac&
&e_mask,x,y,z)
implicit none
INTEGER cctk_dim
INTEGER cctk_gsh(cctk_dim),cctk_lsh(cctk_dim)
INTEGER cctk_lbnd(cctk_dim),cctk_ubnd(cctk_dim)
INTEGER cctk_lssh(3*cctk_dim)
INTEGER cctk_from(cctk_dim),cctk_to(cctk_dim)
INTEGER cctk_bbox(2*cctk_dim)
REAL*8 cctk_delta_time, cctk_time
REAL*8 cctk_delta_space(cctk_dim)
REAL*8 cctk_origin_space(cctk_dim)
INTEGER cctk_levfac(cctk_dim)
INTEGER cctk_levoff(cctk_dim)
INTEGER cctk_levoffdenom(cctk_dim)
INTEGER cctk_timefac
INTEGER cctk_convlevel
INTEGER cctk_nghostzones(cctk_dim)
INTEGER cctk_iteration
integer*4 cctkGH
INTEGER Xdc2_dipole_difference0
INTEGER Xdc2_quadrupole_difference0
INTEGER Xdc2_quadrupole_difference1
INTEGER*4 dc2_difference_is_valid
REAL*8 dc2_dipole_difference(Xdc2_dipole_difference0)
REAL*8 dc2_monopole_difference
REAL*8 dc2_quadrupole_difference(Xdc2_quadrupole_difference0,Xdc2_quadru&
&pole_difference1)
INTEGER Xconfac0
INTEGER Xconfac1
INTEGER Xconfac2
INTEGER Xconfac_1derivs0
INTEGER Xconfac_1derivs1
INTEGER Xconfac_1derivs2
INTEGER Xconfac_2derivs0
INTEGER Xconfac_2derivs1
INTEGER Xconfac_2derivs2
INTEGER Xcoordinates0
INTEGER Xcoordinates1
INTEGER Xcoordinates2
INTEGER Xcurv0
INTEGER Xcurv1
INTEGER Xcurv2
INTEGER Xlapse0
INTEGER Xlapse1
INTEGER Xlapse2
INTEGER Xmask0
INTEGER Xmask1
INTEGER Xmask2
INTEGER Xmetric0
INTEGER Xmetric1
INTEGER Xmetric2
INTEGER Xshift0
INTEGER Xshift1
INTEGER Xshift2
INTEGER Xspace_mask_group0
INTEGER Xspace_mask_group1
INTEGER Xspace_mask_group2
REAL*8 alp(Xlapse0,Xlapse1,Xlapse2)
REAL*8 alp_p(Xlapse0,Xlapse1,Xlapse2)
REAL*8 alp_p_p(Xlapse0,Xlapse1,Xlapse2)
REAL*8 betax(Xshift0,Xshift1,Xshift2)
REAL*8 betax_p(Xshift0,Xshift1,Xshift2)
REAL*8 betax_p_p(Xshift0,Xshift1,Xshift2)
REAL*8 betay(Xshift0,Xshift1,Xshift2)
REAL*8 betay_p(Xshift0,Xshift1,Xshift2)
REAL*8 betay_p_p(Xshift0,Xshift1,Xshift2)
REAL*8 betaz(Xshift0,Xshift1,Xshift2)
REAL*8 betaz_p(Xshift0,Xshift1,Xshift2)
REAL*8 betaz_p_p(Xshift0,Xshift1,Xshift2)
REAL*8 coarse_dx
REAL*8 coarse_dy
REAL*8 coarse_dz
INTEGER*4 conformal_state
REAL*8 emask(Xmask0,Xmask1,Xmask2)
REAL*8 gxx(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxx_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxx_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxy(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxy_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxy_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxz(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxz_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gxz_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyy(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyy_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyy_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyz(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyz_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gyz_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gzz(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gzz_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 gzz_p_p(Xmetric0,Xmetric1,Xmetric2)
REAL*8 kxx(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxx_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxx_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxy(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxy_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxy_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxz(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxz_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kxz_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyy(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyy_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyy_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyz(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyz_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kyz_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kzz(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kzz_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 kzz_p_p(Xcurv0,Xcurv1,Xcurv2)
REAL*8 psi(Xconfac0,Xconfac1,Xconfac2)
REAL*8 psix(Xconfac_1derivs0,Xconfac_1derivs1,Xconfac_1derivs2)
REAL*8 psixx(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psixy(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psixz(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psiy(Xconfac_1derivs0,Xconfac_1derivs1,Xconfac_1derivs2)
REAL*8 psiyy(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psiyz(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 psiz(Xconfac_1derivs0,Xconfac_1derivs1,Xconfac_1derivs2)
REAL*8 psizz(Xconfac_2derivs0,Xconfac_2derivs1,Xconfac_2derivs2)
REAL*8 r(Xcoordinates0,Xcoordinates1,Xcoordinates2)
INTEGER*4 shift_state
INTEGER*4 space_mask(Xspace_mask_group0,Xspace_mask_group1,Xspace_mask_g&
&roup2)
REAL*8 x(Xcoordinates0,Xcoordinates1,Xcoordinates2)
REAL*8 y(Xcoordinates0,Xcoordinates1,Xcoordinates2)
REAL*8 z(Xcoordinates0,Xcoordinates1,Xcoordinates2)
integer CCTK_Equals, CCTK_MyProc, CCTK_nProcs, CCTK_IsThornActive
external CCTK_Equals, CCTK_MyProc, CCTK_nProcs, CCTK_IsThornActive
integer*4 CCTK_PointerTo, CCTK_NullPointer
external CCTK_PointerTo, CCTK_NullPointer
INTEGER*4 fisheye_active
COMMON /cctk_params_global/fisheye_active
REAL*8 correction_width
REAL*8 dipole_factor
REAL*8 grr_factor
REAL*8 grr_offset
REAL*8 monopole_factor
REAL*8 position(3)
REAL*8 predictor_coeff
REAL*8 quadrupole_factor
INTEGER*4 grr_exponent
INTEGER*4 verbose
COMMON /DriftCorrect2priv/correction_width,dipole_factor,grr_factor,grr_&
&offset,monopole_factor,position,predictor_coeff,quadrupole_factor,grr_expo&
&nent,verbose
integer*4 CCTKH0
integer*4 CCTKH1
integer*4 CCTKH2
integer*4 CCTKH3
integer*4 CCTKH4
integer*4 metric_type
integer*4 CCTKH5
COMMON /ADMBASErest/CCTKH0,CCTKH1,CCTKH2,CCTKH3,CCTKH4,metric_type,CCTKH5
INTEGER*4 use_mask
COMMON /SPACEMASKrest/use_mask
REAL*8, parameter :: one=1, half=one/2
REAL*8, parameter :: eps = 1.0e-8
integer, parameter :: facefact(2) = (/ -1, +1 /)
REAL*8 :: dt
integer :: sym(2,3)
integer :: iposition(3)
integer :: iposlocal(3)
integer :: ebndind(3,2,3)
INTEGER*4 :: itmploc(2,3), itmpglo(2,3)
REAL*8 :: rad_current(2,3)
REAL*8 :: grr_current(2,3)
REAL*8 :: grr_desired(2,3)
logical :: have_point(2,3)
REAL*8 :: tmploc(2,3,4), tmpglo(2,3,4)
INTEGER*4 :: difference_was_valid
REAL*8 :: old_monopole_difference
REAL*8 :: old_dipole_difference(3)
REAL*8 :: old_quadrupole_difference(3,3)
REAL*8 :: monopole_coeff
REAL*8 :: dipole_coeff(3)
REAL*8 :: quadrupole_coeff(3,3)
integer :: f, d
integer :: i, j, k
REAL*8 :: xpos(3)
REAL*8 :: rad
REAL*8 :: nn(3)
REAL*8 :: attenuation
REAL*8 :: correction(3)
character :: msg*1000
integer :: min_handle, sum_handle
integer :: ierr
interface
function dc2_metric_value (rad) result (grr)
implicit none
REAL*8 :: grr
REAL*8 :: rad
end function dc2_metric_value
end interface
! emask conventions:
! 0 is excised
! 1 is active
! 0.5 is boundary
logical :: isactive
isactive(i,j,k) = abs(emask(i,j,k) - 1) < 0.001
!!$ isactive(i,j,k) = emask(i,j,k) == 1
dt = (cctk_delta_time/cctk_timefac)
iposition(:) = floor((position(:) - (cctk_origin_space(:)+cctk_delta_space(:&
&)/cctk_levfac(:)*cctk_levoff(:)/cctk_levoffdenom(:))) / (cctk_delta_space(&
&:)/cctk_levfac(:)) + half) + 1
iposlocal(:) = iposition(:) - cctk_lbnd(:)
if (verbose/=0) then
write (msg, '("Black hole at (i,j,k) = (",i4,",",i4,",",i4,")")') ipositi&
&on(:)
call CCTK_Info("DriftCorrect2",(trim(msg)))
i = iposition(1)
j = iposition(2)
k = iposition(3)
write (msg, '("Black hole at (x,y,z) = (",g16.6,",",g16.6,",",g16.6,")")'&
&) x(i,j,k), y(i,j,k), z(i,j,k)
call CCTK_Info("DriftCorrect2",(trim(msg)))
end if
! Find excision mask boundary
ebndind(:,:,:) = 0
do k = 1 + cctk_nghostzones(3), cctk_lsh(3) - cctk_nghostzones(3)
do j = 1 + cctk_nghostzones(2), cctk_lsh(2) - cctk_nghostzones(2)
do i = 1 + cctk_nghostzones(1), cctk_lsh(1) - cctk_nghostzones(1)
if (isactive(i,j,k)) then
if (all((/i,j,k/) == iposlocal(:))) then
call CCTK_Warn(0,129,"driftcorrect.F90","DriftCorrect2", "Bla&
&ck hole position is not excised")
end if
if (i <= iposlocal(1) .and. j == iposlocal(2) .and. k == iposloc&
&al(3) .and. .not. isactive(i+1,j,k)) ebndind(:,1,1) = cctk_lbnd(:) + (/ i,&
&j,k /)
if (i >= iposlocal(1) .and. j == iposlocal(2) .and. k == iposloc&
&al(3) .and. .not. isactive(i-1,j,k)) ebndind(:,2,1) = cctk_lbnd(:) + (/ i,&
&j,k /)
if (i == iposlocal(1) .and. j <= iposlocal(2) .and. k == iposloc&
&al(3) .and. .not. isactive(i,j+1,k)) ebndind(:,1,2) = cctk_lbnd(:) + (/ i,&
&j,k /)
if (i == iposlocal(1) .and. j >= iposlocal(2) .and. k == iposloc&
&al(3) .and. .not. isactive(i,j-1,k)) ebndind(:,2,2) = cctk_lbnd(:) + (/ i,&
&j,k /)
if (i == iposlocal(1) .and. j == iposlocal(2) .and. k <= iposloc&
&al(3) .and. .not. isactive(i,j,k+1)) ebndind(:,1,3) = cctk_lbnd(:) + (/ i,&
&j,k /)
if (i == iposlocal(1) .and. j == iposlocal(2) .and. k >= iposloc&
&al(3) .and. .not. isactive(i,j,k-1)) ebndind(:,2,3) = cctk_lbnd(:) + (/ i,&
&j,k /)
end if
end do
end do
end do
do d = 1, 3
do f = 1, 2
if (ebndind(d,f,d) == 0) then
itmploc(f,d) = 1000*1000*1000
else
itmploc(f,d) = ebndind(d,f,d)
if (f==1) itmploc(f,d) = -itmploc(f,d)
end if
end do
end do
call CCTK_ReductionArrayHandle (min_handle, "minimum")
if (min_handle<0) call CCTK_Warn(0,156,"driftcorrect.F90","DriftCorrect2", "&
&Could not obtain reduction handle")
call CCTK_ReduceLocArrayToArray1D (ierr, cctkGH, -1, min_handle,&
itmploc, itmpglo, size(itmpglo), 102)
if (ierr<0) call CCTK_Warn(0,159,"driftcorrect.F90","DriftCorrect2", "Could &
¬ reduce")
do d = 1, 3
do f = 1, 2
if (itmpglo(f,d) == 1000*1000*1000) then
ebndind(:,f,d) = 0
else
if (f==1) itmpglo(f,d) = -itmpglo(f,d)
ebndind(:,f,d) = iposition(:)
ebndind(d,f,d) = itmpglo(f,d)
end if
end do
end do
if (verbose/=0) then
write (msg, '("Excision boundary is at (i,j,k) (-,+) ((",i4,",",i4,"), ("&
&,i4,",",i4,"), (",i4,",",i4,"))")') ebndind(1,:,1), ebndind(2,:,2), ebndin&
&d(3,:,3)
call CCTK_Info("DriftCorrect2",(trim(msg)))
end if
call DecodeSymParameters3D (sym)
if (any(ebndind(1,1,:) == 0 .and. sym(1,:) == 0)) then
call CCTK_Warn(0,180,"driftcorrect.F90","DriftCorrect2", "internal error")
end if
if (any(ebndind(1,2,:) == 0)) then
call CCTK_Warn(0,183,"driftcorrect.F90","DriftCorrect2", "internal error")
end if
! Find current and desired metric values
rad_current(:,:) = 0
grr_current(:,:) = 0
grr_desired(:,:) = 0
have_point(:,:) = .false.
do d = 1, 3 ! x, y, z direction
do f = 1, 2 ! lower, upper face
if (ebndind(1,f,d) /= 0) then
if (all(ebndind(:,f,d)>=cctk_lbnd(:)+cctk_nghostzones(:)+1&
.and. ebndind(:,f,d)<=cctk_ubnd(:)+1-cctk_nghostzones(:))) then
i = ebndind(1,f,d) - cctk_lbnd(1)
j = ebndind(2,f,d) - cctk_lbnd(2)
k = ebndind(3,f,d) - cctk_lbnd(3)
xpos(1) = x(i,j,k) - position(1)
xpos(2) = y(i,j,k) - position(2)
xpos(3) = z(i,j,k) - position(3)
rad = sqrt(sum(xpos**2))
rad_current(f,d) = rad
select case (d)
case (1)
grr_current(f,d) = gxx(i,j,k)
case (2)
grr_current(f,d) = gyy(i,j,k)
case (3)
grr_current(f,d) = gzz(i,j,k)
case default
call CCTK_Warn(0,221,"driftcorrect.F90","DriftCorrect2", "int&
&ernal error")
end select
grr_desired(f,d) = dc2_metric_value (rad)
have_point(f,d) = .true.
end if
end if
end do
end do
call CCTK_ReductionArrayHandle (sum_handle, "sum")
if (sum_handle<0) call CCTK_Warn(0,235,"driftcorrect.F90","DriftCorrect2", "&
&Could not obtain reduction handle")
tmploc(:,:,1) = rad_current(:,:)
tmploc(:,:,2) = grr_current(:,:)
tmploc(:,:,3) = grr_desired(:,:)
forall (f=1:2, d=1:3)
tmploc(f,d,4) = count((/have_point(f,d)/))
end forall
call CCTK_ReduceLocArrayToArray1D (ierr, cctkGH, -1, sum_handle,&
tmploc, tmpglo, size(tmpglo), 107)
if (ierr<0) call CCTK_Warn(0,244,"driftcorrect.F90","DriftCorrect2", "Could &
¬ reduce")
rad_current(:,:) = tmpglo(:,:,1)
grr_current(:,:) = tmpglo(:,:,2)
grr_desired(:,:) = tmpglo(:,:,3)
have_point(:,:) = abs(tmpglo(:,:,4)-1) < 0.01
if (.not. all(have_point(:,:) .or. sym(:,:)/=0)) call CCTK_Warn(0,249,"drift&
&correct.F90","DriftCorrect2", "internal error")
do d = 1, 3
if (sym(1,d) /= 0) then
rad_current(1,d) = rad_current(2,d)
grr_current(1,d) = grr_current(2,d)
grr_desired(1,d) = grr_desired(2,d)
end if
end do
if (verbose/=0) then
write (msg, '("current r : ", 6g16.6)') rad_current
call CCTK_Info("DriftCorrect2",(trim(msg)))
write (msg, '("current g_rr: ", 6g16.6)') grr_current
call CCTK_Info("DriftCorrect2",(trim(msg)))
write (msg, '("desired g_rr: ", 6g16.6)') grr_desired
call CCTK_Info("DriftCorrect2",(trim(msg)))
end if
! Determine correction
! The correction has three parts, which are similar to multipoles:
! A monopole part, a dipole part, and a part similar to a quadrupole.
if (dc2_difference_is_valid /= 0) then
old_monopole_difference = dc2_monopole_difference
old_dipole_difference = dc2_dipole_difference
old_quadrupole_difference = dc2_quadrupole_difference
end if
dc2_monopole_difference = sum(grr_current(:,:) - grr_desired(:,:))
forall (d=1:3)
dc2_dipole_difference(d) = sum(facefact(:) * (grr_current(:,d) - grr_desi&
&red(:,d)))
end forall
dc2_quadrupole_difference(:,:) = 0
forall (d=1:3)
dc2_quadrupole_difference(d,d)&
= sum(grr_current(:,d) - grr_desired(:,d))&
& - dc2_monopole_difference / 3
end forall
if (dc2_difference_is_valid == 0) then
old_monopole_difference = dc2_monopole_difference
old_dipole_difference = dc2_dipole_difference
old_quadrupole_difference = dc2_quadrupole_difference
end if
dc2_difference_is_valid = 1
write (msg, '("monopole difference: ",g16.6)') dc2_monopole_difference
call CCTK_Info("DriftCorrect2",(trim(msg)))
write (msg, '("dipole difference: ",3g16.6)') dc2_dipole_difference
call CCTK_Info("DriftCorrect2",(trim(msg)))
write (msg, '("quadrupole difference: ",9g16.6)') dc2_quadrupole_difference
call CCTK_Info("DriftCorrect2",(trim(msg)))
monopole_coeff = monopole_factor&
& * ((1 + predictor_coeff) * dc2_monopole_difference&
& - predictor_coeff * old_monopole_difference )
dipole_coeff(:) = dipole_factor&
& * ((1 + predictor_coeff) * dc2_dipole_difference(:)&
& - predictor_coeff * old_dipole_difference(:) )
quadrupole_coeff(:,:) = quadrupole_factor&
& * ((1 + predictor_coeff) * dc2_quadrupole_difference(:,:)&
& - predictor_coeff * old_quadrupole_difference(:,:))
! Apply correction
do k = 1, cctk_lsh(3)
do j = 1, cctk_lsh(2)
do i = 1, cctk_lsh(1)
xpos(1) = (x(i,j,k) - position(1)) / correction_width
xpos(2) = (y(i,j,k) - position(2)) / correction_width
xpos(3) = (z(i,j,k) - position(3)) / correction_width
rad = sqrt(sum(xpos**2))
nn(:) = xpos(:) / (rad + eps)
attenuation = exp (- rad**2)
forall (d=1:3)
correction(d) =&
+ monopole_coeff * nn(d)&
+ dipole_coeff(d)&
+ quadrupole_coeff(d,d) * nn(d)
end forall
correction(:) = correction(:) * attenuation / dt
betax(i,j,k) = betax(i,j,k) + correction(1)
betay(i,j,k) = betay(i,j,k) + correction(2)
betaz(i,j,k) = betaz(i,j,k) + correction(3)
end do
end do
end do
end subroutine dc2_correct_drift
^ permalink raw reply [flat|nested] 25+ messages in thread
end of thread, other threads:[~2018-01-14 5:19 UTC | newest]
Thread overview: 25+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2018-01-14 4:09 Internal compiler error William Clodius
2018-01-14 5:19 ` Steve Kargl
-- strict thread matches above, loose matches on Subject: below --
2011-07-09 19:02 Daniel Carrera
2011-07-09 19:41 ` Daniel Carrera
2011-07-09 19:46 ` Tobias Burnus
2011-07-09 20:02 ` Daniel Carrera
2011-07-09 21:22 ` Tobias Burnus
2009-11-06 4:26 internal " Hans Horn
2009-11-06 8:35 ` Thomas Koenig
2007-07-02 9:02 Virginie Trinite
2007-07-02 9:19 ` FX Coudert
2006-07-11 14:34 [Patch, fortran] PR20893 - unconditional use of optional argument not detected Paul Thomas
2006-07-14 17:34 ` Paul Thomas
2006-07-14 18:00 ` Internal Compiler Error Ray Nachlinger
2006-07-14 20:00 ` Paul Thomas
2006-07-14 20:05 ` Steve Kargl
2006-06-24 21:01 internal compiler error Ron Young
2006-06-24 21:27 ` Steve Kargl
2006-06-24 21:34 ` Steve Kargl
2006-06-24 21:41 ` FX Coudert
2004-11-14 2:09 Internal Compiler Error Matthew Kettlewell
2004-11-14 2:58 ` Steve Kargl
2004-11-14 3:04 ` Andrew Pinski
2004-11-08 10:47 bug in MODULE PROCEDURE's? Martin Reinecke
2004-11-08 12:19 ` internal compiler error Vivek Rao
2003-11-21 15:33 Internal " Erik Schnetter
2003-11-21 14:14 Erik Schnetter
2003-11-24 22:32 ` Paul Brook
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).