Mercurial > hg > CbC > CbC_gcc

annotate gcc/testsuite/gfortran.dg/pr41928.f90 @ 152:2b5abeee2509

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
update gcc11
author anatofuz
date Mon, 25 May 2020 07:50:57 +0900
parents 04ced10e8804
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
111
kono
parents:
diff changeset
1 ! { dg-do compile }
kono
parents:
diff changeset
2 ! { dg-options "-O -fbounds-check -w" }
kono
parents:
diff changeset
3 MODULE kinds
kono
parents:
diff changeset
4 INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND ( 14, 200 )
kono
parents:
diff changeset
5 INTEGER, DIMENSION(:), ALLOCATABLE :: nco,ncoset,nso,nsoset
kono
parents:
diff changeset
6 INTEGER, DIMENSION(:,:,:), ALLOCATABLE :: co,coset
kono
parents:
diff changeset
7 END MODULE kinds
kono
parents:
diff changeset
8 MODULE ai_moments
kono
parents:
diff changeset
9 USE kinds
kono
parents:
diff changeset
10 CONTAINS
kono
parents:
diff changeset
11 SUBROUTINE cossin(la_max,npgfa,zeta,rpgfa,la_min,&
kono
parents:
diff changeset
12 lb_max,npgfb,zetb,rpgfb,lb_min,&
kono
parents:
diff changeset
13 rac,rbc,kvec,cosab,sinab)
kono
parents:
diff changeset
14 REAL(KIND=dp), DIMENSION(ncoset(la_max),&
kono
parents:
diff changeset
15 ncoset(lb_max)) :: sc, ss
kono
parents:
diff changeset
16 DO ipgf=1,npgfa
kono
parents:
diff changeset
17 DO jpgf=1,npgfb
kono
parents:
diff changeset
18 IF (la_max > 0) THEN
kono
parents:
diff changeset
19 DO la=2,la_max
kono
parents:
diff changeset
20 DO ax=2,la
kono
parents:
diff changeset
21 DO ay=0,la-ax
kono
parents:
diff changeset
22 sc(coset(ax,ay,az),1) = rap(1)*sc(coset(ax-1,ay,az),1) +&
kono
parents:
diff changeset
23 f2 * kvec(1)*ss(coset(ax-1,ay,az),1)
kono
parents:
diff changeset
24 ss(coset(ax,ay,az),1) = rap(1)*ss(coset(ax-1,ay,az),1) +&
kono
parents:
diff changeset
25 f2 * kvec(1)*sc(coset(ax-1,ay,az),1)
kono
parents:
diff changeset
26 END DO
kono
parents:
diff changeset
27 END DO
kono
parents:
diff changeset
28 END DO
kono
parents:
diff changeset
29 IF (lb_max > 0) THEN
kono
parents:
diff changeset
30 DO lb=2,lb_max
kono
parents:
diff changeset
31 ss(1,coset(0,0,lb)) = rbp(3)*ss(1,coset(0,0,lb-1)) +&
kono
parents:
diff changeset
32 f2 * kvec(3)*sc(1,coset(0,0,lb-1))
kono
parents:
diff changeset
33 DO bx=2,lb
kono
parents:
diff changeset
34 DO by=0,lb-bx
kono
parents:
diff changeset
35 ss(1,coset(bx,by,bz)) = rbp(1)*ss(1,coset(bx-1,by,bz)) +&
kono
parents:
diff changeset
36 f2 * kvec(1)*sc(1,coset(bx-1,by,bz))
kono
parents:
diff changeset
37 END DO
kono
parents:
diff changeset
38 END DO
kono
parents:
diff changeset
39 END DO
kono
parents:
diff changeset
40 END IF
kono
parents:
diff changeset
41 END IF
kono
parents:
diff changeset
42 DO j=ncoset(lb_min-1)+1,ncoset(lb_max)
kono
parents:
diff changeset
43 END DO
kono
parents:
diff changeset
44 END DO
kono
parents:
diff changeset
45 END DO
kono
parents:
diff changeset
46 END SUBROUTINE cossin
kono
parents:
diff changeset
47 SUBROUTINE moment(la_max,npgfa,zeta,rpgfa,la_min,&
kono
parents:
diff changeset
48 lb_max,npgfb,zetb,rpgfb,&
kono
parents:
diff changeset
49 lc_max,rac,rbc,mab)
kono
parents:
diff changeset
50 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zeta, rpgfa
kono
parents:
diff changeset
51 REAL(KIND=dp), DIMENSION(:), INTENT(IN) :: zetb, rpgfb
kono
parents:
diff changeset
52 REAL(KIND=dp), DIMENSION(:, :, :), &
kono
parents:
diff changeset
53 INTENT(INOUT) :: mab
kono
parents:
diff changeset
54 REAL(KIND=dp), DIMENSION(3) :: rab, rap, rbp, rpc
kono
parents:
diff changeset
55 REAL(KIND=dp), DIMENSION(ncoset(la_max),&
kono
parents:
diff changeset
56 ncoset(lb_max), ncoset(lc_max)) :: s
kono
parents:
diff changeset
57 DO ipgf=1,npgfa
kono
parents:
diff changeset
58 DO jpgf=1,npgfb
kono
parents:
diff changeset
59 IF (rpgfa(ipgf) + rpgfb(jpgf) < dab) THEN
kono
parents:
diff changeset
60 DO k=1, ncoset(lc_max)-1
kono
parents:
diff changeset
61 DO j=nb+1,nb+ncoset(lb_max)
kono
parents:
diff changeset
62 DO i=na+1,na+ncoset(la_max)
kono
parents:
diff changeset
63 mab(i,j,k) = 0.0_dp
kono
parents:
diff changeset
64 END DO
kono
parents:
diff changeset
65 END DO
kono
parents:
diff changeset
66 END DO
kono
parents:
diff changeset
67 END IF
kono
parents:
diff changeset
68 rpc = zetp*(zeta(ipgf)*rac+zetb(jpgf)*rbc)
kono
parents:
diff changeset
69 DO l=2, ncoset(lc_max)
kono
parents:
diff changeset
70 lx = indco(1,l)
kono
parents:
diff changeset
71 l2 = 0
kono
parents:
diff changeset
72 IF ( lz > 0 ) THEN
kono
parents:
diff changeset
73 IF ( lz > 1 ) l2 = coset(lx,ly,lz-2)
kono
parents:
diff changeset
74 ELSE IF ( ly > 0 ) THEN
kono
parents:
diff changeset
75 IF ( ly > 1 ) l2 = coset(lx,ly-2,lz)
kono
parents:
diff changeset
76 IF ( lx > 1 ) l2 = coset(lx-2,ly,lz)
kono
parents:
diff changeset
77 END IF
kono
parents:
diff changeset
78 s(1,1,l) = rpc(i)*s(1,1,l1)
kono
parents:
diff changeset
79 IF ( l2 > 0 ) s(1,1,l) = s(1,1,l) + f2*REAL(ni,dp)*s(1,1,l2)
kono
parents:
diff changeset
80 END DO
kono
parents:
diff changeset
81 DO l = 1, ncoset(lc_max)
kono
parents:
diff changeset
82 IF ( lx > 0 ) THEN
kono
parents:
diff changeset
83 lx1 = coset(lx-1,ly,lz)
kono
parents:
diff changeset
84 END IF
kono
parents:
diff changeset
85 IF ( ly > 0 ) THEN
kono
parents:
diff changeset
86 ly1 = coset(lx,ly-1,lz)
kono
parents:
diff changeset
87 END IF
kono
parents:
diff changeset
88 IF (la_max > 0) THEN
kono
parents:
diff changeset
89 DO la=2,la_max
kono
parents:
diff changeset
90 IF ( lz1 > 0 ) s(coset(0,0,la),1,l) = s(coset(0,0,la),1,l) + &
kono
parents:
diff changeset
91 f2z*s(coset(0,0,la-1),1,lz1)
kono
parents:
diff changeset
92 IF ( ly1 > 0 ) s(coset(0,1,az),1,l) = s(coset(0,1,az),1,l) + &
kono
parents:
diff changeset
93 f2y*s(coset(0,0,az),1,ly1)
kono
parents:
diff changeset
94 DO ay=2,la
kono
parents:
diff changeset
95 s(coset(0,ay,az),1,l) = rap(2)*s(coset(0,ay-1,az),1,l) +&
kono
parents:
diff changeset
96 f2*REAL(ay-1,dp)*s(coset(0,ay-2,az),1,l)
kono
parents:
diff changeset
97 IF ( ly1 > 0 ) s(coset(0,ay,az),1,l) = s(coset(0,ay,az),1,l) + &
kono
parents:
diff changeset
98 f2y*s(coset(0,ay-1,az),1,ly1)
kono
parents:
diff changeset
99 END DO
kono
parents:
diff changeset
100 DO ay=0,la-1
kono
parents:
diff changeset
101 IF ( lx1 > 0 ) s(coset(1,ay,az),1,l) = s(coset(1,ay,az),1,l) + &
kono
parents:
diff changeset
102 f2x*s(coset(0,ay,az),1,lx1)
kono
parents:
diff changeset
103 END DO
kono
parents:
diff changeset
104 DO ax=2,la
kono
parents:
diff changeset
105 DO ay=0,la-ax
kono
parents:
diff changeset
106 s(coset(ax,ay,az),1,l) = rap(1)*s(coset(ax-1,ay,az),1,l) +&
kono
parents:
diff changeset
107 f3*s(coset(ax-2,ay,az),1,l)
kono
parents:
diff changeset
108 IF ( lx1 > 0 ) s(coset(ax,ay,az),1,l) = s(coset(ax,ay,az),1,l) + &
kono
parents:
diff changeset
109 f2x*s(coset(ax-1,ay,az),1,lx1)
kono
parents:
diff changeset
110 END DO
kono
parents:
diff changeset
111 END DO
kono
parents:
diff changeset
112 END DO
kono
parents:
diff changeset
113 IF (lb_max > 0) THEN
kono
parents:
diff changeset
114 DO j=2,ncoset(lb_max)
kono
parents:
diff changeset
115 DO i=1,ncoset(la_max)
kono
parents:
diff changeset
116 s(i,j,l) = 0.0_dp
kono
parents:
diff changeset
117 END DO
kono
parents:
diff changeset
118 END DO
kono
parents:
diff changeset
119 DO la=la_start,la_max-1
kono
parents:
diff changeset
120 DO ax=0,la
kono
parents:
diff changeset
121 DO ay=0,la-ax
kono
parents:
diff changeset
122 s(coset(ax,ay,az),2,l) = s(coset(ax+1,ay,az),1,l) -&
kono
parents:
diff changeset
123 rab(1)*s(coset(ax,ay,az),1,l)
kono
parents:
diff changeset
124 s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az+1),1,l) -&
kono
parents:
diff changeset
125 rab(3)*s(coset(ax,ay,az),1,l)
kono
parents:
diff changeset
126 END DO
kono
parents:
diff changeset
127 END DO
kono
parents:
diff changeset
128 END DO
kono
parents:
diff changeset
129 DO ax=0,la_max
kono
parents:
diff changeset
130 DO ay=0,la_max-ax
kono
parents:
diff changeset
131 IF (ax == 0) THEN
kono
parents:
diff changeset
132 s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l)
kono
parents:
diff changeset
133 ELSE
kono
parents:
diff changeset
134 s(coset(ax,ay,az),2,l) = rbp(1)*s(coset(ax,ay,az),1,l) +&
kono
parents:
diff changeset
135 fx*s(coset(ax-1,ay,az),1,l)
kono
parents:
diff changeset
136 END IF
kono
parents:
diff changeset
137 IF (lx1 > 0) s(coset(ax,ay,az),2,l) = s(coset(ax,ay,az),2,l) +&
kono
parents:
diff changeset
138 f2x*s(coset(ax,ay,az),1,lx1)
kono
parents:
diff changeset
139 IF (ay == 0) THEN
kono
parents:
diff changeset
140 s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l)
kono
parents:
diff changeset
141 ELSE
kono
parents:
diff changeset
142 s(coset(ax,ay,az),3,l) = rbp(2)*s(coset(ax,ay,az),1,l) +&
kono
parents:
diff changeset
143 fy*s(coset(ax,ay-1,az),1,l)
kono
parents:
diff changeset
144 END IF
kono
parents:
diff changeset
145 IF (ly1 > 0) s(coset(ax,ay,az),3,l) = s(coset(ax,ay,az),3,l) +&
kono
parents:
diff changeset
146 f2y*s(coset(ax,ay,az),1,ly1)
kono
parents:
diff changeset
147 IF (az == 0) THEN
kono
parents:
diff changeset
148 s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l)
kono
parents:
diff changeset
149 ELSE
kono
parents:
diff changeset
150 s(coset(ax,ay,az),4,l) = rbp(3)*s(coset(ax,ay,az),1,l) +&
kono
parents:
diff changeset
151 fz*s(coset(ax,ay,az-1),1,l)
kono
parents:
diff changeset
152 END IF
kono
parents:
diff changeset
153 IF (lz1 > 0) s(coset(ax,ay,az),4,l) = s(coset(ax,ay,az),4,l) +&
kono
parents:
diff changeset
154 f2z*s(coset(ax,ay,az),1,lz1)
kono
parents:
diff changeset
155 END DO
kono
parents:
diff changeset
156 END DO
kono
parents:
diff changeset
157 DO lb=2,lb_max
kono
parents:
diff changeset
158 DO la=la_start,la_max-1
kono
parents:
diff changeset
159 DO ax=0,la
kono
parents:
diff changeset
160 DO ay=0,la-ax
kono
parents:
diff changeset
161 s(coset(ax,ay,az),coset(0,0,lb),l) =&
kono
parents:
diff changeset
162 rab(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l)
kono
parents:
diff changeset
163 DO bx=1,lb
kono
parents:
diff changeset
164 DO by=0,lb-bx
kono
parents:
diff changeset
165 s(coset(ax,ay,az),coset(bx,by,bz),l) =&
kono
parents:
diff changeset
166 rab(1)*s(coset(ax,ay,az),coset(bx-1,by,bz),l)
kono
parents:
diff changeset
167 END DO
kono
parents:
diff changeset
168 END DO
kono
parents:
diff changeset
169 END DO
kono
parents:
diff changeset
170 END DO
kono
parents:
diff changeset
171 END DO
kono
parents:
diff changeset
172 DO ax=0,la_max
kono
parents:
diff changeset
173 DO ay=0,la_max-ax
kono
parents:
diff changeset
174 IF (az == 0) THEN
kono
parents:
diff changeset
175 s(coset(ax,ay,az),coset(0,0,lb),l) =&
kono
parents:
diff changeset
176 rbp(3)*s(coset(ax,ay,az),coset(0,0,lb-1),l) +&
kono
parents:
diff changeset
177 f3*s(coset(ax,ay,az),coset(0,0,lb-2),l)
kono
parents:
diff changeset
178 END IF
kono
parents:
diff changeset
179 IF (lz1 > 0) s(coset(ax,ay,az),coset(0,0,lb),l) =&
kono
parents:
diff changeset
180 f2z*s(coset(ax,ay,az),coset(0,0,lb-1),lz1)
kono
parents:
diff changeset
181 IF (ay == 0) THEN
kono
parents:
diff changeset
182 IF (ly1 > 0) s(coset(ax,ay,az),coset(0,1,bz),l) =&
kono
parents:
diff changeset
183 f2y*s(coset(ax,ay,az),coset(0,0,bz),ly1)
kono
parents:
diff changeset
184 DO by=2,lb
kono
parents:
diff changeset
185 s(coset(ax,ay,az),coset(0,by,bz),l) =&
kono
parents:
diff changeset
186 f3*s(coset(ax,ay,az),coset(0,by-2,bz),l)
kono
parents:
diff changeset
187 IF (ly1 > 0) s(coset(ax,ay,az),coset(0,by,bz),l) =&
kono
parents:
diff changeset
188 f2y*s(coset(ax,ay,az),coset(0,by-1,bz),ly1)
kono
parents:
diff changeset
189 END DO
kono
parents:
diff changeset
190 s(coset(ax,ay,az),coset(0,1,bz),l) =&
kono
parents:
diff changeset
191 fy*s(coset(ax,ay-1,az),coset(0,0,bz),l)
kono
parents:
diff changeset
192 END IF
kono
parents:
diff changeset
193 IF (ax == 0) THEN
kono
parents:
diff changeset
194 DO by=0,lb-1
kono
parents:
diff changeset
195 IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =&
kono
parents:
diff changeset
196 f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1)
kono
parents:
diff changeset
197 END DO
kono
parents:
diff changeset
198 DO bx=2,lb
kono
parents:
diff changeset
199 DO by=0,lb-bx
kono
parents:
diff changeset
200 s(coset(ax,ay,az),coset(bx,by,bz),l) =&
kono
parents:
diff changeset
201 f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l)
kono
parents:
diff changeset
202 IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =&
kono
parents:
diff changeset
203 f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1)
kono
parents:
diff changeset
204 END DO
kono
parents:
diff changeset
205 END DO
kono
parents:
diff changeset
206 DO by=0,lb-1
kono
parents:
diff changeset
207 IF (lx1 > 0) s(coset(ax,ay,az),coset(1,by,bz),l) =&
kono
parents:
diff changeset
208 f2x*s(coset(ax,ay,az),coset(0,by,bz),lx1)
kono
parents:
diff changeset
209 END DO
kono
parents:
diff changeset
210 DO bx=2,lb
kono
parents:
diff changeset
211 DO by=0,lb-bx
kono
parents:
diff changeset
212 s(coset(ax,ay,az),coset(bx,by,bz),l) =&
kono
parents:
diff changeset
213 f3*s(coset(ax,ay,az),coset(bx-2,by,bz),l)
kono
parents:
diff changeset
214 IF (lx1 > 0) s(coset(ax,ay,az),coset(bx,by,bz),l) =&
kono
parents:
diff changeset
215 f2x*s(coset(ax,ay,az),coset(bx-1,by,bz),lx1)
kono
parents:
diff changeset
216 END DO
kono
parents:
diff changeset
217 END DO
kono
parents:
diff changeset
218 END IF
kono
parents:
diff changeset
219 END DO
kono
parents:
diff changeset
220 END DO
kono
parents:
diff changeset
221 END DO
kono
parents:
diff changeset
222 END IF
kono
parents:
diff changeset
223 IF (lb_max > 0) THEN
kono
parents:
diff changeset
224 DO lb=2,lb_max
kono
parents:
diff changeset
225 IF (lz1 > 0) s(1,coset(0,0,lb),l) = s(1,coset(0,0,lb),l) +&
kono
parents:
diff changeset
226 f2z*s(1,coset(0,0,lb-1),lz1)
kono
parents:
diff changeset
227 IF (ly1 > 0) s(1,coset(0,1,bz),l) = s(1,coset(0,1,bz),l) +&
kono
parents:
diff changeset
228 f2y*s(1,coset(0,0,bz),ly1)
kono
parents:
diff changeset
229 DO by=2,lb
kono
parents:
diff changeset
230 s(1,coset(0,by,bz),l) = rbp(2)*s(1,coset(0,by-1,bz),l) +&
kono
parents:
diff changeset
231 f2*REAL(by-1,dp)*s(1,coset(0,by-2,bz),l)
kono
parents:
diff changeset
232 IF (lx1 > 0) s(1,coset(1,by,bz),l) = s(1,coset(1,by,bz),l) +&
kono
parents:
diff changeset
233 f2x*s(1,coset(0,by,bz),lx1)
kono
parents:
diff changeset
234 END DO
kono
parents:
diff changeset
235 DO bx=2,lb
kono
parents:
diff changeset
236 DO by=0,lb-bx
kono
parents:
diff changeset
237 IF (lx1 > 0) s(1,coset(bx,by,bz),l) = s(1,coset(bx,by,bz),l) +&
kono
parents:
diff changeset
238 f2x*s(1,coset(bx-1,by,bz),lx1)
kono
parents:
diff changeset
239 END DO
kono
parents:
diff changeset
240 END DO
kono
parents:
diff changeset
241 END DO
kono
parents:
diff changeset
242 END IF
kono
parents:
diff changeset
243 END IF
kono
parents:
diff changeset
244 END DO
kono
parents:
diff changeset
245 DO k=2,ncoset(lc_max)
kono
parents:
diff changeset
246 DO j=1,ncoset(lb_max)
kono
parents:
diff changeset
247 END DO
kono
parents:
diff changeset
248 END DO
kono
parents:
diff changeset
249 END DO
kono
parents:
diff changeset
250 END DO
kono
parents:
diff changeset
251 END SUBROUTINE moment
kono
parents:
diff changeset
252 SUBROUTINE diff_momop(la_max,npgfa,zeta,rpgfa,la_min,&
kono
parents:
diff changeset
253 order,rac,rbc,difmab,mab_ext)
kono
parents:
diff changeset
254 REAL(KIND=dp), DIMENSION(:, :, :), &
kono
parents:
diff changeset
255 OPTIONAL, POINTER :: mab_ext
kono
parents:
diff changeset
256 REAL(KIND=dp), ALLOCATABLE, &
kono
parents:
diff changeset
257 DIMENSION(:, :, :) :: difmab_tmp
kono
parents:
diff changeset
258 DO imom = 1,ncoset(order)-1
kono
parents:
diff changeset
259 CALL adbdr(la_max,npgfa,rpgfa,la_min,&
kono
parents:
diff changeset
260 difmab_tmp(:,:,2), difmab_tmp(:,:,3))
kono
parents:
diff changeset
261 END DO
kono
parents:
diff changeset
262 END SUBROUTINE diff_momop
kono
parents:
diff changeset
263 END MODULE ai_moments