OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_read_rbe3.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!|| hm_read_rbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
25!||--- called by ------------------------------------------------------
26!|| lectur ../starter/source/starter/lectur.F
27!||--- calls -----------------------------------------------------
28!|| ancmsg ../starter/source/output/message/message.F
29!|| fretitl ../starter/source/starter/freform.F
30!|| hm_get_float_array_index ../starter/source/devtools/hm_reader/hm_get_float_array_index.F
31!|| hm_get_int_array_index ../starter/source/devtools/hm_reader/hm_get_int_array_index.F
32!|| hm_get_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
33!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.F
34!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
35!|| hm_sz_r2r ../starter/source/coupling/rad2rad/routines_r2r.F
36!|| kinset ../starter/source/constraints/general/kinset.F
37!|| nodgrnr5 ../starter/source/starter/freform.F
38!|| prerbe3fr ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
39!|| usr2sys ../starter/source/system/sysfus.F
40!||--- uses -----------------------------------------------------
41!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
42!|| message_mod ../starter/share/message_module/message_mod.F
43!|| r2r_mod ../starter/share/modules1/r2r_mod.F
44!|| submodel_mod ../starter/share/modules1/submodel_mod.F
45!||====================================================================
46 SUBROUTINE hm_read_rbe3(IRBE3 ,LRBE3 ,FRBE3 ,ITAB ,ITABM1 ,
47 . IGRNOD ,ISKN ,LXINTD ,IKINE ,IDDLEVEL,
48 . NOM_OPT,ITAGND ,GRNOD_UID,UNITAB,LSUBMODEL )
49C-------------------------------------
50C LECTURE STRUCTURE RIGIDES
51C-----------------------------------------------
52C M o d u l e s
53C-----------------------------------------------
54 USE my_alloc_mod
55 USE unitab_mod
56 USE r2r_mod
57 USE message_mod
58 USE groupdef_mod
59 USE submodel_mod
60 USE hm_option_read_mod
61 USE names_and_titles_mod , ONLY : nchartitle, ncharkey, ncharfield
62C-----------------------------------------------
63C I m p l i c i t T y p e s
64C-----------------------------------------------
65#include "implicit_f.inc"
66C-----------------------------------------------
67C C o m m o n B l o c k s
68C-----------------------------------------------
69#include "scr17_c.inc"
70#include "com01_c.inc"
71#include "com04_c.inc"
72#include "units_c.inc"
73#include "param_c.inc"
74#include "tabsiz_c.inc"
75#include "r2r_c.inc"
76#include "sphcom.inc"
77#include "scr03_c.inc"
78C-----------------------------------------------
79C D u m m y A r g u m e n t s
80C-----------------------------------------------
81 INTEGER IRBE3(NRBE3L,*), LRBE3(*), ITAB(*),ITABM1(*),
82 . ISKN(LISKN,*),LXINTD,
83 . iddlevel,ikine(*),itagnd(*)
84 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
85 my_real FRBE3(6,*)
86 INTEGER NOM_OPT(LNOPT1,*)
87C-----------------------------------------------
88 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
89 INTEGER :: GRNOD_UID
90 TYPE(submodel_data),INTENT(IN)::LSUBMODEL(*)
91C-----------------------------------------------
92C L o c a l V a r i a b l e s
93C-----------------------------------------------
94 INTEGER I, N, K, NSL, NSLT, ITYP, NUSER, NM, NI, NI_OK,
95 . ISK, ISENS, INGU, IGM, J, P,IAD,NS,NN,J6(6),JJ,II,
96 . ic,ic1,ic2,irot,isks,iads,ierr1,imodif,
97 . idir,nrb,id,uid,sub_index,iform
98 my_real w
99 INTEGER, DIMENSION(:),ALLOCATABLE :: IKINE1
100 INTEGER, DIMENSION(:),ALLOCATABLE :: ISKEW0
101 my_real, DIMENSION(:,:),ALLOCATABLE :: wi
102 CHARACTER(LEN=NCHARTITLE) :: TITR
103 CHARACTER(LEN=NCHARKEY) :: KEY
104 CHARACTER(LEN=NCHARFIELD) :: STRING
105 CHARACTER :: CODE*7,MESS*40
106 LOGICAL IS_AVAILABLE
107C-----------------------------------------------
108C E x t e r n a l F u n c t i o n s
109C-----------------------------------------------
110 INTEGER USR2SYS,NODGRNR5
111C
112 DATA mess/'INTERPOLATION CONSTRAINT BODY '/
113C-----------------------------------------------
114C IRBE3(1,I) : IAD0 for LRBE3 and FRBE3
115C IRBE3(2,I) : TYPE usr' id temporaire (print)
116C IRBE3(3,I) : SECONDARY NODES
117C IRBE3(4,I) : REF_DOF
118C IRBE3(5,I) : NUMBER MAIN NODE
119C IRBE3(6,I) : IROT =0 no rotational dependent
120C IRBE3(7,I) : SENSOR NUMBER - not used yet
121C IRBE3(8,I) : Imodif ! 4 : switch to penalty formulation (for testing)
122C IRBE3(9,I) : if penalty formulation : 0=kinematic, 1=penalty
123C IRBE3(10,I) : Numero interne du IRBE3 (necessaire pour Modif/SPMD)
124C=======================================================================
125! complete case of switching to penalty formulation; free nodes w/ spc?
126! 1) hierachy level>1
127! 2) incompatibility kin
128! 3) avoid too much added mass : 2 conditions 1)Is>0 2)rR>?
129! rbe3_mod is used from engine, ini is done in resol_init,internal arrays of pen are added in restart
130 CALL my_alloc(ikine1,3*numnod)
131 CALL my_alloc(iskew0,slrbe3/2)
132 CALL my_alloc(wi,6,numnod)
133c
134 WRITE(iout,1000)
135CC
136 is_available = .false.
137 CALL hm_option_start('/RBE3')
138C
139 DO i=1,3*numnod
140 ikine1(i) = 0
141 ENDDO
142C
143 iads = slrbe3/2
144 iad = 0
145 nrb = 0
146
147C---------otherwise quadratic cycling---------
148 DO j=1,6
149 DO n=1,numnod
150 wi(j,n)=zero
151 ENDDO
152 ENDDO
153
154 DO i=1,nrbe3
155 nrb=nrb+1
156C----------Multidomaines --> on ignore les rbe3 non tages---------
157 IF(nsubdom>0)THEN
158 IF(tagrb3(nrb)==0)CALL hm_sz_r2r(tagrb3,nrb,lsubmodel)
159 END IF
160 iform = 0
161C--------------------------------------------------
162C EXTRACT DATAS OF /RBE3/... LINE
163C--------------------------------------------------
164 CALL hm_option_read_key(lsubmodel,
165 . option_id = id,
166 . unit_id = uid,
167 . option_titr = titr,
168 . submodel_index = sub_index)
169 nom_opt(1,i)=id
170 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
171C
172 CALL hm_get_intv('dependentnode',nsl,is_available,lsubmodel)
173 CALL hm_get_intv('LTX',j6(1),is_available,lsubmodel)
174 CALL hm_get_intv('LTY',j6(2),is_available,lsubmodel)
175 CALL hm_get_intv('LTZ',j6(3),is_available,lsubmodel)
176 CALL hm_get_intv('LRX',j6(4),is_available,lsubmodel)
177 CALL hm_get_intv('LRY',j6(5),is_available,lsubmodel)
178 CALL hm_get_intv('LRZ',j6(6),is_available,lsubmodel)
179 CALL hm_get_intv('nset',nn,is_available,lsubmodel)
180 CALL hm_get_intv('I_Modif',imodif,is_available,lsubmodel)
181 CALL hm_get_intv('Iform',iform,is_available,lsubmodel)
182 irbe3(2,i) = id
183 irbe3(10,i)=i
184 nuser = id
185C
186 IF (imodif==0) imodif =1
187! IF (IMODIF==4) IRBE3(9,I) =1
188 irbe3(8,i) = imodif
189 SELECT CASE (iform)
190 CASE(0,1)
191 irbe3(9,i) =0
192 IF (iform==0) iform =1
193 CASE(2)
194 irbe3(9,i) = -1
195 CASE(3)
196 irbe3(9,i) = 1
197 END SELECT
198 ns = usr2sys(nsl,itabm1,mess,nuser)
199 ic1=j6(1)*4 +j6(2)*2 +j6(3)
200 ic2=j6(4)*4 +j6(5)*2 +j6(6)
201 ic =ic1*512+ic2*64
202 IF (ic==0) ic =7*512+7*64
203 IF (ns10e > 0) THEN
204 IF(itagnd(ns)/=0) THEN
205C------- error out
206 CALL ancmsg(msgid=1208,
207 . msgtype=msgerror,
208 . anmode=aninfo_blind_1,
209 . i1=itab(ns),
210 . c1='RBE3 ',
211 . i2=nuser,
212 . c2='RBE3 ')
213 ENDIF
214 END IF
215 irbe3(3,i) = ns
216 irbe3(4,i) = ic
217 irbe3(1,i) = iad
218 irot = 0
219 DO j=1,nn
220 CALL hm_get_float_array_index('independentnodesetcoeffs',w,j,is_available,lsubmodel,unitab)
221 CALL hm_get_int_array_index('tx',j6(1),j,is_available,lsubmodel)
222 CALL hm_get_int_array_index('ty',j6(2),j,is_available,lsubmodel)
223 CALL hm_get_int_array_index('tz',j6(3),j,is_available,lsubmodel)
224 CALL hm_get_int_array_index('rx',j6(4),j,is_available,lsubmodel)
225 CALL hm_get_int_array_index('ry',j6(5),j,is_available,lsubmodel)
226 CALL hm_get_int_array_index('rz',j6(6),j,is_available,lsubmodel)
227 CALL hm_get_int_array_index('SKEW_ARRAY',isk,j,is_available,lsubmodel)
228 CALL hm_get_int_array_index('independentnodesets',ingu,j,is_available,lsubmodel)
229 IF (w==zero.OR.imodif==3) w=one
230 nm = 0
231 IF(ingu > 0) THEN
232 CALL c_hash_find(grnod_uid,ingu,igm)
233 IF (igm == 0)THEN
234 CALL ancmsg(msgid=53,
235 . msgtype=msgerror,
236 . anmode=aninfo,
237 . c1= mess,
238 . i1=ingu)
239 ELSE
240 nm = igrnod(igm)%NENTITY
241 lrbe3(iad+1:iad+nm) = igrnod(igm)%ENTITY(1:nm)
242 ENDIF
243 END IF !(INGU > 0)
244
245 isks = 0
246 IF ((j6(1)+j6(2)+j6(3)+j6(4)+j6(5)+j6(6))==0) THEN
247 j6(1)=1
248 j6(2)=1
249 j6(3)=1
250 ENDIF
251 IF (isk/=0) THEN
252 DO jj=0,numskw+min(1,nspcond)*numsph+nsubmod
253 IF(isk==iskn(4,jj+1)) THEN
254 isks=jj+1
255 GO TO 10
256 ENDIF
257 ENDDO
258 CALL ancmsg(msgid=184,
259 . msgtype=msgerror,
260 . anmode=aninfo,
261 . c1='RBE3',
262 . i1=nuser,
263 . c2='RBE3',
264 . c3=titr,
265 . i2=isk)
266 10 CONTINUE
267 ENDIF
268 DO k=1,nm
269 ni=lrbe3(iad+k)
270 lrbe3(iads+iad+k)=isks
271 iskew0(iad+k)=isk
272 DO jj=1,6
273 ii = j6(jj)
274 IF (ii>zero) THEN
275 IF (jj>3) irot=1
276 IF (wi(jj,ni)==zero) THEN
277 wi(jj,ni) = w
278 ELSE
279 CALL ancmsg(msgid=705,
280 . msgtype=msgerror,
281 . anmode=aninfo,
282 . i1=nuser,
283 . c1=titr,
284 . i2=itab(ni))
285 ENDIF
286 ENDIF
287 IF (ns10e > 0) THEN
288 IF(itagnd(ni)/=0) THEN
289C------- error out
290 CALL ancmsg(msgid=1211,
291 . msgtype=msgerror,
292 . anmode=aninfo,
293 . i1=itab(ni),
294 . c1='RBE3',
295 . i2=nuser,
296 . c2='RBE3')
297 ENDIF
298 END IF
299 frbe3(jj,iad+k) = wi(jj,ni)
300 ENDDO
301 END DO ! K=1,NM
302 iad = iad+nm
303 ENDDO ! DO J=1,NN
304 irbe3(5,i) = iad-irbe3(1,i)
305 irbe3(6,i) = irot
306
307! optimisation: only concerned nodes are set to zero
308! avoid to set to 0 all nodes (quadratic loop on NRBE3 and NUMNOD)
309 DO ni_ok = irbe3(1,i)+1,irbe3(1,i)+irbe3(5,i)
310 DO jj = 1,6
311 wi(jj,lrbe3(ni_ok)) = zero
312 ENDDO
313 ENDDO
314
315 END DO !I=1,NRBE3
316C
317 IF (ipri<5) WRITE(iout,1103)
318 DO i=1,nrbe3
319 iad = irbe3(1,i)
320 ns = irbe3(3,i)
321 nm = irbe3(5,i)
322 nuser = irbe3(2,i)
323 imodif = irbe3(8,i)
324 IF (imodif/=2) irbe3(8,i)=4
325 CALL prerbe3fr(irbe3 ,i ,j6 ,j6(4) )
326 IF (ipri>=5) THEN
327 WRITE(iout,1100) nuser,itab(ns),j6,nm,imodif,iform
328 WRITE(iout,1101)
329 DO j = 1, nm
330 WRITE(iout,1102) itab(lrbe3(iad+j)),iskew0(iad+j),
331 . (frbe3(jj,iad+j),jj=1,6)
332 ENDDO
333 WRITE(iout,*)
334 ELSE
335c WRITE(IOUT,1103)
336 WRITE(iout,1104) nuser,itab(ns),j6,nm,imodif,iform
337 END IF
338 lxintd = lxintd + nm/4 + 1
339 IF (iddlevel == 0) THEN
340 DO idir=1,6
341 CALL kinset(4096,itab(ns),ikine(ns),idir,0,
342 . ikine1(ns))
343 ENDDO
344 ENDIF
345 ENDDO
346 IF (nspmd==1) lxintd = 0
347C
348 DEALLOCATE(ikine1)
349 DEALLOCATE(iskew0)
350 DEALLOCATE(wi)
351 RETURN
352C
353 1000 FORMAT(//
354 .' INTERPOLATION CONSTRAINT BODY (RBE3) '/
355 . ' ---------------------- '/)
356 1100 FORMAT( 5x,'NUMBER. . . . . . . . . . . . . ',i10
357 . /5x,'DEPENDENT NODE . . . . . . . . .',i10
358 . /5x,'REFERENCE DOF(Trarot). . . . . . . ',3i1,1x,3i1
359 . /5x,'NUMBER OF INDEPENDENT NODES. . .',i10
360 . /5x,'FLAG OF WEIGHTING MODIFICATION .',i10
361 . /5x,'FLAG OF RBE3 FORMULATION. . . . ',i10)
362 1101 FORMAT(//
363 .' WEIGHTING FACTORS OF INDEPENDENT NODES '/
364 .' ------------------- '/
365 .' NODE SKEW DIR_TRA_1 DIR_TRA_2',
366 .' DIR_TRA_3 DIR_ROT_1 DIR_ROT_2',
367 .' DIR_ROT_3'/)
368 1102 FORMAT(3x,2i10,3x,6g20.13)
369 1103 FORMAT(' RBE3_ID DEPENDENT_NODE REF_DOF #IND. IMODIF IFORM'/)
370 1104 FORMAT(3x,2i10,2x,3i1,1x,3i1,3i10)
371C
372 END SUBROUTINE hm_read_rbe3
373!||====================================================================
374!|| inirbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
375!||--- called by ------------------------------------------------------
376!|| lectur ../starter/source/starter/lectur.F
377!||--- calls -----------------------------------------------------
378!|| ancmsg ../starter/source/output/message/message.F
379!|| fretitl2 ../starter/source/starter/freform.F
380!|| hireorbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.f
381!|| ifrontplus ../starter/source/spmd/node/frontplus.F
382!|| nlocal ../starter/source/spmd/node/ddtools.F
383!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
384!||--- uses -----------------------------------------------------
385!|| message_mod ../starter/share/message_module/message_mod.F
386!||====================================================================
387 SUBROUTINE inirbe3(IRBE3 ,LRBE3 ,FRBE3 ,SKEW ,X ,
388 . MS ,IN ,NOM_OPT)
389C-----------------------------------------------
390C M o d u l e s
391C-----------------------------------------------
392 USE message_mod
393 USE names_and_titles_mod , ONLY : nchartitle
394C-----------------------------------------------
395C I m p l i c i t T y p e s
396C-----------------------------------------------
397#include "implicit_f.inc"
398C-----------------------------------------------
399C C o m m o n B l o c k s
400C-----------------------------------------------
401#include "scr17_c.inc"
402#include "com01_c.inc"
403#include "com04_c.inc"
404#include "param_c.inc"
405#include "tabsiz_c.inc"
406C-----------------------------------------------
407C D u m m y A r g u m e n t s
408C-----------------------------------------------
409 INTEGER IRBE3(NRBE3L,*), LRBE3(*)
410 my_real
411 . SKEW(LSKEW,*), FRBE3(*),X(3,*),MS(*),IN(*)
412 INTEGER NOM_OPT(LNOPT1,*)
413C-----------------------------------------------
414C F u n c t i o n
415C-----------------------------------------------
416 INTEGER NLOCAL
417 EXTERNAL NLOCAL
418C-----------------------------------------------
419C L o c a l V a r i a b l e s
420C-----------------------------------------------
421 INTEGER I, N, K, NSL,NM, NI, NMT,M,IROT,IMO,ICR,
422 . J, P,IAD,NS,NN,J6(6),JJ,II,IADS,IERR1,NP,IC,ICT
423 INTEGER ID,IPEN
424 CHARACTER(LEN=NCHARTITLE)::TITR
425C
426 my_real w,wmin,in_t
427C-----------------------------------------------
428C FRBE3(1-3,I) : tw(i)
429C FRBE3(4-6,I) : rw(i)
430C FRBE3(3*SLRBE3+I) : MS
431C FRBE3(3*SLRBE3+SLRBE3/2+I) : IN
432C========================================================================|
433C----- re-ordering by hierrrchy (only 1 level)
434 CALL hireorbe3(irbe3 ,lrbe3 ,frbe3 ,nom_opt)
435 nmt = slrbe3/2
436 iads = 3*slrbe3
437 DO i=1,nrbe3
438 iad = irbe3(1,i)
439 ns = irbe3(3,i)
440 nm = irbe3(5,i)
441 irot =irbe3(6,i)
442 imo = irbe3(8,i)
443 ipen = irbe3(9,i)
444
445 id=nom_opt(1,i)
446 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
447C------ check if solid node for all independent
448 IF (in(ns)>em20.AND.ipen==0) ipen = 2 ! will be switch to pen if arm>0
449 IF (irot>0) THEN
450 in_t = zero
451 DO j=1,nm
452 m= lrbe3(iad+j)
453 in_t = in_t + in(m)
454 ENDDO
455 IF (in_t<em20) THEN
456 CALL ancmsg(msgid=3009,
457 . msgtype=msgwarning,
458 . anmode=aninfo_blind_1,
459 . i1=id,
460 . c1=titr)
461 irot = 0
462 irbe3(6,i) = 0
463 END IF
464 END IF !(IROT>0) THEN
465 CALL rbe3chk(lrbe3(iad+1),lrbe3(nmt+iad+1) ,ns ,x ,
466 . frbe3(6*iad+1),skew ,nm ,irot ,imo, wmin,
467 . ipen, ierr1 )
468 IF (ipen==-2) THEN
469 irbe3(9,i) = 0 ! small arm keep kinematic
470 ELSEIF (ipen==2) THEN
471 irbe3(9,i) = 1 ! add message
472 CALL ancmsg(msgid=3097,
473 . msgtype=msgwarning,
474 . anmode=aninfo_blind_1,
475 . i1=id,
476 . c1=titr)
477 END IF
478 IF (ierr1==400) THEN
479 id= irbe3(2,i)
480 CALL ancmsg(msgid=3098,
481 . msgtype=msgerror,
482 . anmode=aninfo,
483 . i1=id,
484 . c1=titr)
485 ELSEIF (ierr1>0) THEN
486 id= irbe3(2,i)
487 CALL ancmsg(msgid=706,
488 . msgtype=msgerror,
489 . anmode=aninfo,
490 . i1=id,
491 . c1=titr)
492 ELSEIF (ierr1<0) THEN
493 IF (imo==2) THEN
494 id= irbe3(2,i)
495 CALL ancmsg(msgid=749,
496 . msgtype=msgwarning,
497 . anmode=aninfo_blind_1,
498 . i1=id,
499 . c1=titr)
500 ELSE
501 id= irbe3(2,i)
502 CALL ancmsg(msgid=757,
503 . msgtype=msgwarning,
504 . anmode=aninfo_blind_2,
505 . i1=id,
506 . c1=titr,
507 . r1=wmin)
508 END IF
509 END IF
510 DO j=1,nm
511 m= lrbe3(iad+j)
512 frbe3(iads+j) =ms(m)
513 IF (iroddl/=0) frbe3(iads+nmt+j) =in(m)
514 ENDDO
515C------IF NS not in any proc : done already in domdec2
516 DO p = 1, nspmd
517 IF (nlocal(ns,p)==0) THEN
518 GO TO 200
519 ENDIF
520 DO j=1,nm
521 m= lrbe3(iad+j)
522 IF (nspmd>1) CALL ifrontplus(m,p)
523 ENDDO
524C optimisation possible
525 200 CONTINUE
526 END DO
527 iads = iads + nm
528 ENDDO
529C
530 RETURN
531 END
532!||====================================================================
533!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
534!||--- called by ------------------------------------------------------
535!|| inirbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
536!||--- calls -----------------------------------------------------
537!|| invert ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
538!|| rbe3uf ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
539!|| rbe3um ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
540!|| wrrinf ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
541!|| zero1 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
542!||====================================================================
543 SUBROUTINE rbe3chk(INRBE3 ,ILRBE3 ,NS ,XYZ ,FRBE3 ,
544 . SKEW ,NG ,IROT ,IMODIF ,WMIN ,
545 . IPEN ,IERR )
546C-----------------------------------------------
547C I m p l i c i t T y p e s
548C-----------------------------------------------
549#include "implicit_f.inc"
550C-----------------------------------------------
551C C o m m o n B l o c k s
552C-----------------------------------------------
553#include "param_c.inc"
554C-----------------------------------------------
555C D u m m y A r g u m e n t s
556C-----------------------------------------------
557 INTEGER INRBE3(*),ILRBE3(*),NG, NS,IROT,IMODIF,IERR,IPEN
558C REAL
559 my_real
560 . XYZ(3,*), FRBE3(6,*), SKEW(LSKEW,*),WMIN
561C-----------------------------------------------
562C L o c a l V a r i a b l e s
563C-----------------------------------------------
564 INTEGER I, J, K,N, M ,NML, IAD,JJ,KG,NSNGLR,IELSUB,KDIAG
565C REAL
566 my_real
567 * TW(3,NG), RW(3,NG),
568 * FUFXLC(3,NG), FUFYLC(3,NG), FUFZLC(3,NG),
569 * fumxlc(3,ng), fumylc(3,ng), fumzlc(3,ng),
570 * mxlc(3,ng), mylc(3,ng), mzlc(3,ng),
571 * fufx(3,ng), fufy(3,ng), fufz(3,ng),
572 * mufx(3,ng), mufy(3,ng), mufz(3,ng),
573 * fumx(3,ng), fumy(3,ng), fumz(3,ng),
574 * mx(3,ng), my(3,ng), mz(3,ng),
575 * mumx(3,ng), mumy(3,ng), mumz(3,ng),
576 * flocal(3,ng,6), mlocal(3,ng,6),
577 * fbasic(3,ng,6), mbasic(3,ng,6),
578 * fdstnl(3,ng,6), mdstnl(3,ng,6),
579 * fdstnb(3,ng,6), mdstnb(3,ng,6),el(3,3,ng)
580 my_real
581 * denfx, denfy, denfz, denmx, denmy, denmz,
582 * refpt(3), cgmx(3), cgmy(3), cgmz(3), averef,
583 * tfufx(3), tfufy(3), tfufz(3),
584 * tmufx(3), tmufy(3), tmufz(3),
585 * tfumx(3), tfumy(3), tfumz(3),
586 * tmumx(3), tmumy(3), tmumz(3),
587 * a(6,6), c(6,6), t(3,3),smin,smax,mmax,tmax,
588 * xbar(3),rn(3),gamma(9),wi(ng),gamma_max,rndotrn,det,arm
589C
590C INITIALIZATION
591C
592 CALL zero1(flocal,3*ng*6)
593 CALL zero1(mlocal,3*ng*6)
594 CALL zero1(fbasic,3*ng*6)
595 CALL zero1(mbasic,3*ng*6)
596 CALL zero1(fdstnl,3*ng*6)
597 CALL zero1(mdstnl,3*ng*6)
598 CALL zero1(fdstnb,3*ng*6)
599 CALL zero1(mdstnb,3*ng*6)
600 CALL zero1(a,36)
601 CALL zero1(c,36)
602 CALL zero1(cgmx,3)
603 CALL zero1(cgmy,3)
604 CALL zero1(cgmz,3)
605 ierr = 0
606 wmin =zero
607C----------debug use------------
608 kdiag = 0
609 refpt(1) = xyz(1,ns)
610 refpt(2) = xyz(2,ns)
611 refpt(3) = xyz(3,ns)
612 DO k = 1, ng
613 DO i = 1, 3
614 tw(i,k) = frbe3(i,k)
615 rw(i,k) = frbe3(i+3,k)
616 ENDDO
617 ENDDO
618C
619C ERROR OUT IF RBE3 ELEMENT HAS TWO INDEPENDENT NODES WITH
620C NO ROTATIONAL WEIGHTS SET (THIS MEANS THE ELEMENT CANNOT
621C SUPPORT A MOMENT ALONG ITS AXIS)
622C
623 IF (ng == 2.AND.irot==0) THEN
624 ierr = 322
625 GOTO 999
626 ENDIF
627C
628C CALCULATE DIRECTION COSINES OF LOCAL COORDINATE SYSTEMS, IF ANY
629C
630 DO k = 1, ng
631 ielsub = ilrbe3(k)
632 IF (ielsub > 0) THEN
633 DO i = 1, 3
634 el(i,1,k) = skew(i,ielsub)
635 el(i,2,k) = skew(i+3,ielsub)
636 el(i,3,k) = skew(i+6,ielsub)
637 ENDDO
638 ENDIF
639 ENDDO
640C
641C DENOMINATORS FOR DISTRIBUTING FORCES (DENFX, DENFY AND DENFZ)
642C
643 denfx = zero
644 denfy = zero
645 denfz = zero
646 averef = zero
647C
648 DO 70 k = 1, ng
649 kg = inrbe3(k)
650 ielsub = ilrbe3(k)
651 IF (ielsub > 0) THEN
652C
653C IF GRID POINT HAS A LOCAL COORDINATE SYSTEM
654C
655 DO 60 i = 1, 3
656 denfx = denfx + tw(i,k)*el(i,1,k)**2
657 denfy = denfy + tw(i,k)*el(i,2,k)**2
658 denfz = denfz + tw(i,k)*el(i,3,k)**2
659 60 CONTINUE
660 ELSE
661 denfx = denfx + tw(1,k)
662 denfy = denfy + tw(2,k)
663 denfz = denfz + tw(3,k)
664 END IF
665C
666 averef = averef + sqrt( (xyz(1,kg) - refpt(1))**2 +
667 * (xyz(2,kg) - refpt(2))**2 +
668 * (xyz(3,kg) - refpt(3))**2 )
669 70 CONTINUE
670C
671 IF (abs(denfx) <= em20) THEN
672 ierr = 326
673 ENDIF
674C
675 IF (abs(denfy) <= em20) THEN
676 ierr = 327
677 ENDIF
678C
679 IF (abs(denfz) <= em20) THEN
680 ierr = 328
681 ENDIF
682 IF (ierr > 0) GOTO 999
683 averef = averef/ng
684 IF (averef == zero) averef = 1.0d0
685C--- IMODIF=4: normalized TW;
686 IF (imodif==4.OR.ipen>0) THEN
687 DO k = 1, ng
688 frbe3(1,k) = frbe3(1,k)/denfx
689 frbe3(2,k) = frbe3(2,k)/denfy
690 frbe3(3,k) = frbe3(3,k)/denfz
691 frbe3(4,k) = frbe3(4,k)/denfx
692 frbe3(5,k) = frbe3(5,k)/denfy
693 frbe3(6,k) = frbe3(6,k)/denfz
694 ENDDO
695 END IF
696 IF (ipen > 0) THEN
697 xbar(1:3) = zero
698 DO k = 1, ng
699 kg = inrbe3(k)
700 wi(k) = frbe3(1,k)
701 xbar(1:3) = xbar(1:3) + wi(k)*xyz(1:3,kg)
702 ENDDO
703! keep kinematic if very small arm
704 rn(1:3) = refpt(1:3)-xbar(1:3)
705 arm = rn(1)*rn(1)+rn(2)*rn(2)+rn(3)*rn(3)
706 rndotrn = zero
707 DO k = 1, ng
708 kg = inrbe3(k)
709 rn(1:3) = xyz(1:3,kg)-xbar(1:3)
710 rndotrn = max(rndotrn,rn(1)*rn(1)+rn(2)*rn(2)+rn(3)*rn(3))
711 END DO
712 IF (arm/rndotrn < em06) ipen =-2
713C--- CHECK for penalty colinear case w/ irot=0
714 IF (irot==0) THEN
715 gamma(1:9) = zero
716 DO k = 1, ng
717 kg = inrbe3(k)
718 rn(1:3) = xyz(1:3,kg)-xbar(1:3)
719 rndotrn = rn(1)*rn(1)+rn(2)*rn(2)+rn(3)*rn(3)
720!
721 gamma(1) = gamma(1)+wi(k)*(rndotrn-rn(1)*rn(1))
722 gamma(2) = gamma(2)+wi(k)*( -rn(2)*rn(1))
723 gamma(3) = gamma(3)+wi(k)*( -rn(3)*rn(1))
724 gamma(4) = gamma(4)+wi(k)*( -rn(1)*rn(2))
725 gamma(5) = gamma(5)+wi(k)*(rndotrn-rn(2)*rn(2))
726 gamma(6) = gamma(6)+wi(k)*( -rn(3)*rn(2))
727 gamma(7) = gamma(7)+wi(k)*( -rn(1)*rn(3))
728 gamma(8) = gamma(8)+wi(k)*( -rn(2)*rn(3))
729 gamma(9) = gamma(9)+wi(k)*(rndotrn-rn(3)*rn(3))
730 ENDDO
731 det = (gamma(1)*(gamma(5)*gamma(9)-gamma(6)*gamma(8))-
732 * gamma(2)*(gamma(4)*gamma(9)-gamma(6)*gamma(7))+
733 * gamma(3)*(gamma(4)*gamma(8)-gamma(5)*gamma(7)))
734!
735 gamma_max = max(em20,gamma(1),gamma(5),gamma(9))
736 IF(abs(det/(gamma_max*gamma_max*gamma_max)) < em6) ierr = 400
737 END IF
738 END IF
739 IF (ierr > 0) GOTO 999
740!
741C
742C CALCULATE 3 CENTERS OF GRAVITY (CGMX, CGMY AND CGMZ) AND
743C DENOMINATORS FOR DISTRIBUTING MOMENTS (DENMX, DENMY AND DENMZ)
744C
745 DO 40 k = 1, ng
746 kg = inrbe3(k)
747 ielsub = ilrbe3(k)
748 IF (ielsub > 0) THEN
749C
750C IF THERE IS A LOCAL COORDINATE SYSTEM AT THE GRID POINT
751C
752 DO 10 i = 1, 3
753 cgmx(2) = cgmx(2) + tw(i,k)*el(i,3,k)**2*xyz(2,kg)
754 cgmx(3) = cgmx(3) + tw(i,k)*el(i,2,k)**2*xyz(3,kg)
755 10 CONTINUE
756C
757 DO 20 i = 1, 3
758 cgmy(3) = cgmy(3) + tw(i,k)*el(i,1,k)**2*xyz(3,kg)
759 cgmy(1) = cgmy(1) + tw(i,k)*el(i,3,k)**2*xyz(1,kg)
760 20 CONTINUE
761C
762 DO 30 i = 1, 3
763 cgmz(1) = cgmz(1) + tw(i,k)*el(i,2,k)**2*xyz(1,kg)
764 cgmz(2) = cgmz(2) + tw(i,k)*el(i,1,k)**2*xyz(2,kg)
765 30 CONTINUE
766C
767 ELSE
768 cgmx(2) = cgmx(2) + tw(3,k)*xyz(2,kg)
769 cgmx(3) = cgmx(3) + tw(2,k)*xyz(3,kg)
770C
771 cgmy(3) = cgmy(3) + tw(1,k)*xyz(3,kg)
772 cgmy(1) = cgmy(1) + tw(3,k)*xyz(1,kg)
773C
774 cgmz(1) = cgmz(1) + tw(2,k)*xyz(1,kg)
775 cgmz(2) = cgmz(2) + tw(1,k)*xyz(2,kg)
776 END IF
777 40 CONTINUE
778 cgmx(2) = cgmx(2)/denfz
779 cgmx(3) = cgmx(3)/denfy
780C
781 cgmy(3) = cgmy(3)/denfx
782 cgmy(1) = cgmy(1)/denfz
783C
784 cgmz(1) = cgmz(1)/denfy
785 cgmz(2) = cgmz(2)/denfx
786C
787 denmx = zero
788 denmy = zero
789 denmz = zero
790C
791 DO 90 k = 1, ng
792 kg = inrbe3(k)
793 ielsub = ilrbe3(k)
794C
795C NOTE: AS IMPLEMENTED IN NASTRAN 70.7, WE SCALE THE ROTATIONAL
796C WEIGHTS WITH THE SQUARE OF THE AVERAGE DISTANCE OF THE
797C INDEPENDENT GRID POINTS FROM THE REFERENCE POINT TO
798C RENDER THE RBE3 CALCULATIONS UNIT INDEPENDENT
799C
800 IF (ielsub > 0) THEN
801C
802C IF GRID POINT HAS A LOCAL COORDINATE SYSTEM
803C
804 DO 80 i = 1, 3
805 denmx = denmx + rw(i,k)*el(i,1,k)**2*averef**2 +
806 * tw(i,k)*( el(i,3,k)*(xyz(2,kg) - cgmx(2)) -
807 * el(i,2,k)*(xyz(3,kg) - cgmx(3))
808 * ) **2
809 denmy = denmy + rw(i,k)*el(i,2,k)**2*averef**2 +
810 * tw(i,k)*( el(i,1,k)*(xyz(3,kg) - cgmy(3)) -
811 * el(i,3,k)*(xyz(1,kg) - cgmy(1))
812 * ) **2
813 denmz = denmz + rw(i,k)*el(i,3,k)**2*averef**2 +
814 * tw(i,k)*( el(i,2,k)*(xyz(1,kg) - cgmz(1)) -
815 * el(i,1,k)*(xyz(2,kg) - cgmz(2))
816 * ) **2
817 80 CONTINUE
818 ELSE
819 denmx = denmx + rw(1,k)*averef**2 +
820 * tw(2,k)*(xyz(3,kg) - cgmx(3))**2 +
821 * tw(3,k)*(xyz(2,kg) - cgmx(2))**2
822 denmy = denmy + rw(2,k)*averef**2 +
823 * tw(1,k)*(xyz(3,kg) - cgmy(3))**2 +
824 * tw(3,k)*(xyz(1,kg) - cgmy(1))**2
825 denmz = denmz + rw(3,k)*averef**2 +
826 * tw(2,k)*(xyz(1,kg) - cgmz(1))**2 +
827 * tw(1,k)*(xyz(2,kg) - cgmz(2))**2
828 END IF
829 90 CONTINUE
830C
831C PERFORM SOME CHECKS ON WEIGHTS, TO MAKE SURE THAT THE RBE3
832C ELEMENT HAS NO UNCONSTRAINED DEGREES OF FREEDOM
833C
834C
835 IF (abs(denmx) <= em20) THEN
836 ierr = 329
837 ENDIF
838C
839 IF (abs(denmy) <= em20) THEN
840 ierr = 330
841 ENDIF
842C
843 IF (abs(denmz) <= em20) THEN
844 ierr = 331
845 ENDIF
846C
847 smin = min(abs(denmx),abs(denmy),abs(denmz))
848 smax = max(abs(denmx),abs(denmy),abs(denmz))
849C
850 IF (ierr > 0) GOTO 999
851C
852 IF (irot==0 .AND.(smax/smin)>thirty) ierr = -100
853C CALCULATE 3 FORCE DISTRIBUTIONS THAT CREATE NET X, Y AND Z FORCES
854C OF 1 (BESIDES OTHER NONZERO FORCES/MOMENTS IN ALL THE DIRECTIONS)
855C
856 CALL rbe3uf(inrbe3,ilrbe3,el,tw,xyz,refpt,
857 * fufxlc,fufylc,fufzlc,fufx,fufy,fufz,mufx,mufy,mufz,
858 * tfufx,tfufy,tfufz,tmufx,tmufy,tmufz,
859 * denfx,denfy,denfz,ng)
860C
861C CALCULATE 3 MOMENT/FORCE DISTRIBUTIONS THAT CREATE NET X, Y AND Z
862C MOMENTS OF 1 (BESIDES OTHER NONZERO FORCES/MOMENTS IN ALL THE
863C DIRECTIONS) AT CGMX, CGMY AND CGMZ RESPECTIVELY
864C
865 CALL rbe3um(inrbe3,ilrbe3,el,tw,rw,xyz,refpt,cgmx,cgmy,cgmz,
866 * fumxlc,fumylc,fumzlc,mxlc,mylc,mzlc,
867 * fumx,fumy,fumz,mx,my,mz,mumx,mumy,mumz,
868 * tfumx,tfumy,tfumz,tmumx,tmumy,tmumz,
869 * averef,denmx,denmy,denmz,ng,irot )
870C
871C DETERMINE COMBINATORY COEFFICIENTS FOR THESE 6 DISTRIBUTIONS
872C (6 COEFFICIENTS FOR EACH OF 6 CASES)
873C
874C CASE 1 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
875C DISTRIBUTIONS IS A UNIT X-FORCE AT REFERENCE POINT
876C CASE 2 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
877C DISTRIBUTIONS IS A UNIT Y-FORCE AT REFERENCE POINT
878C CASE 3 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
879C DISTRIBUTIONS IS A UNIT Z-FORCE AT REFERENCE POINT
880C CASE 4 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
881C DISTRIBUTIONS IS A UNIT X-MOMENT AT REFERENCE POINT
882C CASE 5 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
883C DISTRIBUTIONS IS A UNIT Y-MOMENT AT REFERENCE POINT
884C CASE 6 - RESULTANT OF THE LINEAR COMBINATION OF THESE FORCE/MOMENT
885C DISTRIBUTIONS IS A UNIT Z-MOMENT AT REFERENCE POINT
886C
887C IN ORDER TO DETERMINE THESE COEFFICIENTS, FIRST SET UP A 6X6
888C MATRIX. THE 6 COLUMNS OF THE INVERSE OF THIS MATRIX ARE THE
889C DESIRED 6 SETS OF COEFFICIENTS.
890C
891 DO 120 i = 1, 3
892 k = i + 3
893 a(i,1) = tfufx(i)
894 a(k,1) = tmufx(i)
895 a(i,2) = tfufy(i)
896 a(k,2) = tmufy(i)
897 a(i,3) = tfufz(i)
898 a(k,3) = tmufz(i)
899 a(i,4) = tfumx(i)
900 a(k,4) = tmumx(i)
901 a(i,5) = tfumy(i)
902 a(k,5) = tmumy(i)
903 a(i,6) = tfumz(i)
904 a(k,6) = tmumz(i)
905 120 CONTINUE
906C
907C INVERT THE 6X6 MATRIX
908C
909 nsnglr = 0
910 CALL invert(a,c,6,nsnglr)
911 IF (nsnglr /= 0) THEN
912 ierr = 332
913 GOTO 999
914 ENDIF
915 IF (kdiag >= 1) THEN
916 CALL wrrinf('C(i,1)=',c(1,1),3)
917 CALL wrrinf('C(i,2)=',c(1,2),3)
918 CALL wrrinf('C(i,3)=',c(1,3),3)
919 ENDIF
920 IF (kdiag==0.AND.ierr==0) RETURN
921C
922C LINEARLY COMBINE FORCE/MOMENT DISTRIBUTIONS FOR THE 6 CASES
923C
924 DO 170 j = 1, 6
925 DO 160 k = 1, ng
926 DO 150 i = 1, 3
927 flocal(i,k,j) = c(1,j)*fufxlc(i,k) + c(2,j)*fufylc(i,k) +
928 * c(3,j)*fufzlc(i,k) + c(4,j)*fumxlc(i,k) +
929 * c(5,j)*fumylc(i,k) + c(6,j)*fumzlc(i,k)
930 mlocal(i,k,j) = c(4,j)*mxlc(i,k) + c(5,j)*mylc(i,k) +
931 * c(6,j)*mzlc(i,k)
932 fbasic(i,k,j) = c(1,j)*fufx(i,k) + c(2,j)*fufy(i,k) +
933 * c(3,j)*fufz(i,k) + c(4,j)*fumx(i,k) +
934 * c(5,j)*fumy(i,k) + c(6,j)*fumz(i,k)
935 mbasic(i,k,j) = c(4,j)*mx(i,k) + c(5,j)*my(i,k) +
936 * c(6,j)*mz(i,k)
937 150 CONTINUE
938 160 CONTINUE
939 170 CONTINUE
940C
941C
942C NO LOCAL COORDINATE SYSTEM AT REFERENCE POINT
943C
944 DO 270 j = 1, 6
945 DO 260 k = 1, ng
946 DO 250 i = 1, 3
947 fdstnl(i,k,j) = flocal(i,k,j)
948 mdstnl(i,k,j) = mlocal(i,k,j)
949 fdstnb(i,k,j) = fbasic(i,k,j)
950 mdstnb(i,k,j) = mbasic(i,k,j)
951 250 CONTINUE
952 260 CONTINUE
953 270 CONTINUE
954C--------------special case with Imodif
955 IF (ierr==-100) THEN
956 mmax=zero
957 DO j = 4, 6
958 DO k = 1, ng
959 DO i = 1, 3
960 IF (mmax<abs(fdstnb(i,k,j))) mmax = abs(fdstnb(i,k,j))
961 END DO
962 END DO
963 END DO
964 IF (mmax<=one) THEN
965 ierr=0
966 ELSE
967 tmax=zero
968 IF (imodif/=2) THEN
969 DO k = 1, ng
970 DO i = 1, 3
971 IF (tmax<tw(i,k)) tmax=tw(i,k)
972 ENDDO
973 ENDDO
974 ENDIF
975 wmin=tmax*em04
976 DO k = 1, ng
977 frbe3(1,k) = max(wmin,frbe3(1,k))
978 frbe3(2,k) = max(wmin,frbe3(2,k))
979 frbe3(3,k) = max(wmin,frbe3(3,k))
980 ENDDO
981 ENDIF
982 END IF
983C
984 999 CONTINUE
985C
986C DIAGNOSTIC INFORMATION
987C
988 IF (kdiag >= 2) THEN
989c CALL WRRINF('REF_POINT',REFPT,3)
990c CALL WRRINF('INDPT_GRDS',INRBE3,NG)
991c IF (SMAX/SMIN > THIRTY) print *,'SMAX/SMIN=',SMAX/SMIN
992 CALL wrrinf('TRAN_WGHTS',tw,3*ng)
993 CALL wrrinf('ROT_WGHTS',rw,3*ng)
994 CALL wrrinf('CGMX',cgmx,3)
995 CALL wrrinf('CGMY',cgmy,3)
996 CALL wrrinf('CGMZ',cgmz,3)
997 CALL wrrinf('DENFX',denfx,1)
998 CALL wrrinf('DENFY',denfy,1)
999 CALL wrrinf('DENFZ',denfz,1)
1000 CALL wrrinf('DENMX',denmx,1)
1001 CALL wrrinf('DENMY',denmy,1)
1002 CALL wrrinf('DENMZ',denmz,1)
1003 CALL wrrinf('AVEREF',averef,1)
1004C
1005 IF (kdiag == 9.or.ierr/=0) THEN
1006 CALL wrrinf('FDSTNB_ULFX@REF',fdstnb(1,1,1),3*ng)
1007 CALL wrrinf('FDSTNB_ULFY@REF',fdstnb(1,1,2),3*ng)
1008 CALL wrrinf('FDSTNB_ULFZ@REF',fdstnb(1,1,3),3*ng)
1009 CALL wrrinf('FDSTNB_ULMX@REF',fdstnb(1,1,4),3*ng)
1010 CALL wrrinf('FDSTNB_ULMY@REF',fdstnb(1,1,5),3*ng)
1011 CALL wrrinf('FDSTNB_ULMZ@REF',fdstnb(1,1,6),3*ng)
1012 CALL wrrinf('MDSTNB_ULFX@REF',mdstnb(1,1,1),3*ng)
1013 CALL wrrinf('MDSTNB_ULFY@REF',mdstnb(1,1,2),3*ng)
1014 CALL wrrinf('MDSTNB_ULFZ@REF',mdstnb(1,1,3),3*ng)
1015 CALL wrrinf('MDSTNB_ULMX@REF',mdstnb(1,1,4),3*ng)
1016 CALL wrrinf('MDSTNB_ULMY@REF',mdstnb(1,1,5),3*ng)
1017 CALL wrrinf('MDSTNB_ULMZ@REF',mdstnb(1,1,6),3*ng)
1018 ENDIF
1019 IF (kdiag >= 30) THEN
1020 CALL wrrinf('FDSTNL_ULFX@REF',fdstnl(1,1,1),3*ng)
1021 CALL wrrinf('FDSTNL_ULFY@REF',fdstnl(1,1,2),3*ng)
1022 CALL wrrinf('FDSTNL_ULFZ@REF',fdstnl(1,1,3),3*ng)
1023 CALL wrrinf('FDSTNL_ULMX@REF',fdstnl(1,1,4),3*ng)
1024 CALL wrrinf('FDSTNL_ULMY@REF',fdstnl(1,1,5),3*ng)
1025 CALL wrrinf('FDSTNL_ULMZ@REF',fdstnl(1,1,6),3*ng)
1026 CALL wrrinf('MDSTNL_ULFX@REF',mdstnl(1,1,1),3*ng)
1027 CALL wrrinf('MDSTNL_ULFY@REF',mdstnl(1,1,2),3*ng)
1028 CALL wrrinf('MDSTNL_ULFZ@REF',mdstnl(1,1,3),3*ng)
1029 CALL wrrinf('MDSTNL_ULMX@REF',mdstnl(1,1,4),3*ng)
1030 CALL wrrinf('MDSTNL_ULMY@REF',mdstnl(1,1,5),3*ng)
1031 CALL wrrinf('MDSTNL_ULMZ@REF',mdstnl(1,1,6),3*ng)
1032C
1033C
1034 ENDIF
1035 ENDIF
1036C
1037 RETURN
1038 END
1039!||====================================================================
1040!|| rbe3uf ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1041!||--- called by ------------------------------------------------------
1042!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1043!|| rbe3cl ../starter/source/constraints/general/kinchk.F
1044!||--- calls -----------------------------------------------------
1045!|| zero1 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1046!||====================================================================
1047 SUBROUTINE rbe3uf(INRBE3,ILRBE3,EL,TW,XYZ,REFPT,
1048 * FUFXLC,FUFYLC,FUFZLC,
1049 * FUFX,FUFY,FUFZ,MUFX,MUFY,MUFZ,
1050 * TFUFX,TFUFY,TFUFZ,TMUFX,TMUFY,TMUFZ,
1051 * DENFX,DENFY,DENFZ,NG)
1052C-----------------------------------------------
1053C I m p l i c i t T y p e s
1054C-----------------------------------------------
1055#include "implicit_f.inc"
1056 INTEGER NG
1057 INTEGER INRBE3(NG), ILRBE3(NG)
1058 my_real
1059 * EL(3,3,*),TW(3,NG), XYZ(3,*), REFPT(3),
1060 * FUFXLC(3,NG), FUFYLC(3,NG), FUFZLC(3,NG),
1061 * FUFX(3,NG), FUFY(3,NG), FUFZ(3,NG),
1062 * MUFX(3,NG), MUFY(3,NG), MUFZ(3,NG),
1063 * TFUFX(3), TFUFY(3), TFUFZ(3),
1064 * TMUFX(3), TMUFY(3), TMUFZ(3)
1065 my_real
1066 * denfx, denfy, denfz,xarm, yarm, zarm
1067 INTEGER I, J, K, KG, IELSUB
1068C
1069C INITIALIZE FORCE AND MOMENT DISTRIBUTIONS TO ZERO
1070C
1071 CALL ZERO1(FUFX,3*NG)
1072 CALL ZERO1(FUFY,3*NG)
1073 CALL ZERO1(FUFZ,3*NG)
1074 CALL zero1(tfufx,3)
1075 CALL zero1(tfufy,3)
1076 CALL zero1(tfufz,3)
1077 CALL zero1(tmufx,3)
1078 CALL zero1(tmufy,3)
1079 CALL zero1(tmufz,3)
1080C
1081C FORCE DISTRIBUTIONS AT RBE3 GRID POINTS CORRESPONDING TO UNIT
1082C APPLIED FORCES AT RBE3 REFERENCE POINT ALONG (BASIC COORDINATE)
1083C X, Y AND Z DIRECTIONS
1084C
1085 DO 50 k = 1, ng
1086 kg = inrbe3(k)
1087 ielsub = ilrbe3(k)
1088 IF (ielsub > 0) THEN
1089C
1090C FORCES AT GRID POINT ALONG GRID POINT'S LOCAL (OUTPUT)
1091C COORDINATE AXES
1092C
1093 DO 10 i = 1, 3
1094 fufxlc(i,k) = tw(i,k)*el(i,1,k)/denfx
1095 fufylc(i,k) = tw(i,k)*el(i,2,k)/denfy
1096 fufzlc(i,k) = tw(i,k)*el(i,3,k)/denfz
1097 10 CONTINUE
1098C
1099C FORCES AT GRID POINT ALONG BASIC COORDINATE AXES
1100C
1101 DO 30 i = 1, 3
1102 DO 20 j = 1, 3
1103 fufx(j,k) = fufx(j,k) + fufxlc(i,k)*el(i,j,k)
1104 fufy(j,k) = fufy(j,k) + fufylc(i,k)*el(i,j,k)
1105 fufz(j,k) = fufz(j,k) + fufzlc(i,k)*el(i,j,k)
1106 20 CONTINUE
1107 30 CONTINUE
1108C
1109 ELSE
1110 fufxlc(1,k) = tw(1,k)/denfx
1111 fufylc(2,k) = tw(2,k)/denfy
1112 fufzlc(3,k) = tw(3,k)/denfz
1113 fufx(1,k) = fufxlc(1,k)
1114 fufy(2,k) = fufylc(2,k)
1115 fufz(3,k) = fufzlc(3,k)
1116 ENDIF
1117C
1118C MOMENTS AT REFERENCE POINT DUE TO THESE FORCE DISTRIBUTIONS
1119C
1120 xarm = xyz(1,kg) - refpt(1)
1121 yarm = xyz(2,kg) - refpt(2)
1122 zarm = xyz(3,kg) - refpt(3)
1123C
1124C MOMENTS AT REFERENCE POINT DUE TO FUFX
1125C
1126 mufx(1,k) = yarm*fufx(3,k) - zarm*fufx(2,k)
1127 mufx(2,k) = zarm*fufx(1,k) - xarm*fufx(3,k)
1128 mufx(3,k) = xarm*fufx(2,k) - yarm*fufx(1,k)
1129C
1130C MOMENTS AT REFERENCE POINT DUE TO FUFY
1131C
1132 mufy(1,k) = yarm*fufy(3,k) - zarm*fufy(2,k)
1133 mufy(2,k) = zarm*fufy(1,k) - xarm*fufy(3,k)
1134 mufy(3,k) = xarm*fufy(2,k) - yarm*fufy(1,k)
1135C
1136C MOMENTS AT REFERENCE POINT DUE TO FUFZ
1137C
1138 mufz(1,k) = yarm*fufz(3,k) - zarm*fufz(2,k)
1139 mufz(2,k) = zarm*fufz(1,k) - xarm*fufz(3,k)
1140 mufz(3,k) = xarm*fufz(2,k) - yarm*fufz(1,k)
1141C
1142C TOTAL FORCES AND MOMENTS
1143C
1144 DO 40 j = 1, 3
1145 tfufx(j) = tfufx(j) + fufx(j,k)
1146 tfufy(j) = tfufy(j) + fufy(j,k)
1147 tfufz(j) = tfufz(j) + fufz(j,k)
1148 tmufx(j) = tmufx(j) + mufx(j,k)
1149 tmufy(j) = tmufy(j) + mufy(j,k)
1150 tmufz(j) = tmufz(j) + mufz(j,k)
1151 40 CONTINUE
1152C
1153 50 CONTINUE
1154C
1155 RETURN
1156 END
1157C
1158!||====================================================================
1159!|| rbe3um ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1160!||--- called by ------------------------------------------------------
1161!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1162!|| rbe3cl ../starter/source/constraints/general/kinchk.F
1163!||--- calls -----------------------------------------------------
1164!|| zero1 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1165!||====================================================================
1166 SUBROUTINE rbe3um(INRBE3,ILRBE3,EL,TW,RW,XYZ,REFPT,CGMX,CGMY,CGMZ,
1167 * FUMXLC,FUMYLC,FUMZLC,MXLC,MYLC,MZLC,
1168 * FUMX,FUMY,FUMZ,MX,MY,MZ,MUMX,MUMY,MUMZ,
1169 * TFUMX,TFUMY,TFUMZ,TMUMX,TMUMY,TMUMZ,
1170 * AVEREF,DENMX,DENMY,DENMZ,NG ,IROT)
1171C-----------------------------------------------
1172C I m p l i c i t T y p e s
1173C-----------------------------------------------
1174#include "implicit_f.inc"
1175 INTEGER NG,IROT
1176 INTEGER INRBE3(NG), ILRBE3(NG)
1177 my_real
1178 * EL(3,3,*),TW(3,NG), RW(3,NG), XYZ(3,*),
1179 * refpt(3), cgmx(3), cgmy(3), cgmz(3),
1180 * fumxlc(3,ng), fumylc(3,ng), fumzlc(3,ng),
1181 * mxlc(3,ng), mylc(3,ng), mzlc(3,ng),
1182 * fumx(3,ng), fumy(3,ng), fumz(3,ng),
1183 * mx(3,ng), my(3,ng), mz(3,ng),
1184 * mumx(3,ng), mumy(3,ng), mumz(3,ng),
1185 * tfumx(3), tfumy(3), tfumz(3),
1186 * tmumx(3), tmumy(3), tmumz(3)
1187 my_real
1188 * averef, denmx, denmy, denmz,xarm, yarm, zarm
1189 INTEGER I, J, K, KG, IELSUB
1190C
1191C INITIALIZE FORCE AND MOMENT DISTRIBUTIONS TO ZERO
1192C
1193 CALL zero1(fumx,3*ng)
1194 CALL zero1(fumy,3*ng)
1195 CALL zero1(fumz,3*ng)
1196 CALL zero1(mx,3*ng)
1197 CALL zero1(my,3*ng)
1198 CALL zero1(mz,3*ng)
1199 CALL zero1(tfumx,3)
1200 CALL zero1(tfumy,3)
1201 CALL zero1(tfumz,3)
1202 CALL zero1(tmumx,3)
1203 CALL zero1(tmumy,3)
1204 CALL zero1(tmumz,3)
1205C
1206C FORCE AND MOMENT DISTRIBUTIONS AT RBE3 GRID POINTS CORRESPONDING
1207C TO UNIT APPLIED MOMENTS AT RBE3 REFERENCE POINT ALONG (BASIC
1208C COORDINATE) X, Y AND Z DIRECTIONS
1209C
1210 DO 50 k = 1, ng
1211 kg = inrbe3(k)
1212 ielsub = ilrbe3(k)
1213 IF (ielsub > 0) THEN
1214C
1215C FORCES AT GRID POINT ALONG GRID POINT'S LOCAL
1216C (OUTPUT) COORDINATE AXES
1217C
1218 DO 10 i = 1, 3
1219 fumxlc(i,k) = tw(i,k)*
1220 * ( el(i,3,k)*(xyz(2,kg) - cgmx(2)) -
1221 * el(i,2,k)*(xyz(3,kg) - cgmx(3))
1222 * )/denmx
1223 fumylc(i,k) = tw(i,k)*
1224 * ( el(i,1,k)*(xyz(3,kg) - cgmy(3)) -
1225 * el(i,3,k)*(xyz(1,kg) - cgmy(1))
1226 * )/denmy
1227 fumzlc(i,k) = tw(i,k)*
1228 * ( el(i,2,k)*(xyz(1,kg) - cgmz(1)) -
1229 * el(i,1,k)*(xyz(2,kg) - cgmz(2))
1230 * )/denmz
1231 10 CONTINUE
1232C
1233C FORCES AND MOMENTS AT GRID POINT ALONG BASIC COORDINATE AXES
1234C
1235 DO 30 i = 1, 3
1236 DO 20 j = 1, 3
1237 fumx(j,k) = fumx(j,k) + fumxlc(i,k)*el(i,j,k)
1238 fumy(j,k) = fumy(j,k) + fumylc(i,k)*el(i,j,k)
1239 fumz(j,k) = fumz(j,k) + fumzlc(i,k)*el(i,j,k)
1240 20 CONTINUE
1241 30 CONTINUE
1242C
1243 ELSE
1244 fumxlc(2,k) = -tw(2,k)*(xyz(3,kg) - cgmx(3))/denmx
1245 fumxlc(3,k) = tw(3,k)*(xyz(2,kg) - cgmx(2))/denmx
1246 fumylc(1,k) = tw(1,k)*(xyz(3,kg) - cgmy(3))/denmy
1247 fumylc(3,k) = -tw(3,k)*(xyz(1,kg) - cgmy(1))/denmy
1248 fumzlc(1,k) = -tw(1,k)*(xyz(2,kg) - cgmz(2))/denmz
1249 fumzlc(2,k) = tw(2,k)*(xyz(1,kg) - cgmz(1))/denmz
1250C
1251 fumx(2,k) = fumxlc(2,k)
1252 fumx(3,k) = fumxlc(3,k)
1253 fumy(1,k) = fumylc(1,k)
1254 fumy(3,k) = fumylc(3,k)
1255 fumz(1,k) = fumzlc(1,k)
1256 fumz(2,k) = fumzlc(2,k)
1257 ENDIF
1258C
1259C MOMENTS AT REFERENCE POINT DUE TO FUMX
1260C
1261 xarm = xyz(1,kg) - refpt(1)
1262 yarm = xyz(2,kg) - refpt(2)
1263 zarm = xyz(3,kg) - refpt(3)
1264C
1265 mumx(1,k) = yarm*fumx(3,k) - zarm*fumx(2,k)
1266 mumx(2,k) = zarm*fumx(1,k) - xarm*fumx(3,k)
1267 mumx(3,k) = xarm*fumx(2,k) - yarm*fumx(1,k)
1268C
1269C MOMENTS AT REFERENCE POINT DUE TO FUMY
1270C
1271 mumy(1,k) = yarm*fumy(3,k) - zarm*fumy(2,k)
1272 mumy(2,k) = zarm*fumy(1,k) - xarm*fumy(3,k)
1273 mumy(3,k) = xarm*fumy(2,k) - yarm*fumy(1,k)
1274C
1275C MOMENTS AT REFERENCE POINT DUE TO FUMZ
1276C
1277 mumz(1,k) = yarm*fumz(3,k) - zarm*fumz(2,k)
1278 mumz(2,k) = zarm*fumz(1,k) - xarm*fumz(3,k)
1279 mumz(3,k) = xarm*fumz(2,k) - yarm*fumz(1,k)
1280C
1281 50 CONTINUE
1282C
1283 IF (irot>0) THEN
1284 DO k = 1, ng
1285 kg = inrbe3(k)
1286 ielsub = ilrbe3(k)
1287 IF (ielsub > 0) THEN
1288C
1289C MOMENTS AT GRID POINT ALONG GRID POINT'S LOCAL
1290C (OUTPUT) COORDINATE AXES
1291C
1292 DO i = 1, 3
1293 mxlc(i,k) = averef**2*rw(i,k)*el(i,1,k)/denmx
1294 mylc(i,k) = averef**2*rw(i,k)*el(i,2,k)/denmy
1295 mzlc(i,k) = averef**2*rw(i,k)*el(i,3,k)/denmz
1296 END DO
1297C
1298C MOMENTS AT GRID POINT ALONG BASIC COORDINATE AXES
1299C
1300 DO i = 1, 3
1301 DO j = 1, 3
1302 mx(j,k) = mx(j,k) + mxlc(i,k)*el(i,j,k)
1303 my(j,k) = my(j,k) + mylc(i,k)*el(i,j,k)
1304 mz(j,k) = mz(j,k) + mzlc(i,k)*el(i,j,k)
1305 END DO
1306 END DO
1307C
1308 ELSE
1309 mxlc(1,k) = averef**2*rw(1,k)/denmx
1310 mylc(2,k) = averef**2*rw(2,k)/denmy
1311 mzlc(3,k) = averef**2*rw(3,k)/denmz
1312C
1313 mx(1,k) = mxlc(1,k)
1314 my(2,k) = mylc(2,k)
1315 mz(3,k) = mzlc(3,k)
1316 ENDIF
1317C
1318 DO j = 1, 3
1319 mumx(j,k) = mumx(j,k) + mx(j,k)
1320 mumy(j,k) = mumy(j,k) + my(j,k)
1321 mumz(j,k) = mumz(j,k) + mz(j,k)
1322 END DO
1323 END DO
1324 END IF
1325C
1326C
1327C TOTAL FORCES AND MOMENTS
1328C
1329C
1330 DO k = 1, ng
1331 DO j = 1, 3
1332 tfumx(j) = tfumx(j) + fumx(j,k)
1333 tfumy(j) = tfumy(j) + fumy(j,k)
1334 tfumz(j) = tfumz(j) + fumz(j,k)
1335 tmumx(j) = tmumx(j) + mumx(j,k)
1336 tmumy(j) = tmumy(j) + mumy(j,k)
1337 tmumz(j) = tmumz(j) + mumz(j,k)
1338 END DO
1339 END DO
1340C
1341 RETURN
1342 END
1343!||====================================================================
1344!|| invert ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1345!||--- called by ------------------------------------------------------
1346!|| damping_range_compute_param ../starter/source/general_controls/damping/damping_range_compute_param.f90
1347!|| law87_upd ../starter/source/materials/mat/mat087/law87_upd.F90
1348!|| mass_fluid_qd ../starter/source/fluid/mass-fluid_qd.F
1349!|| mass_fluid_tg ../starter/source/fluid/mass-fluid_tg.F
1350!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1351!|| rbe3cl ../starter/source/constraints/general/kinchk.F
1352!||====================================================================
1353 SUBROUTINE invert(MATRIX, INVERSE, N, ERRORFLAG)
1354C-----------------------------------------------
1355C I m p l i c i t T y p e s
1356C-----------------------------------------------
1357#include "implicit_f.inc"
1358c !DECLARATIONS
1359 INTEGER, INTENT(IN) :: N
1360 INTEGER, INTENT(OUT) :: ERRORFLAG !RETURN ERROR STATUS. -1 FOR ERROR, 0 FOR NORMAL
1361 my_real
1362 * , INTENT(IN), DIMENSION(N,N) :: MATRIX !INPUT MATRIX
1363 my_real
1364 * , INTENT(OUT), DIMENSION(N,N) :: INVERSE !INVERTED MATRIX
1365
1366 LOGICAL :: FLAG = .true.
1367 INTEGER :: I, J, K, L
1368 my_real
1369 * :: M
1370 my_real
1371 * , DIMENSION(N,2*N) :: AUGMATRIX !AUGMENTED MATRIX
1372
1373c !AUGMENT INPUT MATRIX WITH AN IDENTITY MATRIX
1374 DO i = 1, n
1375 DO j = 1, 2*n
1376 IF (j <= n ) THEN
1377 augmatrix(i,j) = matrix(i,j)
1378 ELSE IF ((i+n) == j) THEN
1379 augmatrix(i,j) = one
1380 ELSE
1381 augmatrix(i,j) = zero
1382 ENDIF
1383 END DO
1384 END DO
1385
1386c !REDUCE AUGMENTED MATRIX TO UPPER TRIANGULAR FORM
1387 DO k =1, n-1
1388 IF (augmatrix(k,k) == 0) THEN
1389 flag = .false.
1390 DO i = k+1, n
1391 IF (augmatrix(i,k) /= 0) THEN
1392 DO j = 1,2*n
1393 augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
1394 END DO
1395 flag = .true.
1396 EXIT
1397 ENDIF
1398 IF (flag .EQV. .false.) THEN
1399 print*, "MATRIX IS NON - INVERTIBLE"
1400 inverse = 0
1401 errorflag = -1
1402 RETURN
1403 ENDIF
1404 END DO
1405 ENDIF
1406 DO j = k+1, n
1407 m = augmatrix(j,k)/augmatrix(k,k)
1408 DO i = k, 2*n
1409 augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
1410 END DO
1411 END DO
1412 END DO
1413
1414c !TEST FOR INVERTIBILITY
1415 DO i = 1, n
1416 IF (augmatrix(i,i) == 0) THEN
1417 print*, "MATRIX IS NON - INVERTIBLE"
1418 inverse = 0
1419 errorflag = -1
1420 RETURN
1421 ENDIF
1422 END DO
1423
1424c !MAKE DIAGONAL ELEMENTS AS 1
1425 DO i = 1 , n
1426 m = augmatrix(i,i)
1427 DO j = i , (2 * n)
1428 augmatrix(i,j) = (augmatrix(i,j) / m)
1429 END DO
1430 END DO
1431
1432c !REDUCED RIGHT SIDE HALF OF AUGMENTED MATRIX TO IDENTITY MATRIX
1433 DO k = n-1, 1, -1
1434 DO i =1, k
1435 m = augmatrix(i,k+1)
1436 DO j = k, (2*n)
1437 augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
1438 END DO
1439 END DO
1440 END DO
1441
1442c !STORE ANSWER
1443 DO i =1, n
1444 DO j = 1, n
1445 inverse(i,j) = augmatrix(i,j+n)
1446 END DO
1447 END DO
1448 errorflag = 0
1449 RETURN
1450 END SUBROUTINE invert
1451C----------------------------
1452!||====================================================================
1453!|| wrrinf ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1454!||--- called by ------------------------------------------------------
1455!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1456!||====================================================================
1457 SUBROUTINE wrrinf(TITLE,R,N)
1458#include "implicit_f.inc"
1459#include "units_c.inc"
1460c !DECLARATIONS
1461 INTEGER N
1462 my_real
1463 . r(n),rmax
1464 CHARACTER TITLE*(*)
1465C----------------------------
1466 INTEGER I
1467 write(iout, *)TITLE,(R(I),I=1,n)
1468c print *,TITLE,(R(I),I=1,N)
1469 RETURN
1470 END
1471C----------------------------
1472!||====================================================================
1473!|| zero1 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1474!||--- called by ------------------------------------------------------
1475!|| rbe3chk ../starter/source/constraints/general/rbe3/hm_read_rbe3.f
1476!|| rbe3cl ../starter/source/constraints/general/kinchk.F
1477!|| rbe3uf ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1478!|| rbe3um ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1479!||====================================================================
1480 SUBROUTINE zero1(R,N)
1481#include "implicit_f.inc"
1482c !DECLARATIONS
1483 INTEGER N
1484 my_real
1485 . R(N)
1486C----------------------------
1487 INTEGER I
1488 DO I = 1,n
1489 r(i) = zero
1490 ENDDO
1491 RETURN
1492 END
1493!||====================================================================
1494!|| prerbe3fr ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1495!||--- called by ------------------------------------------------------
1496!|| hm_read_rbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1497!||====================================================================
1498 SUBROUTINE prerbe3fr(IRBE3 ,N ,JT ,JR )
1499C-----------------------------------------------
1500C I m p l i c i t T y p e s
1501C-----------------------------------------------
1502#include "implicit_f.inc"
1503C-----------------------------------------------
1504C C o m m o n B l o c k s
1505C-----------------------------------------------
1506#include "param_c.inc"
1507C-----------------------------------------------
1508C D u m m y A r g u m e n t s
1509C-----------------------------------------------
1510 INTEGER IRBE3(NRBE3L,*),JT(3) ,JR(3),N
1511C REAL
1512C-----------------------------------------------
1513C L o c a l V a r i a b l e s
1514C-----------------------------------------------
1515 INTEGER I, J,IC,ICT,ICR
1516C======================================================================|
1517 IC=irbe3(4,n)
1518 ict=ic/512
1519 icr=(ic-512*(ict))/64
1520 DO j =1,3
1521 jt(j)=0
1522 jr(j)=0
1523 ENDDO
1524 SELECT CASE (ict)
1525 CASE(1)
1526 jt(3)=1
1527 CASE(2)
1528 jt(2)=1
1529 CASE(3)
1530 jt(2)=1
1531 jt(3)=1
1532 CASE(4)
1533 jt(1)=1
1534 CASE(5)
1535 jt(1)=1
1536 jt(3)=1
1537 CASE(6)
1538 jt(1)=1
1539 jt(2)=1
1540 CASE(7)
1541 jt(1)=1
1542 jt(2)=1
1543 jt(3)=1
1544 END SELECT
1545 SELECT CASE (icr)
1546 CASE(1)
1547 jr(3)=1
1548 CASE(2)
1549 jr(2)=1
1550 CASE(3)
1551 jr(2)=1
1552 jr(3)=1
1553 CASE(4)
1554 jr(1)=1
1555 CASE(5)
1556 jr(1)=1
1557 jr(3)=1
1558 CASE(6)
1559 jr(1)=1
1560 jr(2)=1
1561 CASE(7)
1562 jr(1)=1
1563 jr(2)=1
1564 jr(3)=1
1565 END SELECT
1566C---
1567 RETURN
1568 END
1569!||====================================================================
1570!|| hireorbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1571!||--- called by ------------------------------------------------------
1572!|| inirbe3 ../starter/source/constraints/general/rbe3/hm_read_rbe3.F
1573!||--- calls -----------------------------------------------------
1574!|| ancmsg ../starter/source/output/message/message.F
1575!|| fretitl2 ../starter/source/starter/freform.f
1576!||--- uses -----------------------------------------------------
1577!|| message_mod ../starter/share/message_module/message_mod.F
1578!||====================================================================
1579 SUBROUTINE hireorbe3(IRBE3 ,LRBE3 ,FRBE3 ,NOM_OPT)
1580C-----------------------------------------------
1581C M o d u l e s
1582C-----------------------------------------------
1583 USE my_alloc_mod
1584 USE message_mod
1585 USE names_and_titles_mod , ONLY : nchartitle
1586C-----------------------------------------------
1587C I m p l i c i t T y p e s
1588C-----------------------------------------------
1589#include "implicit_f.inc"
1590C-----------------------------------------------
1591C C o m m o n B l o c k s
1592C-----------------------------------------------
1593#include "com04_c.inc"
1594#include "param_c.inc"
1595#include "scr17_c.inc"
1596#include "tabsiz_c.inc"
1597C-----------------------------------------------
1598C D u m m y A r g u m e n t s
1599C-----------------------------------------------
1600 INTEGER IRBE3(NRBE3L,*), LRBE3(*),NOM_OPT(LNOPT1,*)
1601 my_real
1602 . FRBE3(*)
1603C-----------------------------------------------
1604C L o c a l V a r i a b l e s
1605C-----------------------------------------------
1606 INTEGER I, N, J,K, NS,NM, NI, NMT,M,NFT,JLT,IAD,II,M2,III,IPEN
1607C
1608 INTEGER ID, INDEX(NRBE3),NZ,IAD1,IADS,
1609 . LCOPY(SLRBE3),ICOPY(NRBE3L,NRBE3)
1610 INTEGER,DIMENSION(:),ALLOCATABLE :: ITAG
1611 CHARACTER(LEN=NCHARTITLE)::TITR
1612 my_real FCOPY(SLRBE3*3)
1613C========================================================================|
1614C-----only one level of hierarchy is allowed
1615 CALL my_alloc(itag,numnod)
1616 itag(1:numnod)=0
1617 DO i=1,nrbe3
1618 ns = irbe3(3,i)
1619 IF (itag(ns)==0) itag(ns)=i
1620 index(i) = i
1621 ENDDO
1622 nz = 0
1623! case Iform=2 : error out if >1 level
1624 DO i=1,nrbe3
1625 iad = irbe3(1,i)
1626 nm = irbe3(5,i)
1627 ipen= irbe3(9,i)
1628 IF (ipen>=0) cycle
1629 DO j =1,nm
1630 m = lrbe3(iad+j)
1631 IF (itag(m)>0) THEN
1632 ii = itag(m)
1633 IF (irbe3(9,ii)<0) nz = nz +1
1634 END IF
1635 ENDDO
1636 ENDDO
1637 IF (nz >0 ) THEN
1638C-----error out if >1 level
1639 DO i=1,nrbe3
1640 iad = irbe3(1,i)
1641 nm = irbe3(5,i)
1642 ipen= irbe3(9,i)
1643 IF (ipen>=0) cycle
1644 DO j =1,nm
1645 m = lrbe3(iad+j)
1646 IF (itag(m)>0) THEN
1647 ii = itag(m)
1648 IF (irbe3(9,ii)<0) THEN
1649 nmt = irbe3(5,ii)
1650 DO k =1,nmt
1651 nft = irbe3(1,ii)
1652 m2 = lrbe3(nft+k)
1653 IF (itag(m2)>0) THEN
1654 iii = itag(m2)
1655 IF (irbe3(9,iii)<0) THEN
1656 id=nom_opt(1,iii)
1657 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,iii),ltitr)
1658 CALL ancmsg(msgid=1887,
1659 . msgtype=msgerror,
1660 . anmode=aninfo,
1661 . i1=id,
1662 . c1=titr,
1663 . i2=nom_opt(1,i),
1664 . i3=nom_opt(1,ii))
1665 END IF !(IRBE3(9,III)<0) THEN
1666 END IF
1667 ENDDO
1668 END IF !(IRBE3(9,II)<0) THEN
1669 ENDIF
1670 ENDDO
1671 ENDDO
1672 END IF !(NZ >0 ) THEN
1673! case Iform=1,3
1674 nz = 0
1675 DO i=1,nrbe3
1676 iad = irbe3(1,i)
1677 ipen= irbe3(9,i)
1678 IF (ipen>0) cycle
1679 nm = irbe3(5,i)
1680 DO j =1,nm
1681 m = lrbe3(iad+j)
1682 IF (itag(m)>0) THEN
1683 ipen= irbe3(9,itag(m))
1684 IF (ipen==0) THEN
1685 nz = nz + 1
1686 cycle
1687 END IF
1688 ENDIF
1689 ENDDO
1690 ENDDO
1691 IF (nz >0 ) THEN
1692!-----swtch to penalty if >1 level
1693 DO i=nrbe3,1,-1
1694 iad = irbe3(1,i)
1695 ipen= irbe3(9,i)
1696 IF (ipen>0) cycle
1697 nm = irbe3(5,i)
1698 ii = 0
1699 DO j =1,nm
1700 m = lrbe3(iad+j)
1701 IF (itag(m)>0) THEN
1702 ipen= irbe3(9,itag(m))
1703 IF (ipen/=0) cycle
1704 ii = itag(m)
1705 nmt = irbe3(5,ii)
1706 nft = irbe3(1,ii)
1707 iii = 0
1708 DO k =1,nmt
1709 m2 = lrbe3(nft+k)
1710 IF (itag(m2)>0) THEN
1711 ipen= irbe3(9,itag(m2))
1712 IF (ipen==0) THEN
1713 iii = itag(m2)
1714 cycle
1715 END IF
1716 END IF
1717 ENDDO
1718 IF (iii>0) cycle
1719 ENDIF
1720 ENDDO
1721 IF (ii >0 .AND. iii>0) THEN
1722 id=nom_opt(1,i)
1723 CALL fretitl2(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
1724 irbe3(9,i) = 1
1725 CALL ancmsg(msgid=3099,
1726 . msgtype=msgwarning,
1727 . anmode=aninfo,
1728 . i1=id,
1729 . c1=titr,
1730 . i2=nom_opt(1,ii),
1731 . i3=nom_opt(1,iii))
1732 END IF
1733 ENDDO
1734 END IF
1735C----- re-ordering
1736 nz = 0
1737 DO i=1,nrbe3
1738 iad = irbe3(1,i)
1739 ipen= irbe3(9,i)
1740 IF (ipen>0) cycle
1741 nm = irbe3(5,i)
1742 DO j =1,nm
1743 m = lrbe3(iad+j)
1744 IF (itag(m)>0) THEN
1745 ipen= irbe3(9,itag(m))
1746 IF (ipen<=0) THEN
1747 nz = nz +1
1748!----- exchange INDEX(I) , NZ
1749 IF (index(i) > nz) THEN
1750 ni = index(i)
1751 index(i) = nz
1752 index(nz) = ni
1753 END IF
1754 cycle
1755 END IF !(IPEN==0) THEN
1756 ENDIF
1757 ENDDO
1758 ENDDO
1759 IF (nz >0 ) THEN
1760 iads = slrbe3/2
1761 lcopy(1:slrbe3) = lrbe3(1:slrbe3)
1762 icopy(1:nrbe3l,1:nrbe3) = irbe3(1:nrbe3l,1:nrbe3)
1763 fcopy(1:slrbe3*3) = frbe3(1:slrbe3*3)
1764 iad1 = 0
1765 DO n=1,nrbe3
1766 i = index(n)
1767 iad = icopy(1,i)
1768 ns = icopy(3,i)
1769 nm = icopy(5,i)
1770 irbe3(1,n) = iad1
1771 DO j =2,nrbe3l
1772 irbe3(j,n) = icopy(j,i)
1773 ENDDO
1774 nom_opt(1,n)=irbe3(2,n)
1775 DO j =1,nm
1776 lrbe3(iad1+j)=lcopy(iad+j)
1777 lrbe3(iads+iad1+j)=lcopy(iads+iad+j)
1778 ENDDO
1779 DO j =1,6*nm
1780 frbe3(6*iad1+j)=fcopy(6*iad+j)
1781 ENDDO
1782 iad1 =iad1+nm
1783 ENDDO
1784 END IF
1785C
1786 DEALLOCATE(itag)
1787 RETURN
1788 END SUBROUTINE hireorbe3
1789C========================================================================|
1790
c_hash_find
void c_hash_find(int *map, int *key, int *val)
Definition c_hash_table.cpp:129
my_real
#define my_real
Definition cppsort.cpp:32
damping
subroutine damping(nodft, nodlt, v, vr, a, ar, damp, ms, in, igrnod, dim, itask, weight, tagslv_rby, wfext)
Definition damping.F:882
freform
subroutine freform(irunn, irfl, irfe, h3d_data, flag_cst_ams, dynain_data, sensors, dt, output, glob_therm)
Definition freform.F:88
ifrontplus
subroutine ifrontplus(n, p)
Definition frontplus.F:100
hm_get_float_array_index
subroutine hm_get_float_array_index(name, rval, index, is_available, lsubmodel, unitab)
Definition hm_get_float_array_index.F:105
hm_get_int_array_index
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
Definition hm_get_int_array_index.F:164
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:251
invert
subroutine invert(matrix, inverse, n, errorflag)
Definition hm_read_rbe3.F:1354
zero1
subroutine zero1(r, n)
Definition hm_read_rbe3.F:1481
wrrinf
subroutine wrrinf(title, r, n)
Definition hm_read_rbe3.F:1458
prerbe3fr
subroutine prerbe3fr(irbe3, n, jt, jr)
Definition hm_read_rbe3.F:1499
inirbe3
subroutine inirbe3(irbe3, lrbe3, frbe3, skew, x, ms, in, nom_opt)
Definition hm_read_rbe3.F:389
hm_read_rbe3
subroutine hm_read_rbe3(irbe3, lrbe3, frbe3, itab, itabm1, igrnod, iskn, lxintd, ikine, iddlevel, nom_opt, itagnd, grnod_uid, unitab, lsubmodel)
Definition hm_read_rbe3.F:49
rbe3chk
subroutine rbe3chk(inrbe3, ilrbe3, ns, xyz, frbe3, skew, ng, irot, imodif, wmin, ipen, ierr)
Definition hm_read_rbe3.F:546
hireorbe3
subroutine hireorbe3(irbe3, lrbe3, frbe3, nom_opt)
Definition hm_read_rbe3.F:1580
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 hm_read_rbe3.F:1171
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 hm_read_rbe3.F:1052
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
groupdef_mod
Definition groupdef_mod.F:662
hm_option_read_mod
Definition hm_option_read_mod.F:408
message_mod
Definition message_mod.F:1249
names_and_titles_mod
Definition names_and_titles_mod.F:997
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1003
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1000
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1005
r2r_mod
Definition r2r_mod.F:125
r2r_mod::tagrb3
integer, dimension(:), allocatable tagrb3
Definition r2r_mod.F:138
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
unitab_mod
Definition unitab_mod.F:513
hm_sz_r2r
subroutine hm_sz_r2r(tag, val, lsubmodel)
Definition routines_r2r.F:300
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:620
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
starter
program starter
Definition starter.F:39
submodel_mod::submodel_data
Definition submodel_mod.F:723