Backport PRs 41750, 41841, 41907, 41919, 41926, 41928, 41935, 42055
2009-11-20 H.J. Lu <hongjiu.lu@intel.com> Backport from mainline: 2009-11-18 Alexandre Oliva <aoliva@redhat.com> PR debug/41926 * gcc.dg/vect/vect-debug-pr41926.c: New. 2009-11-16 Paolo Carlini <paolo.carlini@oracle.com> PR c++/42055 * g++.dg/template/crash92.C: New. 2009-11-08 Richard Guenther <rguenther@suse.de> PR rtl-optimization/41928 * gfortran.dg/pr41928.f90: New testcase. 2009-11-06 Jakub Jelinek <jakub@redhat.com> PR middle-end/41935 * gcc.dg/pr41935.c: New test. * c-c++-common/pr41935.c: New test. * gcc.c-torture/execute/pr41935.c: New test. 2009-11-04 Richard Guenther <rguenther@suse.de> PR tree-optimization/41919 * gcc.c-torture/execute/pr41919.c: New testcase. 2009-11-03 Tobias Burnus <burnus@net-b.de> PR fortran/41907 * gfortran.dg/missing_optional_dummy_6.f90: New test. 2009-11-02 Martin Jambor <mjambor@suse.cz> PR tree-optimization/41750 * gcc.c-torture/execute/pr41750.c: New test. 2009-11-02 Jakub Jelinek <jakub@redhat.com> PR tree-optimization/41841 * gcc.dg/pr41841.c: New test. From-SVN: r154366
This commit is contained in:
H.J. Lu
H.J. Lu
parent
3330318df3
commit
1ffc418056
|
|
@ -1,3 +1,48 @@
|
|||
2009-11-20 H.J. Lu <hongjiu.lu@intel.com>
|
||||
|
||||
Backport from mainline:
|
||||
2009-11-18 Alexandre Oliva <aoliva@redhat.com>
|
||||
|
||||
PR debug/41926
|
||||
* gcc.dg/vect/vect-debug-pr41926.c: New.
|
||||
|
||||
2009-11-16 Paolo Carlini <paolo.carlini@oracle.com>
|
||||
|
||||
PR c++/42055
|
||||
* g++.dg/template/crash92.C: New.
|
||||
|
||||
2009-11-08 Richard Guenther <rguenther@suse.de>
|
||||
|
||||
PR rtl-optimization/41928
|
||||
* gfortran.dg/pr41928.f90: New testcase.
|
||||
|
||||
2009-11-06 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR middle-end/41935
|
||||
* gcc.dg/pr41935.c: New test.
|
||||
* c-c++-common/pr41935.c: New test.
|
||||
* gcc.c-torture/execute/pr41935.c: New test.
|
||||
|
||||
2009-11-04 Richard Guenther <rguenther@suse.de>
|
||||
|
||||
PR tree-optimization/41919
|
||||
* gcc.c-torture/execute/pr41919.c: New testcase.
|
||||
|
||||
2009-11-03 Tobias Burnus <burnus@net-b.de>
|
||||
|
||||
PR fortran/41907
|
||||
* gfortran.dg/missing_optional_dummy_6.f90: New test.
|
||||
|
||||
2009-11-02 Martin Jambor <mjambor@suse.cz>
|
||||
|
||||
PR tree-optimization/41750
|
||||
* gcc.c-torture/execute/pr41750.c: New test.
|
||||
|
||||
2009-11-02 Jakub Jelinek <jakub@redhat.com>
|
||||
|
||||
PR tree-optimization/41841
|
||||
* gcc.dg/pr41841.c: New test.
|
||||
|
||||
2009-11-19 Jerry DeLisle <jvdelisle@gcc.gnu.org>
|
||||
|
||||
PR libgfortran/42090
|
||||
|
|
|
|||
|
|
@ -0,0 +1,70 @@
|
|||
/* { dg-options "-Warray-bounds" } */
|
||||
/* { dg-do compile } */
|
||||
|
||||
struct A
|
||||
{
|
||||
int i;
|
||||
char p[1];
|
||||
};
|
||||
|
||||
struct B
|
||||
{
|
||||
struct A a;
|
||||
int i;
|
||||
};
|
||||
|
||||
struct C
|
||||
{
|
||||
int i;
|
||||
struct A a;
|
||||
};
|
||||
|
||||
union D
|
||||
{
|
||||
char p[1];
|
||||
struct A a;
|
||||
struct B b;
|
||||
struct C c;
|
||||
};
|
||||
|
||||
struct E
|
||||
{
|
||||
int i;
|
||||
union D d;
|
||||
};
|
||||
|
||||
struct F
|
||||
{
|
||||
union D d;
|
||||
int i;
|
||||
};
|
||||
|
||||
union G
|
||||
{
|
||||
int i;
|
||||
union D d;
|
||||
};
|
||||
|
||||
void
|
||||
f0 ()
|
||||
{
|
||||
__builtin_offsetof (struct A, p[4]); /* OK */
|
||||
__builtin_offsetof (struct B, a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (struct C, a.p[4]); /* OK */
|
||||
__builtin_offsetof (union D, p[4]); /* OK */
|
||||
__builtin_offsetof (union D, a.p[4]); /* OK */
|
||||
__builtin_offsetof (union D, b.a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (union D, c.a.p[4]); /* OK */
|
||||
__builtin_offsetof (struct E, d.p[4]); /* OK */
|
||||
__builtin_offsetof (struct E, d.a.p[4]); /* OK */
|
||||
__builtin_offsetof (struct E, d.b.a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (struct E, d.c.a.p[4]); /* OK */
|
||||
__builtin_offsetof (struct F, d.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (struct F, d.a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (struct F, d.b.a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (struct F, d.c.a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (union G, d.p[4]); /* OK */
|
||||
__builtin_offsetof (union G, d.a.p[4]); /* OK */
|
||||
__builtin_offsetof (union G, d.b.a.p[4]); /* { dg-warning "greater than size" } */
|
||||
__builtin_offsetof (union G, d.c.a.p[4]); /* OK */
|
||||
}
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
// PR c++/42055
|
||||
|
||||
template<typename T> void foo(T, T); // { dg-error "candidates|template" }
|
||||
|
||||
template<typename T> void foo(T, int); // { dg-error "template" }
|
||||
|
||||
template void foo(int, int); // { dg-error "ambiguous template specialization" }
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
/* PR 41750 - IPA-SRA used to pass hash->sgot by value rather than by
|
||||
reference. */
|
||||
|
||||
struct bfd_link_hash_table
|
||||
{
|
||||
int hash;
|
||||
};
|
||||
|
||||
struct foo_link_hash_table
|
||||
{
|
||||
struct bfd_link_hash_table root;
|
||||
int *dynobj;
|
||||
int *sgot;
|
||||
};
|
||||
|
||||
struct foo_link_info
|
||||
{
|
||||
struct foo_link_hash_table *hash;
|
||||
};
|
||||
|
||||
extern void abort (void);
|
||||
|
||||
int __attribute__((noinline))
|
||||
foo_create_got_section (int *abfd, struct foo_link_info *info)
|
||||
{
|
||||
info->hash->sgot = abfd;
|
||||
return 1;
|
||||
}
|
||||
|
||||
static int *
|
||||
get_got (int *abfd, struct foo_link_info *info,
|
||||
struct foo_link_hash_table *hash)
|
||||
{
|
||||
int *got;
|
||||
int *dynobj;
|
||||
|
||||
got = hash->sgot;
|
||||
if (!got)
|
||||
{
|
||||
dynobj = hash->dynobj;
|
||||
if (!dynobj)
|
||||
hash->dynobj = dynobj = abfd;
|
||||
if (!foo_create_got_section (dynobj, info))
|
||||
return 0;
|
||||
got = hash->sgot;
|
||||
}
|
||||
return got;
|
||||
}
|
||||
|
||||
int * __attribute__((noinline,noclone))
|
||||
elf64_ia64_check_relocs (int *abfd, struct foo_link_info *info)
|
||||
{
|
||||
return get_got (abfd, info, info->hash);
|
||||
}
|
||||
|
||||
struct foo_link_info link_info;
|
||||
struct foo_link_hash_table hash;
|
||||
int abfd;
|
||||
|
||||
int
|
||||
main ()
|
||||
{
|
||||
link_info.hash = &hash;
|
||||
if (elf64_ia64_check_relocs (&abfd, &link_info) != &abfd)
|
||||
abort ();
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,39 @@
|
|||
extern void abort (void);
|
||||
|
||||
#define assert(x) if(!(x)) abort()
|
||||
|
||||
struct S1
|
||||
{
|
||||
signed char f0;
|
||||
};
|
||||
|
||||
int g_23 = 0;
|
||||
|
||||
static struct S1
|
||||
foo (void)
|
||||
{
|
||||
int *l_100 = &g_23;
|
||||
int **l_110 = &l_100;
|
||||
struct S1 l_128 = { 1 };
|
||||
assert (l_100 == &g_23);
|
||||
assert (l_100 == &g_23);
|
||||
assert (l_100 == &g_23);
|
||||
assert (l_100 == &g_23);
|
||||
assert (l_100 == &g_23);
|
||||
assert (l_100 == &g_23);
|
||||
assert (l_100 == &g_23);
|
||||
return l_128;
|
||||
}
|
||||
|
||||
static signed char bar(signed char si1, signed char si2)
|
||||
{
|
||||
return (si1 <= 0) ? si1 : (si2 * 2);
|
||||
}
|
||||
int main (void)
|
||||
{
|
||||
struct S1 s = foo();
|
||||
if (bar(0x99 ^ (s.f0 && 1), 1) != -104)
|
||||
abort ();
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
/* PR middle-end/41935 */
|
||||
|
||||
extern void abort (void);
|
||||
|
||||
long int
|
||||
foo (int n, int i, int j)
|
||||
{
|
||||
typedef int T[n];
|
||||
struct S { int a; T b[n]; };
|
||||
return __builtin_offsetof (struct S, b[i][j]);
|
||||
}
|
||||
|
||||
int
|
||||
main (void)
|
||||
{
|
||||
typedef int T[5];
|
||||
struct S { int a; T b[5]; };
|
||||
if (foo (5, 2, 3)
|
||||
!= __builtin_offsetof (struct S, b) + (5 * 2 + 3) * sizeof (int))
|
||||
abort ();
|
||||
if (foo (5, 5, 5)
|
||||
!= __builtin_offsetof (struct S, b) + (5 * 5 + 5) * sizeof (int))
|
||||
abort ();
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
/* PR tree-optimization/41841 */
|
||||
/* { dg-do compile } */
|
||||
/* { dg-options "-O -fipa-struct-reorg -fwhole-program -fipa-cp" } */
|
||||
|
||||
typedef struct S *T;
|
||||
typedef struct { } *U;
|
||||
extern int f1 (void);
|
||||
|
||||
static void
|
||||
f3 (U x, int y)
|
||||
{
|
||||
T a = (T) x;
|
||||
y && f1 ();
|
||||
}
|
||||
|
||||
static void
|
||||
f2 (T x)
|
||||
{
|
||||
f3 ((U) x, 1);
|
||||
}
|
||||
|
||||
void *volatile a __attribute__((used)) = f2;
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
/* PR middle-end/41935 */
|
||||
/* { dg-do run } */
|
||||
/* { dg-options "-O2" } */
|
||||
|
||||
extern void abort (void);
|
||||
struct A { int a; int b[10]; };
|
||||
|
||||
int
|
||||
foo (struct A *p)
|
||||
{
|
||||
return __builtin_offsetof (struct A, b[p->a]);
|
||||
}
|
||||
|
||||
int
|
||||
main ()
|
||||
{
|
||||
struct A a;
|
||||
a.a = 7;
|
||||
if (foo (&a) != 7 * sizeof (int) + __builtin_offsetof (struct A, b))
|
||||
abort ();
|
||||
a.a = 2;
|
||||
if (foo (&a) != 2 * sizeof (int) + __builtin_offsetof (struct A, b))
|
||||
abort ();
|
||||
return 0;
|
||||
}
|
||||
|
|
@ -0,0 +1,20 @@
|
|||
/* PR debug/41926 */
|
||||
/* { dg-do compile } */
|
||||
/* { dg-options "-O2 -g -ffast-math -funroll-loops -ftree-vectorize -msse2" { target { i?86-*-* x86_64-*-* } } } */
|
||||
|
||||
void
|
||||
foo (double (*__restrict p)[4], double (*__restrict q)[4],
|
||||
double *__restrict prim, double scale, double pp, double pq)
|
||||
{
|
||||
int md, mc, mb, ma, p_index = 0;
|
||||
|
||||
for (md = 0; md < 1; md++)
|
||||
for (mc = 0; mc < 1; mc++)
|
||||
for (mb = 0; mb < 1; mb++)
|
||||
for (ma = 0; ma < 4; ma++)
|
||||
{
|
||||
double tmp = scale * prim[p_index++];
|
||||
p[md][ma] = p[md][ma] - tmp * pp;
|
||||
q[mc][ma] = q[mc][ma] - tmp * pq;
|
||||
}
|
||||
}
|
||||
|
|
@ -0,0 +1,60 @@
|
|||
! { dg-do run }
|
||||
! { dg-options "-fdump-tree-original" }
|
||||
!
|
||||
! PR fortran/41907
|
||||
!
|
||||
program test
|
||||
implicit none
|
||||
call scalar1 ()
|
||||
call assumed_shape1 ()
|
||||
call explicit_shape1 ()
|
||||
contains
|
||||
|
||||
! Calling functions
|
||||
subroutine scalar1 (slr1)
|
||||
integer, optional :: slr1
|
||||
call scalar2 (slr1)
|
||||
end subroutine scalar1
|
||||
|
||||
subroutine assumed_shape1 (as1)
|
||||
integer, dimension(:), optional :: as1
|
||||
call assumed_shape2 (as1)
|
||||
call explicit_shape2 (as1)
|
||||
end subroutine assumed_shape1
|
||||
|
||||
subroutine explicit_shape1 (es1)
|
||||
integer, dimension(5), optional :: es1
|
||||
call assumed_shape2 (es1)
|
||||
call explicit_shape2 (es1)
|
||||
end subroutine explicit_shape1
|
||||
|
||||
|
||||
! Called functions
|
||||
subroutine assumed_shape2 (as2)
|
||||
integer, dimension(:),optional :: as2
|
||||
if (present (as2)) call abort()
|
||||
end subroutine assumed_shape2
|
||||
|
||||
subroutine explicit_shape2 (es2)
|
||||
integer, dimension(5),optional :: es2
|
||||
if (present (es2)) call abort()
|
||||
end subroutine explicit_shape2
|
||||
|
||||
subroutine scalar2 (slr2)
|
||||
integer, optional :: slr2
|
||||
if (present (slr2)) call abort()
|
||||
end subroutine scalar2
|
||||
|
||||
end program test
|
||||
|
||||
! { dg-final { scan-tree-dump-times "scalar2 \\(slr1" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-times "= es1 != 0B" 1 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "assumed_shape2 \\(es1" 0 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "explicit_shape2 \\(es1" 1 "original" } }
|
||||
|
||||
! { dg-final { scan-tree-dump-times "= as1 != 0B" 2 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "assumed_shape2 \\(as1" 0 "original" } }
|
||||
! { dg-final { scan-tree-dump-times "explicit_shape2 \\(as1" 0 "original" } }
|
||||
|
||||
! { dg-final { cleanup-tree-dump "original" } }
|
||||
|
|
@ -0,0 +1,263 @@
|
|||
! { dg-do compile }
|
||||
! { dg-options "-O -fbounds-check -w" }
|
||||
MODULE kinds
|
||||
INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 )
|
||||
INTEGER, DIMENSION(:), ALLOCATABLE :: nco,ncoset,nso,nsoset
|
||||
INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: co,coset
|
||||
END MODULE kinds
|
||||
MODULE ai_moments
|
||||
USE kinds
|
||||
CONTAINS
|
||||
SUBROUTINE cossin(la_max,npgfa,zeta,rpgfa,la_min,&
|
||||
lb_max,npgfb,zetb,rpgfb,lb_min,&
|
||||
rac,rbc,kvec,cosab,sinab)
|
||||
REAL(KIND=dp), DIMENSION(ncoset(la_max),&
|
||||
ncoset(lb_max)) :: sc, ss
|
||||
DO ipgf=1,npgfa
|
||||
DO jpgf=1,npgfb
|
||||
IF (la_max > 0) THEN
|
||||
DO la=2,la_max
|
||||
DO ax=2,la
|
||||
DO ay=0,la-ax
|
||||
sc(coset(ax,ay,az),1) = rap(1)*sc(coset(ax-1,ay,az),1) +&
|
||||
f2 * kvec(1)*ss(coset(ax-1,ay,az),1)
|
||||
ss(coset(ax,ay,az),1) = rap(1)*ss(coset(ax-1,ay,az),1) +&
|
||||
f2 * kvec(1)*sc(coset(ax-1,ay,az),1)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
IF (lb_max > 0) THEN
|
||||
DO lb=2,lb_max
|
||||
ss(1,coset(0,0,lb)) = rbp(3)*ss(1,coset(0,0,lb-1)) +&
|
||||
f2 * kvec(3)*sc(1,coset(0,0,lb-1))
|
||||
DO bx=2,lb
|
||||
DO by=0,lb-bx
|
||||
ss(1,coset(bx,by,bz)) = rbp(1)*ss(1,coset(bx-1,by,bz)) +&
|
||||
f2 * kvec(1)*sc(1,coset(bx-1,by,bz))
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
END IF
|
||||
DO j=ncoset(lb_min-1)+1,ncoset(lb_max)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END SUBROUTINE cossin
|
||||
SUBROUTINE moment(la_max,npgfa,zeta,rpgfa,la_min,&
|
||||
lb_max,npgfb,zetb,rpgfb,&
|
||||
lc_max,rac,rbc,mab)
|
||||
REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta, rpgfa
|
||||
REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb, rpgfb
|
||||
REAL(KIND=dp), DIMENSION(:, :, :), &
|
||||
INTENT(INOUT) :: mab
|
||||
REAL(KIND=dp), DIMENSION(3) :: rab, rap, rbp, rpc
|
||||
REAL(KIND=dp), DIMENSION(ncoset(la_max),&
|
||||
ncoset(lb_max), ncoset(lc_max)) :: s
|
||||
DO ipgf=1,npgfa
|
||||
DO jpgf=1,npgfb
|
||||
IF (rpgfa(ipgf) + rpgfb(jpgf) < dab) THEN
|
||||
DO k=1, ncoset(lc_max)-1
|
||||
DO j=nb+1,nb+ncoset(lb_max)
|
||||
DO i=na+1,na+ncoset(la_max)
|
||||
mab(i,j,k) = 0.0_dp
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
rpc = zetp*(zeta(ipgf)*rac+zetb(jpgf)*rbc)
|
||||
DO l=2, ncoset(lc_max)
|
||||
lx = indco(1,l)
|
||||
l2 = 0
|
||||
IF ( lz > 0 ) THEN
|
||||
IF ( lz > 1 ) l2 = coset(lx,ly,lz-2)
|
||||
ELSE IF ( ly > 0 ) THEN
|
||||
IF ( ly > 1 ) l2 = coset(lx,ly-2,lz)
|
||||
IF ( lx > 1 ) l2 = coset(lx-2,ly,lz)
|
||||
END IF
|
||||
s(1,1,l) = rpc(i)*s(1,1,l1)
|
||||
IF ( l2 > 0 ) s(1,1,l) = s(1,1,l) + f2*REAL(ni,dp)*s(1,1,l2)
|
||||
END DO
|
||||
DO l = 1, ncoset(lc_max)
|
||||
IF ( lx > 0 ) THEN
|
||||
lx1 = coset(lx-1,ly,lz)
|
||||
END IF
|
||||
IF ( ly > 0 ) THEN
|
||||
ly1 = coset(lx,ly-1,lz)
|
||||
END IF
|
||||
IF (la_max > 0) THEN
|
||||
DO la=2,la_max
|
||||
IF ( lz1 > 0 ) s(coset(0,0,la),1,l) = s(coset(0,0,la),1,l) + &
|
||||
f2z*s(coset(0,0,la-1),1,lz1)
|
||||
IF ( ly1 > 0 ) s(coset(0,1,az),1,l) = s(coset(0,1,az),1,l) + &
|
||||
f2y*s(coset(0,0,az),1,ly1)
|
||||
DO ay=2,la
|
||||
s(coset(0,ay,az),1,l) = rap(2)*s(coset(0,ay-1,az),1,l) +&
|
||||
f2*REAL(ay-1,dp)*s(coset(0,ay-2,az),1,l)
|
||||
IF ( ly1 > 0 ) s(coset(0,ay,az),1,l) = s(coset(0,ay,az),1,l) + &
|
||||
f2y*s(coset(0,ay-1,az),1,ly1)
|
||||
END DO
|
||||
DO ay=0,la-1
|
||||
IF ( lx1 > 0 ) s(coset(1,ay,az),1,l) = s(coset(1,ay,az),1,l) + &
|
||||
f2x*s(coset(0,ay,az),1,lx1)
|
||||
END DO
|
||||
DO ax=2,la
|
||||
DO ay=0,la-ax
|
||||
s(coset(ax,ay,az),1,l) = rap(1)*s(coset(ax-1,ay,az),1,l) +&
|
||||
f3*s(coset(ax-2,ay,az),1,l)
|
||||
IF ( lx1 > 0 ) s(coset(ax,ay,az),1,l) = s(coset(ax,ay,az),1,l) + &
|
||||
f2x*s(coset(ax-1,ay,az),1,lx1)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
IF (lb_max > 0) THEN
|
||||
DO j=2,ncoset(lb_max)
|
||||
DO i=1,ncoset(la_max)
|
||||
s(i,j,l) = 0.0_dp
|
||||
END DO
|
||||
END DO
|
||||
DO la=la_start,la_max-1
|
||||
DO ax=0,la
|
||||
DO ay=0,la-ax
|
||||
s(coset(ax,ay,az),2,l) = s(coset(ax+1,ay,az),1,l) -&
|
||||
rab(1)*s(coset(ax,ay,az),1,l)
|
||||
s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az+1),1,l) -&
|
||||
rab(3)*s(coset(ax,ay,az),1,l)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
DO ax=0,la_max
|
||||
DO ay=0,la_max-ax
|
||||
IF (ax == 0) THEN
|
||||
s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l)
|
||||
ELSE
|
||||
s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l) +&
|
||||
fx*s(coset(ax-1,ay,az),1,l)
|
||||
END IF
|
||||
IF (lx1 > 0) s(coset(ax,ay,az),2,l) = s(coset(ax,ay,az),2,l) +&
|
||||
f2x*s(coset(ax,ay,az),1,lx1)
|
||||
IF (ay == 0) THEN
|
||||
s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l)
|
||||
ELSE
|
||||
s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l) +&
|
||||
fy*s(coset(ax,ay-1,az),1,l)
|
||||
END IF
|
||||
IF (ly1 > 0) s(coset(ax,ay,az),3,l) = s(coset(ax,ay,az),3,l) +&
|
||||
f2y*s(coset(ax,ay,az),1,ly1)
|
||||
IF (az == 0) THEN
|
||||
s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l)
|
||||
ELSE
|
||||
s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l) +&
|
||||
fz*s(coset(ax,ay,az-1),1,l)
|
||||
END IF
|
||||
IF (lz1 > 0) s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az),4,l) +&
|
||||
f2z*s(coset(ax,ay,az),1,lz1)
|
||||
END DO
|
||||
END DO
|
||||
DO lb=2,lb_max
|
||||
DO la=la_start,la_max-1
|
||||
DO ax=0,la
|
||||
DO ay=0,la-ax
|
||||
s(coset(ax,ay,az),coset(0,0,lb),l) =&
|
||||
rab(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l)
|
||||
DO bx=1,lb
|
||||
DO by=0,lb-bx
|
||||
s(coset(ax,ay,az),coset(bx,by,bz),l) =&
|
||||
rab(1)*s(coset(ax,ay,az),coset(bx-1,by,bz),l)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
DO ax=0,la_max
|
||||
DO ay=0,la_max-ax
|
||||
IF (az == 0) THEN
|
||||
s(coset(ax,ay,az),coset(0,0,lb),l) =&
|
||||
rbp(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l) +&
|
||||
f3*s(coset(ax,ay,az),coset(0,0,lb-2),l)
|
||||
END IF
|
||||
IF (lz1 > 0) s(coset(ax,ay,az),coset(0,0,lb),l) =&
|
||||
f2z*s(coset(ax,ay,az),coset(0,0,lb-1),lz1)
|
||||
IF (ay == 0) THEN
|
||||
IF (ly1 > 0) s(coset(ax,ay,az),coset(0,1,bz),l) =&
|
||||
f2y*s(coset(ax,ay,az),coset(0,0,bz),ly1)
|
||||
DO by=2,lb
|
||||
s(coset(ax,ay,az),coset(0,by,bz),l) =&
|
||||
f3*s(coset(ax,ay,az),coset(0,by-2,bz),l)
|
||||
IF (ly1 > 0) s(coset(ax,ay,az),coset(0,by,bz),l) =&
|
||||
f2y*s(coset(ax,ay,az),coset(0,by-1,bz),ly1)
|
||||
END DO
|
||||
s(coset(ax,ay,az),coset(0,1,bz),l) =&
|
||||
fy*s(coset(ax,ay-1,az),coset(0,0,bz),l)
|
||||
END IF
|
||||
IF (ax == 0) THEN
|
||||
DO by=0,lb-1
|
||||
IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =&
|
||||
f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1)
|
||||
END DO
|
||||
DO bx=2,lb
|
||||
DO by=0,lb-bx
|
||||
s(coset(ax,ay,az),coset(bx,by,bz),l) =&
|
||||
f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l)
|
||||
IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =&
|
||||
f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1)
|
||||
END DO
|
||||
END DO
|
||||
DO by=0,lb-1
|
||||
IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =&
|
||||
f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1)
|
||||
END DO
|
||||
DO bx=2,lb
|
||||
DO by=0,lb-bx
|
||||
s(coset(ax,ay,az),coset(bx,by,bz),l) =&
|
||||
f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l)
|
||||
IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =&
|
||||
f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1)
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
IF (lb_max > 0) THEN
|
||||
DO lb=2,lb_max
|
||||
IF (lz1 > 0) s(1,coset(0,0,lb),l) = s(1,coset(0,0,lb),l) +&
|
||||
f2z*s(1,coset(0,0,lb-1),lz1)
|
||||
IF (ly1 > 0) s(1,coset(0,1,bz),l) = s(1,coset(0,1,bz),l) +&
|
||||
f2y*s(1,coset(0,0,bz),ly1)
|
||||
DO by=2,lb
|
||||
s(1,coset(0,by,bz),l) = rbp(2)*s(1,coset(0,by-1,bz),l) +&
|
||||
f2*REAL(by-1,dp)*s(1,coset(0,by-2,bz),l)
|
||||
IF (lx1 > 0) s(1,coset(1,by,bz),l) = s(1,coset(1,by,bz),l) +&
|
||||
f2x*s(1,coset(0,by,bz),lx1)
|
||||
END DO
|
||||
DO bx=2,lb
|
||||
DO by=0,lb-bx
|
||||
IF (lx1 > 0) s(1,coset(bx,by,bz),l) = s(1,coset(bx,by,bz),l) +&
|
||||
f2x*s(1,coset(bx-1,by,bz),lx1)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END IF
|
||||
END IF
|
||||
END DO
|
||||
DO k=2,ncoset(lc_max)
|
||||
DO j=1,ncoset(lb_max)
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END DO
|
||||
END SUBROUTINE moment
|
||||
SUBROUTINE diff_momop(la_max,npgfa,zeta,rpgfa,la_min,&
|
||||
order,rac,rbc,difmab,mab_ext)
|
||||
REAL(KIND=dp), DIMENSION(:, :, :), &
|
||||
OPTIONAL, POINTER :: mab_ext
|
||||
REAL(KIND=dp), ALLOCATABLE, &
|
||||
DIMENSION(:, :, :) :: difmab_tmp
|
||||
DO imom = 1,ncoset(order)-1
|
||||
CALL adbdr(la_max,npgfa,rpgfa,la_min,&
|
||||
difmab_tmp(:,:,2), difmab_tmp(:,:,3))
|
||||
END DO
|
||||
END SUBROUTINE diff_momop
|
||||
END MODULE ai_moments
|
||||
Loading…
Reference in New Issue