OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_rlink.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!|| sms_rlink10 ../engine/source/ams/sms_rlink.F
25!||--- called by ------------------------------------------------------
26!|| sms_pcg ../engine/source/ams/sms_pcg.F
27!||--- calls -----------------------------------------------------
28!|| sms_rlink1 ../engine/source/ams/sms_rlink.F
29!|| sms_rlink2 ../engine/source/ams/sms_rlink.F
30!|| spmd_exch_fr6 ../engine/source/mpi/kinematic_conditions/spmd_exch_fr6.F
31!||====================================================================
32 SUBROUTINE sms_rlink10(
33 1 MS ,A ,NLINK ,LLINK ,SKEW ,
34 2 FR_RL ,WEIGHT,FRL6 ,IDOWN ,TAG_LNK_SMS,
35 3 ITAB ,FRL )
36C-----------------------------------------------
37C I m p l i c i t T y p e s
38C-----------------------------------------------
39#include "implicit_f.inc"
40#include "comlock.inc"
41C-----------------------------------------------
42C C o m m o n B l o c k s
43C-----------------------------------------------
44#include "scr03_c.inc"
45#include "com01_c.inc"
46#include "task_c.inc"
47#include "param_c.inc"
48C-----------------------------------------------
49C D u m m y A r g u m e n t s
50C-----------------------------------------------
51 INTEGER NLINK(*),LLINK(*),FR_RL(NSPMD+2,*),WEIGHT(*), IDOWN,
52 . TAG_LNK_SMS(*), ITAB(*)
53 my_real
54 . ms(*), a(3,*), skew(lskew,*)
55 DOUBLE PRECISION FRL6(4,6,NRLINK)
56 my_real
57 . frl(4,nrlink)
58C-----------------------------------------------
59C L o c a l V a r i a b l e s
60C-----------------------------------------------
61 INTEGER K, K1, N, ISK, I, IC, KIND(NRLINK)
62C-----------------------------------------------
63C
64C Pre calcul index
65C
66 k = 1
67 DO i = 1, nrlink
68 kind(i) = k
69 k = k + nlink(4*i-3)
70 ENDDO
71C
72C boucle parallele sur les threads SMP
73!$OMP DO SCHEDULE(DYNAMIC,1)
74 DO n=1,nrlink
75 frl(1,n)=zero
76 frl(2,n)=zero
77 frl(3,n)=zero
78 frl(4,n)=zero
79 IF(tag_lnk_sms(n) < 0)cycle
80
81 k1=4*n-3
82 ic=nlink(k1+1)
83 IF(ic==0) cycle
84
85 k = kind(n)
86 isk=nlink(k1+3)
87 IF(isk==1)THEN
88 CALL sms_rlink1(
89 1 ms ,a ,nlink(k1) ,nlink(k1+1),llink(k),
90 2 weight,frl6(1,1,n),1 ,idown ,fr_rl(nspmd+2,n),
91 3 frl(1,n),tag_lnk_sms(n),itab)
92 ELSE
93 CALL sms_rlink2(
94 1 ms ,a ,nlink(k1),nlink(k1+1),llink(k),
95 2 skew(1,isk),weight ,frl6(1,1,n),1 ,idown ,
96 3 fr_rl(nspmd+2,n),frl(1,n),tag_lnk_sms(n),itab)
97 ENDIF
98 END DO
99!$OMP END DO
100
101 IF(nspmd > 1) THEN
102!$OMP SINGLE
103
104C routine appelee rlink par rlink a optimiser si besoin
105 DO n=1,nrlink
106 IF(tag_lnk_sms(n)==0)cycle
107C routine de calcul Parith/ON de A rigid link
108 IF(fr_rl(ispmd+1,n)/=0)
109 + CALL spmd_exch_fr6(fr_rl(1,n),frl6(1,1,n),4*6)
110 END DO
111
112!$OMP END SINGLE
113 END IF
114
115 100 CONTINUE
116C boucle parallele sur les threads SMP
117!$OMP DO SCHEDULE(DYNAMIC,1)
118 DO n=1,nrlink
119 IF(tag_lnk_sms(n) < 0)cycle
120
121 k1=4*n-3
122 ic=nlink(k1+1)
123 IF(ic==0) cycle
124
125 k = kind(n)
126 isk=nlink(k1+3)
127 IF(isk==1)THEN
128 CALL sms_rlink1(
129 1 ms ,a ,nlink(k1) ,nlink(k1+1),llink(k),
130 2 weight,frl6(1,1,n),2 ,idown ,fr_rl(nspmd+2,n),
131 3 frl(1,n),tag_lnk_sms(n),itab)
132 ELSE
133 CALL sms_rlink2(
134 1 ms ,a ,nlink(k1),nlink(k1+1),llink(k),
135 2 skew(1,isk),weight ,frl6(1,1,n),2 ,idown ,
136 3 fr_rl(nspmd+2,n),frl(1,n),tag_lnk_sms(n),itab)
137 ENDIF
138 END DO
139!$OMP END DO
140C
141 RETURN
142 END
143!||====================================================================
144!|| sms_rlink11 ../engine/source/ams/sms_rlink.f
145!||--- called by ------------------------------------------------------
146!|| sms_pcg ../engine/source/ams/sms_pcg.F
147!||--- calls -----------------------------------------------------
148!|| sms_rlink1 ../engine/source/ams/sms_rlink.F
149!|| sms_rlink2 ../engine/source/ams/sms_rlink.F
150!|| sms_rlink3 ../engine/source/ams/sms_rlink.F
151!|| spmd_exch_fr6 ../engine/source/mpi/kinematic_conditions/spmd_exch_fr6.F
152!||====================================================================
153 SUBROUTINE sms_rlink11(
154 1 MS ,A ,NNLINK,LLLINK,SKEW ,
155 2 FR_LL ,WEIGHT,FRL6 ,X ,XFRAME,
156 3 V ,IDOWN ,TAG_LNK_SMS,ITAB,FRL)
157C-----------------------------------------------
158C I m p l i c i t T y p e s
159C-----------------------------------------------
160#include "implicit_f.inc"
161#include "comlock.inc"
162C-----------------------------------------------
163C C o m m o n B l o c k s
164C-----------------------------------------------
165#include "scr03_c.inc"
166#include "com01_c.inc"
167#include "com04_c.inc"
168#include "task_c.inc"
169#include "param_c.inc"
170C-----------------------------------------------
171C D u m m y A r g u m e n t s
172C-----------------------------------------------
173 INTEGER NNLINK(10,*), LLLINK(*), FR_LL(NSPMD+2,*),
174 . WEIGHT(*), IDOWN, TAG_LNK_SMS(*),ITAB(*)
175 my_real
176 . MS(*), A(3,*), SKEW(LSKEW,*),
177 . XFRAME(NXFRAME,*), X(3,*), V(3,*)
178 DOUBLE PRECISION FRL6(4,6,NLINK)
179 my_real
180 . frl(4,nlink)
181C-----------------------------------------------
182C L o c a l V a r i a b l e s
183C-----------------------------------------------
184 INTEGER K, K1, N, ISK, I, IC, IPOL, KIND(NLINK)
185C-----------------------------------------------
186C
187C Pre calcul index
188C
189 k = 1
190 DO i = 1, nlink
191 kind(i) = k
192 k = k + nnlink(1,i)
193 ENDDO
194C boucle parallele sur les threads SMP
195!$OMP DO SCHEDULE(DYNAMIC,1)
196 DO n=1,nlink
197 frl(1,n)=zero
198 frl(2,n)=zero
199 frl(3,n)=zero
200 frl(4,n)=zero
201 IF(tag_lnk_sms(nrlink+n) < 0)cycle
202
203 ic=nnlink(3,n)
204 IF(ic==0)cycle
205
206 isk=nnlink(5,n)
207 ipol=nnlink(6,n)
208 k = kind(n)
209 ipol=nnlink(6,n)
210 IF(ipol==1)THEN
211 CALL sms_rlink3(
212 1 ms ,x ,a ,v ,nnlink(1,n),
213 2 nnlink(3,n),lllink(k),xframe(1,isk),weight ,frl6(1,1,n),
214 3 1 ,idown ,fr_ll(nspmd+2,n),frl(1,n),tag_lnk_sms(nrlink+n),
215 4 itab)
216 ELSEIF(isk==1)THEN
217 CALL sms_rlink1(
218 1 ms ,a ,nnlink(1,n),nnlink(3,n),lllink(k),
219 2 weight ,frl6(1,1,n),1 ,idown ,fr_ll(nspmd+2,n),
220 3 frl(1,n) ,tag_lnk_sms(nrlink+n),itab)
221 ELSE
222 CALL sms_rlink2(
223 1 ms ,a ,nnlink(1,n),nnlink(3,n),lllink(k),
224 2 skew(1,isk), weight ,frl6(1,1,n),1 ,idown ,
225 3 fr_ll(nspmd+2,n),frl(1,n),tag_lnk_sms(nrlink+n),itab)
226 ENDIF
227 END DO
228!$OMP END DO
229 IF(nspmd > 1) THEN
230!$OMP SINGLE
231
232C routine appelee rlink par rlink a optimiser si besoin
233
234 DO n=1,nlink
235 IF(tag_lnk_sms(nrlink+n) < 0)cycle
236C routine de calcul Parith/ON de A rigid link
237 IF(fr_ll(ispmd+1,n)/=0)
238 + CALL spmd_exch_fr6(fr_ll(1,n),frl6(1,1,n),4*6)
239 END DO
240
241!$OMP END SINGLE
242 END IF
243
244 100 CONTINUE
245C boucle parallele sur les threads SMP
246!$OMP DO SCHEDULE(DYNAMIC,1)
247 DO n=1,nlink
248 IF(tag_lnk_sms(nrlink+n) < 0)cycle
249
250 ic=nnlink(3,n)
251 IF(ic==0)cycle
252
253 isk=nnlink(5,n)
254 ipol=nnlink(6,n)
255 k = kind(n)
256 ipol=nnlink(6,n)
257 IF(ipol==1)THEN
258 CALL sms_rlink3(
259 1 ms ,x ,a ,v ,nnlink(1,n),
260 2 nnlink(3,n),lllink(k),xframe(1,isk),weight ,frl6(1,1,n),
261 3 2 ,idown ,fr_ll(nspmd+2,n),frl(1,n),tag_lnk_sms(nrlink+n),
262 4 itab)
263 ELSEIF(isk==1)THEN
264 CALL sms_rlink1(
265 1 ms ,a ,nnlink(1,n),nnlink(3,n),lllink(k),
266 2 weight ,frl6(1,1,n),2 ,idown ,fr_ll(nspmd+2,n),
267 3 frl(1,n) ,tag_lnk_sms(nrlink+n),itab)
268 ELSE
269 CALL sms_rlink2(
270 1 ms ,a ,nnlink(1,n),nnlink(3,n),lllink(k),
271 2 skew(1,isk),weight ,frl6(1,1,n),2 ,idown ,
272 3 fr_ll(nspmd+2,n),frl(1,n),tag_lnk_sms(nrlink+n),itab)
273 ENDIF
274 END DO
275!$OMP END DO
276C
277 RETURN
278 END
279
280!||====================================================================
281!|| sms_rlink1 ../engine/source/ams/sms_rlink.F
282!||--- called by ------------------------------------------------------
283!|| sms_rlink10 ../engine/source/ams/sms_rlink.F
284!|| sms_rlink11 ../engine/source/ams/sms_rlink.F
285!||--- calls -----------------------------------------------------
286!|| sum_6_float ../engine/source/system/parit.F
287!||====================================================================
288 SUBROUTINE sms_rlink1(MS ,A ,NSN ,IC ,NOD,
289 . WEIGHT,FRL6 ,IFLAG,IDOWN ,PMAIN ,
290 . FRL ,TAG_LNK,ITAB)
291C-----------------------------------------------
292C I m p l i c i t T y p e s
293C-----------------------------------------------
294#include "implicit_f.inc"
295C-----------------------------------------------
296C D u m m y A r g u m e n t s
297C-----------------------------------------------
298 INTEGER NSN, IC, IFLAG, IDOWN, NCNOD, PMAIN, TAG_LNK
299 INTEGER NOD(*),WEIGHT(*), ITAB(*)
300C REAL
301 my_real
302 . MS(*), A(3,*), FRL(4)
303 DOUBLE PRECISION FRL6(4,6)
304C-----------------------------------------------
305C L o c a l V a r i a b l e s
306C-----------------------------------------------
307 INTEGER I, J, IJ, N, K
308C REAL
309 my_real
310 . mass, ax, ay, az, xnsn,
311 . f1(nsn), f2(nsn), f3(nsn), f4(nsn)
312C-----------------------------------------------
313 SELECT CASE(idown)
314
315 CASE(0)
316C
317C Remontee
318 IF(iflag == 1)THEN
319
320C Init Parith/ON
321 DO k = 1, 6
322 frl6(1,k) = zero
323 frl6(2,k) = zero
324 frl6(3,k) = zero
325 frl6(4,k) = zero
326 END DO
327C
328 DO i=1,nsn
329 n = nod(i)
330 IF(weight(n)==1) THEN
331 f2(i)=a(1,n)
332 f3(i)=a(2,n)
333 f4(i)=a(3,n)
334 ELSE
335 f2(i)=zero
336 f3(i)=zero
337 f4(i)=zero
338 ENDIF
339 ENDDO
340C
341C Traitement Parith/ON avant echange
342C
343 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1), 4)
344 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1), 4)
345 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1), 4)
346
347 RETURN
348C
349 ELSEIF(iflag == 2)THEN
350C
351 ax = frl6(2,1)+frl6(2,2)+frl6(2,3)+
352 + frl6(2,4)+frl6(2,5)+frl6(2,6)
353 ay = frl6(3,1)+frl6(3,2)+frl6(3,3)+
354 + frl6(3,4)+frl6(3,5)+frl6(3,6)
355 az = frl6(4,1)+frl6(4,2)+frl6(4,3)+
356 + frl6(4,4)+frl6(4,5)+frl6(4,6)
357 DO i=1,nsn
358 n = nod(i)
359C
360C transmet force dans la dion au nd
361 IF(ic==1.OR.ic==3.OR.ic==5.OR.ic==7)THEN
362 a(3,n) =az
363 ENDIF
364 IF(ic==2.OR.ic==3.OR.ic==6.OR.ic==7)THEN
365 a(2,n) =ay
366 ENDIF
367 IF(ic==4.OR.ic==5.OR.ic==6.OR.ic==7)THEN
368 a(1,n) =ax
369 ENDIF
370 END DO
371C
372 ENDIF
373
374 CASE(1)
375C
376C Redescente
377 IF(iflag == 1)THEN
378C
379C Init Parith/ON
380 DO k = 1, 6
381 frl6(1,k) = zero
382 frl6(2,k) = zero
383 frl6(3,k) = zero
384 frl6(4,k) = zero
385 END DO
386C
387 DO i=1,nsn
388 n = nod(i)
389 IF(weight(n)==1) THEN
390 f1(i)=ms(n)
391 f2(i)=ms(n)*a(1,n)
392 f3(i)=ms(n)*a(2,n)
393 f4(i)=ms(n)*a(3,n)
394 ELSE
395 f1(i)=zero
396 f2(i)=zero
397 f3(i)=zero
398 f4(i)=zero
399 ENDIF
400 ENDDO
401C
402C Traitement Parith/ON avant echange
403C
404 CALL sum_6_float(1 ,nsn ,f1, frl6(1,1), 4)
405 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1), 4)
406 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1), 4)
407 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1), 4)
408
409 RETURN
410C
411 ELSEIF(iflag == 2)THEN
412C
413 mass = frl6(1,1)+frl6(1,2)+frl6(1,3)+
414 + frl6(1,4)+frl6(1,5)+frl6(1,6)
415 ax = frl6(2,1)+frl6(2,2)+frl6(2,3)+
416 + frl6(2,4)+frl6(2,5)+frl6(2,6)
417 ay = frl6(3,1)+frl6(3,2)+frl6(3,3)+
418 + frl6(3,4)+frl6(3,5)+frl6(3,6)
419 az = frl6(4,1)+frl6(4,2)+frl6(4,3)+
420 + frl6(4,4)+frl6(4,5)+frl6(4,6)
421 ax=ax/max(em30,mass)
422 ay=ay/max(em30,mass)
423 az=az/max(em30,mass)
424 DO i=1,nsn
425 n = nod(i)
426 IF(ic==1.OR.ic==3.OR.ic==5.OR.ic==7)THEN
427 a(3,n) =az
428 ENDIF
429 IF(ic==2.OR.ic==3.OR.ic==6.OR.ic==7)THEN
430 a(2,n) =ay
431 ENDIF
432 IF(ic==4.OR.ic==5.OR.ic==6.OR.ic==7)THEN
433 a(1,n) =ax
434 ENDIF
435 END DO
436C
437 ENDIF
438C
439 END SELECT
440 RETURN
441 END
442
443!||====================================================================
444!|| sms_rlink2 ../engine/source/ams/sms_rlink.F
445!||--- called by ------------------------------------------------------
446!|| sms_rlink10 ../engine/source/ams/sms_rlink.f
447!|| sms_rlink11 ../engine/source/ams/sms_rlink.F
448!||--- calls -----------------------------------------------------
449!|| sum_6_float ../engine/source/system/parit.F
450!||====================================================================
451 SUBROUTINE sms_rlink2(MS ,A ,NSN ,IC ,NOD ,
452 2 SKEW,WEIGHT,FRL6 ,IFLAG,IDOWN,
453 3 PMAIN,FRL,TAG_LNK,ITAB)
454C-----------------------------------------------
455C I m p l i c i t T y p e s
456C-----------------------------------------------
457#include "implicit_f.inc"
458C-----------------------------------------------
459C D u m m y A r g u m e n t s
460C-----------------------------------------------
461 INTEGER NSN, IC, IFLAG, IDOWN, PMAIN, TAG_LNK
462 INTEGER NOD(*),WEIGHT(*), ITAB(*), ISK
463C REAL
464 my_real
465 . MS(*), A(3,*),SKEW(*), FRL(4)
466 DOUBLE PRECISION FRL6(4,6)
467C-----------------------------------------------
468C L o c a l V a r i a b l e s
469C-----------------------------------------------
470 INTEGER IC1, ICC, IC2, IC3, I, N, K
471C REAL
472 my_real
473 . mass, ax, ay, az, dax, day, daz, aax, aay,
474 . aaz, xnsn,
475 . f1(nsn), f2(nsn), f3(nsn), f4(nsn)
476C-----------------------------------------------
477 SELECT CASE(idown)
478
479 CASE(0)
480C
481C Remontee
482 IF(iflag == 1)THEN
483
484C Init Parith/ON
485 DO k = 1, 6
486 frl6(1,k) = zero
487 frl6(2,k) = zero
488 frl6(3,k) = zero
489 frl6(4,k) = zero
490 END DO
491
492C
493c AX =ZERO
494c AY =ZERO
495c AZ =ZERO
496C
497 DO i=1,nsn
498 n = nod(i)
499 IF(weight(n)==1) THEN
500 f2(i)=a(1,n)
501 f3(i)=a(2,n)
502 f4(i)=a(3,n)
503 ELSE
504 f2(i)=zero
505 f3(i)=zero
506 f4(i)=zero
507 ENDIF
508 ENDDO
509C
510C Traitement Parith/ON avant echange
511C
512 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1), 4)
513 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1), 4)
514 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1), 4)
515C
516 ELSEIF(iflag == 2)THEN
517 ic1=ic/4
518 icc=ic-4*ic1
519 ic2=icc/2
520 ic3=icc-2*ic2
521C
522 ax = frl6(2,1)+frl6(2,2)+frl6(2,3)+
523 + frl6(2,4)+frl6(2,5)+frl6(2,6)
524 ay = frl6(3,1)+frl6(3,2)+frl6(3,3)+
525 + frl6(3,4)+frl6(3,5)+frl6(3,6)
526 az = frl6(4,1)+frl6(4,2)+frl6(4,3)+
527 + frl6(4,4)+frl6(4,5)+frl6(4,6)
528 DO i=1,nsn
529 n = nod(i)
530C
531C transmet force dans la dion au nd
532 dax =a(1,n)-ax
533 day =a(2,n)-ay
534 daz =a(3,n)-az
535 aax =ic1*(skew(1)*dax+skew(2)*day+skew(3)*daz)
536 aay =ic2*(skew(4)*dax+skew(5)*day+skew(6)*daz)
537 aaz =ic3*(skew(7)*dax+skew(8)*day+skew(9)*daz)
538 a(1,n) =a(1,n)-aax*skew(1)-aay*skew(4)-aaz*skew(7)
539 a(2,n) =a(2,n)-aax*skew(2)-aay*skew(5)-aaz*skew(8)
540 a(3,n) =a(3,n)-aax*skew(3)-aay*skew(6)-aaz*skew(9)
541 END DO
542 END IF
543C
544
545 CASE(1)
546C
547C Redescente
548 IF(iflag == 1)THEN
549
550C Init Parith/ON
551 DO k = 1, 6
552 frl6(1,k) = zero
553 frl6(2,k) = zero
554 frl6(3,k) = zero
555 frl6(4,k) = zero
556 END DO
557
558C
559c MASS =ZERO
560c AX =ZERO
561c AY =ZERO
562c AZ =ZERO
563C
564 DO i=1,nsn
565 n = nod(i)
566 IF(weight(n)==1) THEN
567 f1(i)=ms(n)
568 f2(i)=ms(n)*a(1,n)
569 f3(i)=ms(n)*a(2,n)
570 f4(i)=ms(n)*a(3,n)
571 ELSE
572 f1(i)=zero
573 f2(i)=zero
574 f3(i)=zero
575 f4(i)=zero
576 ENDIF
577 ENDDO
578C
579C Traitement Parith/ON avant echange
580C
581 CALL sum_6_float(1 ,nsn ,f1, frl6(1,1), 4)
582 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1), 4)
583 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1), 4)
584 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1), 4)
585
586C
587 ELSEIF(iflag == 2)THEN
588C
589 ic1=ic/4
590 icc=ic-4*ic1
591 ic2=icc/2
592 ic3=icc-2*ic2
593C
594 mass = frl6(1,1)+frl6(1,2)+frl6(1,3)+
595 + frl6(1,4)+frl6(1,5)+frl6(1,6)
596 ax = frl6(2,1)+frl6(2,2)+frl6(2,3)+
597 + frl6(2,4)+frl6(2,5)+frl6(2,6)
598 ay = frl6(3,1)+frl6(3,2)+frl6(3,3)+
599 + frl6(3,4)+frl6(3,5)+frl6(3,6)
600 az = frl6(4,1)+frl6(4,2)+frl6(4,3)+
601 + frl6(4,4)+frl6(4,5)+frl6(4,6)
602 ax=ax/max(em30,mass)
603 ay=ay/max(em30,mass)
604 az=az/max(em30,mass)
605C
606 DO i=1,nsn
607 n = nod(i)
608 dax =a(1,n)-ax
609 day =a(2,n)-ay
610 daz =a(3,n)-az
611 aax =ic1*(skew(1)*dax+skew(2)*day+skew(3)*daz)
612 aay =ic2*(skew(4)*dax+skew(5)*day+skew(6)*daz)
613 aaz =ic3*(skew(7)*dax+skew(8)*day+skew(9)*daz)
614 a(1,n) =a(1,n)-aax*skew(1)-aay*skew(4)-aaz*skew(7)
615 a(2,n) =a(2,n)-aax*skew(2)-aay*skew(5)-aaz*skew(8)
616 a(3,n) =a(3,n)-aax*skew(3)-aay*skew(6)-aaz*skew(9)
617 END DO
618 END IF
619
620 END SELECT
621C
622 RETURN
623 END
624
625!||====================================================================
626!|| sms_rlink3 ../engine/source/ams/sms_rlink.F
627!||--- called by ------------------------------------------------------
628!|| sms_rlink11 ../engine/source/ams/sms_rlink.F
629!||--- calls -----------------------------------------------------
630!|| sum_6_float ../engine/source/system/parit.F
631!||====================================================================
632 SUBROUTINE sms_rlink3(MS ,X ,A ,V ,NSN ,
633 2 IC ,NOD ,XFRAME,WEIGHT,FRL6 ,
634 3 IFLAG,IDOWN,PMAIN,FRL,TAG_LNK,
635 4 ITAB )
636C-----------------------------------------------
637C I m p l i c i t T y p e s
638C-----------------------------------------------
639#include "implicit_f.inc"
640C-----------------------------------------------
641C C o m m o n B l o c k s
642C-----------------------------------------------
643#include "com08_c.inc"
644C-----------------------------------------------
645C D u m m y A r g u m e n t s
646C-----------------------------------------------
647 INTEGER NSN, IC, IFLAG, IDOWN, PMAIN, TAG_LNK
648 INTEGER NOD(*),WEIGHT(*), ITAB(*)
649C REAL
650 my_real
651 . MS(*), X(3,*), A(3,*), V(3,*),
652 . XFRAME(*), FRL(4)
653 DOUBLE PRECISION FRL6(5,6)
654C-----------------------------------------------
655C L o c a l V a r i a b l e s
656C-----------------------------------------------
657 INTEGER IC1, ICC, IC2, IC3, I, N, K
658C REAL
659 my_real
660 . mass, ax, ay, az, dax, day, daz, aax, aay,
661 . aaz, rx, ry, rz, sx, sy, sz,
662 . tx, ty, tz, ox, oy, oz, aa, r2, atr2,rx0, ry0, rz0, r,
663 . mr2, atmr2,
664 . f1(nsn), f2(nsn), f3(nsn), f4(nsn), f5(nsn)
665C-----------------------------------------------
666 SELECT CASE(idown)
667
668 CASE(0)
669C
670C Remontee
671 sx = xframe(1)
672 sy = xframe(2)
673 sz = xframe(3)
674 aa = one / sqrt(sx*sx + sy*sy + sz*sz)
675 sx = sx * aa
676 sy = sy * aa
677 sz = sz * aa
678 ox = xframe(10)
679 oy = xframe(11)
680 oz = xframe(12)
681
682 IF(iflag == 1)THEN
683
684C Init Parith/ON
685 DO k = 1, 6
686 frl6(1,k) = zero
687 frl6(2,k) = zero
688 frl6(3,k) = zero
689 frl6(4,k) = zero
690 END DO
691
692c R2 = ZERO
693c ATR2 = ZERO
694C-----------------------------------------------------------------------
695C repere polaire axe S = X(frame) , rayon R , angle T
696C-----------------------------------------------------------------------
697 DO i=1,nsn
698 n = nod(i)
699 rx0 = x(1,n) + half * dt2 * v(1,n) - ox
700 ry0 = x(2,n) + half * dt2 * v(2,n) - oy
701 rz0 = x(3,n) + half * dt2 * v(3,n) - oz
702 tx = ry0 * sz - rz0 * sy
703 ty = rz0 * sx - rx0 * sz
704 tz = rx0 * sy - ry0 * sx
705 aa = one / sqrt(tx*tx + ty*ty + tz*tz)
706 tx = tx * aa
707 ty = ty * aa
708 tz = tz * aa
709 rx = sy * tz - sz * ty
710 ry = sz * tx - sx * tz
711 rz = sx * ty - sy * tx
712 r = rx * rx0 + ry * ry0 + rz * rz0
713 r = max(r,em20)
714C-----------------------------------------------------------------------
715C changement de repere global => polaire
716C-----------------------------------------------------------------------
717 ax = a(1,n)
718 ay = a(2,n)
719 az = a(3,n)
720 a(1,n) = rx * ax + ry * ay + rz * az
721 a(2,n) = sx * ax + sy * ay + sz * az
722 a(3,n) = (tx * ax + ty * ay + tz * az) / r
723 IF(weight(n)==1) THEN
724 f1(i) = r*r
725 f2(i) = r*r*a(3,n)
726c R2 = R2 + R*R
727c ATR2 = ATR2 + R*R*A(3,N)
728 ELSE
729 f1(i) = zero
730 f2(i) = zero
731 ENDIF
732 ENDDO
733C
734C Traitement Parith/ON avant echange
735C
736 CALL sum_6_float(1 ,nsn ,f1, frl6(1,1),5)
737 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1),5)
738
739C-----------------------------------------------------------------------
740C masse quantite de mouvement
741C-----------------------------------------------------------------------
742 ax =zero
743 ay =zero
744 mass=zero
745 DO i=1,nsn
746 n = nod(i)
747 IF(weight(n)==1) THEN
748 f3(i)=a(1,n)
749 f4(i)=a(2,n)
750 ELSE
751 f3(i)=zero
752 f4(i)=zero
753 ENDIF
754 ENDDO
755C
756C Traitement Parith/ON avant echange
757C
758 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1),5)
759 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1),5)
760C
761 ELSEIF(iflag == 2)THEN
762C
763 ic1=ic/4
764 icc=ic-4*ic1
765 ic2=icc/2
766 ic3=icc-2*ic2
767C
768 r2 = frl6(1,1)+frl6(1,2)+frl6(1,3)+
769 + frl6(1,4)+frl6(1,5)+frl6(1,6)
770 atr2 = frl6(2,1)+frl6(2,2)+frl6(2,3)+
771 + frl6(2,4)+frl6(2,5)+frl6(2,6)
772 ax = frl6(3,1)+frl6(3,2)+frl6(3,3)+
773 + frl6(3,4)+frl6(3,5)+frl6(3,6)
774 ay = frl6(4,1)+frl6(4,2)+frl6(4,3)+
775 + frl6(4,4)+frl6(4,5)+frl6(4,6)
776
777 az= atr2/r2
778 DO i=1,nsn
779 n = nod(i)
780C
781C transmet force dans la dion au nd 1
782 a(1,n) =a(1,n)-ic1*(a(1,n)-ax)
783 a(2,n) =a(2,n)-ic2*(a(2,n)-ay)
784 a(3,n) =a(3,n)-ic3*(a(3,n)-az)
785 END DO
786C-----------------------------------------------------------------------
787C repere polaire axe S , rayon R , angle T
788C-----------------------------------------------------------------------
789 DO i=1,nsn
790 n = nod(i)
791 rx0 = x(1,n) + half * dt2 * v(1,n) - ox
792 ry0 = x(2,n) + half * dt2 * v(2,n) - oy
793 rz0 = x(3,n) + half * dt2 * v(3,n) - oz
794 tx = ry0 * sz - rz0 * sy
795 ty = rz0 * sx - rx0 * sz
796 tz = rx0 * sy - ry0 * sx
797 aa = one / sqrt(tx*tx + ty*ty + tz*tz)
798 tx = tx * aa
799 ty = ty * aa
800 tz = tz * aa
801 rx = sy * tz - sz * ty
802 ry = sz * tx - sx * tz
803 rz = sx * ty - sy * tx
804 r = rx * rx0 + ry * ry0 + rz * rz0
805 r = max(r,em20)
806C-----------------------------------------------------------------------
807C changement de repere polaire => global
808C-----------------------------------------------------------------------
809 ax = rx * a(1,n) + sx * a(2,n) + tx * a(3,n) * r
810 ay = ry * a(1,n) + sy * a(2,n) + ty * a(3,n) * r
811 az = rz * a(1,n) + sz * a(2,n) + tz * a(3,n) * r
812 a(1,n) = ax
813 a(2,n) = ay
814 a(3,n) = az
815 ENDDO
816
817 END IF
818 CASE(1)
819C
820C Redescente
821
822 sx = xframe(1)
823 sy = xframe(2)
824 sz = xframe(3)
825 aa = one / sqrt(sx*sx + sy*sy + sz*sz)
826 sx = sx * aa
827 sy = sy * aa
828 sz = sz * aa
829 ox = xframe(10)
830 oy = xframe(11)
831 oz = xframe(12)
832C-----------------------------------------------------------------------
833C repere polaire axe S = X(frame) , rayon R , angle T
834C-----------------------------------------------------------------------
835 IF(iflag == 1)THEN
836
837C Init Parith/ON
838 DO k = 1, 6
839 frl6(1,k) = zero
840 frl6(2,k) = zero
841 frl6(3,k) = zero
842 frl6(4,k) = zero
843 frl6(5,k) = zero
844 END DO
845
846c R2 = ZERO
847c ATR2 = ZERO
848C-----------------------------------------------------------------------
849C repere polaire axe S = X(frame) , rayon R , angle T
850C-----------------------------------------------------------------------
851 DO i=1,nsn
852 n = nod(i)
853 rx0 = x(1,n) + half * dt2 * v(1,n) - ox
854 ry0 = x(2,n) + half * dt2 * v(2,n) - oy
855 rz0 = x(3,n) + half * dt2 * v(3,n) - oz
856 tx = ry0 * sz - rz0 * sy
857 ty = rz0 * sx - rx0 * sz
858 tz = rx0 * sy - ry0 * sx
859 aa = one / sqrt(tx*tx + ty*ty + tz*tz)
860 tx = tx * aa
861 ty = ty * aa
862 tz = tz * aa
863 rx = sy * tz - sz * ty
864 ry = sz * tx - sx * tz
865 rz = sx * ty - sy * tx
866 r = rx * rx0 + ry * ry0 + rz * rz0
867 r = max(r,em20)
868C-----------------------------------------------------------------------
869C changement de repere global => polaire
870C-----------------------------------------------------------------------
871 ax = a(1,n)
872 ay = a(2,n)
873 az = a(3,n)
874 a(1,n) = rx * ax + ry * ay + rz * az
875 a(2,n) = sx * ax + sy * ay + sz * az
876 a(3,n) = (tx * ax + ty * ay + tz * az) / r
877 IF(weight(n)==1) THEN
878 f1(i) = r*r*ms(n)
879 f2(i) = r*r*ms(n)*a(3,n)
880c MR2 = MR2 + R*R*M
881c ATMR2 = ATMR2 + R*R*MS(N)*A(3,N)
882 ELSE
883 f1(i) = zero
884 f2(i) = zero
885 ENDIF
886 ENDDO
887C
888C Traitement Parith/ON avant echange
889C
890 CALL sum_6_float(1 ,nsn ,f1, frl6(1,1),5)
891 CALL sum_6_float(1 ,nsn ,f2, frl6(2,1),5)
892
893C-----------------------------------------------------------------------
894C masse quantite de mouvement
895C-----------------------------------------------------------------------
896 ax =zero
897 ay =zero
898 mass=zero
899 DO i=1,nsn
900 n = nod(i)
901 IF(weight(n)==1) THEN
902 f3(i)=a(1,n)
903 f4(i)=a(2,n)
904 f5(i)=ms(n)
905 ELSE
906 f3(i)=zero
907 f4(i)=zero
908 f5(i)=zero
909 ENDIF
910 ENDDO
911C
912C Traitement Parith/ON avant echange
913C
914 CALL sum_6_float(1 ,nsn ,f3, frl6(3,1),5)
915 CALL sum_6_float(1 ,nsn ,f4, frl6(4,1),5)
916 CALL sum_6_float(1 ,nsn ,f5, frl6(5,1),5)
917
918C
919C ELSEIF(IFLAG == 2)THEN
920C
921 ic1=ic/4
922 icc=ic-4*ic1
923 ic2=icc/2
924 ic3=icc-2*ic2
925C
926 mr2 = frl6(1,1)+frl6(1,2)+frl6(1,3)+
927 + frl6(1,4)+frl6(1,5)+frl6(1,6)
928 atmr2= frl6(2,1)+frl6(2,2)+frl6(2,3)+
929 + frl6(2,4)+frl6(2,5)+frl6(2,6)
930 ax = frl6(3,1)+frl6(3,2)+frl6(3,3)+
931 + frl6(3,4)+frl6(3,5)+frl6(3,6)
932 ay = frl6(4,1)+frl6(4,2)+frl6(4,3)+
933 + frl6(4,4)+frl6(4,5)+frl6(4,6)
934 mass = frl6(5,1)+frl6(5,2)+frl6(5,3)+
935 + frl6(5,4)+frl6(5,5)+frl6(5,6)
936
937 ax= ax/mass
938 ay= ay/mass
939 az= atmr2/mr2
940C-----------------------------------------------------------------------
941C link
942C-----------------------------------------------------------------------
943 DO i=1,nsn
944 n = nod(i)
945 a(1,n) =a(1,n)-ic1*(a(1,n)-ax)
946 a(2,n) =a(2,n)-ic2*(a(2,n)-ay)
947 a(3,n) =a(3,n)-ic3*(a(3,n)-az)
948 ENDDO
949C-----------------------------------------------------------------------
950C repere polaire axe S , rayon R , angle T
951C-----------------------------------------------------------------------
952 DO i=1,nsn
953 n = nod(i)
954 rx0 = x(1,n) + half * dt2 * v(1,n) - ox
955 ry0 = x(2,n) + half * dt2 * v(2,n) - oy
956 rz0 = x(3,n) + half * dt2 * v(3,n) - oz
957 tx = ry0 * sz - rz0 * sy
958 ty = rz0 * sx - rx0 * sz
959 tz = rx0 * sy - ry0 * sx
960 aa = one / sqrt(tx*tx + ty*ty + tz*tz)
961 tx = tx * aa
962 ty = ty * aa
963 tz = tz * aa
964 rx = sy * tz - sz * ty
965 ry = sz * tx - sx * tz
966 rz = sx * ty - sy * tx
967 r = rx * rx0 + ry * ry0 + rz * rz0
968 r = max(r,em20)
969C-----------------------------------------------------------------------
970C changement de repere polaire => global
971C-----------------------------------------------------------------------
972 ax = rx * a(1,n) + sx * a(2,n) + tx * a(3,n) * r
973 ay = ry * a(1,n) + sy * a(2,n) + ty * a(3,n) * r
974 az = rz * a(1,n) + sz * a(2,n) + tz * a(3,n) * r
975 a(1,n) = ax
976 a(2,n) = ay
977 a(3,n) = az
978 END DO
979 END IF
980
981 END SELECT
982C
983 RETURN
984 END
max
#define max(a, b)
Definition macros.h:21
sum_6_float
subroutine sum_6_float(jft, jlt, f, f6, n)
Definition parit.F:64
sms_rlink11
subroutine sms_rlink11(ms, a, nnlink, lllink, skew, fr_ll, weight, frl6, x, xframe, v, idown, tag_lnk_sms, itab, frl)
Definition sms_rlink.F:157
sms_rlink10
subroutine sms_rlink10(ms, a, nlink, llink, skew, fr_rl, weight, frl6, idown, tag_lnk_sms, itab, frl)
Definition sms_rlink.F:36
sms_rlink2
subroutine sms_rlink2(ms, a, nsn, ic, nod, skew, weight, frl6, iflag, idown, pmain, frl, tag_lnk, itab)
Definition sms_rlink.F:454
sms_rlink1
subroutine sms_rlink1(ms, a, nsn, ic, nod, weight, frl6, iflag, idown, pmain, frl, tag_lnk, itab)
Definition sms_rlink.F:291
sms_rlink3
subroutine sms_rlink3(ms, x, a, v, nsn, ic, nod, xframe, weight, frl6, iflag, idown, pmain, frl, tag_lnk, itab)
Definition sms_rlink.F:636
spmd_exch_fr6
subroutine spmd_exch_fr6(fr, fs6, len)
Definition spmd_exch_fr6.F:51