OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
s10cumu3p.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| s10cumu3p ../engine/source/elements/solid/solide10/s10cumu3p.F
25!||--- called by ------------------------------------------------------
26!|| s10forc3 ../engine/source/elements/solid/solide10/s10forc3.F
27!||====================================================================
28 SUBROUTINE s10cumu3p(
29 1 OFFG, STI, FSKY, FSKYV,
30 2 IADS, FX, FY, FZ,
31 3 DELTAX2, IADS10, NC, THEM,
32 4 FTHESKY, AR, X, SAV,
33 5 CONDNSKY,CONDE, ITAGDN, NEL,
34 6 NFT, ISMSTR, JTHE, ISROT, NODADT_THERM)
35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39C-----------------------------------------------
40C G l o b a l P a r a m e t e r s
41C-----------------------------------------------
42#include "mvsiz_p.inc"
43C-----------------------------------------------
44C C o m m o n B l o c k s
45C-----------------------------------------------
46#include "parit_c.inc"
47#include "com04_c.inc"
48#include "scr17_c.inc"
49#include "scr18_c.inc"
50C-----------------------------------------------
51C D u m m y A r g u m e n t s
52C-----------------------------------------------
53 INTEGER, INTENT(IN) :: NFT
54 INTEGER, INTENT(IN) :: ISMSTR
55 INTEGER, INTENT(IN) :: JTHE
56 INTEGER, INTENT(IN) :: ISROT
57 INTEGER, INTENT(IN) :: NODADT_THERM
58 INTEGER ITAGDN(*),NEL
59C REAL
60 my_real
61 . offg(*),fskyv(lsky,8),fsky(8,lsky),sti(*),deltax2(*),
62 . fx(mvsiz,10), fy(mvsiz,10), fz(mvsiz,10),them(mvsiz,10),
63 . fthesky(*),ar(3,*),x(3,*), condnsky(*),conde(*)
64 double precision
65 . sav(nel,30)
66 INTEGER IADS(8,*),IADS10(6,*)
67 INTEGER NC(MVSIZ,10)
68C-----------------------------------------------
69C L o c a l V a r i a b l e s
70C-----------------------------------------------
71 INTEGER I, II, K,N,J
72 INTEGER IPERM(4),IPERM1(6),IPERM2(6),N1,N2,NN,JJ,L1,L2,K1,K2
73 my_real
74 . stiv(mvsiz),stie(mvsiz)
75C-----------------------------------------------
76 DATA iperm/1,3,6,5/
77 DATA iperm1/1,2,3,1,2,3/
78 DATA iperm2/2,3,1,4,4,4/
79 my_real
80 . off_l,xm,ym,zm,xx,yy,zz,facirot,facirot2
81C-----------------------------------------------
82c FACIROT = (7./48.) / (1./32/) ! rapport des masses
83 facirot = (nine + third)
84c FACIROT2 = TWO * (7./48.) / (1./32/) ! 2 * rapport des masses
85c FACIROT2 = NINE + THIRD
86 facirot2 = two * (nine + third)
87
88 off_l = 0.
89 DO i=1,nel
90 off_l = min(off_l,offg(i))
91 ENDDO
92 IF(off_l<zero)THEN
93 DO n=1,10
94 DO i=1,nel
95 IF(offg(i)<zero)THEN
96 fx(i,n)=zero
97 fy(i,n)=zero
98 fz(i,n)=zero
99 sti(i)=zero
100 ENDIF
101 ENDDO
102 ENDDO
103 ENDIF
104 IF(jthe < 0 ) THEN
105 IF(off_l<zero)THEN
106 DO j=1,10
107 DO i=1,nel
108 IF(offg(i)<zero)THEN
109 them(i,j)=zero
110 ENDIF
111 ENDDO
112 ENDDO
113 ENDIF
114 IF(nodadt_therm == 1) THEN
115 IF(off_l<zero)THEN
116 DO i=1,nel
117 IF(offg(i)<zero)THEN
118 conde(i)=zero
119 ENDIF
120 ENDDO
121 ENDIF
122 ENDIF
123 ENDIF
124C
125 IF(idt1tet10/=0 .AND. isrot/=1)THEN
126 ELSE
127C same as version 44./ to be checked
128 DO i=1,nel
129 sti(i)=fourth*sti(i)
130 END DO
131 END IF
132C
133 IF(ivector==1) THEN
134 IF(idt1tet10/=0 .AND. isrot/=1)THEN
135 IF(isrot == 0)THEN
136
137 DO i=1,nel
138C
139C DELTAX/SSP = 2/Omega, Omega=SQRT[Spectral Radius(M-1 K)] cf s10deri3.F
140C = SQRT[Volp*Rho/Kp] cf mqviscb.F
141C STIG = sum(Kp) cf s10fint3.F
142C => STIG == sum( Volp*rho ) * Omega**2/4 == M * Omega**2/4
143C
144C cf Assembling respectively Kvertex=Mvertex * Omega**2/2 and Kedge=Medge * Omega**2/2
145 stiv(i) = two/thirty2 * sti(i)
146 stie(i) = two*seven/fourty8 * sti(i)
147 END DO
148
149 DO n= 1,4
150#include "vectorize.inc"
151 DO i=1,nel
152 ii=i+nft
153 k = iads(iperm(n),ii)
154 fskyv(k,1)=fx(i,n)
155 fskyv(k,2)=fy(i,n)
156 fskyv(k,3)=fz(i,n)
157
158 fskyv(k,4)=zero
159 fskyv(k,5)=zero
160 fskyv(k,6)=zero
161 fskyv(k,7)=stiv(i)
162 fskyv(k,8)=zero
163 ENDDO
164 ENDDO
165
166 DO n= 1,6
167 l1=iperm(iperm1(n))
168 l2=iperm(iperm2(n))
169 DO i=1,nel
170 ii=i+nft
171 jj=ii-numels8
172 nn = nc(i,n+4)
173 IF(nn/=0)THEN
174 k = iads10(n,jj)
175 fskyv(k,1)=fx(i,n+4)
176 fskyv(k,2)=fy(i,n+4)
177 fskyv(k,3)=fz(i,n+4)
178 fskyv(k,4)=zero
179 fskyv(k,5)=zero
180 fskyv(k,6)=zero
181 fskyv(k,7)=stie(i)
182 ELSE
183 k = iads(l1,ii)
184 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
185 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
186 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
187 fskyv(k,4)=zero
188 fskyv(k,5)=zero
189 fskyv(k,6)=zero
190 fskyv(k,7)=fskyv(k,7)+half*stie(i)
191 k = iads(l2,ii)
192 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
193 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
194 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
195 fskyv(k,4)=zero
196 fskyv(k,5)=zero
197 fskyv(k,6)=zero
198 fskyv(k,7)=fskyv(k,7)+half*stie(i)
199 ENDIF
200 ENDDO
201 ENDDO
202 ELSEIF(isrot == 2)THEN
203 DO i=1,nel
204C
205C DELTAX/SSP = 2/Omega, Omega=SQRT[Spectral Radius(K)/Mmin] with Mmin=M/4 cf s10deri3.F
206C = SQRT[Volp*Rho/Kp] cf mqviscb.F
207C STIG = sum(Kp) cf s10fint3.F
208C => STIG == sum( Volp*rho ) * Radius(K) / (4 Mmin) == Radius(K)
209 sti(i) = half * sti(i)
210 END DO
211
212 DO n= 1,4
213#include "vectorize.inc"
214 DO i=1,nel
215 ii=i+nft
216 k = iads(iperm(n),ii)
217 fskyv(k,1)=fx(i,n)
218 fskyv(k,2)=fy(i,n)
219 fskyv(k,3)=fz(i,n)
220
221 fskyv(k,4)=zero
222 fskyv(k,5)=zero
223 fskyv(k,6)=zero
224 fskyv(k,7)=sti(i)
225 fskyv(k,8)=zero
226 ENDDO
227 ENDDO
228
229 DO n= 1,6
230 k1=iperm1(n)
231 k2=iperm2(n)
232 l1=iperm(k1)
233 l2=iperm(k2)
234 DO i=1,nel
235 n1=nc(i,k1)
236 n2=nc(i,k2)
237 ii=i+nft
238 jj=ii-numels8
239 nn = nc(i,n+4)
240 IF(nn == 0)THEN
241
242 k = iads(l1,ii)
243 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
244 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
245 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
246 k = iads(l2,ii)
247 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
248 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
249 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
250
251 ELSEIF(itagdn(nn)/=0) THEN
252 k = iads10(n,jj)
253 fskyv(k,1)=fx(i,n+4)
254 fskyv(k,2)=fy(i,n+4)
255 fskyv(k,3)=fz(i,n+4)
256 fskyv(k,7)=sti(i)*facirot
257 ENDIF
258 ENDDO
259 ENDDO
260 ENDIF
261 ELSEIF(isrot == 0)THEN ! IF(IDT1TET10/=0 .AND. ISROT/=1)THEN
262 DO n= 1,4
263#include "vectorize.inc"
264 DO i=1,nel
265 ii=i+nft
266 k = iads(iperm(n),ii)
267 fskyv(k,1)=fx(i,n)
268 fskyv(k,2)=fy(i,n)
269 fskyv(k,3)=fz(i,n)
270
271 fskyv(k,4)=zero
272 fskyv(k,5)=zero
273 fskyv(k,6)=zero
274 fskyv(k,7)=sti(i)*deltax2(i)
275 fskyv(k,8)=zero
276 ENDDO
277 ENDDO
278
279 DO n= 1,6
280 l1=iperm(iperm1(n))
281 l2=iperm(iperm2(n))
282 DO i=1,nel
283 ii=i+nft
284 jj=ii-numels8
285 nn = nc(i,n+4)
286 IF(nn/=0)THEN
287 k = iads10(n,jj)
288 fskyv(k,1)=fx(i,n+4)
289 fskyv(k,2)=fy(i,n+4)
290 fskyv(k,3)=fz(i,n+4)
291 fskyv(k,4)=zero
292 fskyv(k,5)=zero
293 fskyv(k,6)=zero
294 fskyv(k,7)=sti(i)
295 ELSE
296 k = iads(l1,ii)
297 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
298 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
299 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
300 fskyv(k,4)=zero
301 fskyv(k,5)=zero
302 fskyv(k,6)=zero
303 fskyv(k,7)=fskyv(k,7)+half*sti(i)
304 k = iads(l2,ii)
305 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
306 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
307 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
308 fskyv(k,4)=zero
309 fskyv(k,5)=zero
310 fskyv(k,6)=zero
311 fskyv(k,7)=fskyv(k,7)+half*sti(i)
312 ENDIF
313 ENDDO
314 ENDDO
315 ELSEIF(isrot == 1)THEN
316 DO n= 1,4
317#include "vectorize.inc"
318 DO i=1,nel
319 ii=i+nft
320 k = iads(iperm(n),ii)
321 fskyv(k,1)=fx(i,n)
322 fskyv(k,2)=fy(i,n)
323 fskyv(k,3)=fz(i,n)
324
325 fskyv(k,4)=zero
326 fskyv(k,5)=zero
327 fskyv(k,6)=zero
328 fskyv(k,7)=sti(i)*two
329 fskyv(k,8)=sti(i)*deltax2(i)*one_over_8*three
330 ENDDO
331 ENDDO
332
333 IF(ismstr==1.OR.((ismstr==2.OR.ismstr==12).AND.idtmin(1)==3))THEN
334 DO n= 1,6
335 k1=iperm1(n)
336 k2=iperm2(n)
337 l1=iperm(k1)
338 l2=iperm(k2)
339 DO i=1,nel
340 n1=nc(i,k1)
341 n2=nc(i,k2)
342 ii=i+nft
343 jj=ii-numels8
344 nn = nc(i,n+4)
345 IF(abs(offg(i))>one)THEN
346 xx=sav(i,k2)-sav(i,k1)
347 yy=sav(i,k2+10)-sav(i,k1+10)
348 zz=sav(i,k2+20)-sav(i,k1+20)
349 xm = one_over_8*(yy*fz(i,n+4) - zz*fy(i,n+4))
350 ym = one_over_8*(zz*fx(i,n+4) - xx*fz(i,n+4))
351 zm = one_over_8*(xx*fy(i,n+4) - yy*fx(i,n+4))
352 ELSE
353 xm = one_over_8*
354 . ((x(2,n2)-x(2,n1))*fz(i,n+4) - (x(3,n2)-x(3,n1))*fy(i,n+4))
355 ym = one_over_8*
356 . ((x(3,n2)-x(3,n1))*fx(i,n+4) - (x(1,n2)-x(1,n1))*fz(i,n+4))
357 zm = one_over_8*
358 . ((x(1,n2)-x(1,n1))*fy(i,n+4) - (x(2,n2)-x(2,n1))*fx(i,n+4))
359 END IF
360 k = iads(l1,ii)
361 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
362 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
363 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
364 fskyv(k,4)=fskyv(k,4) + xm
365 fskyv(k,5)=fskyv(k,5) + ym
366 fskyv(k,6)=fskyv(k,6) + zm
367 k = iads(l2,ii)
368 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
369 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
370 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
371 fskyv(k,4)=fskyv(k,4) - xm
372 fskyv(k,5)=fskyv(k,5) - ym
373 fskyv(k,6)=fskyv(k,6) - zm
374 ENDDO
375 ENDDO
376 ELSE
377 DO n= 1,6
378 k1=iperm1(n)
379 k2=iperm2(n)
380 l1=iperm(k1)
381 l2=iperm(k2)
382 DO i=1,nel
383 n1=nc(i,k1)
384 n2=nc(i,k2)
385 ii=i+nft
386 jj=ii-numels8
387 nn = nc(i,n+4)
388 xm = one_over_8*
389 . ((x(2,n2)-x(2,n1))*fz(i,n+4) - (x(3,n2)-x(3,n1))*fy(i,n+4))
390 ym = one_over_8*
391 . ((x(3,n2)-x(3,n1))*fx(i,n+4) - (x(1,n2)-x(1,n1))*fz(i,n+4))
392 zm = one_over_8*
393 . ((x(1,n2)-x(1,n1))*fy(i,n+4) - (x(2,n2)-x(2,n1))*fx(i,n+4))
394
395 k = iads(l1,ii)
396 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
397 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
398 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
399 fskyv(k,4)=fskyv(k,4) + xm
400 fskyv(k,5)=fskyv(k,5) + ym
401 fskyv(k,6)=fskyv(k,6) + zm
402 k = iads(l2,ii)
403 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
404 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
405 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
406 fskyv(k,4)=fskyv(k,4) - xm
407 fskyv(k,5)=fskyv(k,5) - ym
408 fskyv(k,6)=fskyv(k,6) - zm
409 ENDDO
410 ENDDO
411 END IF
412 ELSEIF(isrot == 2)THEN
413 DO n= 1,4
414#include "vectorize.inc"
415 DO i=1,nel
416 ii=i+nft
417 k = iads(iperm(n),ii)
418 fskyv(k,1)=fx(i,n)
419 fskyv(k,2)=fy(i,n)
420 fskyv(k,3)=fz(i,n)
421
422 fskyv(k,4)=zero
423 fskyv(k,5)=zero
424 fskyv(k,6)=zero
425 fskyv(k,7)=sti(i)*two
426 fskyv(k,8)=zero
427 ENDDO
428 ENDDO
429
430 DO n= 1,6
431 k1=iperm1(n)
432 k2=iperm2(n)
433 l1=iperm(k1)
434 l2=iperm(k2)
435 DO i=1,nel
436 n1=nc(i,k1)
437 n2=nc(i,k2)
438 ii=i+nft
439 jj=ii-numels8
440 nn = nc(i,n+4)
441 IF(nn == 0)THEN
442
443 k = iads(l1,ii)
444 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
445 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
446 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
447 k = iads(l2,ii)
448 fskyv(k,1)=fskyv(k,1)+half*fx(i,n+4)
449 fskyv(k,2)=fskyv(k,2)+half*fy(i,n+4)
450 fskyv(k,3)=fskyv(k,3)+half*fz(i,n+4)
451
452 ELSEIF(itagdn(nn)/=0) THEN
453 k = iads10(n,jj)
454 fskyv(k,1)=fx(i,n+4)
455 fskyv(k,2)=fy(i,n+4)
456 fskyv(k,3)=fz(i,n+4)
457 fskyv(k,7)=sti(i)*facirot2
458 ENDIF
459 ENDDO
460 ENDDO
461 ENDIF
462
463 ELSE
464
465 IF(idt1tet10/=0 .AND. isrot/=1)THEN
466 IF(isrot == 0)THEN
467
468 DO i=1,nel
469C
470C DELTAX/SSP = 2/Omega, Omega=SQRT[Spectral Radius(M-1 K)] cf s10deri3.F
471C = SQRT[Volp*Rho/Kp] cf mqviscb.F
472C STIG = sum(Kp) cf s10fint3.F
473C => STIG == sum( Volp*rho ) * Omega**2/4 == M * Omega**2/4
474C
475C cf Assembling respectively Kvertex=Mvertex * Omega**2/2 and Kedge=Medge * Omega**2/2
476 stiv(i) = two/thirty2 * sti(i)
477 stie(i) = two*seven/fourty8 * sti(i)
478 END DO
479
480 DO n= 1,4
481 DO i=1,nel
482 ii=i+nft
483 k = iads(iperm(n),ii)
484 fsky(1,k)=fx(i,n)
485 fsky(2,k)=fy(i,n)
486 fsky(3,k)=fz(i,n)
487 fsky(4,k)=zero
488 fsky(5,k)=zero
489 fsky(6,k)=zero
490 fsky(7,k)=stiv(i)
491 fsky(8,k)=zero
492 ENDDO
493 ENDDO
494
495 DO n= 1,6
496 l1=iperm(iperm1(n))
497 l2=iperm(iperm2(n))
498 DO i=1,nel
499 ii=i+nft
500 jj=ii-numels8
501 nn = nc(i,n+4)
502 IF(nn/=0)THEN
503 k = iads10(n,jj)
504 fsky(1,k)=fx(i,n+4)
505 fsky(2,k)=fy(i,n+4)
506 fsky(3,k)=fz(i,n+4)
507 fsky(7,k)=stie(i)
508 ELSE
509 k = iads(l1,ii)
510 fsky(1,k)=fsky(1,k)+half*fx(i,n+4)
511 fsky(2,k)=fsky(2,k)+half*fy(i,n+4)
512 fsky(3,k)=fsky(3,k)+half*fz(i,n+4)
513 fsky(7,k)=fsky(7,k) + half*stie(i)
514 k = iads(l2,ii)
515 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
516 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
517 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
518 fsky(7,k)=fsky(7,k ) + half*stie(i)
519 ENDIF
520 ENDDO
521 ENDDO
522
523 ELSEIF(isrot == 2)THEN
524 DO i=1,nel
525C
526C DELTAX/SSP = 2/Omega, Omega=SQRT[Spectral Radius(M-1 K)] cf s10deri3.F
527C = SQRT[Volp*Rho/Kp] cf mqviscb.F
528C STIG = sum(Kp) cf s10fint3.F
529C => STIG == sum( Volp*rho ) * Omega**2/4 == M * Omega**2/4
530C
531C cf Assembling K = 1/2 * M/4 * Omega**2
532 sti(i) = half * sti(i)
533 END DO
534
535 DO n= 1,4
536 DO i=1,nel
537 ii=i+nft
538 k = iads(iperm(n),ii)
539 fsky(1,k)=fx(i,n)
540 fsky(2,k)=fy(i,n)
541 fsky(3,k)=fz(i,n)
542 fsky(7,k)=sti(i)
543 ENDDO
544 ENDDO
545
546 DO n= 1,6
547 k1=iperm1(n)
548 k2=iperm2(n)
549 l1=iperm(k1)
550 l2=iperm(k2)
551 DO i=1,nel
552 n1=nc(i,k1)
553 n2=nc(i,k2)
554 ii=i+nft
555 jj=ii-numels8
556 nn = nc(i,n+4)
557 IF(nn == 0)THEN
558 k = iads(l1,ii)
559 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
560 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
561 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
562 k = iads(l2,ii)
563 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
564 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
565 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
566
567 ELSEIF(itagdn(nn)/=0) THEN
568 k = iads10(n,jj)
569 fsky(1,k) = fx(i,n+4)
570 fsky(2,k) = fy(i,n+4)
571 fsky(3,k) = fz(i,n+4)
572 fsky(7,k) = sti(i)*facirot
573 ENDIF
574
575 ENDDO
576 ENDDO
577 ENDIF
578
579 ELSEIF(isrot == 0)THEN ! IF(IDT1TET10/=0 .AND. ISROT/=1)THEN
580 DO n= 1,4
581 DO i=1,nel
582 ii=i+nft
583 k = iads(iperm(n),ii)
584 fsky(1,k)=fx(i,n)
585 fsky(2,k)=fy(i,n)
586 fsky(3,k)=fz(i,n)
587 fsky(4,k)=zero
588 fsky(5,k)=zero
589 fsky(6,k)=zero
590 fsky(7,k)=sti(i)*deltax2(i)
591 fsky(8,k)=zero
592 ENDDO
593 ENDDO
594
595 DO n= 1,6
596 l1=iperm(iperm1(n))
597 l2=iperm(iperm2(n))
598 DO i=1,nel
599 ii=i+nft
600 jj=ii-numels8
601 nn = nc(i,n+4)
602 IF(nn/=0)THEN
603 k = iads10(n,jj)
604 fsky(1,k)=fx(i,n+4)
605 fsky(2,k)=fy(i,n+4)
606 fsky(3,k)=fz(i,n+4)
607 fsky(7,k)=sti(i)
608 ELSE
609 k = iads(l1,ii)
610 fsky(1,k)=fsky(1,k)+half*fx(i,n+4)
611 fsky(2,k)=fsky(2,k)+half*fy(i,n+4)
612 fsky(3,k)=fsky(3,k)+half*fz(i,n+4)
613 fsky(7,k)=fsky(7,k) + half*sti(i)
614 k = iads(l2,ii)
615 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
616 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
617 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
618 fsky(7,k)=fsky(7,k ) + half*sti(i)
619 ENDIF
620 ENDDO
621 ENDDO
622
623 ELSEIF(isrot == 1)THEN
624
625 DO n= 1,4
626 DO i=1,nel
627 ii=i+nft
628 k = iads(iperm(n),ii)
629 fsky(1,k)=fx(i,n)
630 fsky(2,k)=fy(i,n)
631 fsky(3,k)=fz(i,n)
632 fsky(4,k)=zero
633 fsky(5,k)=zero
634 fsky(6,k)=zero
635 fsky(7,k)=sti(i)*two
636 fsky(8,k)=sti(i)*deltax2(i)*one_over_8*three
637 ENDDO
638 ENDDO
639
640 IF(ismstr==1.OR.((ismstr==2.OR.ismstr==12).AND.idtmin(1)==3))THEN
641 DO n= 1,6
642 k1=iperm1(n)
643 k2=iperm2(n)
644 l1=iperm(k1)
645 l2=iperm(k2)
646 DO i=1,nel
647 n1=nc(i,k1)
648 n2=nc(i,k2)
649 ii=i+nft
650 jj=ii-numels8
651 nn = nc(i,n+4)
652 IF(abs(offg(i))>one)THEN
653 xx=sav(i,k2)-sav(i,k1)
654 yy=sav(i,k2+10)-sav(i,k1+10)
655 zz=sav(i,k2+20)-sav(i,k1+20)
656 xm = one_over_8*(yy*fz(i,n+4) - zz*fy(i,n+4))
657 ym = one_over_8*(zz*fx(i,n+4) - xx*fz(i,n+4))
658 zm = one_over_8*(xx*fy(i,n+4) - yy*fx(i,n+4))
659 ELSE
660 xm = one_over_8*
661 . ((x(2,n2)-x(2,n1))*fz(i,n+4) - (x(3,n2)-x(3,n1))*fy(i,n+4))
662 ym = one_over_8*
663 . ((x(3,n2)-x(3,n1))*fx(i,n+4) - (x(1,n2)-x(1,n1))*fz(i,n+4))
664 zm = one_over_8*
665 . ((x(1,n2)-x(1,n1))*fy(i,n+4) - (x(2,n2)-x(2,n1))*fx(i,n+4))
666 END IF
667 k = iads(l1,ii)
668 fsky(1,k)=fsky(1,k)+half*fx(i,n+4)
669 fsky(2,k)=fsky(2,k)+half*fy(i,n+4)
670 fsky(3,k)=fsky(3,k)+half*fz(i,n+4)
671 fsky(4,k)=fsky(4,k) + xm
672 fsky(5,k)=fsky(5,k) + ym
673 fsky(6,k)=fsky(6,k) + zm
674 k = iads(l2,ii)
675 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
676 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
677 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
678 fsky(4,k)=fsky(4,k) - xm
679 fsky(5,k)=fsky(5,k) - ym
680 fsky(6,k)=fsky(6,k) - zm
681 ENDDO
682 ENDDO
683 ELSE
684 DO n= 1,6
685 k1=iperm1(n)
686 k2=iperm2(n)
687 l1=iperm(k1)
688 l2=iperm(k2)
689 DO i=1,nel
690 n1=nc(i,k1)
691 n2=nc(i,k2)
692 ii=i+nft
693 jj=ii-numels8
694 nn = nc(i,n+4)
695 xm = one_over_8*
696 . ((x(2,n2)-x(2,n1))*fz(i,n+4) - (x(3,n2)-x(3,n1))*fy(i,n+4))
697 ym = one_over_8*
698 . ((x(3,n2)-x(3,n1))*fx(i,n+4) - (x(1,n2)-x(1,n1))*fz(i,n+4))
699 zm = one_over_8*
700 . ((x(1,n2)-x(1,n1))*fy(i,n+4) - (x(2,n2)-x(2,n1))*fx(i,n+4))
701
702 k = iads(l1,ii)
703 fsky(1,k)=fsky(1,k)+half*fx(i,n+4)
704 fsky(2,k)=fsky(2,k)+half*fy(i,n+4)
705 fsky(3,k)=fsky(3,k)+half*fz(i,n+4)
706 fsky(4,k)=fsky(4,k) + xm
707 fsky(5,k)=fsky(5,k) + ym
708 fsky(6,k)=fsky(6,k) + zm
709 k = iads(l2,ii)
710 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
711 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
712 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
713 fsky(4,k)=fsky(4,k) - xm
714 fsky(5,k)=fsky(5,k) - ym
715 fsky(6,k)=fsky(6,k) - zm
716 ENDDO
717 ENDDO
718 END IF
719 ELSEIF(isrot == 2)THEN
720
721 DO n= 1,4
722 DO i=1,nel
723 ii=i+nft
724 k = iads(iperm(n),ii)
725 fsky(1,k)=fx(i,n)
726 fsky(2,k)=fy(i,n)
727 fsky(3,k)=fz(i,n)
728 fsky(7,k)=sti(i)*two
729 ENDDO
730 ENDDO
731
732 DO n= 1,6
733 k1=iperm1(n)
734 k2=iperm2(n)
735 l1=iperm(k1)
736 l2=iperm(k2)
737 DO i=1,nel
738 n1=nc(i,k1)
739 n2=nc(i,k2)
740 ii=i+nft
741 jj=ii-numels8
742 nn = nc(i,n+4)
743 IF(nn == 0)THEN
744 k = iads(l1,ii)
745 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
746 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
747 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
748 k = iads(l2,ii)
749 fsky(1,k)=fsky(1,k) + half*fx(i,n+4)
750 fsky(2,k)=fsky(2,k) + half*fy(i,n+4)
751 fsky(3,k)=fsky(3,k) + half*fz(i,n+4)
752
753 ELSEIF(itagdn(nn)/=0) THEN
754 k = iads10(n,jj)
755 fsky(1,k) = fx(i,n+4)
756 fsky(2,k) = fy(i,n+4)
757 fsky(3,k) = fz(i,n+4)
758 fsky(7,k) = sti(i)*facirot2
759 ENDIF
760
761 ENDDO
762 ENDDO
763 ENDIF
764 ENDIF
765C
766C heat transfert
767C
768 IF(jthe < 0 ) THEN
769 DO n= 1,4
770 DO i=1,nel
771 ii=i+nft
772 k = iads(iperm(n),ii)
773 fthesky(k)=them(i,n)
774 ENDDO
775 ENDDO
776 IF(isrot == 0)THEN
777 DO n= 1,6
778 n1=iperm1(n)
779 n2=iperm2(n)
780 DO i=1,nel
781 ii=i+nft
782 jj=ii-numels8
783 nn = nc(i,n+4)
784 IF(nn/=0)THEN
785 k = iads10(n,jj)
786 fthesky(k)=them(i,n+4)
787 ELSE
788 k = iads(iperm(n1),ii)
789 fthesky(k)=fthesky(k) + half*them(i,n+4)
790 k = iads(iperm(n2),ii)
791 fthesky(k)=fthesky(k) + half*them(i,n+4)
792 ENDIF
793 ENDDO
794 ENDDO
795 ENDIF
796 ENDIF
797C
798 IF(nodadt_therm == 1) THEN
799
800 DO i=1,nel
801 conde(i)=fourth*conde(i)
802 END DO
803
804 IF(isrot == 0)THEN ! IF(IDT1SOL/=0 .AND. ISROT/=1)THEN
805 DO n= 1,4
806 DO i=1,nel
807 ii=i+nft
808 k = iads(iperm(n),ii)
809 condnsky(k)=conde(i)*deltax2(i)
810 ENDDO
811 ENDDO
812
813 DO n= 1,6
814 l1=iperm(iperm1(n))
815 l2=iperm(iperm2(n))
816 DO i=1,nel
817 ii=i+nft
818 jj=ii-numels8
819 nn = nc(i,n+4)
820 IF(nn/=0)THEN
821 k = iads10(n,jj)
822 condnsky(k)=conde(i)
823 ELSE
824 k = iads(l1,ii)
825 condnsky(k)=condnsky(k) + half*conde(i)
826 k = iads(l2,ii)
827 condnsky(k)=condnsky(k) + half*conde(i)
828 ENDIF
829 ENDDO
830 ENDDO
831 ELSEIF(isrot == 1)THEN
832 DO n= 1,4
833 DO i=1,nel
834 ii=i+nft
835 k = iads(iperm(n),ii)
836 condnsky(k)=conde(i)*deltax2(i)*one_over_8*three
837 ENDDO
838 ENDDO
839 ELSEIF(isrot == 2)THEN
840 DO n= 1,4
841 DO i=1,nel
842 ii=i+nft
843 k = iads(iperm(n),ii)
844 condnsky(k)=conde(i)*two
845 ENDDO
846 ENDDO
847
848 DO n= 1,6
849 k1=iperm1(n)
850 k2=iperm2(n)
851 l1=iperm(k1)
852 l2=iperm(k2)
853 DO i=1,nel
854 n1=nc(i,k1)
855 n2=nc(i,k2)
856 ii=i+nft
857 jj=ii-numels8
858 nn = nc(i,n+4)
859 IF(nn /= 0.AND.itagdn(nn)/=0)THEN
860 k = iads10(n,jj)
861 condnsky(k)=conde(i)*facirot2
862
863 ENDIF
864 ENDDO
865 ENDDO
866 ENDIF
867 ENDIF
868C
869 IF(nsect>0)THEN
870 DO n= 1,6
871 n1=iperm1(n)
872 n2=iperm2(n)
873 DO i=1,nel
874 nn = nc(i,n+4)
875 IF(nn==0)THEN
876 fx(i,n1)=fx(i,n1)+half*fx(i,n+4)
877 fy(i,n1)=fy(i,n1)+half*fy(i,n+4)
878 fz(i,n1)=fz(i,n1)+half*fz(i,n+4)
879 fx(i,n2)=fx(i,n2)+half*fx(i,n+4)
880 fy(i,n2)=fy(i,n2)+half*fy(i,n+4)
881 fz(i,n2)=fz(i,n2)+half*fz(i,n+4)
882 END IF
883 END DO
884 END DO
885 END IF
886C
887 RETURN
888 END
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
s10cumu3p
subroutine s10cumu3p(offg, sti, fsky, fskyv, iads, fx, fy, fz, deltax2, iads10, nc, them, fthesky, ar, x, sav, condnsky, conde, itagdn, nel, nft, ismstr, jthe, isrot, nodadt_therm)
Definition s10cumu3p.F:35