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