OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
rbe3f.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!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
25!||--- called by ------------------------------------------------------
26!|| resol ../engine/source/engine/resol.F
27!||--- calls -----------------------------------------------------
28!|| asp2_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.f
29!|| ass_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
30!|| dmi_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
31!|| foat_to_6_float ../engine/source/system/parit.F
32!|| prerbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
33!|| prerbe3p ../engine/source/constraints/general/rbe3/rbe3f.F
34!|| rbe3f ../engine/source/constraints/general/rbe3/rbe3f.F
35!|| rbe3pen_init ../engine/source/constraints/general/rbe3/rbe3pen_init.F90
36!|| rbe3poff ../engine/source/constraints/general/rbe3/rbe3f.F
37!|| spmd_exch_rbe3 ../engine/source/mpi/kinematic_conditions/spmd_exch_rbe3.F
38!|| spmd_exch_rbe3_pon ../engine/source/mpi/kinematic_conditions/spmd_exch_rbe3_pon.F
39!|| zero1 ../engine/source/system/zero.F
40!||--- uses -----------------------------------------------------
41!|| h3d_mod ../engine/share/modules/h3d_mod.F
42!|| nodal_arrays_mod ../common_source/modules/nodal_arrays.F90
43!|| rbe3_mod ../common_source/modules/constraints/rbe3_mod.F90
44!|| rbe3pen_init_mod ../engine/source/constraints/general/rbe3/rbe3pen_init.F90
45!||====================================================================
46 SUBROUTINE rbe3t1(RBE3 ,NODES ,SKEW ,
47 * DMAST ,ADM ,DINERT,
48 * ADI ,H3D_DATA , DT1 ,
49 * TT ,IMPL_S )
50C-----------------------------------------------
51C M o d u l e s
52C-----------------------------------------------
53 USE h3d_mod
54 USE rbe3_mod
55 use nodal_arrays_mod
56 use rbe3pen_init_mod, only: rbe3pen_init
57C-----------------------------------------------
58C I m p l i c i t T y p e s
59C-----------------------------------------------
60#include "implicit_f.inc"
61C-----------------------------------------------
62C C o m m o n B l o c k s
63C-----------------------------------------------
64#include "com01_c.inc"
65#include "com04_c.inc"
66#include "param_c.inc"
67#include "tabsiz_c.inc"
68#include "parit_c.inc"
69#include "task_c.inc"
70C-----------------------------------------------
71C D u m m y A r g u m e n t s
72C-----------------------------------------------
73C REAL
74 my_real skew(*) !< Skew Array
75 my_real dmast,dt1,tt
76 my_real adm(*)
77 my_real dinert
78 my_real adi(*) !< Animation buffer
79 INTEGER, INTENT(IN) :: IMPL_S
80 TYPE (RBE3_),INTENT(INOUT) :: RBE3
81 TYPE (H3D_DATABASE) :: H3D_DATA
82 TYPE(nodal_arrays_), INTENT(INOUT) :: NODES
83C-----------------------------------------------
84C L o c a l V a r i a b l e s
85C-----------------------------------------------
86 INTEGER I, J, N, MAX_M,JT(3,NRBE3),JR(3,NRBE3),IERR,NMT,
87 . IADA,IADMS,IADFN,IADAR,IADIN,IADFR,IADM0,IADI0,IADL,
88 . IPA,IPMS,IPFN,IPAR,IPIN,IPFR,NMP,IADLP,NS,NML,ICOM,
89 . iadlp1,iadm1,iadi1,nmt0,iadmp(slrbe3/2),iml(slrbe3/2),ipen
90 INTEGER IROTG_LOC !< Local Max of IROT Flags keep for compatibility
91C======================================================================|
92 I7KGLO = 1
93 nmt0 = slrbe3/2
94 CALL prerbe3(rbe3%IRBE3 ,max_m , irotg_loc,jt ,jr )
95 !
96 icom = rbe3%mpi%IAD_RBE3(nspmd+1)-rbe3%mpi%IAD_RBE3(1) !< Flag for SPMD communication
97
98 IF (nmt0>0) THEN
99 IF (ncycle==0) CALL rbe3pen_init(nodes%X,nodes%MS,nodes%IN,nodes%STIFN ,nodes%STIFR,numnod,rbe3,tt,impl_s)
100 CALL prerbe3p(rbe3%IRBE3 ,rbe3%LRBE3 ,iadmp ,iml , nmt )
101 iada=1
102 iadms=iada+3*nmt
103 iadfn=iadms+nmt
104 IF (rbe3%IROTG>0) THEN
105 iadar=iadfn+nmt
106 iadin=iadar+3*nmt
107 iadfr=iadin+nmt
108 ELSE
109 iadar=iadfn
110 iadin=iadar
111 iadfr=iadin
112 ENDIF
113 iadl=iadfr+nmt
114C ALLOCATE(RSUM(IADL),STAT=IERR)
115 CALL zero1(rbe3%RRBE3,iadl)
116 CALL rbe3f(rbe3%IRBE3 ,rbe3%LRBE3 ,nodes%X ,nodes%A ,nodes%AR ,
117 1 nodes%MS ,nodes%IN ,rbe3%FRBE3,skew ,nodes%WEIGHT,
118 2 nodes%STIFN ,nodes%STIFR ,jt ,jr ,rbe3%IROTG ,
119 3 max_m ,rbe3%RRBE3(iada),rbe3%RRBE3(iadar) ,rbe3%RRBE3(iadms),
120 4 rbe3%RRBE3(iadin),rbe3%RRBE3(iadfn),rbe3%RRBE3(iadfr),nmt0 ,
121 5 iadmp ,rbe3%pen,nodes%V,nodes%VR,nmt ,dt1 ,iroddl )
122C
123 IF (nspmd>1.AND.iparit==0) THEN
124 CALL rbe3poff(rbe3%IRBE3 ,rbe3%LRBE3 ,nodes%A ,nodes%MS ,nodes%WEIGHT,
125 1 nodes%AR ,nodes%IN ,nodes%STIFN,nodes%STIFR )
126 END IF
127 IF (iparit>0) THEN
128 nmp = 6*nmt
129 ipa=1
130 ipms=ipa+3*nmp
131 ipfn=ipms+nmp
132 IF (rbe3%IROTG>0) THEN
133 ipar=ipfn+nmp
134 ipin=ipar+3*nmp
135 ipfr=ipin+nmp
136 ELSE
137 ipar=ipfn
138 ipin=ipar
139 ipfr=ipin
140 ENDIF
141 iadlp=ipfr+nmp
142C version spmd p/on
143C RSUM_PON=ZERO
144 CALL foat_to_6_float(1 ,nmt*3 ,rbe3%RRBE3(iada) ,rbe3%RRBE3_PON(ipa) )
145 CALL foat_to_6_float(1 ,nmt ,rbe3%RRBE3(iadms),rbe3%RRBE3_PON(ipms))
146 CALL foat_to_6_float(1 ,nmt ,rbe3%RRBE3(iadfn),rbe3%RRBE3_PON(ipfn))
147 IF (rbe3%IROTG>0) THEN
148 CALL foat_to_6_float(1 ,nmt*3 ,rbe3%RRBE3(iadar) ,rbe3%RRBE3_PON(ipar))
149 CALL foat_to_6_float(1 ,nmt ,rbe3%RRBE3(iadin),rbe3%RRBE3_PON(ipin))
150 CALL foat_to_6_float(1 ,nmt ,rbe3%RRBE3(iadfr),rbe3%RRBE3_PON(ipfr))
151 ENDIF
152 IF (icom>0) THEN
153 CALL spmd_exch_rbe3_pon(
154 . rbe3%RRBE3_PON(ipa),rbe3%RRBE3_PON(ipar),rbe3%RRBE3_PON(ipms),rbe3%RRBE3_PON(ipin),
155 . rbe3%RRBE3_PON(ipfn),rbe3%RRBE3_PON(ipfr),rbe3%mpi%FR_RBE3MP,rbe3%mpi%IAD_RBE3 ,
156 . rbe3%mpi%IAD_RBE3(nspmd+1),rbe3%irotg_sz,rbe3%IROTG)
157 ENDIF
158C
159C Routine assemblage parith/ON
160C
161 CALL asp2_rbe3(rbe3%IRBE3 ,rbe3%LRBE3 ,nodes%A ,nodes%AR ,nodes%MS ,
162 1 nodes%IN,nodes%WEIGHT,nodes%STIFN ,nodes%STIFR ,rbe3%RRBE3_PON(ipa),
163 2 rbe3%RRBE3_PON(ipar),rbe3%RRBE3_PON(ipms),rbe3%RRBE3_PON(ipin),
164 3 rbe3%RRBE3_PON(ipfn),rbe3%RRBE3_PON(ipfr),nmt ,iml ,rbe3%IROTG)
165 ELSE
166C-----------------A-=A*W+DA-----
167 CALL ass_rbe3(rbe3%IRBE3 ,rbe3%LRBE3 ,nodes%A ,nodes%AR ,nodes%MS ,
168 1 nodes%IN ,nodes%WEIGHT,nodes%STIFN ,nodes%STIFR ,rbe3%RRBE3(iada),
169 2 rbe3%RRBE3(iadar) ,rbe3%RRBE3(iadms), rbe3%RRBE3(iadin),
170 3 rbe3%RRBE3(iadfn) ,rbe3%RRBE3(iadfr),nmt ,iml ,rbe3%IROTG)
171 IF (iparit==0.AND.icom>0) THEN
172 CALL spmd_exch_rbe3(
173 . nodes%A ,nodes%AR ,nodes%MS ,nodes%IN ,nodes%STIFN,
174 . nodes%STIFR,rbe3%mpi%FR_RBE3 ,rbe3%mpi%IAD_RBE3 ,rbe3%mpi%IAD_RBE3(nspmd+1),rbe3%irotg_sz,
175 . rbe3%IROTG)
176 ENDIF
177 END IF
178C
179c--------------calcul dms,diner---
180 iadm0= nmt0*6 + 1
181 iadi0= iadm0 + nmt0
182 CALL dmi_rbe3(nmt ,rbe3%LRBE3 ,rbe3%FRBE3(iadm0),rbe3%FRBE3(iadi0),
183 1 rbe3%RRBE3(iadms) ,rbe3%RRBE3(iadin) ,dmast ,adm ,
184 2 dinert,adi ,rbe3%IROTG ,rbe3%IRBE3 ,nodes%MS ,
185 3 nodes%IN ,nodes%WEIGHT,iadmp ,h3d_data)
186C DEALLOCATE(RSUM)
187 END IF ! IF (NMT>0)
188C
189C--- reset of secnd nodes forces is necessary w/AMS
190 DO n=1,nrbe3
191 ns = rbe3%IRBE3(3,n)
192 ipen= rbe3%IRBE3(9,n)
193 IF(ns/=0.AND.ipen<=0) THEN
194 IF (nodes%WEIGHT(ns)/=0) THEN
195 DO j = 1,3
196 IF(jt(j,n)/=0)nodes%A(j,ns)=zero
197 END DO
198 ENDIF
199 END IF
200 END DO
201C---
202 RETURN
203 END
204!||====================================================================
205!|| rbe3poff ../engine/source/constraints/general/rbe3/rbe3f.F
206!||--- called by ------------------------------------------------------
207!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
208!||====================================================================
209 SUBROUTINE rbe3poff(IRBE3 ,LRBE3 ,A ,MS ,WEIGHT,
210 1 AR ,IN ,STIFN,STIFR )
211C-----------------------------------------------
212C I m p l i c i t T y p e s
213C-----------------------------------------------
214#include "implicit_f.inc"
215C-----------------------------------------------
216C D u m m y A r g u m e n t s
217C-----------------------------------------------
218 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*)
219C REAL
220 my_real
221 . A(3,*),AR(3,*),MS(*), IN(*),STIFN(*),STIFR(*)
222C-----------------------------------------------
223C C o m m o n B l o c k s
224C-----------------------------------------------
225#include "com04_c.inc"
226#include "param_c.inc"
227C-----------------------------------------------
228C L o c a l V a r i a b l e s
229C-----------------------------------------------
230 INTEGER I, J, N, NML, IAD,IROT,M,NS
231C-----------------------------------------------
232 DO N=1,nrbe3
233 iad = irbe3(1,n)
234 nml = irbe3(5,n)
235 ns = irbe3(3,n)
236 irot =irbe3(6,n)
237#include "vectorize.inc"
238 DO i=iad+1,iad+nml
239 m = lrbe3(i)
240 a(1,m) = a(1,m)*weight(m)
241 a(2,m) = a(2,m)*weight(m)
242 a(3,m) = a(3,m)*weight(m)
243 ms(m) = ms(m)*weight(m)
244 stifn(m)= stifn(m)*weight(m)
245 ENDDO
246 IF (irot>0) THEN
247#include "vectorize.inc"
248 DO i=iad+1,iad+nml
249 m = lrbe3(i)
250 ar(1,m) = ar(1,m)*weight(m)
251 ar(2,m) = ar(2,m)*weight(m)
252 ar(3,m) = ar(3,m)*weight(m)
253 in(m) = in(m)*weight(m)
254 stifr(m) = stifr(m)*weight(m)
255 ENDDO
256 ENDIF
257 ENDDO
258C-----------
259 RETURN
260 END
261
262!||====================================================================
263!|| rbe3f ../engine/source/constraints/general/rbe3/rbe3f.F
264!||--- called by ------------------------------------------------------
265!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
266!||--- calls -----------------------------------------------------
267!|| mfac_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
268!|| rbe3cl ../engine/source/constraints/general/rbe3/rbe3f.F
269!|| rbe3f_pen ../engine/source/constraints/general/rbe3/rbe3f_pen.F90
270!||--- uses -----------------------------------------------------
271!|| rbe3_mod ../common_source/modules/constraints/rbe3_mod.F90
272!|| rbe3f_pen_mod ../engine/source/constraints/general/rbe3/rbe3f_pen.F90
273!||====================================================================
274 SUBROUTINE rbe3f(IRBE3 ,LRBE3 ,X ,A ,AR ,
275 1 MS ,IN ,FRBE3,SKEW ,WEIGHT,
276 2 STIFN ,STIFR ,JT ,JR ,IROTG ,
277 3 MAX_M ,AM ,ARM ,MSM ,INM ,
278 4 STIFNM,STIFRM,NMT0 ,IADMP ,PEN ,
279 5 V ,VR ,NMT ,DT1 ,IRODDL)
280C-----------------------------------------------
281C M o d u l e s
282C-----------------------------------------------
283 USE rbe3_mod
284 USE rbe3f_pen_mod, only : rbe3f_pen
285C-----------------------------------------------
286C I m p l i c i t T y p e s
287C-----------------------------------------------
288#include "implicit_f.inc"
289C-----------------------------------------------
290C C o m m o n B l o c k s
291C-----------------------------------------------
292#include "com04_c.inc"
293#include "param_c.inc"
294C-----------------------------------------------
295C D u m m y A r g u m e n t s
296C-----------------------------------------------
297 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*)
298 INTEGER MAX_M,IROTG,JT(3,*),JR(3,*),NMT0,IADMP(*)
299 INTEGER, INTENT(IN) :: NMT ! dimension of AM,STIFNM...
300 INTEGER, INTENT(IN) :: IRODDL
301C REAL
302 my_real
303 . X(3,*), A(3,*), AR(3,*), MS(*), IN(*), FRBE3(*),SKEW(*),
304 . STIFN(*) ,STIFR(*), AM(3,*), ARM(3,*), MSM(*), INM(*),
305 . STIFNM(*) ,STIFRM(*), V(3,*), VR(3,*)
306 my_real, INTENT(IN) :: dt1
307 TYPE (RBE3_pen), INTENT(INOUT) :: PEN
308C-----------------------------------------------
309C L o c a l V a r i a b l e s
310C-----------------------------------------------
311 INTEGER I, J, N, NS ,NML, IAD,JJ,IROT,IADS,NM,NN,K,IMOD,IADF,
312 . IPEN,N_P,ipr
313C REAL
314 my_real
315 . fns(3),mns(3),mss(3),ins(3),stn(3),str(3),fsum,msum,
316 . fmax,smax,mmax,sfd,smd,f2max
317 my_real,
318 . DIMENSION(:,:,:),ALLOCATABLE :: fdstnb ,mdstnb
319
320C======================================================================|
321 iads = nmt0
322 IF (max_m>0) THEN
323 ALLOCATE(fdstnb(3,6,max_m))
324 IF (irotg>0) ALLOCATE(mdstnb(3,6,max_m))
325 END IF
326 DO n=1,nrbe3
327 iad = irbe3(1,n)
328 ns = irbe3(3,n)
329 nml = irbe3(5,n)
330 irot =irbe3(6,n)
331 imod =irbe3(8,n)
332 ipen =irbe3(9,n)
333 IF (ns==0.OR.ipen>0) cycle
334 IF (weight(ns)==1) THEN
335 CALL rbe3cl(lrbe3(iad+1),lrbe3(iads+iad+1),ns ,x ,
336 . frbe3(6*iad+1),skew ,nml ,irot ,fdstnb ,
337 . mdstnb ,irbe3(2,n))
338 DO j = 1,3
339 nn = jt(j,n)*weight(ns)
340 fns(j) = a(j,ns)*nn
341 mss(j) = ms(ns)*nn/3
342 stn(j) = stifn(ns)*nn
343 ENDDO
344C---not to add supplementary mass globally
345 IF (imod <=3) THEN
346 CALL mfac_rbe3(fdstnb,mdstnb,nml ,irotg,sfd ,smd)
347 DO i=1,nml
348 k = iadmp(iad+i)
349 DO j = 1,3
350 fsum = fdstnb(j,1,i)+fdstnb(j,2,i)+fdstnb(j,3,i)
351 msm(k) = msm(k)+abs(fsum)*mss(j)*sfd
352 ENDDO
353 ENDDO
354 ELSEIF (imod ==4) THEN
355 DO i=1,nml
356 k = iadmp(iad+i)
357 iadf =6*(iad+i-1)
358 DO j = 1,3
359 msm(k) = msm(k)+frbe3(iadf+j)*mss(j)
360 ENDDO
361 ENDDO
362 END IF
363 DO i=1,nml
364 k = iadmp(iad+i)
365 DO j = 1,3
366 am(1,k) = am(1,k)+fdstnb(1,j,i)*fns(j)
367 am(2,k) = am(2,k)+fdstnb(2,j,i)*fns(j)
368 am(3,k) = am(3,k)+fdstnb(3,j,i)*fns(j)
369 ENDDO
370C-----IMOD=4 STIFNM might be over_estimated but safe
371 smax = zero
372 DO j = 1,3
373 fmax=abs(fdstnb(j,1,i))+abs(fdstnb(j,2,i))+abs(fdstnb(j,3,i))
374 f2max=fdstnb(j,1,i)*fdstnb(j,1,i)+fdstnb(j,2,i)*fdstnb(j,2,i)+
375 . fdstnb(j,3,i)*fdstnb(j,3,i)
376 smax = max(smax,max(fmax,f2max)*stn(j))
377 ENDDO
378 stifnm(k) = stifnm(k)+smax
379 ENDDO
380 IF ((jr(1,n)+jr(2,n)+jr(3,n))>0) THEN
381 DO j = 1,3
382 nn = jr(j,n)*weight(ns)
383 mns(j) = ar(j,ns)*nn
384 ins(j) = in(ns)*nn/3
385 str(j) = stifr(ns)*nn
386 ENDDO
387 DO i=1,nml
388 k = iadmp(iad+i)
389 DO j = 1,3
390 am(1,k) = am(1,k)+fdstnb(1,j+3,i)*mns(j)
391 am(2,k) = am(2,k)+fdstnb(2,j+3,i)*mns(j)
392 am(3,k) = am(3,k)+fdstnb(3,j+3,i)*mns(j)
393 ENDDO
394 smax = zero
395 DO j = 1,3
396C FSUM = FDSTNB(J,J+3,I)
397 fsum = fdstnb(j,4,i)+fdstnb(j,5,i)+fdstnb(j,6,i)
398 msm(k) =msm(k)+abs(fsum)*ins(j)
399 fmax=abs(fdstnb(j,4,i))+abs(fdstnb(j,5,i))+abs(fdstnb(j,6,i))
400 f2max=fdstnb(j,4,i)*fdstnb(j,4,i)+fdstnb(j,5,i)*fdstnb(j,5,i)+
401 . fdstnb(j,6,i)*fdstnb(j,6,i)
402 smax = max(smax,max(fmax,f2max)*str(j))
403 ENDDO
404 stifnm(k) = stifnm(k)+smax
405 ENDDO
406 ENDIF
407 IF (irot>0) THEN
408 DO i=1,nml
409 k = iadmp(iad+i)
410 DO j = 1,3
411 arm(1,k) = arm(1,k)+mdstnb(1,j,i)*fns(j)
412 arm(2,k) = arm(2,k)+mdstnb(2,j,i)*fns(j)
413 arm(3,k) = arm(3,k)+mdstnb(3,j,i)*fns(j)
414 ENDDO
415 smax = zero
416 DO j = 1,3
417C MSUM = MDSTNB(J,J,I)
418 msum = mdstnb(j,1,i)+mdstnb(j,2,i)+mdstnb(j,3,i)
419 IF (imod /=4) inm(k) = inm(k)+abs(msum)*mss(j)
420 mmax=abs(mdstnb(j,1,i))+abs(mdstnb(j,2,i))+abs(mdstnb(j,3,i))
421 smax = max(smax,mmax*stn(j))
422 ENDDO
423 stifrm(k) = stifrm(k)+smax
424 ENDDO
425 IF ((jr(1,n)+jr(2,n)+jr(3,n))>0) THEN
426 IF (imod <=3) THEN
427 DO i=1,nml
428 k = iadmp(iad+i)
429 DO j = 1,3
430 msum = mdstnb(j,4,i)+mdstnb(j,5,i)+mdstnb(j,6,i)
431 inm(k) = inm(k)+abs(msum)*ins(j)*smd
432 ENDDO
433 ENDDO
434 ELSEIF (imod ==4) THEN
435 DO i=1,nml
436 k = iadmp(iad+i)
437 iadf =6*(iad+i-1)
438 DO j = 1,3
439 inm(k) = inm(k)+frbe3(iadf+j+3)*ins(j)
440 ENDDO
441 ENDDO
442 END IF
443 DO i=1,nml
444 k = iadmp(iad+i)
445 DO j = 1,3
446 arm(1,k) = arm(1,k)+mdstnb(1,j+3,i)*mns(j)
447 arm(2,k) = arm(2,k)+mdstnb(2,j+3,i)*mns(j)
448 arm(3,k) = arm(3,k)+mdstnb(3,j+3,i)*mns(j)
449 ENDDO
450 smax = zero
451 DO j = 1,3
452 mmax=abs(mdstnb(j,4,i))+abs(mdstnb(j,5,i))+abs(mdstnb(j,6,i))
453 smax = max(smax,mmax*str(j))
454 ENDDO
455 stifrm(k) = stifrm(k)+smax
456 ENDDO
457 ENDIF
458 ENDIF
459C MS(NS) = ZERO
460 stifn(ns) = em20
461 IF ((jr(1,n)+jr(2,n)+jr(3,n))>0) stifr(ns) = em20
462 ENDIF
463! END IF ! IF (NS>0) THEN
464 ENDDO
465! penalty formulation
466 n_p = 0
467 DO n=1,nrbe3
468 iad = irbe3(1,n)
469 ns = irbe3(3,n)
470 nml = irbe3(5,n)
471 irot =irbe3(6,n)
472 imod =irbe3(8,n)
473 ipen =irbe3(9,n)
474 IF (ns==0.OR.ipen<=0) cycle
475 IF (weight(ns)==1) THEN !STIFNM(k),STIFN(NS),AM(1:3,k)
476 n_p = n_p +1
477 CALL rbe3f_pen(
478 . ns ,nmt0 ,numnod ,nmt ,
479 . nml ,lrbe3(iad+1),lrbe3(iads+iad+1),iadmp(iad+1),
480 . a ,ar ,am ,arm ,
481 . stifn ,stifr ,stifnm ,stifrm ,
482 . v ,vr ,frbe3(6*iad+1),x ,
483 . lskew ,numskw ,skew ,
484 . pen%RRBE3PEN_F(1,n_p) ,pen%RRBE3PEN_STF(1,n_p) ,
485 . pen%RRBE3PEN_FAC(n_p) ,pen%RRBE3PEN_VI(n_p) ,
486 . pen%RRBE3PEN_M(1,n_p) ,dt1 ,in ,
487 . iroddl )
488 ENDIF
489 ENDDO
490C
491 DEALLOCATE(fdstnb)
492 IF (irotg>0) DEALLOCATE(mdstnb)
493C---
494 RETURN
495 END
496!||====================================================================
497!|| ass_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
498!||--- called by ------------------------------------------------------
499!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
500!||====================================================================
501 SUBROUTINE ass_rbe3(IRBE3 ,LRBE3 ,A ,AR ,MS ,
502 1 IN ,WEIGHT,STIFN ,STIFR ,DA ,
503 2 DAR ,DMS ,DIN ,DSTIFN,DSTIFR,
504 3 NMT ,IML ,IROTG)
505C-----------------------------------------------
506C I m p l i c i t T y p e s
507C-----------------------------------------------
508#include "implicit_f.inc"
509C-----------------------------------------------
510C C o m m o n B l o c k s
511C-----------------------------------------------
512#include "com04_c.inc"
513#include "param_c.inc"
514C-----------------------------------------------
515C D u m m y A r g u m e n t s
516C-----------------------------------------------
517 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*),NMT ,IML(*),IROTG
518C REAL
519 my_real
520 . A(3,*), AR(3,*), MS(*), IN(*),
521 . STIFN(*) ,STIFR(*), DA(3,*), DAR(3,*), DMS(*), DIN(*),
522 . DSTIFN(*) ,DSTIFR(*)
523C-----------------------------------------------
524C L o c a l V a r i a b l e s
525C-----------------------------------------------
526 INTEGER I, J, N, NS ,NML, IAD,JJ,IROT,M,IPEN
527C REAL
528C======================================================================|
529#include "vectorize.inc"
530 DO i=1,nmt
531 m = iml(i)
532 a(1,m) = a(1,m) + da(1,i)
533 a(2,m) = a(2,m) + da(2,i)
534 a(3,m) = a(3,m) + da(3,i)
535 ms(m) = ms(m) + dms(i)
536 stifn(m)= stifn(m) + dstifn(i)
537 ENDDO
538 IF (irotg>0) THEN
539 DO i=1,nmt
540 m = iml(i)
541 ar(1,m) = ar(1,m) + dar(1,i)
542 ar(2,m) = ar(2,m) + dar(2,i)
543 ar(3,m) = ar(3,m) + dar(3,i)
544 in(m) = in(m) + din(i)
545 stifr(m) = stifr(m) + dstifr(i)
546 ENDDO
547 ENDIF
548 RETURN
549C
550 DO n=1,nrbe3
551 iad = irbe3(1,n)
552 ns = irbe3(3,n)
553 nml = irbe3(5,n)
554 irot= irbe3(6,n)
555 ipen= irbe3(9,n)
556 IF (ns==0.OR.weight(ns)==0.OR.ipen>0) cycle
557 DO i=iad+1,iad+nml
558 m = lrbe3(i)
559 a(1,m) = a(1,m) + da(1,i)
560 a(2,m) = a(2,m) + da(2,i)
561 a(3,m) = a(3,m) + da(3,i)
562 ms(m) = ms(m) + dms(i)
563 stifn(m)= stifn(m) + dstifn(i)
564 ENDDO
565 IF (irot>0) THEN
566 DO i=iad+1,iad+nml
567 m = lrbe3(i)
568 ar(1,m) = ar(1,m) + dar(1,i)
569 ar(2,m) = ar(2,m) + dar(2,i)
570 ar(3,m) = ar(3,m) + dar(3,i)
571 in(m) = in(m) + din(i)
572 stifr(m) = stifr(m) + dstifr(i)
573 ENDDO
574 ENDIF
575 ENDDO
576C---
577 RETURN
578 END
579!||====================================================================
580!|| asp0_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
581!||====================================================================
582 SUBROUTINE asp0_rbe3(IRBE3 ,LRBE3 ,A ,AR ,MS ,
583 1 IN ,WEIGHT,STIFN ,STIFR ,DA ,
584 2 DAR ,DMS ,DIN ,DSTIFN,DSTIFR)
585C-----------------------------------------------
586C I m p l i c i t T y p e s
587C-----------------------------------------------
588#include "implicit_f.inc"
589C-----------------------------------------------
590C C o m m o n B l o c k s
591C-----------------------------------------------
592#include "com04_c.inc"
593#include "param_c.inc"
594C-----------------------------------------------
595C D u m m y A r g u m e n t s
596C-----------------------------------------------
597 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*)
598C REAL
599 my_real
600 . A(3,*), AR(3,*), MS(*), IN(*),
601 . STIFN(*) ,STIFR(*), DA(3,*), DAR(3,*), DMS(*), DIN(*),
602 . DSTIFN(*) ,DSTIFR(*)
603C-----------------------------------------------
604C L o c a l V a r i a b l e s
605C-----------------------------------------------
606 INTEGER I, J, N, NS ,NML, IAD,JJ,IROT,M,ITAG(NUMNOD)
607C REAL
608C======================================================================|
609 DO N =1,numnod
610 itag(n) = 0
611 END DO
612 DO n=1,nrbe3
613 iad = irbe3(1,n)
614 ns = irbe3(3,n)
615 nml = irbe3(5,n)
616 irot =irbe3(6,n)
617#include "vectorize.inc"
618 DO i=iad+1,iad+nml
619 m = lrbe3(i)
620 IF (itag(m)==0) THEN
621 weight(i) = 1
622 ELSE
623 weight(i) = 0
624 END IF
625 itag(m)=1
626 ENDDO
627 ENDDO
628C
629 DO n=1,nrbe3
630 iad = irbe3(1,n)
631 ns = irbe3(3,n)
632 nml = irbe3(5,n)
633 irot =irbe3(6,n)
634#include "vectorize.inc"
635 DO i=iad+1,iad+nml
636 m = lrbe3(i)
637 da(1,i) = a(1,m)*weight(i) + da(1,i)
638 da(2,i) = a(2,m)*weight(i) + da(2,i)
639 da(3,i) = a(3,m)*weight(i) + da(3,i)
640 dms(i) = ms(m)*weight(i)+dms(i)
641 dstifn(i) = stifn(m)*weight(i)+dstifn(i)
642 ENDDO
643 IF (irot>0) THEN
644#include "vectorize.inc"
645 DO i=iad+1,iad+nml
646 m = lrbe3(i)
647 dar(1,i) = ar(1,m)*weight(i) + dar(1,i)
648 dar(2,i) = ar(2,m)*weight(i) + dar(2,i)
649 dar(3,i) = ar(3,m)*weight(i) + dar(3,i)
650 din(i) = in(m)*weight(i)+din(i)
651 dstifr(i) = stifr(m)*weight(i)+dstifr(i)
652 ENDDO
653 ENDIF
654 ENDDO
655C---
656 RETURN
657 END
658!||====================================================================
659!|| asp1_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
660!||====================================================================
661 SUBROUTINE asp1_rbe3(IRBE3 ,LRBE3 ,A ,AR ,MS ,
662 1 IN ,WEIGHT,STIFN ,STIFR ,DA ,
663 2 DAR ,DMS ,DIN ,DSTIFN,DSTIFR)
664C-----------------------------------------------
665C I m p l i c i t T y p e s
666C-----------------------------------------------
667#include "implicit_f.inc"
668C-----------------------------------------------
669C C o m m o n B l o c k s
670C-----------------------------------------------
671#include "com04_c.inc"
672#include "param_c.inc"
673C-----------------------------------------------
674C D u m m y A r g u m e n t s
675C-----------------------------------------------
676 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*)
677C REAL
678 my_real
679 . a(3,*), ar(3,*), ms(*), in(*),stifn(*) ,stifr(*)
680 double precision
681 . da(6,3,*), dar(6,3,*), dms(6,*),
682 . din(6,*),dstifn(6,*) ,dstifr(6,*)
683C-----------------------------------------------
684C L o c a l V a r i a b l e s
685C-----------------------------------------------
686 INTEGER I, J, N, NS ,NML, IAD,JJ,IROT,M
687C REAL
688C======================================================================|
689 DO N=1,nrbe3
690 iad = irbe3(1,n)
691 ns = irbe3(3,n)
692 nml = irbe3(5,n)
693 irot =irbe3(6,n)
694#include "vectorize.inc"
695 DO i=iad+1,iad+nml
696 m = lrbe3(i)
697 a(1,m) = zero
698 a(2,m) = zero
699 a(3,m) = zero
700 ms(m) = zero
701 stifn(m) = zero
702 ENDDO
703 IF (irot>0) THEN
704#include "vectorize.inc"
705 DO i=iad+1,iad+nml
706 m = lrbe3(i)
707 ar(1,m) = zero
708 ar(2,m) = zero
709 ar(3,m) = zero
710 in(m) = zero
711 stifr(m) = zero
712 ENDDO
713 ENDIF
714 ENDDO
715C
716 DO n=1,nrbe3
717 iad = irbe3(1,n)
718 ns = irbe3(3,n)
719 nml = irbe3(5,n)
720 irot =irbe3(6,n)
721#include "vectorize.inc"
722 DO i=iad+1,iad+nml
723 m = lrbe3(i)
724 DO j=1,6
725 a(1,m) = a(1,m)+ da(j,1,i)
726 a(2,m) = a(2,m)+ da(j,2,i)
727 a(3,m) = a(3,m)+ da(j,3,i)
728 ms(m) = ms(m)+dms(j,i)
729 stifn(m) = stifn(m)+dstifn(j,i)
730 ENDDO
731 ENDDO
732 IF (irot>0) THEN
733#include "vectorize.inc"
734 DO i=iad+1,iad+nml
735 m = lrbe3(i)
736 DO j=1,6
737 ar(1,m) = ar(1,m)+ dar(j,1,i)
738 ar(2,m) = ar(2,m)+ dar(j,2,i)
739 ar(3,m) = ar(3,m)+ dar(j,3,i)
740 in(m) = in(m)+din(j,i)
741 stifr(m) = stifr(m)+dstifr(j,i)
742 ENDDO
743 ENDDO
744 ENDIF
745 ENDDO
746C---
747 RETURN
748 END
749!||====================================================================
750!|| asp2_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
751!||--- called by ------------------------------------------------------
752!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
753!||====================================================================
754 SUBROUTINE asp2_rbe3(IRBE3 ,LRBE3 ,A ,AR ,MS ,
755 1 IN ,WEIGHT,STIFN ,STIFR ,DA ,
756 2 DAR ,DMS ,DIN ,DSTIFN,DSTIFR,
757 3 NMT ,IML ,IROTG )
758C-----------------------------------------------
759C I m p l i c i t T y p e s
760C-----------------------------------------------
761#include "implicit_f.inc"
762C-----------------------------------------------
763C C o m m o n B l o c k s
764C-----------------------------------------------
765#include "param_c.inc"
766C-----------------------------------------------
767C D u m m y A r g u m e n t s
768C-----------------------------------------------
769 INTEGER IRBE3(NRBE3L,*),LRBE3(*),WEIGHT(*),IML(*) ,NMT ,IROTG
770C REAL
771 my_real
772 . A(3,*), AR(3,*), MS(*), IN(*),STIFN(*) ,STIFR(*)
773 double precision
774 . da(6,3,*), dar(6,3,*), dms(6,*),
775 . din(6,*),dstifn(6,*) ,dstifr(6,*)
776C-----------------------------------------------
777C L o c a l V a r i a b l e s
778C-----------------------------------------------
779 INTEGER I, J, N, NS ,NML, IAD,JJ,M
780C REAL
781 my_real
782 . MS1,AX,AY,AZ
783C======================================================================|
784#include "vectorize.inc"
785 DO I=1,nmt
786 m = iml(i)
787 ax = zero
788 ay = zero
789 az = zero
790 DO j=1,6
791 ax = ax + da(j,1,i)
792 ay = ay + da(j,2,i)
793 az = az + da(j,3,i)
794 ms(m) = ms(m)+dms(j,i)
795C MS1 = MS1 + DMS(J,I)
796 stifn(m) = stifn(m)+dstifn(j,i)
797 ENDDO
798 a(1,m) = a(1,m)+ ax
799 a(2,m) = a(2,m)+ ay
800 a(3,m) = a(3,m)+ az
801 ENDDO
802 IF (irotg>0) THEN
803 DO i=1,nmt
804 m = iml(i)
805 ax = zero
806 ay = zero
807 az = zero
808 DO j=1,6
809 ax = ax + dar(j,1,i)
810 ay = ay + dar(j,2,i)
811 az = az + dar(j,3,i)
812 in(m) = in(m)+din(j,i)
813 stifr(m) = stifr(m)+dstifr(j,i)
814 ENDDO
815 ar(1,m) = ar(1,m)+ ax
816 ar(2,m) = ar(2,m)+ ay
817 ar(3,m) = ar(3,m)+ az
818 ENDDO
819 ENDIF
820C---
821 RETURN
822 END
823!||====================================================================
824!|| dmi_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
825!||--- called by ------------------------------------------------------
826!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
827!||--- uses -----------------------------------------------------
828!|| h3d_mod ../engine/share/modules/h3d_mod.F
829!||====================================================================
830 SUBROUTINE dmi_rbe3(NMT ,LRBE3 ,MS0 ,IN0 ,DMS ,
831 1 DIN ,DMAST ,ADM ,DINERT,ADI ,
832 2 IROTG ,IRBE3 ,MS ,IN ,WEIGHT,
833 3 IADMP ,H3D_DATA )
834C-----------------------------------------------
835C M o d u l e s
836C-----------------------------------------------
837 USE h3d_mod
838C-----------------------------------------------
839C I m p l i c i t T y p e s
840C-----------------------------------------------
841#include "implicit_f.inc"
842C-----------------------------------------------
843C C o m m o n B l o c k s
844C-----------------------------------------------
845#include "com01_c.inc"
846#include "com04_c.inc"
847#include "scr14_c.inc"
848#include "scr16_c.inc"
849#include "param_c.inc"
850C-----------------------------------------------
851C D u m m y A r g u m e n t s
852C-----------------------------------------------
853 INTEGER NMT,IRBE3(NRBE3L,*),LRBE3(*),IROTG,WEIGHT(*),IADMP(*)
854C REAL
855 my_real
856 . MS0(*), IN0(*),DMS(*), DIN(*),
857 . DMAST ,ADM(*) ,DINERT,ADI(*),MS(*),IN(*)
858 TYPE (H3D_DATABASE) :: H3D_DATA
859C-----------------------------------------------
860C L o c a l V a r i a b l e s
861C-----------------------------------------------
862 INTEGER I, J ,M,N,NS,NML,IAD,K,IROT,IPEN
863C REAL
864 my_real
865 . MNS,DMAS0
866C======================================================================|
867C----accumulated secnd masses---
868 MNS= zero
869#include "vectorize.inc"
870 DO n=1,nrbe3
871 iad = irbe3(1,n)
872 ns = irbe3(3,n)
873 nml = irbe3(5,n)
874 ipen= irbe3(9,n)
875 IF (ns>0.AND.ipen<=0) THEN
876 IF (weight(ns)==1) THEN
877 IF (nml>0) mns= mns+ms(ns)*weight(ns)
878 ms(ns) = zero
879 IF (iroddl/=0) in(ns) = zero
880 ENDIF
881 ENDIF
882 ENDDO
883C
884 dmas0 = -mns
885 DO j=1,nmt
886 dmas0 = dmas0 + dms(j)
887 ENDDO
888 dmast = dmast + max(zero,dmas0)
889C
890 IF(irotg>0) THEN
891 DO j=1,nmt
892 dinert = dinert + din(j)
893 ENDDO
894 ENDIF
895C-------attention now for ANIM, ADM contains MS(NS),
896C-------output only when real added mass happened: debug usage
897 IF (dmas0>em10) THEN
898 IF(anim_n(2)+outp_n(2)+h3d_data%N_SCAL_DMAS >0) THEN
899#include "vectorize.inc"
900 DO n=1,nrbe3
901 iad = irbe3(1,n)
902 ns = irbe3(3,n)
903 nml = irbe3(5,n)
904 ipen= irbe3(9,n)
905 IF (ns>0.AND.ipen<=0) THEN
906 IF (weight(ns)==1) THEN
907 DO j = 1,nml
908 m = lrbe3(iad+j)
909 k = iadmp(iad+j)
910 adm(m) = adm(m)+dms(k)/max(em20,ms0(iad+j))
911 ENDDO
912 ENDIF
913 ENDIF
914 ENDDO
915 ENDIF
916 IF(anim_n(12)+outp_n(3)>0+h3d_data%N_SCAL_DINER .AND.irotg>0) THEN
917#include "vectorize.inc"
918 DO n=1,nrbe3
919 iad = irbe3(1,n)
920 ns = irbe3(3,n)
921 nml = irbe3(5,n)
922 irot= irbe3(6,n)
923 ipen= irbe3(9,n)
924 IF (ns>0.AND.irot>0.AND.weight(ns)==1.AND.ipen<=0) THEN
925 DO j = 1,nml
926 m = lrbe3(iad+j)
927 k = iadmp(iad+j)
928 adi(m) = adi(m)+din(k)/max(em20,in0(iad+j))
929 ENDDO
930 ENDIF
931 ENDDO
932 ENDIF
933 END IF !(DMAS0>EM10) THEN
934C---
935 RETURN
936 END
937!||====================================================================
938!|| prerbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
939!||--- called by ------------------------------------------------------
940!|| rbe3_imp0 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
941!|| rbe3_impd ../engine/source/constraints/general/rbe3/rbe3v.F
942!|| rbe3_impi ../engine/source/constraints/general/rbe3/rbe3_imp0.F
943!|| rbe3_impr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
944!|| rbe3_impr2 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
945!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
946!|| rbe3v ../engine/source/constraints/general/rbe3/rbe3v.F
947!|| sms_rbe3_nodxi ../engine/source/ams/sms_rbe3.F
948!|| sms_rbe3_prec ../engine/source/ams/sms_rbe3.F
949!|| sms_rbe3t1 ../engine/source/ams/sms_rbe3.F
950!|| sms_rbe3t2 ../engine/source/ams/sms_rbe3.F
951!||====================================================================
952 SUBROUTINE prerbe3(IRBE3 ,MAX_M , IROTG,JT ,JR )
953C-----------------------------------------------
954C I m p l i c i t T y p e s
955C-----------------------------------------------
956#include "implicit_f.inc"
957C-----------------------------------------------
958C C o m m o n B l o c k s
959C-----------------------------------------------
960#include "com04_c.inc"
961#include "param_c.inc"
962C-----------------------------------------------
963C D u m m y A r g u m e n t s
964C-----------------------------------------------
965 INTEGER IRBE3(NRBE3L,*),MAX_M , IROTG,JT(3,*) ,JR(3,*)
966C REAL
967C-----------------------------------------------
968C L o c a l V a r i a b l e s
969C-----------------------------------------------
970 INTEGER I, J, N,NML,IC,ICT,ICR,IROT
971C======================================================================|
972 MAX_M=0
973 irotg=0
974 DO n=1,nrbe3
975 nml = irbe3(5,n)
976 irot =irbe3(6,n)
977 max_m=max(max_m,nml) ! add if (ipen==0)
978 irotg=max(irotg,irot)
979 ic=irbe3(4,n)
980 ict=ic/512
981 icr=(ic-512*(ict))/64
982 DO j =1,3
983 jt(j,n)=0
984 jr(j,n)=0
985 ENDDO
986 SELECT CASE (ict)
987 CASE(1)
988 jt(3,n)=1
989 CASE(2)
990 jt(2,n)=1
991 CASE(3)
992 jt(2,n)=1
993 jt(3,n)=1
994 CASE(4)
995 jt(1,n)=1
996 CASE(5)
997 jt(1,n)=1
998 jt(3,n)=1
999 CASE(6)
1000 jt(1,n)=1
1001 jt(2,n)=1
1002 CASE(7)
1003 jt(1,n)=1
1004 jt(2,n)=1
1005 jt(3,n)=1
1006 END SELECT
1007 SELECT CASE (icr)
1008 CASE(1)
1009 jr(3,n)=1
1010 CASE(2)
1011 jr(2,n)=1
1012 CASE(3)
1013 jr(2,n)=1
1014 jr(3,n)=1
1015 CASE(4)
1016 jr(1,n)=1
1017 CASE(5)
1018 jr(1,n)=1
1019 jr(3,n)=1
1020 CASE(6)
1021 jr(1,n)=1
1022 jr(2,n)=1
1023 CASE(7)
1024 jr(1,n)=1
1025 jr(2,n)=1
1026 jr(3,n)=1
1027 END SELECT
1028 ENDDO
1029C---
1030 RETURN
1031 END
1032!||====================================================================
1033!|| prerbe3fr ../engine/source/constraints/general/rbe3/rbe3f.f
1034!||--- called by ------------------------------------------------------
1035!|| diag_int ../engine/source/mpi/implicit/imp_fri.f
1036!|| fr_u2dd ../engine/source/mpi/implicit/imp_fri.F
1037!|| imp3_a2b ../engine/source/airbag/monv_imp0.F
1038!|| imp3_u2x ../engine/source/airbag/monv_imp0.F
1039!|| upd_fr ../engine/source/mpi/implicit/imp_fri.F
1040!|| upd_kml ../engine/source/mpi/implicit/imp_fri.F
1041!|| upd_ksl ../engine/source/mpi/implicit/imp_fri.F
1042!|| updk_mv ../engine/source/airbag/monv_imp0.F
1043!||====================================================================
1044 SUBROUTINE prerbe3fr(IRBE3 ,N ,JT ,JR )
1045C-----------------------------------------------
1046C I m p l i c i t T y p e s
1047C-----------------------------------------------
1048#include "implicit_f.inc"
1049C-----------------------------------------------
1050C C o m m o n B l o c k s
1051C-----------------------------------------------
1052#include "param_c.inc"
1053C-----------------------------------------------
1054C D u m m y A r g u m e n t s
1055C-----------------------------------------------
1056 INTEGER IRBE3(NRBE3L,*),JT(3) ,JR(3),N
1057C REAL
1058C-----------------------------------------------
1059C L o c a l V a r i a b l e s
1060C-----------------------------------------------
1061 INTEGER I, J, NML,IC,ICT,ICR
1062C======================================================================|
1063 IC=irbe3(4,n)
1064 ict=ic/512
1065 icr=(ic-512*(ict))/64
1066 DO j =1,3
1067 jt(j)=0
1068 jr(j)=0
1069 ENDDO
1070 SELECT CASE (ict)
1071 CASE(1)
1072 jt(3)=1
1073 CASE(2)
1074 jt(2)=1
1075 CASE(3)
1076 jt(2)=1
1077 jt(3)=1
1078 CASE(4)
1079 jt(1)=1
1080 CASE(5)
1081 jt(1)=1
1082 jt(3)=1
1083 CASE(6)
1084 jt(1)=1
1085 jt(2)=1
1086 CASE(7)
1087 jt(1)=1
1088 jt(2)=1
1089 jt(3)=1
1090 END SELECT
1091 SELECT CASE (icr)
1092 CASE(1)
1093 jr(3)=1
1094 CASE(2)
1095 jr(2)=1
1096 CASE(3)
1097 jr(2)=1
1098 jr(3)=1
1099 CASE(4)
1100 jr(1)=1
1101 CASE(5)
1102 jr(1)=1
1103 jr(3)=1
1104 CASE(6)
1105 jr(1)=1
1106 jr(2)=1
1107 CASE(7)
1108 jr(1)=1
1109 jr(2)=1
1110 jr(3)=1
1111 END SELECT
1112C---
1113 RETURN
1114 END
1115!||====================================================================
1116!|| rbe3cl ../engine/source/constraints/general/rbe3/rbe3f.F
1117!||--- called by ------------------------------------------------------
1118!|| id_mvini ../engine/source/airbag/monv_imp0.F
1119!|| iddl_int ../engine/source/mpi/implicit/imp_fri.F
1120!|| rbe3_fr0 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1121!|| rbe3_imp0 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1122!|| rbe3_impd ../engine/source/constraints/general/rbe3/rbe3v.F
1123!|| rbe3_impi ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1124!|| rbe3_impr1 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1125!|| rbe3_impr2 ../engine/source/constraints/general/rbe3/rbe3_imp0.F
1126!|| rbe3_mint ../engine/source/implicit/imp_int_k.F
1127!|| rbe3f ../engine/source/constraints/general/rbe3/rbe3f.F
1128!|| rbe3v ../engine/source/constraints/general/rbe3/rbe3v.F
1129!|| sms_rbe3_1 ../engine/source/ams/sms_rbe3.F
1130!|| sms_rbe3t2 ../engine/source/ams/sms_rbe3.F
1131!||--- calls -----------------------------------------------------
1132!|| ancmsg ../engine/source/output/message/message.F
1133!|| invert ../engine/source/constraints/general/rbe3/rbe3f.F
1134!|| rbe3uf ../engine/source/constraints/general/rbe3/rbe3f.F
1135!|| rbe3um ../engine/source/constraints/general/rbe3/rbe3f.F
1136!|| zero1 ../engine/source/system/zero.F
1137!||--- uses -----------------------------------------------------
1138!|| message_mod ../engine/share/message_module/message_mod.F
1139!||====================================================================
1140 SUBROUTINE rbe3cl(INRBE3 ,ILRBE3 ,NS ,XYZ ,FRBE3 ,
1141 . SKEW ,NG ,IROT ,FDSTNB ,MDSTNB ,ID )
1142C-----------------------------------------------
1143C M o d u l e s
1144C-----------------------------------------------
1145 USE message_mod
1146C-----------------------------------------------
1147C I m p l i c i t T y p e s
1148C-----------------------------------------------
1149#include "implicit_f.inc"
1150C-----------------------------------------------
1151C C o m m o n B l o c k s
1152C-----------------------------------------------
1153#include "task_c.inc"
1154#include "param_c.inc"
1155#include "scr07_c.inc"
1156C-----------------------------------------------
1157C D u m m y A r g u m e n t s
1158C-----------------------------------------------
1159 INTEGER INRBE3(*),ILRBE3(*),NG, NS,IROT,ID
1160C REAL
1161 my_real
1162 . xyz(3,*), frbe3(6,*), skew(lskew,*),fdstnb(3,6,*), mdstnb(3,6,*)
1163C-----------------------------------------------
1164C L o c a l V a r i a b l e s
1165C-----------------------------------------------
1166 INTEGER I, J, K,N, M ,NML, IAD,JJ,KG,NSNGLR,IELSUB,IERR,ng1
1167C REAL
1168 my_real
1169 * TW(3,NG), RW(3,NG),
1170 * FUFXLC(3,NG), FUFYLC(3,NG), FUFZLC(3,NG),
1171 * FUMXLC(3,NG), FUMYLC(3,NG), FUMZLC(3,NG),
1172 * MXLC(3,NG), MYLC(3,NG), MZLC(3,NG),
1173 * FUFX(3,NG), FUFY(3,NG), FUFZ(3,NG),
1174 * MUFX(3,NG), MUFY(3,NG), MUFZ(3,NG),
1175 * FUMX(3,NG), FUMY(3,NG), FUMZ(3,NG),
1176 * MX(3,NG), MY(3,NG), MZ(3,NG),
1177 * MUMX(3,NG), MUMY(3,NG), MUMZ(3,NG),
1178 * EL(3,3,NG)
1179 my_real
1180 * denfx, denfy, denfz, denmx, denmy, denmz,
1181 * refpt(3), cgmx(3), cgmy(3), cgmz(3), averef,
1182 * tfufx(3), tfufy(3), tfufz(3),
1183 * tmufx(3), tmufy(3), tmufz(3),
1184 * tfumx(3), tfumy(3), tfumz(3),
1185 * tmumx(3), tmumy(3), tmumz(3),
1186 * a(6,6), c(6,6), t(3,3)
1187C
1188C INITIALIZATION
1189C
1190 IF (ng==0) RETURN
1191 CALL zero1(fdstnb,3*ng*6)
1192 IF (irot>0) CALL zero1(mdstnb,3*ng*6)
1193 CALL zero1(a,36)
1194 CALL zero1(c,36)
1195 CALL zero1(cgmx,3)
1196 CALL zero1(cgmy,3)
1197 CALL zero1(cgmz,3)
1198 ierr = 0
1199C
1200 refpt(1) = xyz(1,ns)
1201 refpt(2) = xyz(2,ns)
1202 refpt(3) = xyz(3,ns)
1203 DO k = 1, ng
1204 DO i = 1, 3
1205 tw(i,k) = frbe3(i,k)
1206 rw(i,k) = frbe3(i+3,k)
1207 ENDDO
1208 ENDDO
1209C
1210C ERROR OUT IF RBE3 ELEMENT HAS TWO INDEPENDENT NODES WITH
1211C NO ROTATIONAL WEIGHTS SET (THIS MEANS THE ELEMENT CANNOT
1212C SUPPORT A MOMENT ALONG ITS AXIS)
1213C
1214 IF (ng == 2.AND.irot==0) THEN
1215 ierr = 322
1216 GOTO 999
1217 ENDIF
1218C
1219C CALCULATE DIRECTION COSINES OF LOCAL COORDINATE SYSTEMS, IF ANY
1220C
1221 DO k = 1, ng
1222 ielsub = ilrbe3(k)
1223 IF (ielsub > 0) THEN
1224 DO i = 1, 3
1225 el(i,1,k) = skew(i,ielsub)
1226 el(i,2,k) = skew(i+3,ielsub)
1227 el(i,3,k) = skew(i+6,ielsub)
1228 ENDDO
1229 ENDIF
1230 ENDDO
1231C
1232C DENOMINATORS FOR DISTRIBUTING FORCES (DENFX, DENFY AND DENFZ)
1233C
1234 denfx = zero
1235 denfy = zero
1236 denfz = zero
1237 averef = zero
1238C
1239 DO 70 k = 1, ng
1240 kg = inrbe3(k)
1241 ielsub = ilrbe3(k)
1242 IF (ielsub > 0) THEN
1243C
1244C IF GRID POINT HAS A LOCAL COORDINATE SYSTEM
1245C
1246 DO 60 i = 1, 3
1247 denfx = denfx + tw(i,k)*el(i,1,k)**2
1248 denfy = denfy + tw(i,k)*el(i,2,k)**2
1249 denfz = denfz + tw(i,k)*el(i,3,k)**2
1250 60 CONTINUE
1251 ELSE
1252 denfx = denfx + tw(1,k)
1253 denfy = denfy + tw(2,k)
1254 denfz = denfz + tw(3,k)
1255 END IF
1256C
1257 averef = averef + sqrt( (xyz(1,kg) - refpt(1))**2 +
1258 * (xyz(2,kg) - refpt(2))**2 +
1259 * (xyz(3,kg) - refpt(3))**2 )
1260 70 CONTINUE
1261C
1262 IF (abs(denfx) <= em20) THEN
1263 ierr = 326
1264 ENDIF
1265C
1266 IF (abs(denfy) <= em20) THEN
1267 ierr = 327
1268 ENDIF
1269C
1270 IF (abs(denfz) <= em20) THEN
1271 ierr = 328
1272 ENDIF
1273 IF (ierr /= 0) GOTO 999
1274 averef = averef/ng
1275 IF (averef == zero) averef = one
1276C
1277C CALCULATE 3 CENTERS OF GRAVITY (CGMX, CGMY AND CGMZ) AND
1278C DENOMINATORS FOR DISTRIBUTING MOMENTS (DENMX, DENMY AND DENMZ)
1279C
1280 DO 40 k = 1, ng
1281 kg = inrbe3(k)
1282 ielsub = ilrbe3(k)
1283 IF (ielsub > 0) THEN
1284C
1285C IF THERE IS A LOCAL COORDINATE SYSTEM AT THE GRID POINT
1286C
1287 DO 10 i = 1, 3
1288 cgmx(2) = cgmx(2) + tw(i,k)*el(i,3,k)**2*xyz(2,kg)
1289 cgmx(3) = cgmx(3) + tw(i,k)*el(i,2,k)**2*xyz(3,kg)
1290 10 CONTINUE
1291C
1292 DO 20 i = 1, 3
1293 cgmy(3) = cgmy(3) + tw(i,k)*el(i,1,k)**2*xyz(3,kg)
1294 cgmy(1) = cgmy(1) + tw(i,k)*el(i,3,k)**2*xyz(1,kg)
1295 20 CONTINUE
1296C
1297 DO 30 i = 1, 3
1298 cgmz(1) = cgmz(1) + tw(i,k)*el(i,2,k)**2*xyz(1,kg)
1299 cgmz(2) = cgmz(2) + tw(i,k)*el(i,1,k)**2*xyz(2,kg)
1300 30 CONTINUE
1301C
1302 ELSE
1303 cgmx(2) = cgmx(2) + tw(3,k)*xyz(2,kg)
1304 cgmx(3) = cgmx(3) + tw(2,k)*xyz(3,kg)
1305C
1306 cgmy(3) = cgmy(3) + tw(1,k)*xyz(3,kg)
1307 cgmy(1) = cgmy(1) + tw(3,k)*xyz(1,kg)
1308C
1309 cgmz(1) = cgmz(1) + tw(2,k)*xyz(1,kg)
1310 cgmz(2) = cgmz(2) + tw(1,k)*xyz(2,kg)
1311 END IF
1312 40 CONTINUE
1313 cgmx(2) = cgmx(2)/denfz
1314 cgmx(3) = cgmx(3)/denfy
1315C
1316 cgmy(3) = cgmy(3)/denfx
1317 cgmy(1) = cgmy(1)/denfz
1318C
1319 cgmz(1) = cgmz(1)/denfy
1320 cgmz(2) = cgmz(2)/denfx
1321C
1322 denmx = zero
1323 denmy = zero
1324 denmz = zero
1325C
1326 DO 90 k = 1, ng
1327 kg = inrbe3(k)
1328 ielsub = ilrbe3(k)
1329C
1330C NOTE: AS IMPLEMENTED IN NASTRAN 70.7, WE SCALE THE ROTATIONAL
1331C WEIGHTS WITH THE SQUARE OF THE AVERAGE DISTANCE OF THE
1332C INDEPENDENT GRID POINTS FROM THE REFERENCE POINT TO
1333C RENDER THE RBE3 CALCULATIONS UNIT INDEPENDENT
1334C
1335 IF (ielsub > 0) THEN
1336C
1337C IF GRID POINT HAS A LOCAL COORDINATE SYSTEM
1338C
1339 DO 80 i = 1, 3
1340 denmx = denmx + rw(i,k)*el(i,1,k)**2*averef**2 +
1341 * tw(i,k)*( el(i,3,k)*(xyz(2,kg) - cgmx(2)) -
1342 * el(i,2,k)*(xyz(3,kg) - cgmx(3))
1343 * ) **2
1344 denmy = denmy + rw(i,k)*el(i,2,k)**2*averef**2 +
1345 * tw(i,k)*( el(i,1,k)*(xyz(3,kg) - cgmy(3)) -
1346 * el(i,3,k)*(xyz(1,kg) - cgmy(1))
1347 * ) **2
1348 denmz = denmz + rw(i,k)*el(i,3,k)**2*averef**2 +
1349 * tw(i,k)*( el(i,2,k)*(xyz(1,kg) - cgmz(1)) -
1350 * el(i,1,k)*(xyz(2,kg) - cgmz(2))
1351 * ) **2
1352 80 CONTINUE
1353 ELSE
1354 denmx = denmx + rw(1,k)*averef**2 +
1355 * tw(2,k)*(xyz(3,kg) - cgmx(3))**2 +
1356 * tw(3,k)*(xyz(2,kg) - cgmx(2))**2
1357 denmy = denmy + rw(2,k)*averef**2 +
1358 * tw(1,k)*(xyz(3,kg) - cgmy(3))**2 +
1359 * tw(3,k)*(xyz(1,kg) - cgmy(1))**2
1360 denmz = denmz + rw(3,k)*averef**2 +
1361 * tw(2,k)*(xyz(1,kg) - cgmz(1))**2 +
1362 * tw(1,k)*(xyz(2,kg) - cgmz(2))**2
1363 END IF
1364 90 CONTINUE
1365C
1366C PERFORM SOME CHECKS ON WEIGHTS, TO MAKE SURE THAT THE RBE3
1367C ELEMENT HAS NO UNCONSTRAINED DEGREES OF FREEDOM
1368C
1369C
1370 IF (abs(denmx) <= em20) THEN
1371 ierr = 329
1372 ENDIF
1373C
1374 IF (abs(denmy) <= em20) THEN
1375 ierr = 330
1376 ENDIF
1377C
1378 IF (abs(denmz) <= em20) THEN
1379 ierr = 331
1380 ENDIF
1381C
1382 IF (ierr /= 0) GOTO 999
1383C
1384C CALCULATE 3 FORCE DISTRIBUTIONS THAT CREATE NET X, Y AND Z FORCES
1385C OF 1 (BESIDES OTHER NONZERO FORCES/MOMENTS IN ALL THE DIRECTIONS)
1386C
1387 CALL rbe3uf(inrbe3,ilrbe3,el,tw,xyz,refpt,
1388 * fufxlc,fufylc,fufzlc,fufx,fufy,fufz,mufx,mufy,mufz,
1389 * tfufx,tfufy,tfufz,tmufx,tmufy,tmufz,
1390 * denfx,denfy,denfz,ng)
1391C
1392C CALCULATE 3 MOMENT/FORCE DISTRIBUTIONS THAT CREATE NET X, Y AND Z
1393C MOMENTS OF 1 (BESIDES OTHER NONZERO FORCES/MOMENTS IN ALL THE
1394C DIRECTIONS) AT CGMX, CGMY AND CGMZ RESPECTIVELY
1395C
1396 CALL rbe3um(inrbe3,ilrbe3,el,tw,rw,xyz,refpt,cgmx,cgmy,cgmz,
1397 * fumxlc,fumylc,fumzlc,mxlc,mylc,mzlc,
1398 * fumx,fumy,fumz,mx,my,mz,mumx,mumy,mumz,
1399 * tfumx,tfumy,tfumz,tmumx,tmumy,tmumz,
1400 * averef,denmx,denmy,denmz,ng,irot )
1401C
1402C DETERMINE COMBINATORY COEFFICIENTS FOR THESE 6 DISTRIBUTIONS
1403C (6 COEFFICIENTS FOR EACH OF 6 CASES)
1404C
1405C CASE 1 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1406C DISTRIBUTIONS IS A UNIT X-FORCE AT REFERENCE POINT
1407C CASE 2 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1408C DISTRIBUTIONS IS A UNIT Y-FORCE AT REFERENCE POINT
1409C CASE 3 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1410C DISTRIBUTIONS IS A UNIT Z-FORCE AT REFERENCE POINT
1411C CASE 4 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1412C DISTRIBUTIONS IS A UNIT X-MOMENT AT REFERENCE POINT
1413C CASE 5 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1414C DISTRIBUTIONS IS A UNIT Y-MOMENT AT REFERENCE POINT
1415C CASE 6 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
1416C DISTRIBUTIONS IS A UNIT Z-MOMENT AT REFERENCE POINT
1417C
1418C IN ORDER TO DETERMINE THESE COEFFICIENTS, FIRST SET UP A 6X6
1419C MATRIX. THE 6 COLUMNS OF THE INVERSE OF THIS MATRIX ARE THE
1420C DESIRED 6 SETS OF COEFFICIENTS.
1421C
1422 DO 120 i = 1, 3
1423 k = i + 3
1424 a(i,1) = tfufx(i)
1425 a(k,1) = tmufx(i)
1426 a(i,2) = tfufy(i)
1427 a(k,2) = tmufy(i)
1428 a(i,3) = tfufz(i)
1429 a(k,3) = tmufz(i)
1430 a(i,4) = tfumx(i)
1431 a(k,4) = tmumx(i)
1432 a(i,5) = tfumy(i)
1433 a(k,5) = tmumy(i)
1434 a(i,6) = tfumz(i)
1435 a(k,6) = tmumz(i)
1436 120 CONTINUE
1437C
1438C INVERT THE 6X6 MATRIX
1439C
1440 nsnglr = 0
1441 CALL invert(a,c,6,nsnglr)
1442 IF (nsnglr /= 0) THEN
1443 ierr = 332
1444 GOTO 999
1445 ENDIF
1446C
1447 DO i = 1, 3
1448 DO j = 1, 6
1449 DO k = 1, ng
1450 fdstnb(i,j,k) = c(1,j)*fufx(i,k) + c(2,j)*fufy(i,k) +
1451 * c(3,j)*fufz(i,k) + c(4,j)*fumx(i,k) +
1452 * c(5,j)*fumy(i,k) + c(6,j)*fumz(i,k)
1453 ENDDO
1454 ENDDO
1455 ENDDO
1456 IF (irot>0) THEN
1457 DO i = 1, 3
1458 DO j = 1, 6
1459 DO k = 1, ng
1460 mdstnb(i,j,k) = c(4,j)*mx(i,k) + c(5,j)*my(i,k) +
1461 * c(6,j)*mz(i,k)
1462 ENDDO
1463 ENDDO
1464 ENDDO
1465 END IF
1466C
1467 999 CONTINUE
1468 IF (ierr>0) THEN
1469 IF(ispmd==0)THEN
1470 CALL ancmsg(msgid=108,anmode=aninfo,
1471 . i1=id)
1472 ENDIF
1473 mstop = 1
1474 ENDIF
1475C
1476C DIAGNOSTIC INFORMATION
1477C
1478 RETURN
1479 END
1480C----------------------------
1481!||====================================================================
1482!|| wrrinf ../engine/source/constraints/general/rbe3/rbe3f.F
1483!||====================================================================
1484 SUBROUTINE wrrinf(TITLE,R,N)
1485#include "implicit_f.inc"
1486c !DECLARATIONS
1487 INTEGER N
1488 my_real
1489 . r(n)
1490 CHARACTER TITLE*(*)
1491C----------------------------
1492 INTEGER I
1493 print *, title,(r(i),i=1,n)
1494 RETURN
1495 END
1496!||====================================================================
1497!|| rbe3uf ../engine/source/constraints/general/rbe3/rbe3f.f
1498!||--- called by ------------------------------------------------------
1499!|| rbe3cl ../engine/source/constraints/general/rbe3/rbe3f.F
1500!||--- calls -----------------------------------------------------
1501!|| zero1 ../engine/source/system/zero.F
1502!||====================================================================
1503 SUBROUTINE rbe3uf(INRBE3,ILRBE3,EL,TW,XYZ,REFPT,
1504 * FUFXLC,FUFYLC,FUFZLC,
1505 * FUFX,FUFY,FUFZ,MUFX,MUFY,MUFZ,
1506 * TFUFX,TFUFY,TFUFZ,TMUFX,TMUFY,TMUFZ,
1507 * DENFX,DENFY,DENFZ,NG)
1508C-----------------------------------------------
1509C I m p l i c i t T y p e s
1510C-----------------------------------------------
1511#include "implicit_f.inc"
1512 INTEGER NG
1513 INTEGER INRBE3(NG), ILRBE3(NG)
1514 my_real
1515 * el(3,3,*),tw(3,ng), xyz(3,*), refpt(3),
1516 * fufxlc(3,ng), fufylc(3,ng), fufzlc(3,ng),
1517 * fufx(3,ng), fufy(3,ng), fufz(3,ng),
1518 * mufx(3,ng), mufy(3,ng), mufz(3,ng),
1519 * tfufx(3), tfufy(3), tfufz(3),
1520 * tmufx(3), tmufy(3), tmufz(3)
1521 my_real
1522 * denfx, denfy, denfz,xarm, yarm, zarm
1523 INTEGER I, J, K, KG, IELSUB
1524C
1525C INITIALIZE FORCE AND MOMENT DISTRIBUTIONS TO ZERO
1526C
1527 CALL ZERO1(FUFX,3*NG)
1528 CALL zero1(fufy,3*ng)
1529 CALL zero1(fufz,3*ng)
1530 CALL zero1(tfufx,3)
1531 CALL zero1(tfufy,3)
1532 CALL zero1(tfufz,3)
1533 CALL zero1(tmufx,3)
1534 CALL zero1(tmufy,3)
1535 CALL zero1(tmufz,3)
1536C
1537C FORCE DISTRIBUTIONS AT RBE3 GRID POINTS CORRESPONDING TO UNIT
1538C APPLIED FORCES AT RBE3 REFERENCE POINT ALONG (BASIC COORDINATE)
1539C X, Y AND Z DIRECTIONS
1540C
1541 DO 50 k = 1, ng
1542 kg = inrbe3(k)
1543 ielsub = ilrbe3(k)
1544 IF (ielsub > 0) THEN
1545C
1546C FORCES AT GRID POINT ALONG GRID POINT'S LOCAL (OUTPUT)
1547C COORDINATE AXES
1548C
1549 DO 10 i = 1, 3
1550 fufxlc(i,k) = tw(i,k)*el(i,1,k)/denfx
1551 fufylc(i,k) = tw(i,k)*el(i,2,k)/denfy
1552 fufzlc(i,k) = tw(i,k)*el(i,3,k)/denfz
1553 10 CONTINUE
1554C
1555C FORCES AT GRID POINT ALONG BASIC COORDINATE AXES
1556C
1557 DO 30 i = 1, 3
1558 DO 20 j = 1, 3
1559 fufx(j,k) = fufx(j,k) + fufxlc(i,k)*el(i,j,k)
1560 fufy(j,k) = fufy(j,k) + fufylc(i,k)*el(i,j,k)
1561 fufz(j,k) = fufz(j,k) + fufzlc(i,k)*el(i,j,k)
1562 20 CONTINUE
1563 30 CONTINUE
1564C
1565 ELSE
1566 fufxlc(1,k) = tw(1,k)/denfx
1567 fufylc(2,k) = tw(2,k)/denfy
1568 fufzlc(3,k) = tw(3,k)/denfz
1569 fufx(1,k) = fufxlc(1,k)
1570 fufy(2,k) = fufylc(2,k)
1571 fufz(3,k) = fufzlc(3,k)
1572 ENDIF
1573C
1574C MOMENTS AT REFERENCE POINT DUE TO THESE FORCE DISTRIBUTIONS
1575C
1576 xarm = xyz(1,kg) - refpt(1)
1577 yarm = xyz(2,kg) - refpt(2)
1578 zarm = xyz(3,kg) - refpt(3)
1579C
1580C MOMENTS AT REFERENCE POINT DUE TO FUFX
1581C
1582 mufx(1,k) = yarm*fufx(3,k) - zarm*fufx(2,k)
1583 mufx(2,k) = zarm*fufx(1,k) - xarm*fufx(3,k)
1584 mufx(3,k) = xarm*fufx(2,k) - yarm*fufx(1,k)
1585C
1586C MOMENTS AT REFERENCE POINT DUE TO FUFY
1587C
1588 mufy(1,k) = yarm*fufy(3,k) - zarm*fufy(2,k)
1589 mufy(2,k) = zarm*fufy(1,k) - xarm*fufy(3,k)
1590 mufy(3,k) = xarm*fufy(2,k) - yarm*fufy(1,k)
1591C
1592C MOMENTS AT REFERENCE POINT DUE TO FUFZ
1593C
1594 mufz(1,k) = yarm*fufz(3,k) - zarm*fufz(2,k)
1595 mufz(2,k) = zarm*fufz(1,k) - xarm*fufz(3,k)
1596 mufz(3,k) = xarm*fufz(2,k) - yarm*fufz(1,k)
1597C
1598C TOTAL FORCES AND MOMENTS
1599C
1600 DO 40 j = 1, 3
1601 tfufx(j) = tfufx(j) + fufx(j,k)
1602 tfufy(j) = tfufy(j) + fufy(j,k)
1603 tfufz(j) = tfufz(j) + fufz(j,k)
1604 tmufx(j) = tmufx(j) + mufx(j,k)
1605 tmufy(j) = tmufy(j) + mufy(j,k)
1606 tmufz(j) = tmufz(j) + mufz(j,k)
1607 40 CONTINUE
1608C
1609 50 CONTINUE
1610C
1611 RETURN
1612 END
1613C
1614!||====================================================================
1615!|| rbe3um ../engine/source/constraints/general/rbe3/rbe3f.F
1616!||--- called by ------------------------------------------------------
1617!|| rbe3cl ../engine/source/constraints/general/rbe3/rbe3f.F
1618!||--- calls -----------------------------------------------------
1619!|| zero1 ../engine/source/system/zero.F
1620!||====================================================================
1621 SUBROUTINE rbe3um(INRBE3,ILRBE3,EL,TW,RW,XYZ,REFPT,CGMX,CGMY,CGMZ,
1622 * FUMXLC,FUMYLC,FUMZLC,MXLC,MYLC,MZLC,
1623 * FUMX,FUMY,FUMZ,MX,MY,MZ,MUMX,MUMY,MUMZ,
1624 * TFUMX,TFUMY,TFUMZ,TMUMX,TMUMY,TMUMZ,
1625 * AVEREF,DENMX,DENMY,DENMZ,NG ,IROT)
1626C-----------------------------------------------
1627C I m p l i c i t T y p e s
1628C-----------------------------------------------
1629#include "implicit_f.inc"
1630 INTEGER NG,IROT
1631 INTEGER INRBE3(NG), ILRBE3(NG)
1632 my_real
1633 * el(3,3,*),tw(3,ng), rw(3,ng), xyz(3,*),
1634 * refpt(3), cgmx(3), cgmy(3), cgmz(3),
1635 * fumxlc(3,ng), fumylc(3,ng), fumzlc(3,ng),
1636 * mxlc(3,ng), mylc(3,ng), mzlc(3,ng),
1637 * fumx(3,ng), fumy(3,ng), fumz(3,ng),
1638 * mx(3,ng), my(3,ng), mz(3,ng),
1639 * mumx(3,ng), mumy(3,ng), mumz(3,ng),
1640 * tfumx(3), tfumy(3), tfumz(3),
1641 * tmumx(3), tmumy(3), tmumz(3)
1642 my_real
1643 * averef, denmx, denmy, denmz,xarm, yarm, zarm
1644 INTEGER I, J, K, KG, IELSUB
1645C
1646C INITIALIZE FORCE AND MOMENT DISTRIBUTIONS TO ZERO
1647C
1648 CALL ZERO1(FUMX,3*NG)
1649 CALL ZERO1(FUMY,3*NG)
1650 CALL zero1(fumz,3*ng)
1651 CALL zero1(mx,3*ng)
1652 CALL zero1(my,3*ng)
1653 CALL zero1(mz,3*ng)
1654 CALL zero1(tfumx,3)
1655 CALL zero1(tfumy,3)
1656 CALL zero1(tfumz,3)
1657 CALL zero1(tmumx,3)
1658 CALL zero1(tmumy,3)
1659 CALL zero1(tmumz,3)
1660C
1661C FORCE AND MOMENT DISTRIBUTIONS AT RBE3 GRID POINTS CORRESPONDING
1662C TO UNIT APPLIED MOMENTS AT RBE3 REFERENCE POINT ALONG (BASIC
1663C COORDINATE) X, Y AND Z DIRECTIONS
1664C
1665 DO 50 k = 1, ng
1666 kg = inrbe3(k)
1667 ielsub = ilrbe3(k)
1668 IF (ielsub > 0) THEN
1669C
1670C FORCES AT GRID POINT ALONG GRID POINT'S LOCAL
1671C (OUTPUT) COORDINATE AXES
1672C
1673 DO 10 i = 1, 3
1674 fumxlc(i,k) = tw(i,k)*
1675 * ( el(i,3,k)*(xyz(2,kg) - cgmx(2)) -
1676 * el(i,2,k)*(xyz(3,kg) - cgmx(3))
1677 * )/denmx
1678 fumylc(i,k) = tw(i,k)*
1679 * ( el(i,1,k)*(xyz(3,kg) - cgmy(3)) -
1680 * el(i,3,k)*(xyz(1,kg) - cgmy(1))
1681 * )/denmy
1682 fumzlc(i,k) = tw(i,k)*
1683 * ( el(i,2,k)*(xyz(1,kg) - cgmz(1)) -
1684 * el(i,1,k)*(xyz(2,kg) - cgmz(2))
1685 * )/denmz
1686 10 CONTINUE
1687C
1688C FORCES AND MOMENTS AT GRID POINT ALONG BASIC COORDINATE AXES
1689C
1690 DO 30 i = 1, 3
1691 DO 20 j = 1, 3
1692 fumx(j,k) = fumx(j,k) + fumxlc(i,k)*el(i,j,k)
1693 fumy(j,k) = fumy(j,k) + fumylc(i,k)*el(i,j,k)
1694 fumz(j,k) = fumz(j,k) + fumzlc(i,k)*el(i,j,k)
1695 20 CONTINUE
1696 30 CONTINUE
1697C
1698 ELSE
1699 fumxlc(2,k) = -tw(2,k)*(xyz(3,kg) - cgmx(3))/denmx
1700 fumxlc(3,k) = tw(3,k)*(xyz(2,kg) - cgmx(2))/denmx
1701 fumylc(1,k) = tw(1,k)*(xyz(3,kg) - cgmy(3))/denmy
1702 fumylc(3,k) = -tw(3,k)*(xyz(1,kg) - cgmy(1))/denmy
1703 fumzlc(1,k) = -tw(1,k)*(xyz(2,kg) - cgmz(2))/denmz
1704 fumzlc(2,k) = tw(2,k)*(xyz(1,kg) - cgmz(1))/denmz
1705C
1706 fumx(2,k) = fumxlc(2,k)
1707 fumx(3,k) = fumxlc(3,k)
1708 fumy(1,k) = fumylc(1,k)
1709 fumy(3,k) = fumylc(3,k)
1710 fumz(1,k) = fumzlc(1,k)
1711 fumz(2,k) = fumzlc(2,k)
1712 ENDIF
1713C
1714C MOMENTS AT REFERENCE POINT DUE TO FUMX
1715C
1716 xarm = xyz(1,kg) - refpt(1)
1717 yarm = xyz(2,kg) - refpt(2)
1718 zarm = xyz(3,kg) - refpt(3)
1719C
1720 mumx(1,k) = yarm*fumx(3,k) - zarm*fumx(2,k)
1721 mumx(2,k) = zarm*fumx(1,k) - xarm*fumx(3,k)
1722 mumx(3,k) = xarm*fumx(2,k) - yarm*fumx(1,k)
1723C
1724C MOMENTS AT REFERENCE POINT DUE TO FUMY
1725C
1726 mumy(1,k) = yarm*fumy(3,k) - zarm*fumy(2,k)
1727 mumy(2,k) = zarm*fumy(1,k) - xarm*fumy(3,k)
1728 mumy(3,k) = xarm*fumy(2,k) - yarm*fumy(1,k)
1729C
1730C MOMENTS AT REFERENCE POINT DUE TO FUMZ
1731C
1732 mumz(1,k) = yarm*fumz(3,k) - zarm*fumz(2,k)
1733 mumz(2,k) = zarm*fumz(1,k) - xarm*fumz(3,k)
1734 mumz(3,k) = xarm*fumz(2,k) - yarm*fumz(1,k)
1735C
1736 50 CONTINUE
1737C
1738 IF (irot>0) THEN
1739 DO k = 1, ng
1740 kg = inrbe3(k)
1741 ielsub = ilrbe3(k)
1742 IF (ielsub > 0) THEN
1743C
1744C MOMENTS AT GRID POINT ALONG GRID POINT'S LOCAL
1745C (OUTPUT) COORDINATE AXES
1746C
1747 DO i = 1, 3
1748 mxlc(i,k) = averef**2*rw(i,k)*el(i,1,k)/denmx
1749 mylc(i,k) = averef**2*rw(i,k)*el(i,2,k)/denmy
1750 mzlc(i,k) = averef**2*rw(i,k)*el(i,3,k)/denmz
1751 END DO
1752C
1753C MOMENTS AT GRID POINT ALONG BASIC COORDINATE AXES
1754C
1755 DO i = 1, 3
1756 DO j = 1, 3
1757 mx(j,k) = mx(j,k) + mxlc(i,k)*el(i,j,k)
1758 my(j,k) = my(j,k) + mylc(i,k)*el(i,j,k)
1759 mz(j,k) = mz(j,k) + mzlc(i,k)*el(i,j,k)
1760 END DO
1761 END DO
1762C
1763 ELSE
1764 mxlc(1,k) = averef**2*rw(1,k)/denmx
1765 mylc(2,k) = averef**2*rw(2,k)/denmy
1766 mzlc(3,k) = averef**2*rw(3,k)/denmz
1767C
1768 mx(1,k) = mxlc(1,k)
1769 my(2,k) = mylc(2,k)
1770 mz(3,k) = mzlc(3,k)
1771 ENDIF
1772C
1773 DO j = 1, 3
1774 mumx(j,k) = mumx(j,k) + mx(j,k)
1775 mumy(j,k) = mumy(j,k) + my(j,k)
1776 mumz(j,k) = mumz(j,k) + mz(j,k)
1777 END DO
1778 END DO
1779 END IF
1780C
1781C
1782C TOTAL FORCES AND MOMENTS
1783C
1784C
1785 DO k = 1, ng
1786 DO j = 1, 3
1787 tfumx(j) = tfumx(j) + fumx(j,k)
1788 tfumy(j) = tfumy(j) + fumy(j,k)
1789 tfumz(j) = tfumz(j) + fumz(j,k)
1790 tmumx(j) = tmumx(j) + mumx(j,k)
1791 tmumy(j) = tmumy(j) + mumy(j,k)
1792 tmumz(j) = tmumz(j) + mumz(j,k)
1793 END DO
1794 END DO
1795C
1796 RETURN
1797 END
1798!||====================================================================
1799!|| invert ../engine/source/constraints/general/rbe3/rbe3f.F
1800!||--- called by ------------------------------------------------------
1801!|| rbe3cl ../engine/source/constraints/general/rbe3/rbe3f.f
1802!||====================================================================
1803 SUBROUTINE invert(MATRIX, INVERSE, N, ERRORFLAG)
1804C-----------------------------------------------
1805C I m p l i c i t T y p e s
1806C-----------------------------------------------
1807#include "implicit_f.inc"
1808c !DECLARATIONS
1809 INTEGER, INTENT(IN) :: N
1810 INTEGER, INTENT(OUT) :: ERRORFLAG !RETURN ERROR STATUS. -1 FOR ERROR, 0 FOR NORMAL
1811 my_real
1812 * , INTENT(IN), DIMENSION(N,N) :: MATRIX !INPUT MATRIX
1813 my_real
1814 * , INTENT(OUT), DIMENSION(N,N) :: inverse !INVERTED MATRIX
1815
1816 LOGICAL :: FLAG = .true.
1817 INTEGER :: I, J, K, L
1818 my_real
1819 * :: m
1820 my_real
1821 * , DIMENSION(N,2*N) :: augmatrix !AUGMENTED MATRIX
1822
1823c !AUGMENT INPUT MATRIX WITH AN IDENTITY MATRIX
1824 DO i = 1, n
1825 DO j = 1, 2*n
1826 IF (j <= n ) THEN
1827 augmatrix(i,j) = matrix(i,j)
1828 ELSE IF ((i+n) == j) THEN
1829 augmatrix(i,j) = one
1830 ELSE
1831 augmatrix(i,j) = zero
1832 ENDIF
1833 END DO
1834 END DO
1835
1836c !REDUCE AUGMENTED MATRIX TO UPPER TRIANGULAR FORM
1837 DO k =1, n-1
1838 IF (augmatrix(k,k) == 0) THEN
1839 flag = .false.
1840 DO i = k+1, n
1841 IF (augmatrix(i,k) /= 0) THEN
1842 DO j = 1,2*n
1843 augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
1844 END DO
1845 flag = .true.
1846 EXIT
1847 ENDIF
1848 IF (flag .EQV. .false.) THEN
1849 inverse = 0
1850 errorflag = -1
1851 RETURN
1852 ENDIF
1853 END DO
1854 ENDIF
1855 DO j = k+1, n
1856 m = augmatrix(j,k)/augmatrix(k,k)
1857 DO i = k, 2*n
1858 augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
1859 END DO
1860 END DO
1861 END DO
1862
1863c !TEST FOR INVERTIBILITY
1864 DO i = 1, n
1865 IF (augmatrix(i,i) == 0) THEN
1866c PRINT*, "MATRIX IS NON - INVERTIBLE"
1867 inverse = 0
1868 errorflag = -1
1869 RETURN
1870 ENDIF
1871 END DO
1872
1873c !MAKE DIAGONAL ELEMENTS AS 1
1874 DO i = 1 , n
1875 m = augmatrix(i,i)
1876 DO j = i , (2 * n)
1877 augmatrix(i,j) = (augmatrix(i,j) / m)
1878 END DO
1879 END DO
1880
1881c !REDUCED RIGHT SIDE HALF OF AUGMENTED MATRIX TO IDENTITY MATRIX
1882 DO k = n-1, 1, -1
1883 DO i =1, k
1884 m = augmatrix(i,k+1)
1885 DO j = k, (2*n)
1886 augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
1887 END DO
1888 END DO
1889 END DO
1890
1891c !STORE ANSWER
1892 DO i =1, n
1893 DO j = 1, n
1894 inverse(i,j) = augmatrix(i,j+n)
1895 END DO
1896 END DO
1897 errorflag = 0
1898 RETURN
1899 END SUBROUTINE invert
1900!||====================================================================
1901!|| rbe3frf ../engine/source/constraints/general/rbe3/rbe3f.F
1902!||--- called by ------------------------------------------------------
1903!|| imp3_a2b ../engine/source/airbag/monv_imp0.F
1904!|| upd_fr ../engine/source/mpi/implicit/imp_fri.F
1905!||====================================================================
1906 SUBROUTINE rbe3frf(NML ,IML ,NS ,A ,AR ,
1907 * FDSTNB,MDSTNB,JT ,JR ,IROT )
1908C-----------------------------------------------
1909C I m p l i c i t T y p e s
1910C-----------------------------------------------
1911#include "implicit_f.inc"
1912C-----------------------------------------------
1913C D u m m y A r g u m e n t s
1914C-----------------------------------------------
1915 INTEGER NML ,IML(*) ,NS,JT(*),JR(*),IROT
1916C REAL
1917 my_real
1918 . a(3,*), ar(3,*), fdstnb(3,6,*) ,mdstnb(3,6,*)
1919C-----------------------------------------------
1920C L o c a l V a r i a b l e s
1921C-----------------------------------------------
1922 INTEGER I, J, N,M
1923C REAL
1924 my_real
1925 . fns(3),mns(3)
1926C======================================================================|
1927 DO j = 1,3
1928 fns(j) = a(j,ns)*jt(j)
1929 ENDDO
1930 DO i=1,nml
1931 m = iml(i)
1932 DO j = 1,3
1933 a(1,m) = a(1,m)+fdstnb(1,j,i)*fns(j)
1934 a(2,m) = a(2,m)+fdstnb(2,j,i)*fns(j)
1935 a(3,m) = a(3,m)+fdstnb(3,j,i)*fns(j)
1936 ENDDO
1937 ENDDO
1938 IF ((jr(1)+jr(2)+jr(3))>0) THEN
1939 DO j = 1,3
1940 mns(j) = ar(j,ns)*jr(j)
1941 ENDDO
1942 DO i=1,nml
1943 m = iml(i)
1944 DO j = 1,3
1945 a(1,m) = a(1,m)+fdstnb(1,j+3,i)*mns(j)
1946 a(2,m) = a(2,m)+fdstnb(2,j+3,i)*mns(j)
1947 a(3,m) = a(3,m)+fdstnb(3,j+3,i)*mns(j)
1948 ENDDO
1949 ENDDO
1950 ENDIF
1951 IF (irot>0) THEN
1952 DO i=1,nml
1953 m = iml(i)
1954 DO j = 1,3
1955 ar(1,m) = ar(1,m)+mdstnb(1,j,i)*fns(j)
1956 ar(2,m) = ar(2,m)+mdstnb(2,j,i)*fns(j)
1957 ar(3,m) = ar(3,m)+mdstnb(3,j,i)*fns(j)
1958 ENDDO
1959 ENDDO
1960 IF ((jr(1)+jr(2)+jr(3))>0) THEN
1961 DO i=1,nml
1962 m = iml(i)
1963 DO j = 1,3
1964 ar(1,m) = ar(1,m)+mdstnb(1,j+3,i)*mns(j)
1965 ar(2,m) = ar(2,m)+mdstnb(2,j+3,i)*mns(j)
1966 ar(3,m) = ar(3,m)+mdstnb(3,j+3,i)*mns(j)
1967 ENDDO
1968 ENDDO
1969 ENDIF
1970 ENDIF
1971C---
1972 RETURN
1973 END
1974!||====================================================================
1975!|| prerbe3p ../engine/source/constraints/general/rbe3/rbe3f.F
1976!||--- called by ------------------------------------------------------
1977!|| rbe3t1 ../engine/source/constraints/general/rbe3/rbe3f.F
1978!|| sms_rbe3_prec ../engine/source/ams/sms_rbe3.F
1979!|| sms_rbe3t1 ../engine/source/ams/sms_rbe3.F
1980!|| sms_rbe3t2 ../engine/source/ams/sms_rbe3.F
1981!||====================================================================
1982 SUBROUTINE prerbe3p(IRBE3 ,LRBE3 ,AD_M , IML ,NMT )
1983C-----------------------------------------------
1984C I m p l i c i t T y p e s
1985C-----------------------------------------------
1986#include "implicit_f.inc"
1987C-----------------------------------------------
1988C C o m m o n B l o c k s
1989C-----------------------------------------------
1990#include "com04_c.inc"
1991#include "param_c.inc"
1992C-----------------------------------------------
1993C D u m m y A r g u m e n t s
1994C-----------------------------------------------
1995 INTEGER IRBE3(NRBE3L,*),LRBE3(*),AD_M(*) ,IML(*) , NMT
1996C REAL
1997C-----------------------------------------------
1998C L o c a l V a r i a b l e s
1999C-----------------------------------------------
2000 INTEGER I, J, N,M,IAD,NS,NML,ITAG(NUMNOD)
2001C NMT: number (no doublon) of main nodes,AD(M): index from NMT0->NMT
2002C======================================================================|
2003 DO n =1,numnod
2004 itag(n) = 0
2005 END DO
2006 nmt = 0
2007 DO n=1,nrbe3
2008 iad = irbe3(1,n)
2009 ns = irbe3(3,n)
2010 nml = irbe3(5,n)
2011 DO i=1,nml
2012 m = lrbe3(iad+i)
2013 IF (itag(m)==0) THEN
2014 nmt = nmt + 1
2015 ad_m(iad+i) = nmt
2016 itag(m) = nmt
2017 iml(nmt) = m
2018 ELSE
2019 ad_m(iad+i) = itag(m)
2020 ENDIF
2021 ENDDO
2022 ENDDO
2023C---
2024 RETURN
2025 END
2026!||====================================================================
2027!|| prerbe3p0 ../engine/source/constraints/general/rbe3/rbe3f.F
2028!||--- called by ------------------------------------------------------
2029!|| resol ../engine/source/engine/resol.F
2030!||--- calls -----------------------------------------------------
2031!||--- uses -----------------------------------------------------
2032!|| my_alloc_mod ../common_source/tools/memory/my_alloc.F90
2033!|| rbe3_mod ../common_source/modules/constraints/rbe3_mod.F90
2034!||====================================================================
2035 SUBROUTINE prerbe3p0(RBE3)
2036 use rbe3_mod
2037 use my_alloc_mod
2038C-----------------------------------------------
2039C I m p l i c i t T y p e s
2040C-----------------------------------------------
2041#include "implicit_f.inc"
2042C-----------------------------------------------
2043C C o m m o n B l o c k s
2044C-----------------------------------------------
2045#include "com04_c.inc"
2046#include "param_c.inc"
2047C-----------------------------------------------
2048C D u m m y A r g u m e n t s
2049C-----------------------------------------------
2050 type(rbe3_),intent(inout) :: RBE3
2051C REAL
2052C-----------------------------------------------
2053C L o c a l V a r i a b l e s
2054C-----------------------------------------------
2055 INTEGER I, N,M,IAD,NS,NML,NMP
2056 INTEGER,DIMENSION(:),ALLOCATABLE :: ITAG
2057C NMT: number (no doublon) of main nodes,AD(M): index from NMT0->NMT
2058C======================================================================|
2059 CALL MY_ALLOC(ITAG,NUMNOD)
2060 DO N =1,numnod
2061 itag(n) = 0
2062 END DO
2063 rbe3%NMT = 0
2064 DO n=1,nrbe3
2065 iad = rbe3%IRBE3(1,n)
2066 ns = rbe3%IRBE3(3,n)
2067 nml = rbe3%IRBE3(5,n)
2068 DO i=1,nml
2069 m = rbe3%LRBE3(iad+i)
2070 IF (itag(m)==0) THEN
2071 rbe3%NMT = rbe3%NMT + 1
2072 itag(m) = rbe3%NMT
2073 ENDIF
2074 ENDDO
2075 ENDDO
2076C---
2077 ! Size of RBE3%RRBE3 / ALLOCATION
2078 rbe3%RRBE3_SZ=5*rbe3%NMT+1
2079 IF (rbe3%irotg > 0)then
2080 rbe3%RRBE3_SZ=rbe3%RRBE3_SZ+5*rbe3%NMT
2081 endif
2082 CALL my_alloc(rbe3%RRBE3,rbe3%RRBE3_SZ)
2083 rbe3%RRBE3 = zero
2084
2085 ! Size of RBE3%RRBE3_PON / ALLOCATION
2086 nmp = rbe3%NMT*6
2087 rbe3%RRBE3_PON_SZ = 5*nmp+1
2088 IF (rbe3%irotg > 0)then
2089 rbe3%RRBE3_PON_SZ=rbe3%RRBE3_PON_SZ+5*nmp
2090 endif
2091 CALL my_alloc(rbe3%RRBE3_PON,rbe3%RRBE3_PON_SZ)
2092 rbe3%RRBE3_PON=zero
2093
2094 DEALLOCATE(itag)
2095 RETURN
2096 END
2097!||====================================================================
2098!|| mfac_rbe3 ../engine/source/constraints/general/rbe3/rbe3f.F
2099!||--- called by ------------------------------------------------------
2100!|| rbe3f ../engine/source/constraints/general/rbe3/rbe3f.F
2101!|| sms_rbe3_1 ../engine/source/ams/sms_rbe3.F
2102!||====================================================================
2103 SUBROUTINE mfac_rbe3(FDSTNB,MDSTNB,NML ,IROT,SF,SM)
2104C-----------------------------------------------
2105C I m p l i c i t T y p e s
2106C-----------------------------------------------
2107#include "implicit_f.inc"
2108C-----------------------------------------------
2109C D u m m y A r g u m e n t s
2110C-----------------------------------------------
2111 INTEGER NML,IROT
2112 my_real
2113 . fdstnb(3,6,*) ,mdstnb(3,6,*),sf,sm
2114C-----------------------------------------------
2115C L o c a l V a r i a b l e s
2116C-----------------------------------------------
2117 INTEGER I,J,IFD,IMD
2118 my_real
2119 . fsum,msum,sum
2120C======================================================================|
2121 ifd=0
2122 sf=one
2123 sm=one
2124 DO i=1,nml
2125 DO j = 1,3
2126 IF (ifd==0) THEN
2127 fsum = fdstnb(j,1,i)+fdstnb(j,2,i)+fdstnb(j,3,i)
2128 IF (fsum <0) ifd=1
2129 END IF
2130 ENDDO
2131 ENDDO
2132C--renormalizing to avoid mass adding
2133 IF (ifd >0) THEN
2134 sum =zero
2135 DO i=1,nml
2136 DO j = 1,3
2137 fsum = fdstnb(j,1,i)+fdstnb(j,2,i)+fdstnb(j,3,i)
2138 sum = sum +abs(fsum)
2139 ENDDO
2140 ENDDO
2141 sf = three/sum
2142 END IF
2143C
2144 IF (irot==0) RETURN
2145C
2146 imd=0
2147 DO i=1,nml
2148 DO j = 1,3
2149 IF (imd==0) THEN
2150 msum = mdstnb(j,1,i)+mdstnb(j,2,i)+mdstnb(j,3,i)
2151 IF (msum <0) imd=1
2152 END IF
2153 ENDDO
2154 ENDDO
2155 IF (imd >0) THEN
2156 sum =zero
2157 DO i=1,nml
2158 DO j = 1,3
2159 msum = mdstnb(j,1,i)+mdstnb(j,2,i)+mdstnb(j,3,i)
2160 sum = sum +abs(msum)
2161 ENDDO
2162 ENDDO
2163 sm = three/sum
2164 END IF
2165C---
2166 RETURN
2167 END
my_real
#define my_real
Definition cppsort.cpp:32
zero1
subroutine zero1(r, n)
Definition hm_read_rbe3.F:1481
diag_int
subroutine diag_int(nsl, ndof, ipari, intbuf_tab, kss, x, ibfv, skew, xframe, irbe3, lrbe3, irbe2, lrbe2)
Definition imp_fri.F:1839
imp_fri
subroutine imp_fri(num_imp, ns_imp, ne_imp, ipari, intbuf_tab, npby, lpby, itab, nrbyac, irbyac, nint2, iint2, iddl, ikc, ndof, inloc, nsrem, nsl, nbintc, intlist, x, ibfv, lj, skew, xframe, iskew, icodt, a, ud, lb, ifdis, nddl, urd, iddli, irbe3, lrbe3, frbe3, irbe2, lrbe2)
Definition imp_fri.F:45
max
#define max(a, b)
Definition macros.h:21
h3d_mod
Definition h3d_mod.F:308
message_mod
Definition message_mod.F:1249
foat_to_6_float
subroutine foat_to_6_float(jft, jlt, f, f6)
Definition parit.F:225
rbe3t1
subroutine rbe3t1(rbe3, nodes, skew, dmast, adm, dinert, adi, h3d_data, dt1, tt, impl_s)
Definition rbe3f.F:50
rbe3frf
subroutine rbe3frf(nml, iml, ns, a, ar, fdstnb, mdstnb, jt, jr, irot)
Definition rbe3f.F:1908
invert
subroutine invert(matrix, inverse, n, errorflag)
Definition rbe3f.F:1804
rbe3cl
subroutine rbe3cl(inrbe3, ilrbe3, ns, xyz, frbe3, skew, ng, irot, fdstnb, mdstnb, id)
Definition rbe3f.F:1142
asp0_rbe3
subroutine asp0_rbe3(irbe3, lrbe3, a, ar, ms, in, weight, stifn, stifr, da, dar, dms, din, dstifn, dstifr)
Definition rbe3f.F:585
wrrinf
subroutine wrrinf(title, r, n)
Definition rbe3f.F:1485
ass_rbe3
subroutine ass_rbe3(irbe3, lrbe3, a, ar, ms, in, weight, stifn, stifr, da, dar, dms, din, dstifn, dstifr, nmt, iml, irotg)
Definition rbe3f.F:505
prerbe3p
subroutine prerbe3p(irbe3, lrbe3, ad_m, iml, nmt)
Definition rbe3f.F:1983
asp1_rbe3
subroutine asp1_rbe3(irbe3, lrbe3, a, ar, ms, in, weight, stifn, stifr, da, dar, dms, din, dstifn, dstifr)
Definition rbe3f.F:664
dmi_rbe3
subroutine dmi_rbe3(nmt, lrbe3, ms0, in0, dms, din, dmast, adm, dinert, adi, irotg, irbe3, ms, in, weight, iadmp, h3d_data)
Definition rbe3f.F:834
rbe3poff
subroutine rbe3poff(irbe3, lrbe3, a, ms, weight, ar, in, stifn, stifr)
Definition rbe3f.F:211
rbe3f
subroutine rbe3f(irbe3, lrbe3, x, a, ar, ms, in, frbe3, skew, weight, stifn, stifr, jt, jr, irotg, max_m, am, arm, msm, inm, stifnm, stifrm, nmt0, iadmp, pen, v, vr, nmt, dt1, iroddl)
Definition rbe3f.F:280
prerbe3fr
subroutine prerbe3fr(irbe3, n, jt, jr)
Definition rbe3f.F:1045
prerbe3p0
subroutine prerbe3p0(rbe3)
Definition rbe3f.F:2036
rbe3um
subroutine rbe3um(inrbe3, ilrbe3, el, tw, rw, xyz, refpt, cgmx, cgmy, cgmz, fumxlc, fumylc, fumzlc, mxlc, mylc, mzlc, fumx, fumy, fumz, mx, my, mz, mumx, mumy, mumz, tfumx, tfumy, tfumz, tmumx, tmumy, tmumz, averef, denmx, denmy, denmz, ng, irot)
Definition rbe3f.F:1626
mfac_rbe3
subroutine mfac_rbe3(fdstnb, mdstnb, nml, irot, sf, sm)
Definition rbe3f.F:2104
rbe3uf
subroutine rbe3uf(inrbe3, ilrbe3, el, tw, xyz, refpt, fufxlc, fufylc, fufzlc, fufx, fufy, fufz, mufx, mufy, mufz, tfufx, tfufy, tfufz, tmufx, tmufy, tmufz, denfx, denfy, denfz, ng)
Definition rbe3f.F:1508
prerbe3
subroutine prerbe3(irbe3, max_m, irotg, jt, jr)
Definition rbe3f.F:953
asp2_rbe3
subroutine asp2_rbe3(irbe3, lrbe3, a, ar, ms, in, weight, stifn, stifr, da, dar, dms, din, dstifn, dstifr, nmt, iml, irotg)
Definition rbe3f.F:758
spmd_exch_rbe3
subroutine spmd_exch_rbe3(a, ar, ms, in, stifn, stifr, fr_m, iad_m, lcomm, isize, irot)
Definition spmd_exch_rbe3.F:35
spmd_exch_rbe3_pon
subroutine spmd_exch_rbe3_pon(a, ar, ms, in, stifn, stifr, fr_m, iad_m, lcomm, isize, irot)
Definition spmd_exch_rbe3_pon.F:36
ancmsg
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
Definition message.F:889