OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_rbe2.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_diag_rbe2 ../engine/source/ams/sms_rbe2.F
25!||--- calls -----------------------------------------------------
26!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
27!|| sms_rbe_5 ../engine/source/ams/sms_rbe2.F
28!|| spmd_exch_rbe2_sms ../engine/source/mpi/kinematic_conditions/spmd_exch_rbe2_sms.F
29!|| spmd_max_i ../engine/source/mpi/implicit/imp_spmd.F
30!||====================================================================
31 SUBROUTINE sms_diag_rbe2(
32 1 IRBE2 ,LRBE2 ,NODXI_SMS,JAD_SMS,JDI_SMS,LT_SMS,
33 2 NMRBE2,MS,DIAG_SMS,PREC_SMS3,IAD_RBE2,FR_RBE2M,
34 3 WEIGHT,SKEW)
35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39#include "comlock.inc"
40C-----------------------------------------------
41C C o m m o n B l o c k s
42C-----------------------------------------------
43#include "com01_c.inc"
44#include "com04_c.inc"
45#include "param_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER IRBE2(NRBE2L,*),LRBE2(*),NODXI_SMS(*),
50 . JAD_SMS(*),JDI_SMS(*),NMRBE2, IAD_RBE2(*),
51 . FR_RBE2M(*), WEIGHT(*)
52C REAL
53 my_real
54 . lt_sms(*), ms(*), diag_sms(*), prec_sms3(3,*), skew(lskew,*)
55C-----------------------------------------------
56C L o c a l V a r i a b l e s
57C-----------------------------------------------
58 INTEGER K, N, ISK, I, J, M, JT(3,NRBE2),JR(3,NRBE2),
59 . IAD, NS, NSN, MID, NHI, IRAD, IJ, NN, TAG(3,NUMNOD),
60 . ICOM, ISIZE
61 my_real
62 . diag_rbe2(3,numnod), dd
63 double precision
64 . frbe2m6(3,6,nmrbe2)
65C-----------------------------------------------
66 CALL prerbe2(irbe2 ,jt ,jr )
67 icom = iad_rbe2(nspmd+1)-iad_rbe2(1)
68 IF (nspmd>1)CALL spmd_max_i(icom)
69C
70 tag(1:3,1:numnod)=0
71C
72 DO nhi=nhrbe2,0,-1
73 DO n=1,nrbe2
74 IF (irbe2(9,n)/=nhi) cycle
75 iad = irbe2(1,n)
76 nsn = irbe2(5,n)
77 m = irbe2(3,n)
78 DO i=1,nsn
79 ns=lrbe2(iad+i)
80 IF(jt(1,n)/=0)THEN
81 IF(tag(1,m)==0)THEN
82 tag(1,ns)=m
83 ELSE
84 tag(1,ns)=tag(1,m)
85 END IF
86 END IF
87 IF(jt(2,n)/=0)THEN
88 IF(tag(2,m)==0)THEN
89 tag(2,ns)=m
90 ELSE
91 tag(2,ns)=tag(2,m)
92 END IF
93 END IF
94 IF(jt(3,n)/=0)THEN
95 IF(tag(3,m)==0)THEN
96 tag(3,ns)=m
97 ELSE
98 tag(3,ns)=tag(3,m)
99 END IF
100 END IF
101 END DO
102 END DO
103 END DO
104C
105C
106 DO n=1,numnod
107 diag_rbe2(1,n)=diag_sms(n)
108 diag_rbe2(2,n)=diag_sms(n)
109 diag_rbe2(3,n)=diag_sms(n)
110 END DO
111C
112 DO nhi=0,nhrbe2
113 DO n=1,nmrbe2
114 DO k=1,6
115 frbe2m6(1,k,n) = zero
116 frbe2m6(2,k,n) = zero
117 frbe2m6(3,k,n) = zero
118 END DO
119 END DO
120 DO n=1,nrbe2
121 IF (irbe2(9,n)/=nhi) cycle
122 iad = irbe2(1,n)
123 nsn = irbe2(5,n)
124 m = irbe2(3,n)
125 isk = irbe2(7,n)
126 mid = iabs(irbe2(6,n))
127 irad = irbe2(11,n)
128 CALL sms_rbe_5(nsn ,lrbe2(iad+1),diag_rbe2,ms ,weight,
129 1 jt ,frbe2m6(1,1,mid),m ,irad ,isk ,
130 2 skew )
131
132 END DO
133C-----------------
134 IF (icom>0) THEN
135 isize=3
136 CALL spmd_exch_rbe2_sms(
137 . frbe2m6 ,iad_rbe2,fr_rbe2m,iad_rbe2(nspmd+1),isize)
138 ENDIF
139C
140C assemblage parith/ON
141#include "vectorize.inc"
142 DO n=1,nrbe2
143 IF (irbe2(9,n)/=nhi) cycle
144 m = irbe2(3,n)
145 mid = irbe2(6,n)
146 irad = irbe2(11,n)
147 IF (mid<0) cycle
148 DO j=1,3
149 dd=diag_rbe2(j,m)
150 DO k=1,6
151 dd = dd + frbe2m6(j,k,mid)
152 ENDDO
153 diag_rbe2(j,m)=dd
154 END DO
155 ENDDO
156C
157 END DO
158C-----------------
159C
160 DO n=1,nrbe2
161 iad = irbe2(1,n)
162 nsn = irbe2(5,n)
163 m = irbe2(3,n)
164 isk = irbe2(7,n)
165 mid = iabs(irbe2(6,n))
166 irad = irbe2(11,n)
167 IF(jt(1,n)+jt(2,n)+jt(3,n)/=0.AND.nodxi_sms(m)==0)THEN
168 DO i=1,nsn
169 ns = lrbe2(iad+i)
170 DO ij=jad_sms(ns),jad_sms(ns+1)-1
171 nn=jdi_sms(ij)
172 IF(tag(1,nn)==tag(1,ns))
173 . diag_rbe2(1,m)=max(ms(m),diag_rbe2(1,m)+lt_sms(ij))
174 IF(tag(2,nn)==tag(2,ns))
175 . diag_rbe2(2,m)=max(ms(m),diag_rbe2(2,m)+lt_sms(ij))
176 IF(tag(3,nn)==tag(3,ns))
177 . diag_rbe2(3,m)=max(ms(m),diag_rbe2(3,m)+lt_sms(ij))
178 END DO
179 ENDDO
180 END IF
181 END DO
182C
183 DO n=1,nrbe2
184 m = irbe2(3,n)
185 mid = irbe2(6,n)
186 irad = irbe2(11,n)
187 IF (mid<0) cycle
188 DO j=1,3
189 IF(diag_rbe2(j,m)==zero)THEN
190 prec_sms3(j,m)=zero
191 ELSE
192 prec_sms3(j,m)=one/diag_rbe2(j,m)
193 END IF
194 END DO
195 ENDDO
196C
197 RETURN
198 END
199
200!||====================================================================
201!|| sms_rbe2_nodxi ../engine/source/ams/sms_rbe2.F
202!||--- called by ------------------------------------------------------
203!|| sms_build_diag ../engine/source/ams/sms_build_diag.F
204!||--- calls -----------------------------------------------------
205!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
206!||====================================================================
207 SUBROUTINE sms_rbe2_nodxi(
208 1 IRBE2 ,LRBE2 ,NODXI_SMS)
209C-----------------------------------------------
210C I m p l i c i t T y p e s
211C-----------------------------------------------
212#include "implicit_f.inc"
213#include "comlock.inc"
214C-----------------------------------------------
215C C o m m o n B l o c k s
216C-----------------------------------------------
217#include "com04_c.inc"
218#include "param_c.inc"
219C-----------------------------------------------
220C D u m m y A r g u m e n t s
221C-----------------------------------------------
222 INTEGER IRBE2(NRBE2L,*),LRBE2(*),NODXI_SMS(*)
223C REAL
224C-----------------------------------------------
225C L o c a l V a r i a b l e s
226C-----------------------------------------------
227 INTEGER K, N, ISK, I, J, M, JT(3,NRBE2),JR(3,NRBE2),
228 . IAD, NS, NSN, MID, NHI, IRAD
229C-----------------------------------------------
230 CALL PRERBE2(IRBE2 ,JT ,JR )
231C
232 DO nhi=0,nhrbe2
233 DO n=1,nrbe2
234 IF (irbe2(9,n)/=nhi) cycle
235 iad = irbe2(1,n)
236 nsn = irbe2(5,n)
237 m = irbe2(3,n)
238 isk = irbe2(7,n)
239 mid = iabs(irbe2(6,n))
240 irad = irbe2(11,n)
241 IF(jt(1,n)+jt(2,n)+jt(3,n)/=0.AND.nodxi_sms(m)==0)THEN
242 DO i=1,nsn
243 ns = lrbe2(iad+i)
244 IF(nodxi_sms(ns)/=0) THEN
245 nodxi_sms(m)=1
246 EXIT
247 END IF
248 ENDDO
249 END IF
250 END DO
251 END DO
252C
253 RETURN
254 END
255
256!||====================================================================
257!|| sms_rbe_cnds ../engine/source/ams/sms_rbe2.F
258!||--- called by ------------------------------------------------------
259!|| sms_encin_2 ../engine/source/ams/sms_encin_2.F
260!|| sms_mass_scale_2 ../engine/source/ams/sms_mass_scale_2.F
261!|| sms_pcg ../engine/source/ams/sms_pcg.F
262!||--- calls -----------------------------------------------------
263!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
264!|| sms_rbe2_s ../engine/source/ams/sms_rbe2.F
265!|| sms_rbe_1 ../engine/source/ams/sms_rbe2.F
266!|| sms_rbe_2 ../engine/source/ams/sms_rbe2.F
267!|| spmd_exch_rbe2_sms ../engine/source/mpi/kinematic_conditions/spmd_exch_rbe2_sms.F
268!|| spmd_max_i ../engine/source/mpi/implicit/imp_spmd.F
269!||====================================================================
270 SUBROUTINE sms_rbe_cnds(
271 1 IRBE2 ,LRBE2 ,X ,A ,AR ,
272 1 MS ,IN ,SKEW ,WEIGHT ,IAD_RBE2,
273 2 FR_RBE2M,NMRBE2)
274C-----------------------------------------------
275C I m p l i c i t T y p e s
276C-----------------------------------------------
277#include "implicit_f.inc"
278#include "comlock.inc"
279C-----------------------------------------------
280C C o m m o n B l o c k s
281C-----------------------------------------------
282#include "com01_c.inc"
283#include "com04_c.inc"
284#include "param_c.inc"
285C-----------------------------------------------
286C D u m m y A r g u m e n t s
287C-----------------------------------------------
288 INTEGER IRBE2(NRBE2L,*),LRBE2(*),WEIGHT(*),IAD_RBE2(*),
289 . FR_RBE2M(*) ,NMRBE2
290C REAL
291 my_real
292 . X(3,*), A(3,*), AR(3,*), MS(*), IN(*),
293 . SKEW(LSKEW,*)
294C-----------------------------------------------
295C L o c a l V a r i a b l e s
296C-----------------------------------------------
297 INTEGER K, N, ISK, I, J, M, ISIZE, JT(3,NRBE2),JR(3,NRBE2),
298 . iad, ns, icom, nsn, mid, nhi, irad
299 double precision
300 . frbe2m6(3,6,nmrbe2)
301C-----------------------------------------------
302 CALL prerbe2(irbe2 ,jt ,jr )
303 icom = iad_rbe2(nspmd+1)-iad_rbe2(1)
304 IF (nspmd>1)CALL spmd_max_i(icom)
305C
306 DO nhi=0,nhrbe2
307 DO n=1,nmrbe2
308 DO j=1,3
309 DO k=1,6
310 frbe2m6(j,k,n) = zero
311 END DO
312 END DO
313 END DO
314 DO n=1,nrbe2
315 IF (irbe2(9,n)/=nhi) cycle
316 iad = irbe2(1,n)
317 nsn = irbe2(5,n)
318 m = irbe2(3,n)
319 isk = irbe2(7,n)
320 mid = iabs(irbe2(6,n))
321 irad = irbe2(11,n)
322 CALL sms_rbe_1(nsn ,lrbe2(iad+1),x ,a ,ar ,
323 1 ms ,in ,weight,jt(1,n),frbe2m6(1,1,mid),
324 2 m ,irad ,isk ,skew )
325 END DO
326C-----------------
327 IF (icom>0) THEN
328 isize=3
329 CALL spmd_exch_rbe2_sms(
330 . frbe2m6 ,iad_rbe2,fr_rbe2m,iad_rbe2(nspmd+1),isize)
331 ENDIF
332C
333C Routine assemblage parith/ON
334C
335 isize=3
336 CALL sms_rbe2_s(irbe2 ,isize,a ,weight ,frbe2m6,
337 1 nmrbe2 ,nhi )
338C
339
340
341 END DO
342C
343 DO n=1,nrbe2
344 iad = irbe2(1,n)
345 m = irbe2(3,n)
346 nsn = irbe2(5,n)
347 isk = irbe2(7,n)
348 irad = irbe2(11,n)
349 CALL sms_rbe_2(nsn ,lrbe2(iad+1),x ,a ,ar ,
350 1 jt(1,n),m ,irad ,isk ,skew )
351 ENDDO
352C
353 RETURN
354 END
355
356!||====================================================================
357!|| sms_rbe_accl ../engine/source/ams/sms_rbe2.F
358!||--- called by ------------------------------------------------------
359!|| sms_pcg ../engine/source/ams/sms_pcg.F
360!||--- calls -----------------------------------------------------
361!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
362!|| sms_rbe_3 ../engine/source/ams/sms_rbe2.F
363!||====================================================================
364 SUBROUTINE sms_rbe_accl(
365 1 IRBE2 ,LRBE2 ,R ,A ,PREC_SMS3,
366 1 SKEW ,WEIGHT ,IAD_RBE2 ,FR_RBE2M,NMRBE2)
367C-----------------------------------------------
368C I m p l i c i t T y p e s
369C-----------------------------------------------
370#include "implicit_f.inc"
371#include "comlock.inc"
372C-----------------------------------------------
373C C o m m o n B l o c k s
374C-----------------------------------------------
375#include "com04_c.inc"
376#include "param_c.inc"
377C-----------------------------------------------
378C D u m m y A r g u m e n t s
379C-----------------------------------------------
380 INTEGER IRBE2(NRBE2L,*),LRBE2(*),WEIGHT(*),IAD_RBE2(*),
381 . FR_RBE2M(*) ,NMRBE2
382C REAL
383 my_real
384 . R(3,*), A(3,*), PREC_SMS3(*), SKEW(LSKEW,*)
385C-----------------------------------------------
386C L o c a l V a r i a b l e s
387C-----------------------------------------------
388 INTEGER K, N, ISK, I, J, M, ISIZE, JT(3,NRBE2),JR(3,NRBE2),
389 . iad, ns, icom, nsn, mid, nhi, irad
390C-----------------------------------------------
391 CALL prerbe2(irbe2 ,jt ,jr )
392C
393 DO n=nrbe2,1,-1
394 iad = irbe2(1,n)
395 m = irbe2(3,n)
396 nsn = irbe2(5,n)
397 isk = irbe2(7,n)
398 irad = irbe2(11,n)
399 CALL sms_rbe_3(nsn ,lrbe2(iad+1),r ,a ,prec_sms3,
400 1 jt(1,n),m ,irad ,isk ,skew )
401 ENDDO
402C
403 RETURN
404 END
405
406!||====================================================================
407!|| sms_rbe_corr ../engine/source/ams/sms_rbe2.F
408!||--- called by ------------------------------------------------------
409!|| sms_encin_2 ../engine/source/ams/sms_encin_2.F
410!|| sms_pcg ../engine/source/ams/sms_pcg.F
411!||--- calls -----------------------------------------------------
412!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.F
413!|| sms_rbe_4 ../engine/source/ams/sms_rbe2.F
414!||====================================================================
415 SUBROUTINE sms_rbe_corr(
416 1 IRBE2 ,LRBE2 ,V ,W ,MS ,
417 1 SKEW ,WEIGHT ,IAD_RBE2,FR_RBE2M,NMRBE2)
418C-----------------------------------------------
419C I m p l i c i t T y p e s
420C-----------------------------------------------
421#include "implicit_f.inc"
422#include "comlock.inc"
423C-----------------------------------------------
424C C o m m o n B l o c k s
425C-----------------------------------------------
426#include "com04_c.inc"
427#include "param_c.inc"
428C-----------------------------------------------
429C D u m m y A r g u m e n t s
430C-----------------------------------------------
431 INTEGER IRBE2(NRBE2L,*),LRBE2(*),WEIGHT(*),IAD_RBE2(*),
432 . FR_RBE2M(*) ,NMRBE2
433C REAL
434 my_real
435 . V(3,*), W(3,*), MS(*), SKEW(LSKEW,*)
436C-----------------------------------------------
437C L o c a l V a r i a b l e s
438C-----------------------------------------------
439 INTEGER K, N, ISK, I, J, M, ISIZE, JT(3,NRBE2),JR(3,NRBE2),
440 . IAD, NS, ICOM, NSN, MID, NHI, IRAD
441C-----------------------------------------------
442 CALL prerbe2(irbe2 ,jt ,jr )
443C
444 DO n=1,nrbe2
445 iad = irbe2(1,n)
446 m = irbe2(3,n)
447 nsn = irbe2(5,n)
448 isk = irbe2(7,n)
449 irad = irbe2(11,n)
450 CALL sms_rbe_4(nsn ,lrbe2(iad+1),v ,w ,ms ,
451 1 jt(1,n),m ,irad ,isk ,skew )
452 ENDDO
453C
454 RETURN
455 END
456
457!||====================================================================
458!|| sms_rbe_prec ../engine/source/ams/sms_rbe2.f
459!||--- called by ------------------------------------------------------
460!|| sms_pcg ../engine/source/ams/sms_pcg.F
461!||--- calls -----------------------------------------------------
462!|| prerbe2 ../engine/source/constraints/general/rbe2/rbe2f.f
463!|| sms_rbe_5 ../engine/source/ams/sms_rbe2.F
464!|| spmd_exch_rbe2_sms ../engine/source/mpi/kinematic_conditions/spmd_exch_rbe2_sms.F
465!|| spmd_max_i ../engine/source/mpi/implicit/imp_spmd.F
466!||====================================================================
467 SUBROUTINE sms_rbe_prec(
468 1 IRBE2 ,LRBE2 ,DIAG_SMS ,MS ,DIAG_SMS3,
469 1 SKEW ,WEIGHT ,IAD_RBE2 ,FR_RBE2M,NMRBE2)
470C-----------------------------------------------
471C I m p l i c i t T y p e s
472C-----------------------------------------------
473#include "implicit_f.inc"
474#include "comlock.inc"
475C-----------------------------------------------
476C C o m m o n B l o c k s
477C-----------------------------------------------
478#include "com01_c.inc"
479#include "com04_c.inc"
480#include "param_c.inc"
481C-----------------------------------------------
482C D u m m y A r g u m e n t s
483C-----------------------------------------------
484 INTEGER IRBE2(NRBE2L,*),LRBE2(*),WEIGHT(*),IAD_RBE2(*),
485 . FR_RBE2M(*) ,NMRBE2
486C REAL
487 my_real
488 . DIAG_SMS(*), MS(*), DIAG_SMS3(3,*), SKEW(LSKEW,*)
489C-----------------------------------------------
490C L o c a l V a r i a b l e s
491C-----------------------------------------------
492 INTEGER K, N, ISK, I, J, M, ISIZE, JT(3,NRBE2),JR(3,NRBE2),
493 . IAD, NS, ICOM, NSN, MID, NHI, IRAD
494 my_real
495 . DD
496 DOUBLE PRECISION
497 . frbe2m6(3,6,nmrbe2)
498C-----------------------------------------------
499 CALL prerbe2(irbe2 ,jt ,jr )
500 icom = iad_rbe2(nspmd+1)-iad_rbe2(1)
501 IF (nspmd>1)CALL spmd_max_i(icom)
502C
503 DO nhi=0,nhrbe2
504 DO n=1,nmrbe2
505 DO k=1,6
506 frbe2m6(1,k,n) = zero
507 frbe2m6(2,k,n) = zero
508 frbe2m6(3,k,n) = zero
509 END DO
510 END DO
511 DO n=1,nrbe2
512 IF (irbe2(9,n)/=nhi) cycle
513 iad = irbe2(1,n)
514 nsn = irbe2(5,n)
515 m = irbe2(3,n)
516 isk = irbe2(7,n)
517 mid = iabs(irbe2(6,n))
518 irad = irbe2(11,n)
519 CALL sms_rbe_5(nsn ,lrbe2(iad+1),diag_sms3,ms ,weight,
520 1 jt ,frbe2m6(1,1,mid),m ,irad ,isk ,
521 2 skew )
522
523 END DO
524C-----------------
525 IF (icom>0) THEN
526 isize=3
527 CALL spmd_exch_rbe2_sms(
528 . frbe2m6 ,iad_rbe2,fr_rbe2m,iad_rbe2(nspmd+1),isize)
529 ENDIF
530C
531C assemblage parith/ON
532#include "vectorize.inc"
533 DO n=1,nrbe2
534 IF (irbe2(9,n)/=nhi) cycle
535 m = irbe2(3,n)
536 mid = irbe2(6,n)
537 irad = irbe2(11,n)
538 IF (mid<0) cycle
539 DO j=1,3
540 dd=diag_sms3(j,m)
541 DO k=1,6
542 dd = dd + frbe2m6(j,k,mid)
543 ENDDO
544 diag_sms3(j,m)=dd
545 END DO
546 ENDDO
547C
548 END DO
549C-----------------
550 RETURN
551 END
552
553!||====================================================================
554!|| sms_rbe_1 ../engine/source/ams/sms_rbe2.F
555!||--- called by ------------------------------------------------------
556!|| sms_rbe_cnds ../engine/source/ams/sms_rbe2.F
557!||--- calls -----------------------------------------------------
558!|| cdi_bcn ../engine/source/constraints/general/rbe2/rbe2_imp0.F
559!|| sum_6_float ../engine/source/system/parit.f
560!||====================================================================
561 SUBROUTINE sms_rbe_1(NSL ,ISL ,X ,A ,AR ,
562 1 MS ,IN ,WEIGHT,JT ,FS6 ,
563 2 M ,IRAD ,ISK ,SKEW )
564C-----------------------------------------------
565C I m p l i c i t T y p e s
566C-----------------------------------------------
567#include "implicit_f.inc"
568C-----------------------------------------------
569C C o m m o n B l o c k s
570C-----------------------------------------------
571#include "param_c.inc"
572C-----------------------------------------------
573C D u m m y A r g u m e n t s
574C-----------------------------------------------
575 INTEGER NSL,ISL(*),WEIGHT(*),JT(3),M,IRAD,ISK
576C REAL
577 my_real
578 . x(3,*), a(3,*), ar(3,*), ms(*), in(*), skew(lskew,*)
579 double precision
580 . fs6(3,6)
581C-----------------------------------------------
582C L o c a l V a r i a b l e s
583C-----------------------------------------------
584 INTEGER I, J, N, K, IJT, JT1(3), IC
585C REAL
586 my_real
587 . F1(NSL), F2(NSL), F3(NSL), RX, RY, RZ, CDT(9)
588C-----------------------------------------------
589 IF ((JT(1)+JT(2)+JT(3))>0) THEN
590 ijt=1
591 ELSE
592 ijt=0
593 ENDIF
594
595 IF(isk<=1)THEN
596C
597C Remontee des forces
598 DO k = 1, 6
599 fs6(1,k) = zero
600 fs6(2,k) = zero
601 fs6(3,k) = zero
602 END DO
603C
604 DO i=1,nsl
605 n = isl(i)
606 IF(weight(n)==1) THEN
607 f1(i)=jt(1)*a(1,n)
608 f2(i)=jt(2)*a(2,n)
609 f3(i)=jt(3)*a(3,n)
610 ELSE
611 f1(i)=zero
612 f2(i)=zero
613 f3(i)=zero
614 ENDIF
615 ENDDO
616C
617 ELSE ! IF(ISK<=1)THEN
618 ic = jt(1)*100+jt(2)*10+jt(3)
619 CALL cdi_bcn(ic ,skew(1,isk) ,jt ,cdt ,jt1 )
620 DO i=1,nsl
621 n = isl(i)
622 rx = a(1,n)*weight(n)
623 ry = a(2,n)*weight(n)
624 rz = a(3,n)*weight(n)
625 f1(i) = cdt(1)*rx+cdt(2)*ry+cdt(3)*rz
626 f2(i) = cdt(4)*rx+cdt(5)*ry+cdt(6)*rz
627 f3(i) = cdt(7)*rx+cdt(8)*ry+cdt(9)*rz
628 ENDDO
629 END IF
630C
631C Traitement Parith/ON avant echange
632C
633 CALL sum_6_float(1 ,nsl ,f1, fs6(1,1), 3)
634 CALL sum_6_float(1 ,nsl ,f2, fs6(2,1), 3)
635 CALL sum_6_float(1 ,nsl ,f3, fs6(3,1), 3)
636
637 RETURN
638 END
639
640!||====================================================================
641!|| sms_rbe_2 ../engine/source/ams/sms_rbe2.F
642!||--- called by ------------------------------------------------------
643!|| sms_rbe_cnds ../engine/source/ams/sms_rbe2.F
644!||====================================================================
645 SUBROUTINE sms_rbe_2(NSL ,ISL ,X ,A ,AR ,
646 1 JT ,M ,IRAD ,ISK ,SKEW )
647C-----------------------------------------------
648C I m p l i c i t T y p e s
649C-----------------------------------------------
650#include "implicit_f.inc"
651C-----------------------------------------------
652C C o m m o n B l o c k s
653C-----------------------------------------------
654#include "param_c.inc"
655C-----------------------------------------------
656C D u m m y A r g u m e n t s
657C-----------------------------------------------
658 INTEGER NSL, ISL(*), JT(3), M, IRAD, ISK
659C REAL
660 my_real
661 . x(3,*), a(3,*), ar(3,*), skew(lskew,*)
662C-----------------------------------------------
663C L o c a l V a r i a b l e s
664C-----------------------------------------------
665 INTEGER I, J, N, IJT
666C REAL
667 my_real
668 . AAX, AAY, AAZ
669C-----------------------------------------------
670 IF ((JT(1)+JT(2)+JT(3))>0) THEN
671 IJT=1
672 else
673 ijt=0
674 ENDIF
675C
676C Reset 2nd membre
677 IF(isk<=1)THEN
678 DO i=1,nsl
679 n = isl(i)
680 IF(jt(3)>0)THEN
681 a(3,n) =zero
682 ENDIF
683 IF(jt(2)>0)THEN
684 a(2,n) =zero
685 ENDIF
686 IF(jt(1)>0)THEN
687 a(1,n) =zero
688 ENDIF
689 END DO
690 ELSE
691 DO i=1,nsl
692 n = isl(i)
693 aax =jt(1)*(skew(1,isk)*a(1,n)+skew(2,isk)*a(2,n)+skew(3,isk)*a(3,n))
694 aay =jt(2)*(skew(4,isk)*a(1,n)+skew(5,isk)*a(2,n)+skew(6,isk)*a(3,n))
695 aaz =jt(3)*(skew(7,isk)*a(1,n)+skew(8,isk)*a(2,n)+skew(9,isk)*a(3,n))
696 a(1,n) =a(1,n)-aax*skew(1,isk)-aay*skew(4,isk)-aaz*skew(7,isk)
697 a(2,n) =a(2,n)-aax*skew(2,isk)-aay*skew(5,isk)-aaz*skew(8,isk)
698 a(3,n) =a(3,n)-aax*skew(3,isk)-aay*skew(6,isk)-aaz*skew(9,isk)
699 ENDDO
700 END IF
701C
702 RETURN
703 END
704
705!||====================================================================
706!|| sms_rbe_3 ../engine/source/ams/sms_rbe2.F
707!||--- called by ------------------------------------------------------
708!|| sms_rbe_accl ../engine/source/ams/sms_rbe2.F
709!||====================================================================
710 SUBROUTINE sms_rbe_3(NSL ,ISL ,R ,A ,PREC_SMS3,
711 1 JT ,M ,IRAD ,ISK ,SKEW )
712C-----------------------------------------------
713C I m p l i c i t T y p e s
714C-----------------------------------------------
715#include "implicit_f.inc"
716C-----------------------------------------------
717C C o m m o n B l o c k s
718C-----------------------------------------------
719#include "param_c.inc"
720C-----------------------------------------------
721C D u m m y A r g u m e n t s
722C-----------------------------------------------
723 INTEGER NSL,ISL(*),JT(3),M,IRAD, ISK
724C REAL
725 my_real
726 . R(3,*), A(3,*), SKEW(LSKEW,*), PREC_SMS3(3,*)
727C-----------------------------------------------
728C L o c a l V a r i a b l e s
729C-----------------------------------------------
730 INTEGER I, J, N, IJT
731C REAL
732 my_real
733 . AAX, AAY, AAZ, DAX, DAY, DAZ
734C-----------------------------------------------
735 IF ((JT(1)+JT(2)+JT(3))>0) THEN
736 IJT=1
737 else
738 ijt=0
739 ENDIF
740C
741C retablit accelerations secnds == main
742C (le terme de rotation AR x MN est dj pass au 2nd membre)
743 IF(isk<=1)THEN
744 IF(jt(3)>0)a(3,m)=r(3,m)*prec_sms3(3,m)
745 IF(jt(2)>0)a(2,m)=r(2,m)*prec_sms3(2,m)
746 IF(jt(1)>0)a(1,m)=r(1,m)*prec_sms3(1,m)
747 DO i=1,nsl
748 n = isl(i)
749 IF(jt(3)>0)THEN
750 a(3,n) =a(3,m)
751 ENDIF
752 IF(jt(2)>0)THEN
753 a(2,n) =a(2,m)
754 ENDIF
755 IF(jt(1)>0)THEN
756 a(1,n) =a(1,m)
757 ENDIF
758 END DO
759 ELSE
760 DO i=1,nsl
761 n = isl(i)
762 dax =a(1,n)-a(1,m)
763 day =a(2,n)-a(2,m)
764 daz =a(3,n)-a(3,m)
765 aax =jt(1)*(skew(1,isk)*dax+skew(2,isk)*day+skew(3,isk)*daz)
766 aay =jt(2)*(skew(4,isk)*dax+skew(5,isk)*day+skew(6,isk)*daz)
767 aaz =jt(3)*(skew(7,isk)*dax+skew(8,isk)*day+skew(9,isk)*daz)
768 a(1,n) =a(1,n)-aax*skew(1,isk)-aay*skew(4,isk)-aaz*skew(7,isk)
769 a(2,n) =a(2,n)-aax*skew(2,isk)-aay*skew(5,isk)-aaz*skew(8,isk)
770 a(3,n) =a(3,n)-aax*skew(3,isk)-aay*skew(6,isk)-aaz*skew(9,isk)
771 ENDDO
772 END IF
773
774 RETURN
775 END
776
777
778!||====================================================================
779!|| sms_rbe_4 ../engine/source/ams/sms_rbe2.F
780!||--- called by ------------------------------------------------------
781!|| sms_rbe_corr ../engine/source/ams/sms_rbe2.F
782!||====================================================================
783 SUBROUTINE sms_rbe_4(NSL ,ISL ,V ,W ,MS ,
784 1 JT ,M ,IRAD ,ISK ,SKEW )
785C-----------------------------------------------
786C I m p l i c i t T y p e s
787C-----------------------------------------------
788#include "implicit_f.inc"
789C-----------------------------------------------
790C C o m m o n B l o c k s
791C-----------------------------------------------
792#include "param_c.inc"
793C-----------------------------------------------
794C D u m m y A r g u m e n t s
795C-----------------------------------------------
796 INTEGER NSL,ISL(*),JT(3),M,IRAD, ISK
797C REAL
798 my_real
799 . V(3,*), W(3,*), MS(*), SKEW(LSKEW,*)
800C-----------------------------------------------
801C L o c a l V a r i a b l e s
802C-----------------------------------------------
803 INTEGER I, J, N, IJT
804C REAL
805 my_real
806 . AAX, AAY, AAZ, DAX, DAY, DAZ
807C-----------------------------------------------
808 IF ((JT(1)+JT(2)+JT(3))>0) THEN
809 IJT=1
810 else
811 ijt=0
812 ENDIF
813C
814C Corrige W=[M]V (MS(N)*V(..,N) already counted into MS(M)*V(..,M))
815 IF(isk<=1)THEN
816 DO i=1,nsl
817 n = isl(i)
818 IF(jt(3)>0)THEN
819 w(3,n) =w(3,n)-ms(n)*v(3,n)
820 ENDIF
821 IF(jt(2)>0)THEN
822 w(2,n) =w(2,n)-ms(n)*v(2,n)
823 ENDIF
824 IF(jt(1)>0)THEN
825 w(1,n) =w(1,n)-ms(n)*v(1,n)
826 ENDIF
827 END DO
828 ELSE
829 DO i=1,nsl
830 n = isl(i)
831 dax =ms(n)*v(1,n)
832 day =ms(n)*v(2,n)
833 daz =ms(n)*v(3,n)
834 aax =jt(1)*(skew(1,isk)*dax+skew(2,isk)*day+skew(3,isk)*daz)
835 aay =jt(2)*(skew(4,isk)*dax+skew(5,isk)*day+skew(6,isk)*daz)
836 aaz =jt(3)*(skew(7,isk)*dax+skew(8,isk)*day+skew(9,isk)*daz)
837 w(1,n) =w(1,n)-aax*skew(1,isk)-aay*skew(4,isk)-aaz*skew(7,isk)
838 w(2,n) =w(2,n)-aax*skew(2,isk)-aay*skew(5,isk)-aaz*skew(8,isk)
839 w(3,n) =w(3,n)-aax*skew(3,isk)-aay*skew(6,isk)-aaz*skew(9,isk)
840 ENDDO
841 END IF
842
843 RETURN
844 END
845
846!||====================================================================
847!|| sms_rbe_5 ../engine/source/ams/sms_rbe2.F
848!||--- called by ------------------------------------------------------
849!|| sms_diag_rbe2 ../engine/source/ams/sms_rbe2.F
850!|| sms_rbe_prec ../engine/source/ams/sms_rbe2.F
851!||--- calls -----------------------------------------------------
852!|| cdi_bcn ../engine/source/constraints/general/rbe2/rbe2_imp0.F
853!|| sum_6_float ../engine/source/system/parit.F
854!||====================================================================
855 SUBROUTINE sms_rbe_5(NSL ,ISL ,DIAG_SMS3,MS ,WEIGHT,
856 1 JT ,FS6 ,M ,IRAD ,ISK ,
857 2 SKEW )
858C-----------------------------------------------
859C I m p l i c i t T y p e s
860C-----------------------------------------------
861#include "implicit_f.inc"
862C-----------------------------------------------
863C C o m m o n B l o c k s
864C-----------------------------------------------
865#include "param_c.inc"
866C-----------------------------------------------
867C D u m m y A r g u m e n t s
868C-----------------------------------------------
869 INTEGER NSL,ISL(*),WEIGHT(*),JT(3),M,IRAD, ISK
870C REAL
871 my_real
872 . DIAG_SMS3(3,*), MS(*), SKEW(LSKEW,*)
873 DOUBLE PRECISION
874 . FS6(3,6)
875C-----------------------------------------------
876C L o c a l V a r i a b l e s
877C-----------------------------------------------
878 INTEGER I, J, N, K, IJT, JT1(3), IC
879C REAL
880 my_real
881 . F1(NSL), F2(NSL), F3(NSL), RX, RY, RZ, CDT(9)
882C-----------------------------------------------
883 IF ((JT(1)+JT(2)+JT(3))>0) THEN
884 IJT=1
885 else
886 ijt=0
887 ENDIF
888
889C
890C Remontee des diagonales
891 DO k = 1, 6
892 fs6(1,k) = zero
893 fs6(2,k) = zero
894 fs6(3,k) = zero
895 END DO
896C
897 IF(isk<=1)THEN
898 DO i=1,nsl
899 n = isl(i)
900 IF(weight(n)==1) THEN
901 f1(i)=jt(1)*(diag_sms3(1,n)-ms(n))
902 f2(i)=jt(2)*(diag_sms3(2,n)-ms(n))
903 f3(i)=jt(3)*(diag_sms3(3,n)-ms(n))
904 ELSE
905 f1(i)=zero
906 f2(i)=zero
907 f3(i)=zero
908 ENDIF
909 ENDDO
910C
911 ELSE ! IF(ISK<=1)THEN
912 ic = jt(1)*100+jt(2)*10+jt(3)
913 CALL cdi_bcn(ic ,skew(1,isk) ,jt ,cdt ,jt1 )
914 DO i=1,nsl
915 n = isl(i)
916 rx = (diag_sms3(1,n)-ms(n))*weight(n)
917 ry = (diag_sms3(2,n)-ms(n))*weight(n)
918 rz = (diag_sms3(3,n)-ms(n))*weight(n)
919 f1(i) = cdt(1)*rx+cdt(2)*ry+cdt(3)*rz
920 f2(i) = cdt(4)*rx+cdt(5)*ry+cdt(6)*rz
921 f3(i) = cdt(7)*rx+cdt(8)*ry+cdt(9)*rz
922 ENDDO
923 END IF
924C
925C
926C Traitement Parith/ON avant echange
927C
928 CALL sum_6_float(1 ,nsl ,f1, fs6(1,1), 3)
929 CALL sum_6_float(1 ,nsl ,f2, fs6(2,1), 3)
930 CALL sum_6_float(1 ,nsl ,f3, fs6(3,1), 3)
931
932 RETURN
933 END
934
935!||====================================================================
936!|| sms_rbe2_s ../engine/source/ams/sms_rbe2.F
937!||--- called by ------------------------------------------------------
938!|| sms_rbe_cnds ../engine/source/ams/sms_rbe2.F
939!||====================================================================
940 SUBROUTINE sms_rbe2_s(IRBE2 ,ISIZE,A ,WEIGHT,F6 ,
941 1 NMRBE2,IH )
942C-----------------------------------------------
943C I m p l i c i t T y p e s
944C-----------------------------------------------
945#include "implicit_f.inc"
946C-----------------------------------------------
947C C o m m o n B l o c k s
948C-----------------------------------------------
949#include "com04_c.inc"
950#include "param_c.inc"
951C-----------------------------------------------
952C D u m m y A r g u m e n t s
953C-----------------------------------------------
954 INTEGER IRBE2(NRBE2L,*),ISIZE, WEIGHT(*),NMRBE2,IH
955 my_real A(ISIZE,*)
956 DOUBLE PRECISION F6(ISIZE,6,*)
957C-----------------------------------------------
958C L o c a l V a r i a b l e s
959C-----------------------------------------------
960 INTEGER I, J, K, N, NS ,NML, IAD,JJ,M,MID,IROT,IRAD
961C======================================================================|
962#include "vectorize.inc"
963 DO n=1,nrbe2
964 IF (ih/=irbe2(9,n)) cycle
965 m = irbe2(3,n)
966 mid = irbe2(6,n)
967 irad = irbe2(11,n)
968 IF (mid<0) cycle
969 DO k=1,6
970 DO j=1,isize
971 a(j,m) = a(j,m)+ f6(j,k,mid)
972 ENDDO
973 ENDDO
974 ENDDO
975C---
976 RETURN
977 END
978
my_real
#define my_real
Definition cppsort.cpp:32
spmd_max_i
subroutine spmd_max_i(n)
Definition imp_spmd.F:1362
prerbe2
subroutine prerbe2(irbe2, jt, jr)
Definition kinchk.F:1974
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
cdi_bcn
subroutine cdi_bcn(ict, skew, jt, kt, jt1)
Definition rbe2_imp0.F:1012
rbe2f
subroutine rbe2f(nsl, isl, x, a, ar, ms, in, weight, jt, jr, f6, m6, stifn, stifr, stif6, stir6, m, irad)
Definition rbe2f.F:135
sms_rbe_cnds
subroutine sms_rbe_cnds(irbe2, lrbe2, x, a, ar, ms, in, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:274
sms_rbe2_s
subroutine sms_rbe2_s(irbe2, isize, a, weight, f6, nmrbe2, ih)
Definition sms_rbe2.F:942
sms_rbe_5
subroutine sms_rbe_5(nsl, isl, diag_sms3, ms, weight, jt, fs6, m, irad, isk, skew)
Definition sms_rbe2.F:858
sms_rbe_2
subroutine sms_rbe_2(nsl, isl, x, a, ar, jt, m, irad, isk, skew)
Definition sms_rbe2.F:647
sms_rbe_accl
subroutine sms_rbe_accl(irbe2, lrbe2, r, a, prec_sms3, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:367
sms_diag_rbe2
subroutine sms_diag_rbe2(irbe2, lrbe2, nodxi_sms, jad_sms, jdi_sms, lt_sms, nmrbe2, ms, diag_sms, prec_sms3, iad_rbe2, fr_rbe2m, weight, skew)
Definition sms_rbe2.F:35
sms_rbe_4
subroutine sms_rbe_4(nsl, isl, v, w, ms, jt, m, irad, isk, skew)
Definition sms_rbe2.F:785
sms_rbe_1
subroutine sms_rbe_1(nsl, isl, x, a, ar, ms, in, weight, jt, fs6, m, irad, isk, skew)
Definition sms_rbe2.F:564
sms_rbe_prec
subroutine sms_rbe_prec(irbe2, lrbe2, diag_sms, ms, diag_sms3, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:470
sms_rbe_3
subroutine sms_rbe_3(nsl, isl, r, a, prec_sms3, jt, m, irad, isk, skew)
Definition sms_rbe2.F:712
sms_rbe_corr
subroutine sms_rbe_corr(irbe2, lrbe2, v, w, ms, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
Definition sms_rbe2.F:418
sms_rbe2_nodxi
subroutine sms_rbe2_nodxi(irbe2, lrbe2, nodxi_sms)
Definition sms_rbe2.F:209
spmd_exch_rbe2_sms
subroutine spmd_exch_rbe2_sms(a, iad_m, fr_m, lcomm, isize)
Definition spmd_exch_rbe2_sms.F:35