OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
read_dfs_detpoint.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "units_c.inc"
#include "param_c.inc"
#include "tabsiz_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine read_dfs_detpoint (detonators, x, ipm, pm, itabm1, unitab, lsubmodel, igrnod)

Function/Subroutine Documentation

◆ read_dfs_detpoint()

subroutine read_dfs_detpoint ( type(detonators_struct_), intent(inout) detonators,
dimension(3,numnod), intent(in) x,
integer, dimension(npropmi,nummat), intent(in) ipm,
dimension(npropm,nummat), intent(inout) pm,
integer, dimension(sitabm1), intent(in) itabm1,
type (unit_type_), intent(in) unitab,
type(submodel_data), dimension(nsubmod), intent(in) lsubmodel,
type (group_), dimension(ngrnod), intent(in) igrnod )

Definition at line 46 of file read_dfs_detpoint.F.

47C-----------------------------------------------
48C M o d u l e s
49C-----------------------------------------------
50 USE unitab_mod
51 USE message_mod
52 USE detonators_mod , ONLY : detonators_struct_
53 USE groupdef_mod
54 USE hm_option_read_mod
55 USE submodel_mod
56 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
57 USE material_is_high_explosive_mod , ONLY : material_is_high_explosive
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C C o m m o n B l o c k s
64C-----------------------------------------------
65#include "com04_c.inc"
66#include "units_c.inc"
67#include "param_c.inc"
68#include "tabsiz_c.inc"
69C-----------------------------------------------
70C D u m m y A r g u m e n t s
71C-----------------------------------------------
72 TYPE (UNIT_TYPE_),INTENT(IN) :: UNITAB
73 INTEGER,INTENT(IN) :: ITABM1(SITABM1)
74 INTEGER,INTENT(IN) :: IPM(NPROPMI,NUMMAT)
75 my_real,INTENT(IN) :: x(3,numnod)
76 TYPE(SUBMODEL_DATA),INTENT(IN) :: LSUBMODEL(NSUBMOD)
77 TYPE(DETONATORS_STRUCT_),INTENT(INOUT) :: DETONATORS
78 TYPE (GROUP_),DIMENSION(NGRNOD),INTENT(IN) :: IGRNOD
79 my_real,INTENT(INOUT) :: pm(npropm,nummat)
80C-----------------------------------------------
81C L o c a l V a r i a b l e s
82C-----------------------------------------------
83 INTEGER :: I,MAT,IGU,IGS,MDET,DET_ID,IDET
84 INTEGER :: NODE_ID1,uID1,UID,internal_ID,NNOD
85 INTEGER :: UNUSED
86 my_real :: xc, yc, zc, tdet
87 CHARACTER*40 :: MESS
88 CHARACTER(LEN=NCHARTITLE) :: TITR
89 CHARACTER*32 :: MSG_C2
90 LOGICAL :: IS_ENCRYPTED, IS_AVAILABLE, IS_AVAILABLE_SHADOW
91 LOGICAL :: IS_NODE_DEFINED,IS_GRNOD_DEFINED
92 INTEGER :: I_SHADOW
93 INTEGER :: MLW
94 INTEGER :: IMAT, MLW_SUBMAT, SUBMAT_UID, NBMAT, KK, MID
95 CHARACTER(LEN=NCHARKEY) :: KEY, KEY2
96C-----------------------------------------------
97C E x t e r n a l F u n c t i o n s
98C-----------------------------------------------
99 INTEGER,EXTERNAL :: NODGRNR5, USR2SYS, NINTRI
100 INTEGER :: UNUSED_MAT_DETONATOR
101 DATA mess/'DETONATORS DEFINITION '/
102C-----------------------------------------------
103C S o u r c e L i n e s
104C-----------------------------------------------
105 CALL hm_option_start('/DFS/DETPOIN')
106
107 DO idet=1,detonators%N_DET_POINT
108
109 CALL hm_option_read_key(lsubmodel,option_id=det_id, unit_id=uid,keyword2=key,keyword3=key2)
110 IF (len_trim(key) > 0) key = key(1:7)
111 IF (len_trim(key2) > 0) key2 = key2(1:5)
112
113 is_encrypted= .false.
114 is_available = .false.
115 is_available_shadow = .false.
116 is_node_defined = .false.
117 is_grnod_defined = .false.
118 i_shadow = 0
119 IF(key2(1:4)=='NODE')is_node_defined = .true.
120 IF(key2(1:3)=='SET')is_grnod_defined = .true.
121 CALL hm_option_is_encrypted(is_encrypted)
122 !---------------------------------!
123 ! READING !
124 !---------------------------------!
125 IF(is_node_defined)THEN
126 msg_c2 = '/DFS/DETPOINT/NODE'
127 CALL hm_get_intv('rad_det_Ishadow', i_shadow, is_available_shadow, lsubmodel)
128 CALL hm_get_floatv('rad_det_time', tdet, is_available, lsubmodel,unitab)
129 CALL hm_get_intv('rad_det_materialid', mat, is_available, lsubmodel)
130 CALL hm_get_intv('rad_det_node1', uid1, is_available, lsubmodel)
131 xc=zero
132 yc=zero
133 zc=zero
134 ELSEIF(is_grnod_defined)THEN
135 msg_c2 = '/DFS/DETPOINT/SET'
136 CALL hm_get_intv('rad_det_Ishadow', i_shadow, is_available_shadow, lsubmodel)
137 CALL hm_get_floatv('rad_det_time', tdet, is_available, lsubmodel,unitab)
138 CALL hm_get_intv('rad_det_materialid', mat, is_available, lsubmodel)
139 CALL hm_get_intv('rad_det_grnod1', uid1, is_available, lsubmodel)
140 xc=zero
141 yc=zero
142 zc=zero
143 ELSE
144 i_shadow = 0
145 msg_c2 = '/DFS/DETPOINT'
146 CALL hm_get_floatv('rad_det_locationA_X', xc, is_available, lsubmodel, unitab)
147 CALL hm_get_floatv('rad_det_locationA_Y', yc, is_available, lsubmodel, unitab)
148 CALL hm_get_floatv('rad_det_locationA_Z', zc, is_available, lsubmodel, unitab)
149 CALL hm_get_floatv('rad_det_time', tdet, is_available, lsubmodel,unitab)
150 CALL hm_get_intv('rad_det_materialid', mat, is_available, lsubmodel)
151 ENDIF
152
153 mdet = mat
154
155 IF (tdet > infinity) tdet= infinity
156 IF (tdet < -infinity)tdet=-infinity
157
158 !default value for shadowing flag
159 IF(is_available_shadow)THEN
160 IF(i_shadow < 0 .OR. i_shadow > 1)THEN
161 i_shadow = 0
162 CALL ancmsg(msgid=102,msgtype=msgwarning,anmode=aninfo_blind_1,
163 . i1=det_id,
164 . c1='INVALID I_SHADOW FLAG. FLAG IS SET TO 0',
165 . c2=msg_c2,
166 . i2=mdet)
167 END IF
168 ENDIF
169
170 IF(i_shadow == 1) detonators%IS_SHADOWING_REQUIRED = .true.
171
172 IF(i_shadow == 1) THEN
173 IF(mdet > 0)THEN
174 DO i=1,nummat
175 mid = ipm(1,i)
176 IF(mid /= mdet) cycle
177 pm(96,i) = 1 !SHADOW FLAG SET ON
178 EXIT
179 ENDDO
180 ELSE
181 !enable flag for all compatible material laws
182 DO i=1,nummat
183 mlw = ipm(2,i)
184
185 !========= LAW151 : check if at least one submaterial is a high explosive
186 IF(mlw == 151)THEN
187 nbmat = ipm(20,i)
188 DO imat=1,nbmat
189 submat_uid = ipm(20+imat,i) !Internal ID not yet defined (later in fsdcod.F)
190 mlw_submat = 0
191 DO kk=1,nummat
192 IF(ipm(1,kk)==submat_uid)THEN
193 ! KK is internal identifier
194 mlw_submat = ipm(2,kk) ! material law type
195 EXIT
196 ENDIF
197 ENDDO
198 IF(mlw_submat > 0)THEN
199 IF(material_is_high_explosive(mlw_submat))THEN
200 pm(96,i)=1 !SHADOW FLAG SET ON
201 EXIT
202 ENDIF
203 ENDIF
204 ENDDO
205
206 ELSE
207 !========= OTHER LAWS : direct check
208 IF(material_is_high_explosive(mlw))pm(96,i)=1 !SHADOW FLAG SET ON
209
210 ENDIF
211
212 ENDDO
213 ENDIF
214 ENDIF
215
216 IF(is_node_defined)THEN
217 node_id1=usr2sys(uid1,itabm1,mess,det_id)
218 detonators%POINT(idet)%NNOD = 1
219 ALLOCATE(detonators%POINT(idet)%NODLIST(1))
220 detonators%POINT(idet)%NODLIST(1) = node_id1 !internal id
221 IF(node_id1 > 0)THEN
222 xc = x(1,node_id1)
223 yc = x(2,node_id1)
224 zc = x(3,node_id1)
225 ENDIF
226 IF(node_id1==0)THEN
227 CALL ancmsg(msgid=104, msgtype=msgerror, anmode=aninfo, c1='/DFS/DETPOINT/NODE', i1=det_id, c2='INVALID NODE_ID')
228 ENDIF
229 ENDIF
230
231 ! /DFS/DETPOINT/GRNOD
232 ! check if provided group identifier does exist
233 internal_id = 0
234 IF(is_grnod_defined)THEN
235 nnod = 0
236 DO i=1,ngrnod
237 IF (igrnod(i)%ID == uid1) THEN
238 internal_id = i
239 nnod = igrnod(i)%NENTITY
240 detonators%POINT(idet)%NNOD = nnod
241 ALLOCATE(detonators%POINT(idet)%NODLIST(nnod))
242 !filling nodlist
243 nnod=nodgrnr5(uid1,internal_id,detonators%POINT(idet)%NODLIST,igrnod,itabm1,mess)
244 EXIT
245 ENDIF
246 ENDDO
247 IF(internal_id == 0)THEN
248 CALL ancmsg(msgid=104, msgtype=msgerror, anmode=aninfo, c1='/DFS/DETPOINT/SET', i1=det_id, c2='INVALID SET_ID')
249 ENDIF
250 ENDIF
251
252 !---------------------------------!
253 ! checking user flags !
254 ! +INTERNAL ID !
255 !---------------------------------!
256 mdet=mat !bak
257 unused=0
258 IF(mat > 0)unused=unused_mat_detonator(mat,nummat,ipm)
259 IF (mat < 0) THEN
260 CALL ancmsg(msgid=102,msgtype=msgerror,anmode=aninfo,
261 . i1=det_id,
262 . c1='DETONATOR IS REFERRING TO A NEGATIVE MATERIAL ID',
263 . c2='/DFS/DETPOINT',
264 . i2=mdet)
265 ELSEIF (unused == 1) THEN
266 CALL ancmsg(msgid=102,msgtype=msgerror,anmode=aninfo,
267 . i1=det_id,
268 . c1='DETONATOR IS REFERRING TO AN UNKNOWN MATERIAL ID',
269 . c2='/DFS/DETPOINT',
270 . i2=mdet)
271 ELSEIF (unused == 2) THEN
272 CALL ancmsg(msgid=102,msgtype=msgerror,anmode=aninfo,
273 . i1=det_id,
274 . c1='DETONATOR MUST REFER TO A JWL MATERIAL LAW (LAWS 5, 51, 97, 151)',
275 . c2='/DFS/DETPOINT',
276 . i2=mdet)
277 ELSE
278 ! VALID MATERIAL ID
279 detonators%POINT(idet)%IS_MAT_VALID = .true.
280 ! STARTER LISTING FILEetpoint
281 IF(is_encrypted)THEN
282 WRITE(iout,1001)
283 ELSEIF(is_node_defined)THEN
284 WRITE(iout,1401) det_id,i_shadow,uid1,xc,yc,zc,tdet,mdet
285 ELSEIF(is_grnod_defined)THEN
286 WRITE(iout,1402) det_id,i_shadow,uid1,nnod,tdet,mdet
287 ELSE
288 WRITE(iout,1400) det_id,xc,yc,zc,tdet,mdet
289 ENDIF
290 ! STORAGE
291 detonators%POINT(idet)%SHADOW = i_shadow
292 detonators%POINT(idet)%TDET = tdet
293 detonators%POINT(idet)%MAT = mat
294 detonators%POINT(idet)%XDET = xc
295 detonators%POINT(idet)%YDET = yc
296 detonators%POINT(idet)%ZDET = zc
297 detonators%POINT(idet)%GRNOD_ID = internal_id
298 END IF
299
300 enddo! next IDET
301
302C-----------------------------------------------
303C O u t p u t F o r m a t
304C-----------------------------------------------
305 1001 FORMAT(///5x,
306 & 'DETONATION POINT ',i10,/5x,
307 & '---------------- ',/5x,
308 & 'CONFIDENTIAL DATA')
309 1400 FORMAT(///5x,
310 & 'DETONATION POINT ',i10,/5x,
311 & '---------------- ',/5x,
312 & 'X-COORDINATE =',1pg20.13,/5x,
313 & 'Y-COORDINATE =',1pg20.13,/5x,
314 & 'Z-COORDINATE =',1pg20.13,/5x,
315 & 'DETONATION TIME =',1pg20.13,/5x,
316 & 'EXPLOSIVE MATERIAL NUMBER =',i10 )
317 1401 FORMAT(///5x,
318 & 'DETONATION POINT (NODE) ',i10,/5x,
319 & '----------------------- ',/5x,
320 & 'SHADOWING FLAG =',i10 ,/5x,
321 & 'NODE ID =',i10 ,/5x,
322 & ' X-COORDINATE =',1pg20.13,/5x,
323 & ' Y-COORDINATE =',1pg20.13,/5x,
324 & ' Z-COORDINATE =',1pg20.13,/5x,
325 & 'DETONATION TIME =',1pg20.13,/5x,
326 & 'EXPLOSIVE MATERIAL NUMBER =',i10 )
327 1402 FORMAT(///5x,
328 & 'DETONATION POINT (SET) ',i10,/5x,
329 & '---------------------- ',/5x,
330 & 'SHADOWING FLAG =',i10 ,/5x,
331 & 'SET ID =',i10 ,/5x,
332 & ' NUMBER OF NODES =',i10,/5x,
333 & 'DETONATION TIME =',1pg20.13,/5x,
334 & 'EXPLOSIVE MATERIAL NUMBER =',i10 )
335C-----------------------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_floatv
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
Definition hm_get_floatv.F:415
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_is_encrypted
subroutine hm_option_is_encrypted(is_encrypted)
Definition hm_option_is_encrypted.F:284
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
detonators_mod
Definition detonators_mod.F:79
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
submodel_mod
Definition submodel_mod.F:712
unitab_mod
Definition unitab_mod.F:513
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
nodgrnr5
integer function nodgrnr5(igu, igs, ibuf, igrnod, itabm1, mess)
Definition freform.F:303
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
detonators_mod::detonators_struct_
Definition detonators_mod.F:154
unused_mat_detonator
integer function unused_mat_detonator(mdet, nummat, listmat)
Definition unused_mat_detonator.F:33