OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
thres_count.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "task_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine thres_count (iparg, ithbuf, elbuf_tab, igeo, ixr, ithgrp, nthgrp2, wa_size, index_wa_spring, sithbuf)

Function/Subroutine Documentation

◆ thres_count()

subroutine thres_count ( integer, dimension(nparg,*) iparg,
integer, dimension(*) ithbuf,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixr,*) ixr,
integer, dimension(nithgr,*) ithgrp,
integer nthgrp2,
integer, intent(inout) wa_size,
integer, dimension(2*nthgrp2+1), intent(inout) index_wa_spring,
integer, intent(in) sithbuf )

Definition at line 30 of file thres_count.F.

32C-----------------------------------------------
33C M o d u l e s
34C-----------------------------------------------
35 USE elbufdef_mod
36C-----------------------------------------------
37C I m p l i c i t T y p e s
38C-----------------------------------------------
39#include "implicit_f.inc"
40C-----------------------------------------------
41C C o m m o n B l o c k s
42C-----------------------------------------------
43#include "com01_c.inc"
44#include "task_c.inc"
45#include "param_c.inc"
46C-----------------------------------------------
47C D u m m y A r g u m e n t s
48C-----------------------------------------------
49 INTEGER,INTENT(IN) :: SITHBUF
50 INTEGER IPARG(NPARG,*),ITHBUF(*),IXR(NIXR,*),
51 . IGEO(NPROPGI,*),ITHGRP(NITHGR,*),NTHGRP2
52 INTEGER, INTENT(inout) :: WA_SIZE
53 INTEGER, DIMENSION(2*NTHGRP2+1), INTENT(inout) :: INDEX_WA_SPRING
54C
55 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
56! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
57! NTHGRP2 : integer ; number of TH group
58! WA_SIZE : integer ; size of working array for spring element
59! INDEX_WA_SPRING : integer ; dimension=NTHGRP2
60! local index of WA array, sent to PROC0
61! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
62C-----------------------------------------------
63C L o c a l V a r i a b l e s
64C-----------------------------------------------
65 LOGICAL :: BOOL
66 INTEGER :: II,I,N,IH,NG,ITY,MTE,K,IP,L,
67 . LWA,NEL,NFT,IPROP,IGTYP,J,JJ(6)
68 INTEGER :: NN,IAD,IADV,NVAR,ITYP,NITER,J_FIRST
69 INTEGER, DIMENSION(NTHGRP2) :: INDEX_RESSORT
70
71 my_real
72 . wwa(100)
73 my_real
74 . v1,v2,v3,e1x,e1y,e1z,e2x,e2y,e2z,e3x,e3y,e3z
75C
76 TYPE(G_BUFEL_) ,POINTER :: GBUF
77!$COMMENT
78! THRES_COUNT description
79! count the size of working array for
80! spring element
81!
82! THRES_COUNT organization :
83! loop over the NTHGRP2 TH group and
84! if a group is a spring group, then :
85! - add the size of the group NVAR to the
86! global size WA_SIZE (WA_SIZE=WA_SIZE+NVAR)
87! - add another case for the local position
88! WA_SIZE = WA_SIZE + 1
89! the local position is useful to build
90! the global index SPRING_STRUCT(I)%TH_SPRING on PROC0
91!$ENDCOMMENT
92
93C-----------------------------------------------
94C ELEMENTS RESSORTS
95C-----------------------------------------------
96 wa_size = 0
97 index_ressort(1:nthgrp2) = 0
98
99 DO niter=1,nthgrp2
100
101 ityp=ithgrp(2,niter)
102 nn =ithgrp(4,niter)
103 iad =ithgrp(5,niter)
104 nvar=ithgrp(6,niter)
105 iadv=ithgrp(7,niter)
106
107 ih=iad
108 IF(ityp==6) THEN
109C specifique spmd
110C decalage IH
111 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
112 ih = ih + 1
113 ENDDO
114 IF (ih >= iad+nn) GOTO 666
115C
116 DO ng=1,ngroup
117 ity=iparg(5,ng)
118 gbuf => elbuf_tab(ng)%GBUF
119 IF (ity == 6) THEN
120 nft=iparg(3,ng)
121 nft=iparg(3,ng)
122 iprop = ixr(1,nft+1)
123 igtyp = igeo(11,iprop)
124 mte=iparg(1,ng)
125 nel=iparg(2,ng)
126C
127 DO k=1,6
128 jj(k) = (k-1)*nel + 1
129 ENDDO
130C
131 IF (igtyp == 4) THEN
132 DO i=1,nel
133 n=i+nft
134 k=ithbuf(ih)
135 ip=ithbuf(ih+nn)
136C
137 IF (k == n) THEN
138 ih=ih+1
139C traitement specifique spmd
140C recherche du ii correct
141 ii = ((ih-1) - iad)*nvar
142 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
143 ih = ih + 1
144 ENDDO
145C
146 IF (ih > iad+nn) GOTO 666
147 wa_size = wa_size + nvar + 1
148 ENDIF
149 ENDDO
150 ELSEIF (igtyp == 26) THEN
151 DO i=1,nel
152 n=i+nft
153 k=ithbuf(ih)
154 ip=ithbuf(ih+nn)
155C
156 IF (k == n) THEN
157 ih=ih+1
158C recherche du ii correct
159 ii = ((ih-1) - iad)*nvar
160 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
161 ih = ih + 1
162 ENDDO
163C
164 IF (ih > iad+nn) GOTO 666
165 wa_size = wa_size + nvar + 1
166 ENDIF
167 ENDDO
168 ELSEIF (igtyp == 27) THEN
169 DO i=1,nel
170 n=i+nft
171 k=ithbuf(ih)
172 ip=ithbuf(ih+nn)
173C
174 IF (k == n) THEN
175 ih=ih+1
176C recherche du ii correct
177 ii = ((ih-1) - iad)*nvar
178 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
179 ih = ih + 1
180 ENDDO
181C
182 IF (ih > iad+nn) GOTO 666
183 wa_size = wa_size + nvar + 1
184 ENDIF
185 ENDDO
186 ELSEIF( igtyp == 12) THEN
187 DO i=1,nel
188 n=i+nft
189 k=ithbuf(ih)
190 ip=ithbuf(ih+nn)
191C
192 IF (k == n) THEN
193 ih=ih+1
194
195 ii = ((ih-1) - iad)*nvar
196 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
197 ih = ih + 1
198 ENDDO
199
200C
201 IF (ih > iad+nn) GOTO 666
202 wa_size = wa_size + nvar + 1
203 ENDIF
204 ENDDO
205 ELSEIF (igtyp == 8 .OR. igtyp == 13 .OR. igtyp == 25
206 . .OR. igtyp == 23 ) THEN
207 DO i=1,nel
208 n=i+nft
209 k=ithbuf(ih)
210 ip=ithbuf(ih+nn)
211C
212 IF (k == n) THEN
213 ih=ih+1
214C traitement specifique spmd
215C recherche du ii correct
216 ii = ((ih-1) - iad)*nvar
217 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
218 ih = ih + 1
219 ENDDO
220C
221 IF (ih > iad+nn) GOTO 666
222 wa_size = wa_size + nvar + 1
223 ENDIF
224 ENDDO
225 ELSEIF (igtyp >= 29) THEN
226 IF (igtyp <= 31 .OR. igtyp == 35 .OR. igtyp == 36. or.
227 . igtyp == 44) THEN
228 DO i=1,nel
229 n=i+nft
230 k=ithbuf(ih)
231 ip=ithbuf(ih+nn)
232C
233 IF (k == n) THEN
234 ih=ih+1
235C traitement specifique spmd
236C recherche du ii correct
237 ii = ((ih-1) - iad)*nvar
238 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih<iad+nn)
239 ih = ih + 1
240 ENDDO
241 IF (ih > iad+nn) GOTO 666
242 wa_size = wa_size + nvar + 1
243 ENDIF
244 ENDDO
245 ELSEIF (igtyp == 32) THEN
246 DO i=1,nel
247 n=i+nft
248 k=ithbuf(ih)
249 ip=ithbuf(ih+nn)
250C
251 IF (k == n) THEN
252 ih=ih+1
253C traitement specifique spmd
254C recherche du ii correct
255 ii = ((ih-1) - iad)*nvar
256 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
257 ih = ih + 1
258 ENDDO
259C
260 IF (ih > iad+nn) GOTO 666
261 wa_size = wa_size + nvar + 1
262 ENDIF
263 ENDDO
264 ELSEIF (igtyp == 33 .OR. igtyp == 45) THEN
265 DO i=1,nel
266 n=i+nft
267 k=ithbuf(ih)
268 ip=ithbuf(ih+nn)
269C
270 IF (k == n) THEN
271 ih=ih+1
272C traitement specifique spmd
273C recherche du ii correct
274 ii = ((ih-1) - iad)*nvar
275 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
276 ih = ih + 1
277 ENDDO
278C
279 IF (ih > iad+nn) GOTO 666
280 wa_size = wa_size + nvar + 1
281 ENDIF
282 ENDDO ! DO I=1,NEL
283 ENDIF
284 ENDIF ! IF (IGTYP)
285 ENDIF ! IF (ITY)
286 ENDDO ! DO NG=1,NGROUP
287
288 666 continue
289 index_ressort(niter) = wa_size
290 ENDIF
291 ENDDO ! DO N=1,NTHGRP2
292
293
294 j_first = 0
295 bool = .true.
296 DO i=1,nthgrp2
297 IF(bool.EQV..true.) THEN
298 IF( index_ressort(i)/=0 ) THEN
299 bool = .false.
300 j_first = i
301 ENDIF
302 ENDIF
303 ENDDO
304
305 j = 0
306 IF(j_first>0) THEN
307 j=j+1
308 index_wa_spring(j) = index_ressort(j_first)
309 j=j+1
310 index_wa_spring(j) = j_first
311 DO i=j_first+1,nthgrp2
312 IF( index_ressort(i)-index_ressort(i-1)>0 ) THEN
313 j=j+1
314 index_wa_spring(j) = index_ressort(i)
315 j=j+1
316 index_wa_spring(j) = i
317 ENDIF
318 ENDDO
319 ENDIF
320 index_wa_spring(2*nthgrp2+1) = j ! number of non-zero index
321C-----------
322 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
nvar
integer function nvar(text)
Definition nvar.F:32