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 IF (key(1:3) == 'NRF' ) cycle
142 ilagm = 0
143 IF (key(1:6) == 'LAGMUL' ) ilagm = 1
144 icyc = 0
145 IF (key(1:6) == 'CYCLIC' ) icyc = 1
146C--------------------------------------------------
147C EXTRACT DATAS (INTEGER VALUES)
148C--------------------------------------------------
149 IF (icyc == 1 )THEN
150 CALL hm_get_intv('grnd_ID1',igr1,is_available,lsubmodel)
151 CALL hm_get_intv('grnd_ID2',igr2,is_available,lsubmodel)
152 CALL hm_get_intv('skew_ID',is,is_available,lsubmodel)
153 ELSE
154 CALL hm_get_intv('dof1',j6(1),is_available,lsubmodel)
155 CALL hm_get_intv('dof2',j6(2),is_available,lsubmodel)
156 CALL hm_get_intv('dof3',j6(3),is_available,lsubmodel)
157 CALL hm_get_intv('dof4',j6(4),is_available,lsubmodel)
158 CALL hm_get_intv('dof5',j6(5),is_available,lsubmodel)
159 CALL hm_get_intv('dof6',j6(6),is_available,lsubmodel)
160 CALL hm_get_intv('inputsystem',is,is_available,lsubmodel)
161 END IF !(ICYC == 1 )THEN
162c
163 IF(is == 0 .AND. sub_index /= 0 ) is = lsubmodel(sub_index)%SKEW
164 is0 = is
165 CALL hm_get_intv('entityid',igr,is_available,lsubmodel)
166C--------------------------------------------------
167C
168 DO j=0,numskw+min(iun,nspcond)*numsph+nsubmod
169 IF(is == iskn(4,j+1)) THEN
170 is=j+1
171 GO TO 100
172 ENDIF
173 ENDDO
174 CALL ancmsg(msgid=137,anmode=aninfo,msgtype=msgerror,
175 . c1='BOUNDARY CONDITION',
176 . c2='BOUNDARY CONDITION',
177 . i2=is,i1=id,c3=titr)
178 100 CONTINUE
179C
180 IF (icyc == 0 )THEN
181 chkcod = 0
182 DO j=1,6
183 IF (j6(j) >= 2) THEN
184 chkcod = 1
185 ENDIF
186 ENDDO
187 IF(chkcod == 1)
188 . CALL ancmsg(msgid=1051,anmode=aninfo_blind,
189 . msgtype=msgerror,i1=id,c1=titr,c2=code)
190 ic1=j6(1)*4 +j6(2)*2 +j6(3)
191 ic2=j6(4)*4 +j6(5)*2 +j6(6)
192 ic =ic1*512+ic2*64
193 ingr2usr => igrnod(1:ngrnod)%ID
194 igrs=ngr2usr(igr,ingr2usr,ngrnod)
195 IF (igrs==0) THEN
196 CALL ancmsg(msgid=678,anmode=aninfo,msgtype=msgerror,
197 . i1=id,i2=igr,c1=titr)
198 END IF
199 IF (ilagm == 0) THEN
200 DO j=1,igrnod(igrs)%NENTITY
201 nosys=igrnod(igrs)%ENTITY(j)
202 icode(nosys)=my_or(ic,icode(nosys))
203 IF(iskew(nosys)==-1.OR.iskew(nosys)==is)THEN
204 check_new=is
205 ELSE
206 CALL ancmsg(msgid=148,anmode=aninfo,msgtype=msgerror,
207 . i1=itab(nosys),prmod=msg_cumu)
208 ENDIF
209 iskew(nosys)=check_new
210
211 DO k=1,6
212 IF(j6(k)/=0)
213 . CALL kinset(1,itab(nosys),ikine(nosys),k,iskew(nosys)
214 . ,ikine1(nosys))
215 ENDDO
216 ENDDO
217 CALL ancmsg(msgid=148,anmode=aninfo,msgtype=msgerror,
218 . i1=id,c1=titr,prmod=msg_print)
219 ELSE
220 nbcslag = nbcslag+1
221 ibcslag(1,nbcslag) = igrs
222 ibcslag(2,nbcslag) = id
223 ibcslag(3,nbcslag) = ic
224 ibcslag(4,nbcslag) = is
225 ibcslag(5,nbcslag) = id
226 DO j=1,igrnod(igrs)%NENTITY
227 nosys=igrnod(igrs)%ENTITY(j)
228 CALL kinset(512,itab(nosys),ikine(nosys),7,0
229 . ,ikine1lag(nosys))
230 DO k=1,6
231 IF(j6(k)/=0) THEN
232 lag_nhf = lag_nhf + 1
233 lag_ncf = lag_ncf + 1
234 IF(is==0) THEN
235 lag_nkf = lag_nkf + 1
236 ELSE
237 lag_nkf = lag_nkf + 3
238 ENDIF
239 ENDIF
240 ENDDO
241 ENDDO
242 ENDIF
243C--- /BCS/CYCLIC
244 ELSE
245C------Imov=0 only fixing skew is allowed
246 IF (iskn(5,is)/=0) THEN
247 CALL ancmsg(msgid=1760,anmode=aninfo,msgtype=msgerror,
248 . i1=id,i2=is0,c1=titr,prmod=msg_print)
249 END IF
250C----- in SKEW 1:9 (x',y',z'); 10:12 (X0,Y0,Z0)
251 ingr2usr => igrnod(1:ngrnod)%ID
252 igrs1=ngr2usr(igr1,ingr2usr,ngrnod)
253 igrs2=ngr2usr(igr2,ingr2usr,ngrnod)
254 nby_ni = igrnod(igrs1)%NENTITY
255 nbcscyci = nbcscyci + 1
256 ibcscyc(1,nbcscyci)=iad_l
257 ibcscyc(2,nbcscyci)=is
258 ibcscyc(3,nbcscyci)=nby_ni
259 ibcscyc(4,nbcscyci)=id
260 DO j=1,nby_ni
261 lbcscyc(1,j+iad_l)=igrnod(igrs1)%ENTITY(j)
262 lbcscyc(2,j+iad_l)=igrnod(igrs2)%ENTITY(j)
263 END DO
264 iad_l =iad_l+nby_ni
265 END IF !(IBCSCYC == 0 )THEN
266 ENDDO
267C
268 DEALLOCATE(ikine1)
269 RETURN
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:528
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
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: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
names_and_titles_mod::ncharfield
integer, parameter ncharfield
Definition names_and_titles_mod.F:1010
submodel_mod
Definition submodel_mod.F:717
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:725
unitab_mod
Definition unitab_mod.F:517
ngr2usr
integer function ngr2usr(iu, igr, ngr)
Definition nintrr.F:323
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:895
fretitl
subroutine fretitl(titr, iasc, l)
Definition freform.F:615