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