OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
lecbcscyc.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_preread_bcscyc ../starter/source/constraints/general/bcs/lecbcscyc.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_intv ../starter/source/devtools/hm_reader/hm_get_intv.F
31!|| hm_option_read_key ../starter/source/devtools/hm_reader/hm_option_read_key.f
32!|| hm_option_start ../starter/source/devtools/hm_reader/hm_option_start.F
33!|| ngr2usr ../starter/source/system/nintrr.f
34!||--- uses -----------------------------------------------------
35!|| hm_option_read_mod ../starter/share/modules1/hm_option_read_mod.F
36!|| message_mod ../starter/share/message_module/message_mod.f
37!|| submodel_mod ../starter/share/modules1/submodel_mod.f
38!||====================================================================
39 SUBROUTINE hm_preread_bcscyc(IGRNOD ,NOM_OPT ,LSUBMODEL,NBCSCYNN)
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
127 END
128!||====================================================================
129!|| ini_bcscyc ../starter/source/constraints/general/bcs/lecbcscyc.F
130!||--- called by ------------------------------------------------------
131!|| lectur ../starter/source/starter/lectur.F
132!||--- calls -----------------------------------------------------
133!|| ancmsg ../starter/source/output/message/message.F
134!|| inibcs_cy ../starter/source/constraints/general/bcs/lecbcscyc.F
135!||--- uses -----------------------------------------------------
136!|| message_mod ../starter/share/message_module/message_mod.F
137!||====================================================================
138 SUBROUTINE ini_bcscyc(IBCSCYC,LBCSCYC,SKEW,X,ITAB,ICODE,IBFV,ITAGCYC)
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
249 END SUBROUTINE ini_bcscyc
250!||====================================================================
251!|| inibcs_cy ../starter/source/constraints/general/bcs/lecbcscyc.F
252!||--- called by ------------------------------------------------------
253!|| ini_bcscyc ../starter/source/constraints/general/bcs/lecbcscyc.F
254!||--- calls -----------------------------------------------------
255!|| ancmsg ../starter/source/output/message/message.F
256!|| car2cylin ../starter/source/constraints/general/bcs/lecbcscyc.F
257!||--- uses -----------------------------------------------------
258!|| message_mod ../starter/share/message_module/message_mod.F
259!||====================================================================
260 SUBROUTINE inibcs_cy(NBCY_N,IXCYCL,ISK,SKEW,X ,ITAB,ID)
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
356 END SUBROUTINE inibcs_cy
357!||====================================================================
358!|| car2cylin ../starter/source/constraints/general/bcs/lecbcscyc.F
359!||--- called by ------------------------------------------------------
360!|| inibcs_cy ../starter/source/constraints/general/bcs/lecbcscyc.F
361!||====================================================================
362 SUBROUTINE car2cylin(NBCY_N,IX,X,CY_X,DIS,SKEW,XYZ0,TOL,IER)
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
413 END SUBROUTINE car2cylin
414!||====================================================================
415!|| int2cy_chk ../starter/source/constraints/general/bcs/lecbcscyc.F
416!||--- called by ------------------------------------------------------
417!|| inintr2 ../starter/source/interfaces/inter3d1/inintr2.F
418!||--- calls -----------------------------------------------------
419!|| ancmsg ../starter/source/output/message/message.F
420!|| intab ../starter/source/interfaces/inter3d1/i24tools.F
421!||--- uses -----------------------------------------------------
422!|| message_mod ../starter/share/message_module/message_mod.F
423!||====================================================================
424 SUBROUTINE int2cy_chk(IPARI,INTBUF_TAB,ITAGCYC,ITAB)
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
476 END SUBROUTINE int2cy_chk
477C kinchk
478C 2) partial incompatible : impvel (same between n1,n2 with icoord=1)
479C 3) special case : bcs now:1) future :2)
480C 4) remove ND of NS10E at NS10E side
481C nspmd>1 : n1,n2 in the same domain
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
hm_option_read_key
subroutine hm_option_read_key(lsubmodel, option_id, unit_id, submodel_index, submodel_id, option_titr, keyword1, keyword2, keyword3, keyword4, opt_pos)
Definition hm_option_read_key.F:251
hm_option_start
subroutine hm_option_start(entity_type)
Definition hm_option_start.F:253
hm_option_read_mod::hm_option_read_key
Definition hm_option_read_mod.F:414
ini_bcscyc
subroutine ini_bcscyc(ibcscyc, lbcscyc, skew, x, itab, icode, ibfv, itagcyc)
Definition lecbcscyc.F:139
inibcs_cy
subroutine inibcs_cy(nbcy_n, ixcycl, isk, skew, x, itab, id)
Definition lecbcscyc.F:261
car2cylin
subroutine car2cylin(nbcy_n, ix, x, cy_x, dis, skew, xyz0, tol, ier)
Definition lecbcscyc.F:363
hm_preread_bcscyc
subroutine hm_preread_bcscyc(igrnod, nom_opt, lsubmodel, nbcscynn)
Definition lecbcscyc.F:40
int2cy_chk
subroutine int2cy_chk(ipari, intbuf_tab, itagcyc, itab)
Definition lecbcscyc.F:425
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
myqsort
subroutine myqsort(n, a, perm, error)
Definition myqsort.F:51
groupdef_mod
Definition groupdef_mod.F:668
hm_option_read_mod
Definition hm_option_read_mod.F:412
message_mod
Definition message_mod.F:1257
names_and_titles_mod
Definition names_and_titles_mod.F:1002
names_and_titles_mod::nchartitle
integer, parameter nchartitle
Definition names_and_titles_mod.F:1008
names_and_titles_mod::ncharkey
integer, parameter ncharkey
Definition names_and_titles_mod.F:1005
submodel_mod
Definition submodel_mod.F:717
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:323
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
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615
starter
program starter
Definition starter.F:39
submodel_mod::submodel_data
Definition submodel_mod.F:728