OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
hm_tagpart.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_tagpart (bufftmp, ipart, key, id, titr, titr1, flag, subset, lsubmodel)

Function/Subroutine Documentation

◆ hm_tagpart()

subroutine hm_tagpart ( integer, dimension(*) bufftmp,
integer, dimension(lipart1,*) ipart,
character, dimension(*) key,
integer id,
character(len=nchartitle) titr,
character(len=nchartitle) titr1,
integer flag,
type (subset_), dimension(nsubs) subset,
type(submodel_data), dimension(nsubmod) lsubmodel )

Definition at line 38 of file hm_tagpart.F.

40C old routine w/o index of BUFFTMP
41C-----------------------------------------------
42C M o d u l e s
43C-----------------------------------------------
44 USE r2r_mod
45 USE message_mod
46 USE groupdef_mod
47 USE hm_option_read_mod
48 USE submodel_mod
49 USE names_and_titles_mod , ONLY : nchartitle
50C-----------------------------------------------
51C I m p l i c i t T y p e s
52C-----------------------------------------------
53#include "implicit_f.inc"
54C-----------------------------------------------
55C C o m m o n B l o c k s
56C-----------------------------------------------
57#include "scr17_c.inc"
58#include "com04_c.inc"
59#include "r2r_c.inc"
60C-----------------------------------------------
61C D u m m y A r g u m e n t s
62C-----------------------------------------------
63 INTEGER BUFFTMP(*),IPART(LIPART1,*),ID,
64 . FLAG
65 CHARACTER KEY*(*)
66 TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
67C-----------------------------------------------
68 TYPE (SUBSET_) , DIMENSION(NSUBS) :: SUBSET
69C-----------------------------------------------
70C L o c a l V a r i a b l e s
71C-----------------------------------------------
72 LOGICAL IS_AVAILABLE, IS_ENCRYPTED
73 INTEGER J,NSEG,J10(10),IGS,JREC,IADV,ISU,K,L,IPP,NUMA,KK,JJ,NENTITY
74 CHARACTER MOT*4
75 CHARACTER(LEN=NCHARTITLE) :: TITR,TITR1
76 INTEGER,DIMENSION(:),ALLOCATABLE :: LIST_ENTITY
77C-----------------------------------------------
78 INTERFACE
79 SUBROUTINE groups_get_elem_list(arg1,arg2,arg3)
80 USE submodel_mod
81 INTEGER,DIMENSION(:),ALLOCATABLE :: arg1
82 INTEGER,INTENT(INOUT) :: arg2
83 TYPE(SUBMODEL_DATA) :: arg3(NSUBMOD)
84 END SUBROUTINE
85 END INTERFACE
86C=======================================================================
87 nentity = 0
88 IF (key(1:6) == 'SUBSET') THEN
89C-------------------------
90C groupes de SUBSETS
91C-------------------------
92 CALL groups_get_elem_list(list_entity, nentity, lsubmodel)
93 DO kk=1,nentity
94 jj=list_entity(kk)
95 IF(jj /= 0)THEN
96 isu=0
97 DO k=1,nsubs
98 IF (jj == subset(k)%ID) THEN
99 isu=k
100 DO l=1,subset(isu)%NTPART
101 !tag les parts
102 bufftmp(subset(isu)%TPART(l)) = 1
103 ENDDO
104 EXIT
105 ELSEIF (jj == -subset(k)%ID) THEN
106 isu=k
107 DO l=1,subset(isu)%NTPART
108 !tag les parts
109 bufftmp(subset(isu)%TPART(l)) = -1
110 ENDDO
111 EXIT
112 ENDIF
113 ENDDO
114 IF (isu == 0 .AND. flag == 0) THEN
115 CALL ancmsg(msgid=194,
116 . msgtype=msgwarning,
117 . anmode=aninfo,
118 . i1=id,
119 . c1=titr1,
120 . c2=titr,
121 . c3='SUBSET',
122 . i2=jj)
123 ENDIF
124 ENDIF
125 enddo! NEXT KK
126 IF(ALLOCATED(list_entity))DEALLOCATE (list_entity)
127
128 ELSEIF (key(1:4) == 'PART' .OR. key(1:3) == 'MAT' .OR. key(1:4) == 'PROP') THEN
129C-------------------------
130C groupes de PART,MAT,PROP
131C-------------------------
132 IF(key(1:4) == 'PART')THEN
133 mot='PART'
134 ipp=4
135 ELSEIF(key(1:3) == 'MAT')THEN
136 mot='MAT'
137 ipp=5
138 ELSEIF(key(1:4) == 'PROP')THEN
139 mot='PROP'
140 ipp=6
141 ENDIF
142
143 CALL groups_get_elem_list(list_entity, nentity, lsubmodel)
144 DO kk=1,nentity
145 jj=list_entity(kk)
146 IF(jj /= 0)THEN
147 isu=0
148 DO k=1,npart
149 numa = ipart(ipp,k)
150 IF (nsubdom>0) THEN
151 IF (ipp==5) numa = ipart_r2r(2,k)
152 ENDIF
153C-------------------------------------------------------------------------------------------------------------
154 IF(jj == numa)THEN
155 isu=k
156C !tag les parts
157 bufftmp(isu)=1
158 ELSEIF(-jj == numa)THEN
159 isu=k
160C !tag les parts
161 bufftmp(isu)=-1
162 ENDIF
163 ENDDO
164 IF(isu == 0 .AND. flag == 0)THEN
165 IF(mot(1:4)/='PART')THEN
166 CALL ancmsg(msgid=195,
167 . msgtype=msgwarning,
168 . anmode=aninfo,
169 . i1=id,
170 . c1=titr1,
171 . c2=titr1,
172 . c3=titr,
173 . c4=mot,
174 . i2=jj)
175 ELSE
176 CALL ancmsg(msgid=194,
177 . msgtype=msgwarning,
178 . anmode=aninfo,
179 . i1=id,
180 . c1=titr1,
181 . c2=titr1,
182 . c3=titr,
183 . c4='PART',
184 . i2=jj)
185 ENDIF
186 ENDIF
187 ENDIF
188 enddo! NEXT KK
189 IF(ALLOCATED(list_entity))DEALLOCATE (list_entity)
190
191C-------------------------
192 ENDIF
193C-------------------------
194 RETURN
groups_get_elem_list
subroutine groups_get_elem_list(list_entity, nentity, lsubmodel)
Definition groups_get_elem_list.F:46
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