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 31 of file thres_count.F.

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