OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
lecbcscyc.F File Reference
#include "implicit_f.inc"
#include "scr17_c.inc"
#include "com04_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine hm_preread_bcscyc (igrnod, nom_opt, lsubmodel, nbcscynn)
subroutine ini_bcscyc (ibcscyc, lbcscyc, skew, x, itab, icode, ibfv, itagcyc)
subroutine inibcs_cy (nbcy_n, ixcycl, isk, skew, x, itab, id)
subroutine car2cylin (nbcy_n, ix, x, cy_x, dis, skew, xyz0, tol, ier)
subroutine int2cy_chk (ipari, intbuf_tab, itagcyc, itab)

Function/Subroutine Documentation

◆ car2cylin()

subroutine car2cylin ( integer nbcy_n,
integer, dimension(*) ix,
x,
cy_x,
dis,
skew,
xyz0,
tol,
integer ier )

Definition at line 362 of file lecbcscyc.F.

363C-----------------------------------------------
364C I m p l i c i t T y p e s
365C-----------------------------------------------
366#include "implicit_f.inc"
367C-----------------------------------------------
368C D u m m y A r g u m e n t s
369C-----------------------------------------------
370 INTEGER NBCY_N,IX(*),IER
371 my_real
372 . x(3,*),skew(9),xyz0(3),cy_x(3,*),dis(*),tol
373C-----------------------------------------------
374C L o c a l V a r i a b l e s
375C-----------------------------------------------
376 INTEGER I
377 my_real xx,yy,zz,xl,yl,zl,r2,th_mean,th_max,zl_min
378C========================================================================|
379C----- compute cylindrical coordinates(r,cos(theta),z) and dis=r*r+z*z
380 th_mean =zero
381 zl_min = ep20
382 DO i=1,nbcy_n
383 xx = x(1,ix(i))-xyz0(1)
384 yy = x(2,ix(i))-xyz0(2)
385 zz = x(3,ix(i))-xyz0(3)
386 xl = xx*skew(1)+yy*skew(2)+zz*skew(3)
387 yl = xx*skew(4)+yy*skew(5)+zz*skew(6)
388 zl = xx*skew(7)+yy*skew(8)+zz*skew(9)
389 r2 = xl*xl+yl*yl
390 cy_x(1,i) = sqrt(r2)
391 cy_x(2,i) = xl/cy_x(1,i)
392 cy_x(3,i) = zl
393 dis(i) = r2
394 th_mean = th_mean + cy_x(2,i)
395 zl_min = min(zl_min,zl)
396 ENDDO
397 DO i=1,nbcy_n
398 cy_x(3,i) = cy_x(3,i)-zl_min
399 dis(i) = dis(i) + cy_x(3,i)*cy_x(3,i)
400 ENDDO
401 th_mean =th_mean/nbcy_n
402 ier = 0
403 th_max =zero
404 DO i=1,nbcy_n
405 th_max = max(th_max,abs(cy_x(2,i)-th_mean))
406 ENDDO
407c print *,'TH_MAX,TH_MEAN=',TH_MAX,TH_MEAN
408 IF (th_max>tol*abs(th_mean)) ier = -1
409C--- numeric
410 IF (th_max<em6) ier = 0
411C
412 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21

◆ hm_preread_bcscyc()

subroutine hm_preread_bcscyc ( type (group_), dimension(ngrnod), target igrnod,
integer, dimension(lnopt1,*) nom_opt,
type(submodel_data), dimension(*), intent(in) lsubmodel,
integer nbcscynn )

Definition at line 39 of file lecbcscyc.F.

40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE message_mod
44 USE groupdef_mod
45 USE submodel_mod
46 USE hm_option_read_mod
47 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
48C-----------------------------------------------
49C I m p l i c i t T y p e s
50C-----------------------------------------------
51#include "implicit_f.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "scr17_c.inc"
56#include "com04_c.inc"
57C-----------------------------------------------
58C D u m m y A r g u m e n t s
59C-----------------------------------------------
60 INTEGER NBCSCYNN,NOM_OPT(LNOPT1,*)
61C INPUT ARGUMENTS
62 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
63C-----------------------------------------------
64 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
65C-----------------------------------------------
66C L o c a l V a r i a b l e s
67C-----------------------------------------------
68 INTEGER I,IGR1,IGR2,IGRS1,IGRS2,NBCS_CY_N,ID,SUB_INDEX
69 CHARACTER(LEN=NCHARKEY) :: KEY
70 CHARACTER(LEN=NCHARTITLE) :: TITR
71 LOGICAL IS_AVAILABLE
72C-----------------------------------------------
73C E x t e r n a l F u n c t i o n s
74C-----------------------------------------------
75 INTEGER NGR2USR
76!
77 INTEGER, DIMENSION(:), POINTER :: INGR2USR
78C
79C======================================================================|
80C
81 is_available = .false.
82C
83 nbcs_cy_n = 0
84C--------------------------------------------------
85C START BROWSING MODEL /BCS
86C--------------------------------------------------
87 CALL hm_option_start('/BCS')
88C--------------------------------------------------
89C BROWSING MODEL PARTS 1->NBCS
90C--------------------------------------------------
91 DO i=1,numbcs
92 titr = ''
93C--------------------------------------------------
94C EXTRACT DATAS OF /BCS/... LINE
95C--------------------------------------------------
96 CALL hm_option_read_key(lsubmodel,
97 . option_id = id,
98 . option_titr = titr,
99 . submodel_index = sub_index,
100 . keyword2 = key)
101 IF (key(1:6) /= 'CYCLIC' ) cycle
102 nom_opt(1,i)=id
103 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
104c
105 CALL hm_get_intv('grnd_ID1',igr1,is_available,lsubmodel)
106 CALL hm_get_intv('grnd_ID2',igr2,is_available,lsubmodel)
107 ingr2usr => igrnod(1:ngrnod)%ID
108 igrs1=ngr2usr(igr1,ingr2usr,ngrnod)
109 igrs2=ngr2usr(igr2,ingr2usr,ngrnod)
110 IF (igrs1==0) THEN
111 CALL ancmsg(msgid=678,anmode=aninfo,msgtype=msgerror,
112 . i1=id,i2=igr1,c1=titr)
113 END IF
114 IF (igrs2==0) THEN
115 CALL ancmsg(msgid=678,anmode=aninfo,msgtype=msgerror,
116 . i1=id,i2=igr2,c1=titr)
117 END IF
118 IF (igrnod(igrs1)%NENTITY /= igrnod(igrs2)%NENTITY) THEN
119 CALL ancmsg(msgid=1753,anmode=aninfo,msgtype=msgerror,
120 . i1=id,c1=titr)
121 END IF
122 nbcs_cy_n = nbcs_cy_n + igrnod(igrs1)%NENTITY
123 ENDDO
124 nbcscynn = 2*nbcs_cy_n
125C
126 RETURN
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
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:410
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
submodel_mod
Definition submodel_mod.F:712
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:325
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

◆ ini_bcscyc()

subroutine ini_bcscyc ( integer, dimension(4,*) ibcscyc,
integer, dimension(2,*) lbcscyc,
skew,
x,
integer, dimension(*) itab,
integer, dimension(*) icode,
integer, dimension(nifv,*) ibfv,
integer, dimension(*) itagcyc )

Definition at line 138 of file lecbcscyc.F.

139C-----------------------------------------------
140C M o d u l e s
141C-----------------------------------------------
142 USE message_mod
143C-----------------------------------------------
144C I m p l i c i t T y p e s
145C-----------------------------------------------
146#include "implicit_f.inc"
147C-----------------------------------------------
148C C o m m o n B l o c k s
149C-----------------------------------------------
150#include "param_c.inc"
151#include "com04_c.inc"
152C-----------------------------------------------
153C D u m m y A r g u m e n t s
154C-----------------------------------------------
155 INTEGER IBCSCYC(4,*),LBCSCYC(2,*),ITAB(*),ICODE(*),IBFV(NIFV,*),
156 . ITAGCYC(*)
157 my_real
158 . x(3,*),skew(lskew,*)
159C-----------------------------------------------
160C L o c a l V a r i a b l e s
161C-----------------------------------------------
162 INTEGER I, J ,ISK,IAD,NN,N1,N2,ID,ITAGIMP(NUMNOD),NF1,NF2,ICOOR
163C----- ini
164 DO i=1,nbcscyc
165 iad = ibcscyc(1,i)+1
166 isk = ibcscyc(2,i)
167 nn = ibcscyc(3,i)
168 id = ibcscyc(4,i)
169 CALL inibcs_cy(nn,lbcscyc(1,iad),isk,skew,x ,itab,id)
170 END DO
171C------ ITAGCYC :ID for incompatibility check
172 itagcyc(1:numnod) =0
173 DO i=1,nbcscyc
174 iad = ibcscyc(1,i)
175 isk = ibcscyc(2,i)
176 nn = ibcscyc(3,i)
177 DO j = 1,nn
178 n1 = lbcscyc(1,iad+j)
179 n2 = lbcscyc(2,iad+j)
180 itagcyc(n1) =id
181 itagcyc(n2) =id
182 END DO
183 END DO
184C----- check
185C-------BCS for the moment uncompatible
186 DO i=1,nbcscyc
187 iad = ibcscyc(1,i)
188 isk = ibcscyc(2,i)
189 nn = ibcscyc(3,i)
190 id = ibcscyc(4,i)
191 DO j = 1,nn
192 n1 = lbcscyc(1,iad+j)
193 n2 = lbcscyc(2,iad+j)
194 IF (icode(n1) >= 512 ) THEN
195 CALL ancmsg(msgid=1749,anmode=aninfo,msgtype=msgerror,
196 . i1=id,i2=itab(n1))
197 END IF
198 IF (icode(n2) >= 512 ) THEN
199 CALL ancmsg(msgid=1750,anmode=aninfo,msgtype=msgerror,
200 . i1=id,i2=itab(n2))
201 END IF
202 END DO
203 END DO
204C-------/IMPDIS,IMPVEL,IMPACC
205 itagimp(1:numnod)=0
206 DO j=1,nfxvel
207 n1 =iabs(ibfv(1,j))
208 isk = ibfv(2,j)/10
209 icoor = ibfv(10,j)
210 IF (itagimp(n1)==0) THEN
211 IF (icoor==1) THEN
212 itagimp(n1) = isk
213 ELSE
214 itagimp(n1) = -isk
215 END IF
216 ELSE
217 IF (icoor==1 .AND. itagimp(n1) == isk) THEN
218 ELSE
219 itagimp(n1) = -isk
220 END IF
221 END IF
222 ENDDO
223C
224 DO i=1,nbcscyc
225 iad = ibcscyc(1,i)
226 isk = ibcscyc(2,i)
227 nn = ibcscyc(3,i)
228 id = ibcscyc(4,i)
229 DO j = 1,nn
230 n1 = lbcscyc(1,iad+j)
231 n2 = lbcscyc(2,iad+j)
232 nf1 = itagimp(n1)
233 nf2 = itagimp(n2)
234C------ok for NF1=0,NF2=0; NF1=NF2=ISK
235 IF (nf1==nf2) THEN
236 IF (nf1==0.OR.nf1==isk) THEN
237 ELSE
238 CALL ancmsg(msgid=1751,anmode=aninfo,msgtype=msgerror,
239 . i1=id ,i2=itab(n1),i3=itab(n2))
240 END IF
241 ELSE
242 CALL ancmsg(msgid=1752,anmode=aninfo,msgtype=msgerror,
243 . i1=id ,i2=itab(n1),i3=itab(n2))
244 END IF
245 END DO
246 END DO
247C
248 RETURN
inibcs_cy
subroutine inibcs_cy(nbcy_n, ixcycl, isk, skew, x, itab, id)
Definition lecbcscyc.F:261

◆ inibcs_cy()

subroutine inibcs_cy ( integer nbcy_n,
integer, dimension(2,*) ixcycl,
integer isk,
skew,
x,
integer, dimension(*) itab,
integer id )

Definition at line 260 of file lecbcscyc.F.

261C-----------------------------------------------
262C M o d u l e s
263C-----------------------------------------------
264 USE message_mod
265C-----------------------------------------------
266C I m p l i c i t T y p e s
267C-----------------------------------------------
268#include "implicit_f.inc"
269C-----------------------------------------------
270C C o m m o n B l o c k s
271C-----------------------------------------------
272#include "param_c.inc"
273C-----------------------------------------------
274C D u m m y A r g u m e n t s
275C-----------------------------------------------
276 INTEGER NBCY_N,IXCYCL(2,*),ITAB(*),ISK,ID
277 my_real
278 . x(3,*),skew(lskew,*)
279C-----------------------------------------------
280C L o c a l V a r i a b l e s
281C-----------------------------------------------
282 INTEGER I, J ,N1(NBCY_N),N2(NBCY_N),INDEX(NBCY_N),IER1
283C
284 my_real
285 . cy_x1(3,nbcy_n), cy_x2(3,nbcy_n),dis1(nbcy_n),dis2(nbcy_n),lmin,
286 . cy_tmp(3,nbcy_n),ri,zi,tol,err_th,ermax
287C========================================================================|
288C-----for each cut-section nodes, compute cylindrical coordinates and dis
289 DO i=1,nbcy_n
290 n1(i) = ixcycl(1,i)
291 n2(i) = ixcycl(2,i)
292 ENDDO
293C-------5% error
294 err_th=zep05
295 CALL car2cylin(nbcy_n,n1,x,cy_x1,dis1,
296 . skew(1,isk),skew(10,isk),err_th,ier1)
297c--------check (r,cos(theta),z), cos(theta) not too diff
298 IF (ier1<0 ) THEN
299 CALL ancmsg(msgid=1761,anmode=aninfo,msgtype=msgerror,i1=id)
300 END IF
301C------sorting by dis
302 CALL myqsort(nbcy_n, dis1, index, ier1)
303 cy_tmp(1:3,1:nbcy_n) = cy_x1(1:3,1:nbcy_n)
304 DO i=1,nbcy_n
305 j = index(i)
306 n1(i) = ixcycl(1,j)
307 cy_x1(1:3,i)=cy_tmp(1:3,j)
308 ENDDO
309 lmin = ep20
310 DO i=2,nbcy_n
311 ri = abs(cy_x1(1,i)-cy_x1(1,i-1))
312 zi = abs(cy_x1(3,i)-cy_x1(3,i-1))
313 lmin =min(lmin,max(ri,zi))
314 ENDDO
315 CALL car2cylin(nbcy_n,n2,x,cy_x2,dis2,
316 . skew(1,isk),skew(10,isk),err_th,ier1)
317c--------check (r,cos(theta),z), cos(theta) not too diff
318 IF (ier1<0 ) THEN
319 CALL ancmsg(msgid=1762,anmode=aninfo,msgtype=msgerror,i1=id)
320 END IF
321C------sorting by dis
322 CALL myqsort(nbcy_n, dis2, index, ier1)
323 cy_tmp(1:3,1:nbcy_n) = cy_x2(1:3,1:nbcy_n)
324 DO i=1,nbcy_n
325 j = index(i)
326 n2(i) = ixcycl(2,j)
327 cy_x2(1:3,i)=cy_tmp(1:3,j)
328 ENDDO
329 DO i=2,nbcy_n
330 ri = abs(cy_x2(1,i)-cy_x2(1,i-1))
331 zi = abs(cy_x2(3,i)-cy_x2(3,i-1))
332 lmin =min(lmin,max(ri,zi))
333 ENDDO
334 tol = lmin*err_th
335 ermax = zero
336 j = 1
337 DO i=1,nbcy_n
338 ri = abs(cy_x2(1,i)-cy_x1(1,i))
339 zi = abs(cy_x2(3,i)-cy_x1(3,i))
340 lmin =max(ri,zi)
341 IF (lmin>ermax) THEN
342 ermax=lmin
343 j = i
344 END IF
345 ENDDO
346 IF (ermax>tol ) THEN
347 CALL ancmsg(msgid=1763,anmode=aninfo,msgtype=msgerror,
348 . i1=id,i2=itab(n1(j)),i3=itab(n2(j)))
349 END IF
350 DO i=1,nbcy_n
351 ixcycl(1,i) = n1(i)
352 ixcycl(2,i) = n2(i)
353 ENDDO
354C
355 RETURN
car2cylin
subroutine car2cylin(nbcy_n, ix, x, cy_x, dis, skew, xyz0, tol, ier)
Definition lecbcscyc.F:363
myqsort
subroutine myqsort(n, a, perm, error)
Definition myqsort.F:51

◆ int2cy_chk()

subroutine int2cy_chk ( integer, dimension(npari,ninter) ipari,
type(intbuf_struct_), dimension(ninter) intbuf_tab,
integer, dimension(*) itagcyc,
integer, dimension(*) itab )

Definition at line 424 of file lecbcscyc.F.

425C-----------------------------------------------
426C M o d u l e s
427C-----------------------------------------------
428 USE message_mod
429 USE intbufdef_mod
430 USE names_and_titles_mod , ONLY : nchartitle
431C-----------------------------------------------
432C I m p l i c i t T y p e s
433C-----------------------------------------------
434#include "implicit_f.inc"
435C-----------------------------------------------
436C C o m m o n B l o c k s
437C-----------------------------------------------
438#include "param_c.inc"
439#include "com04_c.inc"
440C-----------------------------------------------
441C D u m m y A r g u m e n t s
442C-----------------------------------------------
443 INTEGER IPARI(NPARI,NINTER),ITAGCYC(*),ITAB(*)
444 TYPE(INTBUF_STRUCT_), DIMENSION(NINTER) :: INTBUF_TAB
445C-----------------------------------------------
446C External function
447C-----------------------------------------------
448 LOGICAL INTAB
449 EXTERNAL intab
450C-----------------------------------------------
451C L o c a l V a r i a b l e s
452C-----------------------------------------------
453 INTEGER I,N,NTY,NSN,ISL,NOINT
454 INTEGER ILEV
455C=======================================================================
456 DO n=1,ninter
457 nty = ipari(7,n)
458 IF (nty == 2 ) THEN
459 nsn = ipari(5,n)
460 ilev = ipari(20,n)
461 noint = ipari(15,n)
462C----------only kinematic ones
463 IF (ilev >= 25 .AND. ilev <= 28) cycle
464 DO i=1,nsn
465 isl = intbuf_tab(n)%NSV(i)
466 IF (itagcyc(isl)/=0) THEN
467 CALL ancmsg(msgid=1758,anmode=aninfo,msgtype=msgerror,
468 . i1=itagcyc(isl),i2=itab(isl),i3=noint)
469 END IF
470 END DO
471 END IF
472 END DO
473C
474c-----------
475 RETURN
intab
logical function intab(nic, ic, n)
Definition i24tools.F:95