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

Go to the source code of this file.

Functions/Subroutines

subroutine hm_read_sphcel (itab, itabm1, ipart, ipartsp, ipm, igeo, kxsp, ixsp, nod2sp, reservep, ixs, iparts, isolnod, sph2sol, sol2sph, irst, x, sol2sph_typ, lsubmodel, spbuf, unitab, ipri)

Function/Subroutine Documentation

◆ hm_read_sphcel()

subroutine hm_read_sphcel ( integer, dimension(*) itab,
integer, dimension(*) itabm1,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) ipartsp,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(*) nod2sp,
integer, dimension(nbpartinlet) reservep,
integer, dimension(nixs,*) ixs,
integer, dimension(*) iparts,
integer, dimension(*) isolnod,
integer, dimension(*) sph2sol,
integer, dimension(2,*) sol2sph,
integer, dimension(3,nsphsol) irst,
x,
integer, dimension(*) sol2sph_typ,
type(submodel_data), dimension(nsubmod) lsubmodel,
dimension(nspbuf,numsph), intent(inout) spbuf,
type (unit_type_), intent(in) unitab,
integer, intent(in) ipri )

Definition at line 44 of file hm_read_sphcel.F.

49C-----------------------------------------------
50C ROUTINE DESCRIPTION :
51C ===================
52C READ /SPHCEL ELEMENTS USING HM_READER
53C-----------------------------------------------
54C DUMMY ARGUMENTS DESCRIPTION:
55C ===================
56C
57C NAME DESCRIPTION
58C
59C IXQ /QUAD ARRAY : CONNECTIVITY, ID, MID PID
60C ITAB USER ID OF NODES
61C ITABM1 REVERSE TAB ITAB
62C IPART PART ARRAY
63C IPARTSP INTERNAL PART ID OF A GIVEN QUAD (INTERNAL ID)
64C IPM MATERIAL ARRAY (INTEGER)
65C IGEO PROP ARRAY (INTEGER)
66C LSUBMODEL SUBMODEL STRUCTURE
67C
68C KXSP(1,*) :INUTILISE
69C KXSP(2,*) :NG : +/- NO DU GROUPE
70C KXSP(3,*) :IPRC : NO SYSTEME DU NOEUD ASSOCIE
71C KXSP(4,*) :NVOIS : NOMBRE DE VOISINS.
72C KXSP(5,*) :NVOIS : NOMBRE DE CANDIDATS RETENUS PAR LE BUCKET.
73C KXSP(6,*) :NVOISS : NOMBRE DE VOISINS DANS LA PARTIE SYMETRIQUE.
74C KXSP(7,*) :NVOISS : NOMBRE DE CANDIDATS RETENUS DANS LA PARTIE SYMETRIQUE.
75C KXSP(NISP,*) :ID : ID DE LA CELLULE.
76C UNITAB UNIT ARRAY
77C IPRI PRINT FLAG (in 0.out file)
78C-----------------------------------------------
79C IXSP(1:KVOISPH,*) :IVOIS : NOS DES VOISINS.
80C-----------------------------------------------
81C M o d u l e s
82C-----------------------------------------------
83 USE my_alloc_mod
84 USE message_mod
85 USE hm_option_read_mod
86 USE submodel_mod , ONLY : nsubmod, submodel_data
87 USE unitab_mod
88 USE names_and_titles_mod , ONLY : nchartitle, ncharkey
89 USE reader_old_mod , ONLY : line, kcur, ksphopt, irec, koptad
90 USE user_id_mod , ONLY : id_limit
91C-----------------------------------------------
92C I m p l i c i t T y p e s
93C-----------------------------------------------
94#include "implicit_f.inc"
95C-----------------------------------------------
96C C o m m o n B l o c k s
97C-----------------------------------------------
98#include "com01_c.inc"
99#include "com04_c.inc"
100#include "units_c.inc"
101#include "sphcom.inc"
102#include "scr17_c.inc"
103#include "param_c.inc"
104C-----------------------------------------------
105C D u m m y A r g u m e n t s
106C-----------------------------------------------
107 INTEGER KXSP(NISP,*),IXSP(KVOISPH,*),
108 . NOD2SP(*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
109 . ITAB(*),ITABM1(*),IPART(LIPART1,*),IPARTSP(*),
110 . RESERVEP(NBPARTINLET), IXS(NIXS,*), IPARTS(*), ISOLNOD(*),
111 . SPH2SOL(*), SOL2SPH(2,*), IRST(3,NSPHSOL),SOL2SPH_TYP(*)
112 my_real x(3,*)
113 TYPE(SUBMODEL_DATA) LSUBMODEL(NSUBMOD)
114 my_real, INTENT(INOUT) :: spbuf(nspbuf,numsph)
115 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
116 INTEGER, INTENT(IN) :: IPRI
117C-----------------------------------------------
118C L o c a l V a r i a b l e s
119C-----------------------------------------------
120 INTEGER I,N,J,ID,IDS,K,
121 . MID,PID,IPRT,IPIDS,NSPHDIR,
122 . NSPHCEL,NCELL,IDNOD,INOD,IDMAX,KSPHRES,
123 . NBP,IT,NT,NP,NN,ITOPO,STAT,
124 . INDEX_PART,UID,IFLAGUNIT
125 my_real bid,fac_m
126 CHARACTER MESS*40
127 CHARACTER(LEN=NCHARKEY) :: KEY
128 LOGICAL IS_AVAILABLE
129
130 LOGICAL :: CHECK_LAW
131 INTEGER :: MID_SPH,MID_SOL
132 INTEGER :: LAW_SPH,LAW_SOL
133 INTEGER :: ERROR_NUM
134 INTEGER :: I1,I2,I3,I4,I5
135 CHARACTER(LEN=NCHARTITLE) :: C1
136 CHARACTER(LEN=NCHARTITLE) :: TITR
137 INTEGER :: USER_PART_SPH,USER_PART_SOL
138 INTEGER :: USER_MID_SPH,USER_MID_SOL
139 LOGICAL, DIMENSION(NPART) :: TAG_PART
140 INTEGER, DIMENSION(NPART) :: PART_ID_SPH,PART_ID_SOL
141 INTEGER, DIMENSION(:), ALLOCATABLE :: SUB_SPH
142 INTEGER, DIMENSION(:), ALLOCATABLE :: TYPE
143 real*8, DIMENSION(:), ALLOCATABLE :: hm_mass
144 INTEGER, DIMENSION(:), ALLOCATABLE :: UID_SPH
145 INTEGER, DIMENSION(:), ALLOCATABLE :: ITAG
146C-----------------------------------------------
147C E x t e r n a l F u n c t i o n s
148C-----------------------------------------------
149 INTEGER USR2SYS
150C-----------------------------------------------
151 DATA mess /'SPH CONNECTIVITIES DEFINITION '/
152C--------------------------------------------------
153C ALLOCS & INITS
154c use NUMELQ IN PLACE OF NUMELC ( NBADMESH routine is modifying NUMELC )
155C--------------------------------------------------
156 CALL my_alloc(itag,numnod)
157 ALLOCATE (sub_sph(numsph),stat=stat)
158 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
159 . msgtype=msgerror,
160 . c1='SUB_SPH')
161 ALLOCATE (uid_sph(numsph),stat=stat)
162 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
163 . msgtype=msgerror,
164 . c1='UID_SPH')
165 ALLOCATE (TYPE(NUMSPH),STAT=stat)
166 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
167 . msgtype=msgerror,
168 . c1='TYPE')
169 ALLOCATE (hm_mass(numsph),stat=stat)
170 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
171 . msgtype=msgerror,
172 . c1='HM_MASS')
173 sub_sph(1:numsph) = 0
174 uid_sph(1:numsph) = 0
175 hm_mass(1:numsph) = zero
176 TYPE(1:NUMSPH) = 0
177 index_part = 1
178 uid = -1
179
180C--------------------------------------------------
181C READING QUADS INPUTS IN HM STRUCTURE
182C--------------------------------------------------
183 CALL cpp_sphcel_read(kxsp,nisp,ipartsp,sub_sph,TYPE,HM_MASS,UID_SPH)
184C--------------------------------------------------
185 CALL hm_option_count('/SPHCEL',nsphcel)
186 ncell=0
187 idmax=0
188C--------------------------------------------------
189C FILL OTHER STRUCTURES + CHECKS
190C--------------------------------------------------
191 DO i=1,nsphcel
192C--------------------------------------------------
193C SUBMODEL OFFSET
194C--------------------------------------------------
195 IF(sub_sph(i) /= 0)THEN
196 IF(uid_sph(i) == 0 .AND. lsubmodel(sub_sph(i))%UID /= 0)
197 . uid_sph(i) = lsubmodel(sub_sph(i))%UID
198 ENDIF
199C--------------------------------------------------
200C UNITS
201C--------------------------------------------------
202 fac_m = one
203 IF(uid_sph(i) /= uid )THEN
204 uid = uid_sph(i)
205 iflagunit = 0
206 DO j=1,unitab%NUNITS
207 IF (unitab%UNIT_ID(j) == uid) THEN
208 fac_m = unitab%FAC_M(j)
209 iflagunit = 1
210 ENDIF
211 ENDDO
212 IF (uid/=0.AND.iflagunit==0) THEN
213 CALL ancmsg(msgid=643,anmode=aninfo,msgtype=msgerror,
214 . i1=uid,c1='/SPHCELL')
215 ENDIF
216 ENDIF
217 hm_mass(i) = hm_mass(i) * fac_m
218C--------------------------------------------------
219C STORAGE OF MASS PER PARTICULE
220C--------------------------------------------------
221 IF ((TYPE(I)==0).AND.(hm_mass(i) > zero)) THEN
222 TYPE(I)=1
223 ENDIF
224 spbuf(12,i) = hm_mass(i)
225 spbuf(13,i) = TYPE(I)
226C--------------------------------------------------
227C INTERNAL PART ID
228C--------------------------------------------------
229 IF( ipart(4,index_part) /= ipartsp(i) )THEN
230 DO j=1,npart
231 IF(ipart(4,j)== ipartsp(i) ) index_part = j
232 ENDDO
233 ENDIF
234 IF(ipart(4,index_part) /= ipartsp(i)) THEN
235 CALL ancmsg(msgid=402,
236 . msgtype=msgerror,
237 . anmode=aninfo_blind_1,
238 . c1="SPHCEL",
239 . i1=ipartsp(i),
240 . i2=ipartsp(i),
241 . prmod=msg_cumu)
242 ENDIF
243 idnod = kxsp(3,i)
244 inod=usr2sys(idnod,itabm1,mess,id)
245 kxsp(3,i)=inod
246 ncell=ncell+1
247 ipartsp(ncell)=index_part
248 nod2sp(inod) =ncell
249C meme identifiant que le noeud.
250 kxsp(nisp,ncell)=idnod
251 idmax=max(idmax,idnod)
252C--------------------------------------------------
253 IF (kxsp(nisp,i)>id_limit%GLOBAL)THEN
254 CALL ancmsg(msgid=509,anmode=aninfo,msgtype=msgerror,
255 . i1=kxsp(nisp,i),c1=line,c2='/SPHCEL')
256 ENDIF
257 ENDDO
258C-------------------------------------
259 IF(ALLOCATED(sub_sph)) DEALLOCATE(sub_sph)
260 IF(ALLOCATED(uid_sph)) DEALLOCATE(uid_sph)
261 IF(ALLOCATED(type)) DEALLOCATE(type)
262 IF(ALLOCATED(hm_mass)) DEALLOCATE(hm_mass)
263C-------------------------------------
264 first_sphres=ncell+1
265 IF(nsphres/=0)THEN
266 kcur =ksphopt
267 irec =koptad(kcur)-1
268 inod =isphres
269 nbp = 1
270
271 CALL hm_option_start('/SPH/RESERVE')
272 DO n=1,nbpartinlet
273 CALL hm_option_read_key(lsubmodel,
274 . option_id = id,
275 . keyword2 = key)
276 ids=0
277 DO j=1,npart
278 IF(ipart(4,j)==id) THEN
279 IF(igeo(11,ipart(2,j))/=34)THEN
280 CALL ancmsg(msgid=1068,
281 . msgtype=msgerror,
282 . anmode=aninfo,
283 . i1=id,
284 . i2=id)
285 ELSE
286 ids=j
287 END IF
288 GOTO 175
289 ENDIF
290 ENDDO
291 CALL ancmsg(msgid=441,
292 . msgtype=msgerror,
293 . anmode=aninfo,
294 . i1=id,
295 . i2=id)
296175 CONTINUE
297 CALL hm_get_intv('Np',ksphres,is_available,lsubmodel)
298C if SPH part not found reserve is emptied to prevent additional errors
299 IF (ids==0) THEN
300 nsphres = nsphres - ksphres*nspmd
301 numsph = numsph - ksphres*nspmd
302 ksphres = 0
303 ENDIF
304c store nb of reserve for this part
305 reservep(nbp)=ksphres
306 nbp=nbp+1
307c KSPHRES by proc
308 ksphres = ksphres*nspmd
309 DO j=1,ksphres
310 ncell=ncell+1
311 ipartsp(ncell)=ids
312 inod =inod+1
313 kxsp(3,ncell) =inod
314 nod2sp(inod) =ncell
315 kxsp(2,ncell)=-1
316 idmax=idmax+1
317 kxsp(nisp,ncell)=idmax
318 ENDDO
319 ENDDO
320 ENDIF
321C-------------------------------------
322 first_sphsol=ncell+1
323 IF(nsphsol/=0)THEN
324C
325 kcontact=1
326C
327 inod =firstnod_sphsol-1
328 DO n=1,numels8
329 sol2sph(1,n)=0
330 sol2sph(2,n)=0
331 ipids =ipart(2,iparts(n))
332 nsphdir=igeo(37,ipids)
333 ids =igeo(38,ipids)
334 IF(nsphdir/=0)THEN
335 IF(isolnod(n)==8)THEN
336 DO j=1,8
337 itag(ixs(1+j,n))=0
338 END DO
339 nn=0
340 DO j=1,8
341 IF(itag(ixs(1+j,n))==0)THEN
342 nn=nn+1
343 itag(ixs(1+j,n))=1
344 END IF
345 END DO
346 IF(nn==4)THEN
347 itopo=4
348 np=0
349 nt=0
350 DO it=1,nsphdir
351 nt=nt+it
352 np=np+nt
353 END DO
354 ELSE
355 itopo=8
356 np=nsphdir*nsphdir*nsphdir
357 END IF
358 ELSEIF(isolnod(n)==6)THEN
359 itopo=6
360 np=0
361 nt=0
362 DO it=1,nsphdir
363 nt=nt+it
364 END DO
365 np=np+nsphdir*nt
366 ELSEIF(isolnod(n)==4)THEN
367 itopo=4
368 np=0
369 nt=0
370 DO it=1,nsphdir
371 nt=nt+it
372 np=np+nt
373 END DO
374 END IF
375C---
376C SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
377 sol2sph(1,n)=ncell
378 sol2sph(2,n)=ncell+np
379 sol2sph_typ(n)=itopo
380 DO i=1,np
381 sph2sol(ncell+i)=n
382 END DO
383C---
384 IF(itopo==4)THEN
385C-- Tetra
386 CALL soltosphx4(nsphdir,ncell ,inod ,ids ,idmax ,
387 . x ,ixs(1,n),kxsp ,ipartsp,nod2sp ,
388 . irst )
389 ELSEIF (itopo==8) THEN
390C-- Hexa + degenerated penta6
391 CALL soltosphx8(nsphdir,ncell ,inod ,ids ,idmax ,
392 . x ,ixs(1,n),kxsp ,ipartsp,nod2sp ,
393 . irst )
394 ENDIF
395 ENDIF
396 ENDDO
397 ENDIF
398! ------------------------------------
399! check the material consistency between
400! the solide and the sph (SOL2PSH)
401 check_law = .false.
402 error_num = 0
403 tag_part(1:npart) = .false.
404 IF(nsphsol/=0) THEN
405 DO i =1,numsph
406 n = sph2sol(i)
407 IF(n/=0) THEN
408 mid_sph = ipart(1,ipartsp(i))
409 mid_sol = ipart(1,iparts(n))
410 law_sph = ipm(2,mid_sph)
411 law_sol = ipm(2,mid_sol)
412 IF(law_sph/=law_sol) THEN
413 check_law = .true.
414 IF( .NOT.tag_part(ipartsp(i)) ) THEN
415 error_num = error_num + 1
416 tag_part(ipartsp(i)) = .true.
417 part_id_sph(error_num) = ipartsp(i)
418 part_id_sol(error_num) = iparts(n)
419 ENDIF
420 ENDIF
421 ENDIF
422 ENDDO
423 ENDIF
424
425 IF(check_law) THEN
426 DO i=1,error_num
427 titr(1:nchartitle) =''
428 CALL fretitl2(titr,ipart(lipart1-ltitr+1,part_id_sph(i)),ltitr-1)
429 user_part_sph = ipart(4,part_id_sph(i))
430 user_part_sol = ipart(4,part_id_sol(i))
431 user_mid_sph = ipart(5,part_id_sph(i))
432 user_mid_sol = ipart(5,part_id_sol(i))
433 CALL ancmsg(msgid=1911,
434 . msgtype=msgerror,
435 . anmode=aninfo,
436 . i1=user_part_sph,c1=titr(1:len_trim(titr)),
437 . i2=user_mid_sph,i3=user_part_sph,
438 . i4=user_mid_sol,i5=user_part_sol )
439 ENDDO
440 ENDIF
441C-------------------------------------
442C Recherche des ID doubles
443C-------------------------------------
444 CALL udouble(kxsp(nisp,1),nisp,numsph,mess,0,bid)
445C-------------------------------------
446C Print
447C-------------------------------------
448 i1=1
449 i2=min0(50,numsph)
450C
451 IF(ipri>=5) THEN
452 90 WRITE (iout,300)
453 DO 100 i=i1,i2
454 iprt=ipartsp(i)
455 mid =ipm(1,ipart(1,iprt))
456 pid =igeo(1,ipart(2,iprt))
457 WRITE (iout,'(6(I10,1X))') i,kxsp(nisp,i),mid,pid,
458 . kxsp(3,i),itab(kxsp(3,i))
459 100 CONTINUE
460 IF(i2==numsph)GOTO 200
461 i1=i1+50
462 i2=min0(i2+50,numsph)
463 GOTO 90
464C
465 200 CONTINUE
466 WRITE (iout,'(A)') 'END OF CELL TRACEBACK'
467 ENDIF
468
469 DEALLOCATE(itag)
470C
471 300 FORMAT(/' SPH CELLS '/
472 + ' ----------------------'/
473 + ' LOC-CEL GLO-CEL MATER ',
474 + ' GEOM LOC-NOD GLO-NOD ')
475 RETURN
476C-------------------------------------
my_real
#define my_real
Definition cppsort.cpp:32
hm_get_intv
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
Definition hm_get_intv.F:523
hm_option_count
subroutine hm_option_count(entity_type, hm_option_number)
Definition hm_option_count.F:105
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
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
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
submodel_mod::nsubmod
integer nsubmod
Definition submodel_mod.F:720
unitab_mod
Definition unitab_mod.F:513
soltosphx4
subroutine soltosphx4(nsphdir, ncell, inod, ids, idmax, x, ixs, kxsp, ipartsp, nod2sp, irst)
Definition soltosph.F:189
soltosphx8
subroutine soltosphx8(nsphdir, ncell, inod, ids, idmax, x, ixs, kxsp, ipartsp, nod2sp, irst)
Definition soltosph.F:34
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
fretitl2
subroutine fretitl2(titr, iasc, l)
Definition freform.F:804
usr2sys
integer function usr2sys(iu, itabm1, mess, id)
Definition sysfus.F:160
udouble
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
Definition sysfus.F:589
submodel_mod::submodel_data
Definition submodel_mod.F:723