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

Go to the source code of this file.

Functions/Subroutines

subroutine spgrhead (kxsp, ixsp, iparg, pm, ipart, ipartsp, eadd, cepsp, nd, ipm, igeo, spbuf, sph2sol, sol2sph, irst, mat_param, ixsps)

Function/Subroutine Documentation

◆ spgrhead()

subroutine spgrhead ( integer, dimension(nisp,*) kxsp,
integer, dimension(kvoisph,*) ixsp,
integer, dimension(nparg,*) iparg,
pm,
integer, dimension(lipart1,*) ipart,
integer, dimension(*) ipartsp,
integer, dimension(*) eadd,
integer, dimension(*) cepsp,
integer nd,
integer, dimension(npropmi,nummat) ipm,
integer, dimension(npropgi,numgeo) igeo,
spbuf,
integer, dimension(*) sph2sol,
integer, dimension(2,*) sol2sph,
integer, dimension(3,nsphsol) irst,
type(matparam_struct_), dimension(nummat), intent(in) mat_param,
integer, dimension(kvoisph,numsph), intent(inout) ixsps )

Definition at line 32 of file spgrhead.F.

36C-----------------------------------------------
37C M o d u l e s
38C-----------------------------------------------
39 USE my_alloc_mod
40 USE message_mod
41 USE matparam_def_mod
42C-----------------------------------------------
43C I m p l i c i t T y p e s
44C-----------------------------------------------
45#include "implicit_f.inc"
46C-----------------------------------------------
47C C o m m o n B l o c k s
48C-----------------------------------------------
49#include "vect01_c.inc"
50#include "com04_c.inc"
51#include "sphcom.inc"
52#include "param_c.inc"
53#include "scr17_c.inc"
54C-----------------------------------------------
55C D u m m y A r g u m e n t s
56C-----------------------------------------------
57 INTEGER, DIMENSION(KVOISPH,NUMSPH),INTENT(INOUT) :: IXSPS
58 INTEGER KXSP(NISP,*),IPARG(NPARG,*),IXSP(KVOISPH,*),
59 . IPART(LIPART1,*),IPARTSP(*), EADD(*), CEPSP(*),
60 . IPM(NPROPMI,NUMMAT), IGEO(NPROPGI,NUMGEO),
61 . ND, SPH2SOL(*), SOL2SPH(2,*), IRST(3,NSPHSOL)
62 my_real pm(npropm,nummat), spbuf(nspbuf,numsph)
63 TYPE(MATPARAM_STRUCT_) ,DIMENSION(NUMMAT), INTENT(IN) :: MAT_PARAM
64C-----------------------------------------------
65C L o c a l V a r i a b l e s
66C-----------------------------------------------
67 INTEGER NE, NG, MT, MLN, I, J, MODE, II0, JJ0,
68 . II, JJ, II1, JJ1, II2, JJ2, II3, JJ3, II4, JJ4,
69 . N, IGTYP,IORDER,IPRT,ISLEEP,IUN,IFAIL,IEOS, IKIND, STAT,
70 . JALE_FROM_MAT, JALE_FROM_PROP
71 INTEGER WORK(70000)
72 INTEGER, DIMENSION(:,:),ALLOCATABLE :: ITRI
73 INTEGER, DIMENSION(:),ALLOCATABLE :: INDEX
74 INTEGER, DIMENSION(:,:),ALLOCATABLE :: INUM
75 INTEGER, DIMENSION(:),ALLOCATABLE :: XEP
76 my_real, DIMENSION(:,:),ALLOCATABLE :: rnum
77 DATA iun/1/
78C-----------------------------------------------
79C E x t e r n a l F u n c t i o n s
80C-----------------------------------------------
81 INTEGER MY_SHIFTL,MY_SHIFTR,MY_AND
82 EXTERNAL my_shiftl,my_shiftr,my_and
83 my_real, EXTERNAL :: get_u_geo
84C-----------------------------------------------
85
86C======================================================================|
87C GENERAL SORTING : ALL CRITERIA, ALL ELEMENTS
88C----------------------------------------------------------
89 CALL my_alloc(itri,7,numsph)
90 CALL my_alloc(index,2*numsph)
91 CALL my_alloc(inum,13,numsph)
92 CALL my_alloc(xep,numsph)
93 CALL my_alloc(rnum,nspbuf,numsph)
94
95 DO i=1,numsph
96 IF(nsphsol==0)THEN
97 itri(1,i)=0
98 ELSE
99 itri(1,i)=sph2sol(i)
100 END IF
101 itri(7,i)=i
102 index(i)=i
103 inum(1,i)=ipartsp(i)
104 inum(2,i)=kxsp(1,i)
105 inum(3,i)=kxsp(2,i)
106 inum(4,i)=kxsp(3,i)
107 inum(5,i)=kxsp(4,i)
108 inum(6,i)=kxsp(5,i)
109 inum(7,i)=kxsp(6,i)
110 inum(8,i)=kxsp(7,i)
111 inum(9,i)=kxsp(8,i)
112C tri spbuf
113 DO j=1,nspbuf
114 rnum(j,i)=spbuf(j,i)
115 END DO
116 ENDDO
117
118 DO i=1,numsph
119 xep(i)=cepsp(i)
120 END DO
121
122 DO i = 1, numsph
123 DO j = 1, kvoisph
124 ixsps(j,i) = ixsp(j,i)
125 END DO
126 END DO
127C
128 DO i = 1, numsph
129 iprt =ipartsp(i)
130 mt =ipart(1,iprt)
131 mln =nint(pm(19,abs(mt)))
132 ng =ipart(2,iprt)
133 igtyp = igeo(11,ng)
134 isorth= min(iun,igeo(2,ng))
135 israt = ipm(3,mt)
136 ieos = ipm(4,mt)
137C warning : -1<=IORDER<=1
138 iorder=get_u_geo(5,ng)
139 isleep=kxsp(2,i)
140 IF(nsphsol==0)THEN
141 itri(1,i)=0
142 ELSE
143 itri(1,i)=sph2sol(i)
144 END IF
145C
146 jale_from_mat = nint(pm(72,mt))
147 jale_from_prop = igeo(62,ng)
148 jale = max(jale_from_mat, jale_from_prop) !if inconsistent, error message was displayed in PART reader
149
150 jlag=0
151 IF(jale==0.AND.mln/=18)jlag=1
152 jeul=0
153 IF(jale==2)THEN
154 jale=0
155 jeul=1
156 END IF
157 jtur=nint(pm(70,mt))
158 jthe=nint(pm(71,mt))
159 ifail = 0
160 IF (mat_param(mt)%NFAIL > 0) ifail = 1
161C Key 1
162 jthe=my_shiftl(jthe,1)
163 jtur=my_shiftl(jtur,2)
164 jeul=my_shiftl(jeul,3)
165 jlag=my_shiftl(jlag,4)
166 jale=my_shiftl(jale,5)
167C ISSN=MY_SHIFTL(ISSN,6)
168C JHBE=MY_SHIFTL(JHBE,9)
169C JPOR=MY_SHIFTL(JPOR,12)
170! do not sort in the following cases
171 IF(mln<28.OR.mln==36.OR.mln==46.OR.mln==47)mln=0
172 mln = my_shiftl(mln,21)
173 ifail = my_shiftl(ifail,31)
174 itri(2,i)=mln+jale+jlag+jeul+jtur+jthe+ifail
175C
176 itri(3,i)=ng
177C
178 itri(4,i)=mt
179C Key 4
180 iorder= my_shiftl(iorder,0)
181 isorth= my_shiftl(isorth,2)
182 israt = my_shiftl(israt,3)
183 ieos = my_shiftl(ieos,5)
184C next = MY_SHIFTL(next,9)
185 itri(5,i)=iorder+israt+isorth+ieos
186C Key5 5
187 itri(6,i)=isleep
188 END DO
189C
190 mode = 0
191 CALL my_orders( mode, work, itri, index, numsph , 7)
192C
193 DO i=1,numsph
194 ipartsp(i)= inum(1,index(i))
195 kxsp(1,i) = inum(2,index(i))
196 kxsp(2,i) = inum(3,index(i))
197 kxsp(3,i) = inum(4,index(i))
198 kxsp(4,i) = inum(5,index(i))
199 kxsp(5,i) = inum(6,index(i))
200 kxsp(6,i) = inum(7,index(i))
201 kxsp(7,i) = inum(8,index(i))
202 kxsp(8,i) = inum(9,index(i))
203
204c sorting spbuf
205 DO j=1,nspbuf
206 spbuf(j,i) = rnum(j,index(i))
207 ENDDO
208 END DO
209C
210 DO i=1,numsph
211 cepsp(i) = xep(index(i))
212 END DO
213C
214 DO i = 1, numsph
215 DO j = 1, kvoisph
216 ixsp(j,i) = ixsps(j,index(i))
217 END DO
218 END DO
219C
220 IF(nsphsol/=0)THEN
221C
222 DO i=1,numsph
223 inum(10,i)=sph2sol(i)
224 IF(i >= first_sphsol .AND. i < first_sphsol+nsphsol)THEN
225 inum(11,i)=irst(1,i-first_sphsol+1)
226 inum(12,i)=irst(2,i-first_sphsol+1)
227 inum(13,i)=irst(3,i-first_sphsol+1)
228 END IF
229 END DO
230C
231 DO i=1,numsph
232 sph2sol(i) = inum(10,index(i))
233 IF(i >= first_sphsol .AND. i < first_sphsol+nsphsol)THEN
234C INDEX(I) < FIRST_SPHSOL <=> internal error
235 irst(1,i-first_sphsol+1)=inum(11,index(i))
236 irst(2,i-first_sphsol+1)=inum(12,index(i))
237 irst(3,i-first_sphsol+1)=inum(13,index(i))
238 END IF
239 END DO
240C
241C Rebuild SOL2SPH, SOL2SPH(1,N)+1<=I<=SOLSPH(2,N) <=> N==SPH2SOL(I)
242 DO n=1,numels8
243 sol2sph(1,n)=0
244 sol2sph(2,n)=0
245 END DO
246 n=sph2sol(first_sphsol)
247 sol2sph(1,n)=0
248 sol2sph(2,n)=sol2sph(1,n)+1
249 DO i=first_sphsol+1,first_sphsol+nsphsol-1
250 IF(sph2sol(i)==n)THEN
251 sol2sph(2,n)=sol2sph(2,n)+1
252 ELSE
253 n=sph2sol(i)
254 sol2sph(1,n)=i-1
255 sol2sph(2,n)=sol2sph(1,n)+1
256 END IF
257 END DO
258C
259 END IF
260C reneumbering th groups and surface buffer
261C--------------------------------------------------------------
262C DETERMINATION DES SUPER_GROUPES
263C--------------------------------------------------------------
264 nd=1
265 eadd(1) = 1
266 DO i=2,numsph
267 ii0=itri(1,index(i))
268 jj0=itri(1,index(i-1))
269 ii=itri(2,index(i))
270 jj=itri(2,index(i-1))
271 ii1=itri(3,index(i))
272 jj1=itri(3,index(i-1))
273 ii2=itri(4,index(i))
274 jj2=itri(4,index(i-1))
275 ii3=itri(5,index(i))
276 jj3=itri(5,index(i-1))
277 ii4=itri(6,index(i))
278 jj4=itri(6,index(i-1))
279 IF((ii0==0.AND.ii0/=jj0) .OR. ii/=jj .OR. ii1/=jj1.OR.ii2/=jj2 .OR. ii3/=jj3.OR.ii4/=jj4) THEN
280 nd=nd+1
281 eadd(nd)=i
282 END IF
283 END DO
284 eadd(nd+1) = numsph+1
285 ne = 0
286 DO n=1,nd
287 ne = ne + eadd(n+1)-eadd(n)
288 ENDDO
289 DEALLOCATE(itri)
290 DEALLOCATE(index)
291 DEALLOCATE(inum)
292 DEALLOCATE(xep)
293 DEALLOCATE(rnum)
294
295C-----------
296 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
message_mod
Definition message_mod.F:1249
my_shiftr
int my_shiftr(int *a, int *n)
Definition precision.c:45
my_shiftl
int my_shiftl(int *a, int *n)
Definition precision.c:36
my_and
int my_and(int *a, int *b)
Definition precision.c:54