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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_tagpart2 (bufftmp, ipart, key, id, titr, titr1, indx, nindx, flag, subset, lsubmodel, map)

Function/Subroutine Documentation

◆ hm_tagpart2()

subroutine hm_tagpart2 ( integer, dimension(*) bufftmp,
integer, dimension(lipart1,*) ipart,
character, dimension(*) key,
integer id,
character(len=nchartitle) titr,
character(len=nchartitle) titr1,
integer, dimension(*) indx,
integer nindx,
integer flag,
type (subset_), dimension(nsubs) subset,
type(submodel_data), dimension(nsubmod) lsubmodel,
integer, dimension(npart,2), intent(in) map )

Definition at line 40 of file hm_tagpart2.F.

43C optimized routine w/ index of BUFFTMP
44C-----------------------------------------------
45C M o d u l e s
46C-----------------------------------------------
47 USE message_mod
48 USE r2r_mod
49 USE groupdef_mod
50 USE hm_option_read_mod
51 USE submodel_mod
52 USE names_and_titles_mod , ONLY : nchartitle
53C-----------------------------------------------
54C I m p l i c i t T y p e s
55C-----------------------------------------------
56#include "implicit_f.inc"
57C-----------------------------------------------
58C C o m m o n B l o c k s
59C-----------------------------------------------
60#include "scr17_c.inc"
61#include "com04_c.inc"
62#include "r2r_c.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 INTEGER BUFFTMP(*),IPART(LIPART1,*),
67 . INDX(*), NINDX, ID, FLAG
68 CHARACTER KEY*(*)
69 TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
70C-----------------------------------------------
71 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
72 INTEGER, DIMENSION(NPART,2), INTENT(in) :: MAP
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER J,NSEG,JREC,IADV,ISU,K,L,IPP,NUMA,JJ,KK,NENTITY_POS, NENTITY_NEG,NENTITY
77 INTEGER,DIMENSION(:),ALLOCATABLE :: TAG_ENTITY_POS, TAG_ENTITY_NEG,LIST_ENTITY
78 INTEGER :: ID_LOCAL
79 INTEGER, DIMENSION(:), ALLOCATABLE :: ENTITY_POS,ENTITY_NEG
80 CHARACTER MOT*4
81 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
82 LOGICAL IS_AVAILABLE,IS_ENCRYPTED
83 INTEGER SET_USRTOS
84 EXTERNAL set_usrtos
85C-----------------------------------------------
86 INTERFACE
87 SUBROUTINE groups_get_elem_list(arg1,arg2,arg3)
88 USE submodel_mod
89 INTEGER,DIMENSION(:),ALLOCATABLE :: arg1
90 INTEGER,INTENT(INOUT) :: arg2
91 TYPE(SUBMODEL_DATA) :: arg3(NSUBMOD)
92 END SUBROUTINE
93 END INTERFACE
94C-----------------------------------------------
95 IF (key(1:6) == 'SUBSET') THEN
96C-------------------------
97C groupes de SUBSETS
98C-------------------------
99
100 CALL groups_get_elem_list(list_entity, nentity, lsubmodel)
101 DO kk=1,nentity
102 jj=list_entity(kk)
103 IF (jj /= 0) THEN
104 isu=0
105 DO k=1,nsubs
106 IF (jj == subset(k)%ID) THEN
107 isu=k
108 DO l=1,subset(isu)%NTPART
109C tag les parts
110 IF(bufftmp(subset(isu)%TPART(l))==0)THEN
111 bufftmp(subset(isu)%TPART(l))=1
112 nindx=nindx+1
113 indx(nindx)=subset(isu)%TPART(l)
114 END IF
115 ENDDO
116 EXIT
117 ELSEIF (jj == -subset(k)%ID) THEN
118 isu=k
119 DO l=1,subset(isu)%NTPART
120C tag les parts
121 IF(bufftmp(subset(isu)%TPART(l))==0)THEN
122 bufftmp(subset(isu)%TPART(l))=-1
123 nindx=nindx+1
124 indx(nindx)=subset(isu)%TPART(l)
125 END IF
126 ENDDO
127 EXIT
128 ENDIF
129 ENDDO
130 IF (isu == 0 .AND. flag == 0) THEN
131 CALL ancmsg(msgid=194,
132 . msgtype=msgwarning,
133 . anmode=aninfo,
134 . i1=id,
135 . c1=titr1,
136 . c2=titr,
137 . c3='SUBSET',
138 . i2=jj)
139 ENDIF
140 ENDIF
141 ENDDO
142 IF(ALLOCATED(list_entity))DEALLOCATE (list_entity)
143
144 ELSEIF (key(1:4) == 'PART' .OR. key(1:3) == 'MAT' .OR.
145 . key(1:4) == 'PROP') THEN
146C-------------------------
147C groupes de PART,MAT,PROP
148C-------------------------
149 IF(key(1:4) == 'PART')THEN
150 mot='PART'
151 ipp=4
152 ELSEIF(key(1:3) == 'MAT')THEN
153 mot='MAT'
154 ipp=5
155 ELSEIF(key(1:4) == 'PROP')THEN
156 mot='PROP'
157 ipp=6
158 ENDIF
159
160 CALL hm_get_intv ('idsmax' ,nentity_pos,is_available,lsubmodel)
161 CALL hm_get_intv ('negativeIdsmax' ,nentity_neg,is_available,lsubmodel)
162 ALLOCATE(tag_entity_pos(nentity_pos))
163 ALLOCATE(tag_entity_neg(nentity_neg))
164 tag_entity_pos(1:nentity_pos)=0
165 tag_entity_neg(1:nentity_neg)=0
166
167 ALLOCATE(entity_pos(nentity_pos))
168 ALLOCATE(entity_neg(nentity_neg))
169
170 DO kk=1,nentity_pos
171 CALL hm_get_int_array_index ('ids' ,jj ,kk,is_available,lsubmodel)
172 entity_pos(kk) = jj
173 ENDDO
174
175 DO kk=1,nentity_neg
176 CALL hm_get_int_array_index ('negativeIds' ,jj ,kk,is_available,lsubmodel)
177 entity_neg(kk) = jj
178 ENDDO
179
180
181 IF(ipp==4) THEN
182 DO kk=1,nentity_pos
183 jj = entity_pos(kk)
184 id_local = set_usrtos(jj,map,npart)
185 IF(id_local == 0) THEN
186 ! part not found
187 cycle
188 ENDIF
189 isu=map(id_local,2)
190 tag_entity_pos(kk)=1
191 !tag les parts
192 IF(bufftmp(isu)==0)THEN
193 bufftmp(isu)=1
194 nindx=nindx+1
195 indx(nindx)=isu
196 END IF
197 ENDDO
198
199 DO kk=1,nentity_neg
200 jj = entity_neg(kk)
201 id_local = set_usrtos(jj,map,npart)
202 IF(id_local == 0) THEN
203 ! Part not found
204 cycle
205 ENDIF
206
207 isu=map(id_local,2)
208 tag_entity_neg(kk)=1
209 !tag les parts
210 IF(bufftmp(isu)==0)THEN
211 bufftmp(isu)=-1
212 nindx=nindx+1
213 indx(nindx)=isu
214 END IF
215 ENDDO
216 ELSE
217 DO kk=1,nentity_pos
218 jj = entity_pos(kk)
219 DO k=1,npart
220 numa = ipart(ipp,k)
221
222 IF (nsubdom>0) THEN
223 IF (ipp==5) numa = ipart_r2r(2,k)
224 ENDIF
225 isu = 0
226 IF(jj == numa)THEN
227 isu=k
228 tag_entity_pos(kk)=1
229 !tag les parts
230 IF(bufftmp(isu)==0)THEN
231 bufftmp(isu)=1
232 nindx=nindx+1
233 indx(nindx)=isu
234 END IF
235 ENDIF
236 ENDDO
237 ENDDO
238
239 DO kk=1,nentity_neg
240 jj = entity_neg(kk)
241 DO k=1,npart
242 numa = ipart(ipp,k)
243
244 IF (nsubdom>0) THEN
245 IF (ipp==5) numa = ipart_r2r(2,k)
246 ENDIF
247 isu = 0
248 IF(jj == numa)THEN
249 isu=k
250 tag_entity_neg(kk)=1
251 !tag les parts
252 IF(bufftmp(isu)==0)THEN
253 bufftmp(isu)=-1
254 nindx=nindx+1
255 indx(nindx)=isu
256 END IF
257 ENDIF
258 ENDDO
259 ENDDO
260 ENDIF
261
262 !If positive USER_ID is not relevant
263 IF(flag == 0)THEN
264 DO kk=1,nentity_pos
265 IF(tag_entity_pos(kk)==0)THEN
266 CALL hm_get_int_array_index ('ids' ,jj ,kk,is_available,lsubmodel)
267 CALL ancmsg(msgid=194, msgtype=msgwarning,anmode=aninfo,i1=id,c1=titr1,c2=titr,c3=mot,i2=jj)
268 ENDIF
269 ENDDO
270 ENDIF
271
272 !If negative USER_ID is not relevant
273 IF(flag == 0)THEN
274 DO kk=1,nentity_neg
275 IF(tag_entity_neg(kk)==0)THEN
276 CALL hm_get_int_array_index ('negativeIdsmax' ,jj ,kk,is_available,lsubmodel)
277 CALL ancmsg(msgid=194, msgtype=msgwarning,anmode=aninfo,i1=id,c1=titr1,c2=titr,c3=mot,i2=jj)
278 ENDIF
279 ENDDO
280 ENDIF
281
282 DEALLOCATE(tag_entity_pos)
283 DEALLOCATE(tag_entity_neg)
284 DEALLOCATE(entity_pos)
285 DEALLOCATE(entity_neg)
286
287C-------------------------
288 ENDIF
289C-------------------------
290 RETURN
groups_get_elem_list
subroutine groups_get_elem_list(list_entity, nentity, lsubmodel)
Definition groups_get_elem_list.F:46
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
set_usrtos
integer function set_usrtos(iu, ipartm1, npart)
Definition ipartm1.F:128
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
r2r_mod
Definition r2r_mod.F:125
r2r_mod::ipart_r2r
integer, dimension(:,:), allocatable ipart_r2r
Definition r2r_mod.F:144
submodel_mod
Definition submodel_mod.F:712
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