OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
thres.F
Go to the documentation of this file.
1Copyright> OpenRadioss
2Copyright> Copyright (C) 1986-2025 Altair Engineering Inc.
3Copyright>
4Copyright> This program is free software: you can redistribute it and/or modify
5Copyright> it under the terms of the GNU Affero General Public License as published by
6Copyright> the Free Software Foundation, either version 3 of the License, or
7Copyright> (at your option) any later version.
8Copyright>
9Copyright> This program is distributed in the hope that it will be useful,
10Copyright> but WITHOUT ANY WARRANTY; without even the implied warranty of
11Copyright> MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12Copyright> GNU Affero General Public License for more details.
13Copyright>
14Copyright> You should have received a copy of the GNU Affero General Public License
15Copyright> along with this program. If not, see <https://www.gnu.org/licenses/>.
16Copyright>
17Copyright>
18Copyright> Commercial Alternative: Altair Radioss Software
19Copyright>
20Copyright> As an alternative to this open-source version, Altair also offers Altair Radioss
21Copyright> software under a commercial license. Contact Altair to discuss further if the
22Copyright> commercial version may interest you: https://www.altair.com/radioss/.
23!||====================================================================
24!|| thres ../engine/source/output/th/thres.F
25!||--- called by ------------------------------------------------------
26!|| hist2 ../engine/source/output/th/hist2.F
27!||--- uses -----------------------------------------------------
28!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
29!|| element_mod ../common_source/modules/elements/element_mod.F90
30!||====================================================================
31 SUBROUTINE thres(IPARG,ITHBUF,ELBUF_TAB,WA,IGEO,
32 . IXR,NTHGRP2,ITHGRP,X)
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 "com04_c.inc"
47#include "task_c.inc"
48#include "param_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER, INTENT(in) :: NTHGRP2
53 INTEGER, DIMENSION(NITHGR,*), INTENT(in) :: ITHGRP
54 INTEGER IPARG(NPARG,*),ITHBUF(*),IXR(NIXR,*),
55 . igeo(npropgi,*)
56 my_real
57 . wa(*),x(3,numnod)
58C
59 TYPE (ELBUF_STRUCT_), TARGET, DIMENSION(NGROUP) :: ELBUF_TAB
60! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
61! NTHGRP2 : integer ; number of TH group
62! WA_SIZE : integer ; size of working array for spring element
63! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
64C-----------------------------------------------
65C L o c a l V a r i a b l e s
66C-----------------------------------------------
67 INTEGER :: II,I,N,IH,NG,ITY,MTE,K,IP,L
68 INTEGER :: IJK,NEL,NFT,IPROP,IGTYP,JJ(6)
69 INTEGER :: NITER,IAD,NN,IADV,NVAR,ITYP,NODE1,NODE2,NODE3
70 my_real wwa(100)
71 my_real v1,v2,v3,e1x,e1y,e1z,e2x,e2y,e2z,e3x,e3y,e3z
72 TYPE(g_bufel_) ,POINTER :: GBUF
73!$COMMENT
74! THRES description
75! initialization of WA array for spring element
76!
77! THRES organization :
78! loop over the NTHGRP2 TH group and
79! if a group is a spring group, then :
80! - initialization of the NVAR value
81! - add the position II at the end of the chunk (NVAR+1 value)
82!$ENDCOMMENT
83C-----------------------------------------------
84C ELEMENTS RESSORTS
85C-----------------------------------------------
86 ijk = 0
87 DO niter=1,nthgrp2
88 ii=0
89 ityp=ithgrp(2,niter)
90 nn =ithgrp(4,niter)
91 iad =ithgrp(5,niter)
92 nvar=ithgrp(6,niter)
93 iadv=ithgrp(7,niter)
94
95 IF(ityp==6) THEN
96 ih=iad
97C SPECIFIC SPMD
98C decalage IH
99 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
100 ih = ih + 1
101 ENDDO
102 IF (ih >= iad+nn) cycle
103C
104 DO ng=1,ngroup
105 ity=iparg(5,ng)
106 gbuf => elbuf_tab(ng)%GBUF
107 IF (ity == 6) THEN
108 nft=iparg(3,ng)
109 nft=iparg(3,ng)
110 iprop = ixr(1,nft+1)
111 igtyp = igeo(11,iprop)
112 mte=iparg(1,ng)
113 nel=iparg(2,ng)
114C
115 DO k=1,6
116 jj(k) = (k-1)*nel + 1
117 ENDDO
118C
119 IF (igtyp == 4) THEN
120 DO i=1,nel
121 n=i+nft
122 k=ithbuf(ih)
123 ip=ithbuf(ih+nn)
124 node1 = ixr(2,n)
125 node2 = ixr(3,n)
126C
127 IF (k == n) THEN
128 ih=ih+1
129C SPECT SPMD treatment
130C search for the correct ii
131 ii = ((ih-1) - iad)*nvar
132 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
133 ih = ih + 1
134 ENDDO
135C
136 IF (ih > iad+nn) GOTO 666
137C
138 wwa(1)=gbuf%OFF(i)
139 wwa(2)=gbuf%FOR(i)
140 wwa(3)=zero
141 wwa(4)=zero
142 wwa(5)=zero
143 wwa(6)=zero
144 wwa(7)=zero
145 wwa(8)=gbuf%TOTDEPL(i)
146 wwa(9)=zero
147 wwa(10)=zero
148 wwa(11)=zero
149 wwa(12)=zero
150 wwa(13)=zero
151 wwa(14)=gbuf%EINT(i)
152 wwa(15)=zero
153 wwa(16)=zero
154 DO l=17,64
155 wwa(l)= zero
156 ENDDO
157 ! Absolute spring length
158 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
159 . (x(2,node2)-x(2,node1))**2 +
160 . (x(3,node2)-x(3,node1))**2)
161 DO l=iadv,iadv+nvar-1
162 k=ithbuf(l)
163 ijk=ijk+1
164 wa(ijk)=wwa(k)
165 ENDDO
166 ijk=ijk+1
167 wa(ijk) = ii
168 ENDIF
169 ENDDO
170 ELSEIF (igtyp == 26) THEN
171 DO i=1,nel
172 n=i+nft
173 k=ithbuf(ih)
174 ip=ithbuf(ih+nn)
175 node1 = ixr(2,n)
176 node2 = ixr(3,n)
177C
178 IF (k == n) THEN
179 ih=ih+1
180C search for the correct ii
181 ii = ((ih-1) - iad)*nvar
182 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
183 ih = ih + 1
184 ENDDO
185C
186 IF (ih > iad+nn) GOTO 666
187C
188 wwa(1)=gbuf%OFF(i)
189 wwa(2)=gbuf%FOR(i)
190 wwa(3)=zero
191 wwa(4)=zero
192 wwa(5)=zero
193 wwa(6)=zero
194 wwa(7)=zero
195 wwa(8)=gbuf%TOTDEPL(i)
196 wwa(9)=zero
197 wwa(10)=zero
198 wwa(11)=zero
199 wwa(12)=zero
200 wwa(13)=zero
201 wwa(14)=gbuf%EINT(i)
202 wwa(15)=zero
203 wwa(16)=zero
204 DO l=17,64
205 wwa(l)= zero
206 ENDDO
207 ! Absolute spring length
208 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
209 . (x(2,node2)-x(2,node1))**2 +
210 . (x(3,node2)-x(3,node1))**2)
211 ! Failure criterion
212 IF (gbuf%G_RUPTCRIT > 0) THEN
213 wwa(66) = gbuf%RUPTCRIT(i)
214 ELSE
215 wwa(66) = zero
216 ENDIF
217 DO l=iadv,iadv+nvar-1
218 k=ithbuf(l)
219 ijk=ijk+1
220 wa(ijk)=wwa(k)
221 ENDDO
222 ijk=ijk+1
223 wa(ijk) = ii
224 ENDIF
225 ENDDO
226 ELSEIF (igtyp == 27) THEN
227 DO i=1,nel
228 n=i+nft
229 k=ithbuf(ih)
230 ip=ithbuf(ih+nn)
231 node1 = ixr(2,n)
232 node2 = ixr(3,n)
233C
234 IF (k == n) THEN
235 ih=ih+1
236C search for the correct ii
237 ii = ((ih-1) - iad)*nvar
238 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
239 ih = ih + 1
240 ENDDO
241C
242 IF (ih > iad+nn) GOTO 666
243C
244 wwa(1)=gbuf%OFF(i)
245 wwa(2)=gbuf%FOR(i)
246 wwa(3)=zero
247 wwa(4)=zero
248 wwa(5)=zero
249 wwa(6)=zero
250 wwa(7)=zero
251 wwa(8)=gbuf%TOTDEPL(i)
252 wwa(9)=zero
253 wwa(10)=zero
254 wwa(11)=zero
255 wwa(12)=zero
256 wwa(13)=zero
257 wwa(14)=gbuf%EINT(i)
258 wwa(15)=zero
259 wwa(16)=zero
260 DO l=17,64
261 wwa(l)= zero
262 ENDDO
263 ! Absolute spring length
264 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
265 . (x(2,node2)-x(2,node1))**2 +
266 . (x(3,node2)-x(3,node1))**2)
267 ! Failure criterion
268 IF (gbuf%G_RUPTCRIT > 0) THEN
269 wwa(66) = gbuf%RUPTCRIT(i)
270 ELSE
271 wwa(66) = zero
272 ENDIF
273 DO l=iadv,iadv+nvar-1
274 k=ithbuf(l)
275 ijk=ijk+1
276 wa(ijk)=wwa(k)
277 ENDDO
278 ijk=ijk+1
279 wa(ijk) = ii
280 ENDIF
281 ENDDO
282 ELSEIF( igtyp == 12) THEN
283 DO i=1,nel
284 n=i+nft
285 k=ithbuf(ih)
286 ip=ithbuf(ih+nn)
287 node1 = ixr(2,n)
288 node2 = ixr(3,n)
289 node3 = ixr(4,n)
290C
291 IF (k == n) THEN
292 ih=ih+1
293 ii = ((ih-1) - iad)*nvar
294 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
295 ih = ih + 1
296 ENDDO
297C
298 IF (ih > iad+nn) GOTO 666
299C
300 wwa(1)=gbuf%OFF(i)
301 wwa(2)=gbuf%FOR(i)
302 wwa(3)=zero
303 wwa(4)=zero
304 wwa(5)=zero
305 wwa(6)=zero
306 wwa(7)=zero
307 wwa(8)=gbuf%TOTDEPL(i)
308 wwa(9)=zero
309 wwa(10)=zero
310 wwa(11)=zero
311 wwa(12)=zero
312 wwa(13)=zero
313 wwa(14)=gbuf%EINT(i)
314 wwa(15)=gbuf%FOR(i) + gbuf%DFS(i)
315 wwa(16)=gbuf%FOR(i) - gbuf%DFS(i)
316 DO l=17,64
317 wwa(l)= zero
318 ENDDO
319 ! Absolute spring length
320 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
321 . (x(2,node2)-x(2,node1))**2 +
322 . (x(3,node2)-x(3,node1))**2)
323 . + sqrt((x(1,node3)-x(1,node2))**2 +
324 . (x(2,node3)-x(2,node2))**2 +
325 . (x(3,node3)-x(3,node2))**2)
326 DO l=iadv,iadv+nvar-1
327 k=ithbuf(l)
328 ijk=ijk+1
329 wa(ijk)=wwa(k)
330 ENDDO
331 ijk=ijk+1
332 wa(ijk) = ii
333 ENDIF
334 ENDDO
335 ELSEIF (igtyp == 8 .OR. igtyp == 13 .OR. igtyp == 25
336 . .OR. igtyp == 23 ) THEN
337 DO i=1,nel
338 n=i+nft
339 k=ithbuf(ih)
340 ip=ithbuf(ih+nn)
341 node1 = ixr(2,n)
342 node2 = ixr(3,n)
343C
344 IF (k == n) THEN
345 ih=ih+1
346C SPECT SPMD treatment
347C search for the correct ii
348 ii = ((ih-1) - iad)*nvar
349 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
350 ih = ih + 1
351 ENDDO
352C
353 IF (ih > iad+nn) GOTO 666
354C
355 wwa(1)=gbuf%OFF(i)
356 wwa(2)=gbuf%FOR(jj(1)+i-1)
357 wwa(3)=gbuf%FOR(jj(2)+i-1)
358 wwa(4)=gbuf%FOR(jj(3)+i-1)
359 wwa(5)=gbuf%MOM(jj(1)+i-1)
360 wwa(6)=gbuf%MOM(jj(2)+i-1)
361 wwa(7)=gbuf%MOM(jj(3)+i-1)
362 wwa(8)=gbuf%TOTDEPL(jj(1)+i-1)
363 wwa(9)=gbuf%TOTDEPL(jj(2)+i-1)
364 wwa(10)=gbuf%TOTDEPL(jj(3)+i-1)
365 wwa(11)=gbuf%TOTROT(jj(1)+i-1)
366 wwa(12)=gbuf%TOTROT(jj(2)+i-1)
367 wwa(13)=gbuf%TOTROT(jj(3)+i-1)
368 wwa(14)=gbuf%EINT(i)
369 wwa(15)=zero
370 wwa(16)=zero
371 DO l=17,64
372 wwa(l)= zero
373 ENDDO
374 ! Absolute spring length
375 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
376 . (x(2,node2)-x(2,node1))**2 +
377 . (x(3,node2)-x(3,node1))**2)
378 ! Failure criterion
379 IF (gbuf%G_RUPTCRIT > 0) THEN
380 wwa(66) = gbuf%RUPTCRIT(i)
381 ELSE
382 wwa(66) = zero
383 ENDIF
384 DO l=iadv,iadv+nvar-1
385 k=ithbuf(l)
386 ijk=ijk+1
387 wa(ijk)=wwa(k)
388 ENDDO
389 ijk=ijk+1
390 wa(ijk) = ii
391 ENDIF
392 ENDDO
393 ELSEIF (igtyp >= 29) THEN
394 IF (igtyp <= 31 .OR. igtyp == 35 .OR. igtyp == 36. or.
395 . igtyp == 44) THEN
396 DO i=1,nel
397 n=i+nft
398 k=ithbuf(ih)
399 ip=ithbuf(ih+nn)
400 node1 = ixr(2,n)
401 node2 = ixr(3,n)
402C
403 IF (k == n) THEN
404 ih=ih+1
405C SPECT SPMD treatment
406C search for the correct ii
407 ii = ((ih-1) - iad)*nvar
408 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih<iad+nn)
409 ih = ih + 1
410 ENDDO
411C
412 IF (ih > iad+nn) GOTO 666
413C
414 wwa(1)=gbuf%OFF(i)
415 wwa(2)=gbuf%FOR(jj(1)+i-1)
416 wwa(3)=gbuf%FOR(jj(2)+i-1)
417 wwa(4)=gbuf%FOR(jj(3)+i-1)
418 wwa(5)=gbuf%MOM(jj(1)+i-1)
419 wwa(6)=gbuf%MOM(jj(2)+i-1)
420 wwa(7)=gbuf%MOM(jj(3)+i-1)
421 wwa(8) =gbuf%V_REPCVT(jj(1)+i-1)
422 wwa(9) =gbuf%V_REPCVT(jj(2)+i-1)
423 wwa(10)=gbuf%V_REPCVT(jj(3)+i-1)
424 wwa(11)=gbuf%VR_REPCVT(jj(1)+i-1)
425 wwa(12)=gbuf%VR_REPCVT(jj(2)+i-1)
426 wwa(13)=gbuf%VR_REPCVT(jj(3)+i-1)
427 wwa(14)=gbuf%EINT(i)
428!
429 wwa(15)=zero
430 wwa(16)=zero
431C--- repere
432 e1x = gbuf%SKEW(6*(i-1) + 1)
433 e1y = gbuf%SKEW(6*(i-1) + 2)
434 e1z = gbuf%SKEW(6*(i-1) + 3)
435 e2x = gbuf%SKEW(6*(i-1) + 4)
436 e2y = gbuf%SKEW(6*(i-1) + 5)
437 e2z = gbuf%SKEW(6*(i-1) + 6)
438 e3x = e1y*e2z - e1z*e2y
439 e3y = e1z*e2x - e1x*e2z
440 e3z = e1x*e2y - e1y*e2x
441C--- force locale
442 v1 = gbuf%FOR(jj(1)+i-1)
443 v2 = gbuf%FOR(jj(2)+i-1)
444 v3 = gbuf%FOR(jj(3)+i-1)
445 wwa(23)=-v1
446 wwa(24)=-v2
447 wwa(25)=-v3
448 wwa(26)= v1
449 wwa(27)= v2
450 wwa(28)= v3
451C--- force globale
452 wwa(20)= v1*e1x+v2*e1y+v3*e1z
453 wwa(21)= v1*e2x+v2*e2y+v3*e2z
454 wwa(22)= v1*e3x+v2*e3y+v3*e3z
455 wwa(17)=-wwa(20)
456 wwa(18)=-wwa(21)
457 wwa(19)=-wwa(22)
458C--- moment local
459 v1 = gbuf%MOM(jj(1)+i-1)
460 v2 = gbuf%MOM(jj(4)+i-1)
461 v3 = gbuf%MOM(jj(5)+i-1)
462 wwa(35)= v1
463 wwa(36)= v2
464 wwa(37)= v3
465 wwa(38)=-v1
466 wwa(39)= v2 + two*gbuf%MOM(jj(2)+i-1)
467 wwa(40)= v3 + two*gbuf%MOM(jj(3)+i-1)
468C--- moment global
469 wwa(29)= v1*e1x+v2*e1y+v3*e1z
470 wwa(30)= v1*e2x+v2*e2y+v3*e2z
471 wwa(31)= v1*e3x+v2*e3y+v3*e3z
472 wwa(32)= wwa(38)*e1x+wwa(39)*e1y+wwa(40)*e1z
473 wwa(33)= wwa(38)*e2x+wwa(39)*e2y+wwa(40)*e2z
474 wwa(34)= wwa(38)*e3x+wwa(39)*e3y+wwa(40)*e3z
475C--- deformation locale
476 v1 = -gbuf%V_REPCVT(jj(1)+i-1)
477 wwa(47)= v1
478 wwa(48)= zero
479 wwa(49)= zero
480 wwa(50)=-v1
481 wwa(51)= zero
482 wwa(52)= zero
483C--- deformation globale
484 wwa(41)= v1*e1x
485 wwa(42)= v1*e2x
486 wwa(43)= v1*e3x
487 wwa(44)=-wwa(41)
488 wwa(45)=-wwa(42)
489 wwa(46)=-wwa(43)
490C--- Local rotation node1
491 v1 = -gbuf%VR_REPCVT(jj(1)+i-1)
492 v2 = gbuf%V_REPCVT(jj(2)+i-1)
493 v3 = gbuf%V_REPCVT(jj(3)+i-1)
494 wwa(59)= v1
495 wwa(60)= v2
496 wwa(61)= v3
497C--- rotation globale Noeud1
498 wwa(53)= v1*e1x+v2*e1y+v3*e1z
499 wwa(54)= v1*e2x+v2*e2y+v3*e2z
500 wwa(55)= v1*e3x+v2*e3y+v3*e3z
501C--- Local rotation node2
502 v2 = gbuf%VR_REPCVT(jj(2)+i-1)
503 v3 = gbuf%VR_REPCVT(jj(3)+i-1)
504 wwa(62)=-v1
505 wwa(63)= v2
506 wwa(64)= v3
507C--- rotation globale Noeud2
508 wwa(56)=-v1*e1x+v2*e1y+v3*e1z
509 wwa(57)=-v1*e2x+v2*e2y+v3*e2z
510 wwa(58)=-v1*e3x+v2*e3y+v3*e3z
511C--- absolute spring length
512 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
513 . (x(2,node2)-x(2,node1))**2 +
514 . (x(3,node2)-x(3,node1))**2)
515c
516 DO l=iadv,iadv+nvar-1
517 k=ithbuf(l)
518 ijk=ijk+1
519 wa(ijk)=wwa(k)
520 ENDDO
521 ijk=ijk+1
522 wa(ijk) = ii
523 ENDIF
524 ENDDO
525 ELSEIF (igtyp == 32) THEN
526 DO i=1,nel
527 n=i+nft
528 k=ithbuf(ih)
529 ip=ithbuf(ih+nn)
530 node1 = ixr(2,n)
531 node2 = ixr(3,n)
532C
533 IF (k == n) THEN
534 ih=ih+1
535C SPECT SPMD treatment
536C search for the correct ii
537 ii = ((ih-1) - iad)*nvar
538 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
539 ih = ih + 1
540 ENDDO
541C
542 IF (ih > iad+nn) GOTO 666
543C
544 wwa(1)=gbuf%OFF(i)
545 wwa(2)=gbuf%FOR(jj(1)+i-1)
546 wwa(3)=gbuf%FOR(jj(2)+i-1)
547 wwa(4)=gbuf%FOR(jj(3)+i-1)
548 wwa(5)=gbuf%MOM(jj(1)+i-1)
549 wwa(6)=gbuf%MOM(jj(2)+i-1)
550 wwa(7)=gbuf%MOM(jj(3)+i-1)
551 wwa(8)=gbuf%V_REPCVT(jj(1)+i-1)
552 wwa(9)=gbuf%V_REPCVT(jj(2)+i-1)
553 wwa(10)=gbuf%V_REPCVT(jj(3)+i-1)
554 wwa(11)=gbuf%VR_REPCVT(jj(1)+i-1)
555 wwa(12)=gbuf%VR_REPCVT(jj(2)+i-1)
556 wwa(13)=gbuf%VR_REPCVT(jj(3)+i-1)
557 wwa(14)=gbuf%EINT(i)
558 wwa(15)=zero
559 wwa(16)=zero
560 DO l=17,64
561 wwa(l)= zero
562 ENDDO
563 ! Absolute spring length
564 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
565 . (x(2,node2)-x(2,node1))**2 +
566 . (x(3,node2)-x(3,node1))**2)
567 DO l=iadv,iadv+nvar-1
568 k=ithbuf(l)
569 ijk=ijk+1
570 wa(ijk)=wwa(k)
571 ENDDO
572 ijk=ijk+1
573 wa(ijk) = ii
574 ENDIF
575 ENDDO
576 ELSEIF (igtyp == 33 .OR. igtyp == 45) THEN
577 DO i=1,nel
578 n=i+nft
579 k=ithbuf(ih)
580 ip=ithbuf(ih+nn)
581 node1 = ixr(2,n)
582 node2 = ixr(3,n)
583C
584 IF (k == n) THEN
585 ih=ih+1
586C SPECT SPMD treatment
587C search for the correct ii
588 ii = ((ih-1) - iad)*nvar
589 DO WHILE (ithbuf(ih+nn) /= ispmd .AND. ih < iad+nn)
590 ih = ih + 1
591 ENDDO
592C
593 IF (ih > iad+nn) GOTO 666
594C
595 wwa(1)=gbuf%OFF(i)
596 wwa(2)=gbuf%FOR(jj(1)+i-1)
597 wwa(3)=gbuf%FOR(jj(2)+i-1)
598 wwa(4)=gbuf%FOR(jj(3)+i-1)
599 wwa(5)=gbuf%MOM(jj(1)+i-1)
600 wwa(6)=gbuf%MOM(jj(2)+i-1)
601 wwa(7)=gbuf%MOM(jj(3)+i-1)
602 wwa(8)=gbuf%TOTDEPL(jj(1)+i-1)
603 wwa(9)=gbuf%TOTDEPL(jj(2)+i-1)
604 wwa(10)=gbuf%TOTDEPL(jj(3)+i-1)
605 wwa(11)=gbuf%TOTROT(jj(1)+i-1)
606 wwa(12)=gbuf%TOTROT(jj(2)+i-1)
607 wwa(13)=gbuf%TOTROT(jj(3)+i-1)
608 wwa(14)=gbuf%EINT(i)
609 wwa(15)=zero
610 wwa(16)=zero
611 DO l=17,64
612 wwa(l)= zero
613 ENDDO
614 ! Absolute spring length
615 wwa(65)= sqrt((x(1,node2)-x(1,node1))**2 +
616 . (x(2,node2)-x(2,node1))**2 +
617 . (x(3,node2)-x(3,node1))**2)
618 DO l=iadv,iadv+nvar-1
619 k=ithbuf(l)
620 ijk=ijk+1
621 wa(ijk)=wwa(k)
622 ENDDO
623 ijk=ijk+1
624 wa(ijk) = ii
625 ENDIF
626 ENDDO ! DO I=1,NEL
627 ENDIF
628 ENDIF ! IF (IGTYP)
629 ENDIF ! IF (ITY)
630 ENDDO ! DO NG=1,NGROUP
631
632 ENDIF ! if(ITYP==6)
633
634 666 ENDDO ! DO N=1,NTHGRP2
635C-----------
636 RETURN
637 END
my_real
#define my_real
Definition cppsort.cpp:32
thres
subroutine thres(iparg, ithbuf, elbuf_tab, wa, igeo, ixr, nthgrp2, ithgrp, x)
Definition thres.F:33