OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_rbe2.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "param_c.inc"
#include "vectorize.inc"

Go to the source code of this file.

Functions/Subroutines

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)
subroutine sms_rbe2_nodxi (irbe2, lrbe2, nodxi_sms)
subroutine sms_rbe_cnds (irbe2, lrbe2, x, a, ar, ms, in, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
subroutine sms_rbe_accl (irbe2, lrbe2, r, a, prec_sms3, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
subroutine sms_rbe_corr (irbe2, lrbe2, v, w, ms, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
subroutine sms_rbe_prec (irbe2, lrbe2, diag_sms, ms, diag_sms3, skew, weight, iad_rbe2, fr_rbe2m, nmrbe2)
subroutine sms_rbe_1 (nsl, isl, x, a, ar, ms, in, weight, jt, fs6, m, irad, isk, skew)
subroutine sms_rbe_2 (nsl, isl, x, a, ar, jt, m, irad, isk, skew)
subroutine sms_rbe_3 (nsl, isl, r, a, prec_sms3, jt, m, irad, isk, skew)
subroutine sms_rbe_4 (nsl, isl, v, w, ms, jt, m, irad, isk, skew)
subroutine sms_rbe_5 (nsl, isl, diag_sms3, ms, weight, jt, fs6, m, irad, isk, skew)
subroutine sms_rbe2_s (irbe2, isize, a, weight, f6, nmrbe2, ih)

Function/Subroutine Documentation

◆ sms_diag_rbe2()

subroutine sms_diag_rbe2 ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) nodxi_sms,
integer, dimension(*) jad_sms,
integer, dimension(*) jdi_sms,
lt_sms,
integer nmrbe2,
ms,
diag_sms,
prec_sms3,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer, dimension(*) weight,
skew )

Definition at line 31 of file sms_rbe2.F.

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
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
sms_rbe_5
subroutine sms_rbe_5(nsl, isl, diag_sms3, ms, weight, jt, fs6, m, irad, isk, skew)
Definition sms_rbe2.F:858
spmd_exch_rbe2_sms
subroutine spmd_exch_rbe2_sms(a, iad_m, fr_m, lcomm, isize)
Definition spmd_exch_rbe2_sms.F:35

◆ sms_rbe2_nodxi()

subroutine sms_rbe2_nodxi ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) nodxi_sms )

Definition at line 207 of file sms_rbe2.F.

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

◆ sms_rbe2_s()

subroutine sms_rbe2_s ( integer, dimension(nrbe2l,*) irbe2,
integer isize,
a,
integer, dimension(*) weight,
double precision, dimension(isize,6,*) f6,
integer nmrbe2,
integer ih )

Definition at line 940 of file sms_rbe2.F.

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

◆ sms_rbe_1()

subroutine sms_rbe_1 ( integer nsl,
integer, dimension(*) isl,
x,
a,
ar,
ms,
in,
integer, dimension(*) weight,
integer, dimension(3) jt,
double precision, dimension(3,6) fs6,
integer m,
integer irad,
integer isk,
skew )

Definition at line 561 of file sms_rbe2.F.

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
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

◆ sms_rbe_2()

subroutine sms_rbe_2 ( integer nsl,
integer, dimension(*) isl,
x,
a,
ar,
integer, dimension(3) jt,
integer m,
integer irad,
integer isk,
skew )

Definition at line 645 of file sms_rbe2.F.

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

◆ sms_rbe_3()

subroutine sms_rbe_3 ( integer nsl,
integer, dimension(*) isl,
r,
a,
prec_sms3,
integer, dimension(3) jt,
integer m,
integer irad,
integer isk,
skew )

Definition at line 710 of file sms_rbe2.F.

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

◆ sms_rbe_4()

subroutine sms_rbe_4 ( integer nsl,
integer, dimension(*) isl,
v,
w,
ms,
integer, dimension(3) jt,
integer m,
integer irad,
integer isk,
skew )

Definition at line 783 of file sms_rbe2.F.

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

◆ sms_rbe_5()

subroutine sms_rbe_5 ( integer nsl,
integer, dimension(*) isl,
diag_sms3,
ms,
integer, dimension(*) weight,
integer, dimension(3) jt,
double precision, dimension(3,6) fs6,
integer m,
integer irad,
integer isk,
skew )

Definition at line 855 of file sms_rbe2.F.

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

◆ sms_rbe_accl()

subroutine sms_rbe_accl ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
r,
a,
prec_sms3,
skew,
integer, dimension(*) weight,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer nmrbe2 )

Definition at line 364 of file sms_rbe2.F.

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
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_cnds()

subroutine sms_rbe_cnds ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
x,
a,
ar,
ms,
in,
skew,
integer, dimension(*) weight,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer nmrbe2 )

Definition at line 270 of file sms_rbe2.F.

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
sms_rbe2_s
subroutine sms_rbe2_s(irbe2, isize, a, weight, f6, nmrbe2, ih)
Definition sms_rbe2.F:942
sms_rbe_2
subroutine sms_rbe_2(nsl, isl, x, a, ar, jt, m, irad, isk, skew)
Definition sms_rbe2.F:647
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_corr()

subroutine sms_rbe_corr ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
v,
w,
ms,
skew,
integer, dimension(*) weight,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer nmrbe2 )

Definition at line 415 of file sms_rbe2.F.

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
sms_rbe_4
subroutine sms_rbe_4(nsl, isl, v, w, ms, jt, m, irad, isk, skew)
Definition sms_rbe2.F:785

◆ sms_rbe_prec()

subroutine sms_rbe_prec ( integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
diag_sms,
ms,
diag_sms3,
skew,
integer, dimension(*) weight,
integer, dimension(*) iad_rbe2,
integer, dimension(*) fr_rbe2m,
integer nmrbe2 )

Definition at line 467 of file sms_rbe2.F.

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