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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_bcs (icode, iskew, itab, itabm1, ikine, igrnod, ibcslag, lag_ncf, lag_nkf, lag_nhf, ikine1lag, iskn, nom_opt, unitab, lsubmodel, ibcscyc, lbcscyc)

Function/Subroutine Documentation

◆ hm_read_bcs()

subroutine hm_read_bcs ( integer, dimension(*) icode,
integer, dimension(*) iskew,
integer, dimension(*) itab,
integer, dimension(*) itabm1,
integer, dimension(*) ikine,
type (group_), dimension(ngrnod), target igrnod,
integer, dimension(5,*) ibcslag,
integer lag_ncf,
integer lag_nkf,
integer lag_nhf,
integer, dimension(*) ikine1lag,
integer, dimension(liskn,*) iskn,
integer, dimension(lnopt1,*) nom_opt,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(*), intent(in) lsubmodel,
integer, dimension(4,*) ibcscyc,
integer, dimension(2,*) lbcscyc )

Definition at line 41 of file hm_read_bcs.F.

45C-----------------------------------------------
46C M o d u l e s
47C-----------------------------------------------
48 USE unitab_mod
49 USE message_mod
50 USE groupdef_mod
51 USE submodel_mod
52 USE hm_option_read_mod
53 USE names_and_titles_mod , ONLY : nchartitle, ncharfield, ncharkey
54C-----------------------------------------------
55C I m p l i c i t T y p e s
56C-----------------------------------------------
57#include "implicit_f.inc"
58C-----------------------------------------------
59C C o m m o n B l o c k s
60C-----------------------------------------------
61#include "scr17_c.inc"
62#include "com04_c.inc"
63#include "param_c.inc"
64#include "sphcom.inc"
65C-----------------------------------------------
66C D u m m y A r g u m e n t s
67C-----------------------------------------------
68 INTEGER ICODE(*), ISKEW(*), ITAB(*), ITABM1(*), IKINE(*),
69 . IBCSLAG(5,*),
70 . LAG_NCF,LAG_NKF,LAG_NHF,IKINE1LAG(*),ISKN(LISKN,*)
71 INTEGER NOM_OPT(LNOPT1,*),IBCSCYC(4,*) ,LBCSCYC(2,*)
72C INPUT ARGUMENTS
73 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
74 TYPE(SUBMODEL_DATA),INTENT(IN)::LSUBMODEL(*)
75C-----------------------------------------------
76 TYPE (GROUP_) ,TARGET, DIMENSION(NGRNOD) :: IGRNOD
77C-----------------------------------------------
78C L o c a l V a r i a b l e s
79C-----------------------------------------------
80 INTEGER I,JJ(12), IC, NC, N, NUSR, IS, IC1, IC2, IC3, IC4,
81 . NOSYS, J,J10(10),IGR,IGRS,ISU,IBCALE,J6(6),K,
82 . IC0, IC01, IC02, IC03, IC04, ID ,ILAGM, NBCSLAG,
83 . SUB_ID,
84 . CHKCOD,ISERR,NOD,S_STRING,SUB_INDEX
85 INTEGER IUN,IGR1,IGRS1,IGR2,IGRS2,IAD_L,NBY_NI,NBCSCYCI,ICYC,IS0
86 CHARACTER MESS*40
87 CHARACTER(LEN=NCHARKEY) :: KEY, KEY2
88 CHARACTER(LEN=NCHARFIELD) :: STRING
89 CHARACTER(LEN=NCHARTITLE) :: TITR
90 CHARACTER :: CODE*7
91 CHARACTER :: OPT*8
92 LOGICAL IS_AVAILABLE
93 INTEGER, DIMENSION(:), ALLOCATABLE :: IKINE1
94C-----------------------------------------------
95C E x t e r n a l F u n c t i o n s
96C-----------------------------------------------
97 INTEGER USR2SYS,MY_OR,CHECK_NEW,NGR2USR
98!
99 INTEGER, DIMENSION(:), POINTER :: INGR2USR
100C
101C-----------------------------------------------
102C D a t a
103C-----------------------------------------------
104 DATA iun/1/
105 DATA mess/'BOUNDARY CONDITIONS '/
106C======================================================================|
107C
108 is_available = .false.
109 nbcslag = 0
110 nbcscyci = 0
111 iad_l = 0
112 DO i=1,numnod
113 iskew(i)=-1
114 ENDDO
115C
116 ALLOCATE(ikine1(3 * numnod))
117 DO i=1,3*numnod
118 ikine1(i) = 0
119 ENDDO
120C
121C--------------------------------------------------
122C START BROWSING MODEL /BCS
123C--------------------------------------------------
124 CALL hm_option_start('/BCS')
125C--------------------------------------------------
126C BROWSING MODEL PARTS 1->NBCS
127C--------------------------------------------------
128 DO i=1,numbcs
129 titr = ''
130C--------------------------------------------------
131C EXTRACT DATAS OF /BCS/... LINE
132C--------------------------------------------------
133 CALL hm_option_read_key(lsubmodel,
134 . option_id = id,
135 . option_titr = titr,
136 . submodel_index = sub_index,
137 . keyword2 = key)
138 nom_opt(1,i)=id
139 CALL fretitl(titr,nom_opt(lnopt1-ltitr+1,i),ltitr)
140 IF (key(1:4) == 'WALL' ) cycle
141 ilagm = 0
142 IF (key(1:6) == 'LAGMUL' ) ilagm = 1
143 icyc = 0
144 IF (key(1:6) == 'CYCLIC' ) icyc = 1
145C--------------------------------------------------
146C EXTRACT DATAS (INTEGER VALUES)
147C--------------------------------------------------
148 IF (icyc == 1 )THEN
149 CALL hm_get_intv('grnd_ID1',igr1,is_available,lsubmodel)
150 CALL hm_get_intv('grnd_ID2',igr2,is_available,lsubmodel)
151 CALL hm_get_intv('skew_ID',is,is_available,lsubmodel)
152 ELSE
153 CALL hm_get_intv('dof1',j6(1),is_available,lsubmodel)
154 CALL hm_get_intv('dof2',j6(2),is_available,lsubmodel)
155 CALL hm_get_intv('dof3',j6(3),is_available,lsubmodel)
156 CALL hm_get_intv('dof4',j6(4),is_available,lsubmodel)
157 CALL hm_get_intv('dof5',j6(5),is_available,lsubmodel)
158 CALL hm_get_intv('dof6',j6(6),is_available,lsubmodel)
159 CALL hm_get_intv('inputsystem',is,is_available,lsubmodel)
160 END IF !(ICYC == 1 )THEN
161c
162 IF(is == 0 .AND. sub_index /= 0 ) is = lsubmodel(sub_index)%SKEW
163 is0 = is
164 CALL hm_get_intv('entityid',igr,is_available,lsubmodel)
165C--------------------------------------------------
166C
167 DO j=0,numskw+min(iun,nspcond)*numsph+nsubmod
168 IF(is == iskn(4,j+1)) THEN
169 is=j+1
170 GO TO 100
171 ENDIF
172 ENDDO
173 CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
174 . c1='BOUNDARY CONDITION',
175 . c2='BOUNDARY CONDITION',
176 . i2=is,i1=id,c3=titr)
177 100 CONTINUE
178C
179 IF (icyc == 0 )THEN
180 chkcod = 0
181 DO j=1,6
182 IF (j6(j) >= 2) THEN
183 chkcod = 1
184 ENDIF
185 ENDDO
186 IF(chkcod == 1)
187 . CALL ancmsg(msgid=1051,anmode=aninfo_blind,
188 . msgtype=msgerror,i1=id,c1=titr,c2=code)
189 ic1=j6(1)*4 +j6(2)*2 +j6(3)
190 ic2=j6(4)*4 +j6(5)*2 +j6(6)
191 ic =ic1*512+ic2*64
192 ingr2usr => igrnod(1:ngrnod)%ID
193 igrs=ngr2usr(igr,ingr2usr,ngrnod)
194 IF (igrs==0) THEN
195 CALL ancmsg(msgid=678,anmode=aninfo,msgtype=msgerror,
196 . i1=id,i2=igr,c1=titr)
197 END IF
198 IF (ilagm == 0) THEN
199 DO j=1,igrnod(igrs)%NENTITY
200 nosys=igrnod(igrs)%ENTITY(j)
201 icode(nosys)=my_or(ic,icode(nosys))
202 IF(iskew(nosys)==-1.OR.iskew(nosys)==is)THEN
203 check_new=is
204 ELSE
205 CALL ancmsg(msgid=148,anmode=aninfo,msgtype=msgerror,
206 . i1=itab(nosys),prmod=msg_cumu)
207 ENDIF
208 iskew(nosys)=check_new
209
210 DO k=1,6
211 IF(j6(k)/=0)
212 . CALL kinset(1,itab(nosys),ikine(nosys),k,iskew(nosys)
213 . ,ikine1(nosys))
214 ENDDO
215 ENDDO
216 CALL ancmsg(msgid=148,anmode=aninfo,msgtype=msgerror,
217 . i1=id,c1=titr,prmod=msg_print)
218 ELSE
219 nbcslag = nbcslag+1
220 ibcslag(1,nbcslag) = igrs
221 ibcslag(2,nbcslag) = id
222 ibcslag(3,nbcslag) = ic
223 ibcslag(4,nbcslag) = is
224 ibcslag(5,nbcslag) = id
225 DO j=1,igrnod(igrs)%NENTITY
226 nosys=igrnod(igrs)%ENTITY(j)
227 CALL kinset(512,itab(nosys),ikine(nosys),7,0
228 . ,ikine1lag(nosys))
229 DO k=1,6
230 IF(j6(k)/=0) THEN
231 lag_nhf = lag_nhf + 1
232 lag_ncf = lag_ncf + 1
233 IF(is==0) THEN
234 lag_nkf = lag_nkf + 1
235 ELSE
236 lag_nkf = lag_nkf + 3
237 ENDIF
238 ENDIF
239 ENDDO
240 ENDDO
241 ENDIF
242C--- /BCS/CYCLIC
243 ELSE
244C------Imov=0 only fixing skew is allowed
245 IF (iskn(5,is)/=0) THEN
246 CALL ancmsg(msgid=1760,anmode=aninfo,msgtype=msgerror,
247 . i1=id,i2=is0,c1=titr,prmod=msg_print)
248 END IF
249C----- in SKEW 1:9 (x',y',z'); 10:12 (X0,Y0,Z0)
250 ingr2usr => igrnod(1:ngrnod)%ID
251 igrs1=ngr2usr(igr1,ingr2usr,ngrnod)
252 igrs2=ngr2usr(igr2,ingr2usr,ngrnod)
253 nby_ni = igrnod(igrs1)%NENTITY
254 nbcscyci = nbcscyci + 1
255 ibcscyc(1,nbcscyci)=iad_l
256 ibcscyc(2,nbcscyci)=is
257 ibcscyc(3,nbcscyci)=nby_ni
258 ibcscyc(4,nbcscyci)=id
259 DO j=1,nby_ni
260 lbcscyc(1,j+iad_l)=igrnod(igrs1)%ENTITY(j)
261 lbcscyc(2,j+iad_l)=igrnod(igrs2)%ENTITY(j)
262 END DO
263 iad_l =iad_l+nby_ni
264 END IF !(IBCSCYC == 0 )THEN
265 ENDDO
266C
267 DEALLOCATE(ikine1)
268 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
kinset
subroutine kinset(ik, node, ikine, idir, isk, ikine1)
Definition kinset.F:57
min
#define min(a, b)
Definition macros.h:20
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
submodel_mod
Definition submodel_mod.F:712
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
unitab_mod
Definition unitab_mod.F:513
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:325
my_or
int my_or(int *a, int *b)
Definition precision.c:63
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