OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
thnod.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "sphcom.inc"
#include "scr03_c.inc"
#include "scr16_c.inc"
#include "param_c.inc"
#include "submodel.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine thnod (output, ithbuf, wa, x, d, v, a, vr, ar, iskwn, iframe, skew, xframe, weight, temp, inod, fthreac, nodreac, cptreac, dr, iform, nthgrp2, ithgrp, pinch_data, itherm_fe)

Function/Subroutine Documentation

◆ thnod()

subroutine thnod ( type(output_), intent(inout) output,
integer, dimension(*) ithbuf,
wa,
x,
d,
v,
a,
vr,
ar,
integer, dimension(liskn,*) iskwn,
integer, dimension(liskn,*) iframe,
skew,
xframe,
integer, dimension(numnod) weight,
temp,
integer, dimension(*) inod,
fthreac,
integer, dimension(*) nodreac,
integer cptreac,
dr,
integer iform,
integer nthgrp2,
integer, dimension(nithgr,*), intent(in) ithgrp,
type(pinch) pinch_data,
integer, intent(in) itherm_fe )

Definition at line 36 of file thnod.F.

42C-----------------------------------------------
43C M o d u l e s
44C-----------------------------------------------
45 USE plyxfem_mod
46 USE pinchtype_mod
47 USE output_mod
48 USE th_mod , ONLY : th_has_noda_pext
49C-----------------------------------------------
50C I m p l i c i t T y p e s
51C-----------------------------------------------
52#include "implicit_f.inc"
53C-----------------------------------------------
54C C o m m o n B l o c k s
55C-----------------------------------------------
56#include "com01_c.inc"
57#include "com04_c.inc"
58#include "sphcom.inc"
59#include "scr03_c.inc"
60#include "scr16_c.inc"
61#include "param_c.inc"
62#include "submodel.inc"
63C-----------------------------------------------
64C D u m m y A r g u m e n t s
65C-----------------------------------------------
66 TYPE(OUTPUT_), intent(inout) :: output
67 INTEGER CPTREAC,ITHBUF(*),
68 . ISKWN(LISKN,*),IFRAME(LISKN,*),WEIGHT(NUMNOD),INOD(*),
69 . NODREAC(*),IFORM,NTHGRP2
70 INTEGER, DIMENSION(NITHGR,*), INTENT(in) :: ITHGRP
71 INTEGER ,intent(in) :: ITHERM_FE
72 my_real
73 . wa(*),x(3,*),d(3,numnod),v(3,*),a(3,*),vr(3,*),ar(3,*),
74 . skew(lskew,*),xframe(nxframe,*),temp(*),fthreac(6,*),
75 . dr(3,*)
76 TYPE(PINCH) :: PINCH_DATA
77! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
78! NTHGRP2 : integer ; number of TH group
79! WA_SIZE : integer ; size of working array for node element
80! -*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-**-*-*-*-*-*-*-*-*-*-*-*-*
81C-----------------------------------------------
82C L o c a l V a r i a b l e s
83C-----------------------------------------------
84 LOGICAL :: CONDITION
85 INTEGER I, J, ISK, II, L, K, IUN, IFRA,IPLY,IDIR,N
86 INTEGER :: II_SAVE,IJK, ITYP
87 INTEGER :: IAD,NN,IADV,NVAR
88 my_real :: xl(3),dl(3),vl(3),al(3),vrl(3),arl(3),vrg(3),arg(3)
89 DATA iun/1/
90C-------------------------
91C NODES
92C DEPLACEMENT, VELOCITY, ACCELERATION,
93C VELOCITY ANGULAIRE, ACCELERATION ANGULAIRE,
94C & POSITION
95C-------------------------
96 ijk = 0
97 DO n=1,nthgrp2
98 ityp=ithgrp(2,n)
99 nn =ithgrp(4,n)
100 iad =ithgrp(5,n)
101 nvar=ithgrp(6,n)
102 iadv=ithgrp(7,n)
103 ii=0
104 IF(ityp==0)THEN
105 IF(iroddl/=0)THEN
106 ii=0
107 DO j=iad,iad+nn-1
108 i=ithbuf(j)
109 isk = 1 + ithbuf(j+nn)
110 condition = (i <= 0)
111 IF(.NOT. condition) condition = (weight(i) == 0)
112 IF (condition) THEN
113 DO l=iadv,iadv+nvar-1
114 ii=ii+1
115 ENDDO
116 ELSEIF(isk==1)THEN
117C---------
118C output with respect to the global SKEW.
119 ii_save = ii
120 DO l=iadv,iadv+nvar-1
121 k=ithbuf(l)
122 ii=ii+1
123 ijk=ijk+1
124 IF (k==1)THEN
125 wa(ijk)=d(1,i)
126 ELSEIF(k==2)THEN
127 wa(ijk)=d(2,i)
128 ELSEIF(k==3)THEN
129 wa(ijk)=d(3,i)
130 ELSEIF(k==4)THEN
131 wa(ijk)=v(1,i)
132 ELSEIF(k==5)THEN
133 wa(ijk)=v(2,i)
134 ELSEIF(k==6)THEN
135 wa(ijk)=v(3,i)
136 ELSEIF(k==7)THEN
137 wa(ijk)=a(1,i)
138 ELSEIF(k==8)THEN
139 wa(ijk)=a(2,i)
140 ELSEIF(k==9)THEN
141 wa(ijk)=a(3,i)
142 ELSEIF(k==10)THEN
143 wa(ijk)=vr(1,i)
144 ELSEIF(k==11)THEN
145 wa(ijk)=vr(2,i)
146 ELSEIF(k==12)THEN
147 wa(ijk)=vr(3,i)
148 ELSEIF(k==13)THEN
149 wa(ijk)=ar(1,i)
150 ELSEIF(k==14)THEN
151 wa(ijk)=ar(2,i)
152 ELSEIF(k==15)THEN
153 wa(ijk)=ar(3,i)
154 ELSEIF(k==16)THEN
155 wa(ijk)=x(1,i)
156 ELSEIF(k==17)THEN
157 wa(ijk)=x(2,i)
158 ELSEIF(k==18)THEN
159 wa(ijk)=x(3,i)
160 ELSEIF(k==19)THEN
161C workaround for possible PGI bug
162 call sync_data(i)
163 IF (itherm_fe /= 0) THEN
164 wa(ijk) = temp(i)
165 ELSE
166 wa(ijk) = zero
167 ENDIF
168 ELSEIF(k > 19 .AND. k <= 619) THEN
169 IF(iplyxfem > 0) THEN
170 idir = mod((k - 19),3)
171 IF(idir == 0) idir = 3
172 iply = (k - 19)/3
173 IF(mod((k - 19),3) /= 0) iply = iply + 1
174 wa(ijk) = ply(iply)%U(idir,inod(i))
175 ENDIF
176 ELSEIF(k == 620) THEN
177 IF (nodreac(i) /= 0) THEN
178 wa(ijk) = fthreac(1,nodreac(i))
179 ELSE
180 wa(ijk) = zero
181 ENDIF
182 ELSEIF(k == 621) THEN
183 IF (nodreac(i) /= 0) THEN
184 wa(ijk) = fthreac(2,nodreac(i))
185 ELSE
186 wa(ijk) = zero
187 ENDIF
188 ELSEIF(k == 622) THEN
189 IF (nodreac(i) /= 0) THEN
190 wa(ijk) = fthreac(3,nodreac(i))
191 ELSE
192 wa(ijk) = zero
193 ENDIF
194 ELSEIF(k == 623) THEN
195 IF (nodreac(i) /= 0) THEN
196 wa(ijk) = fthreac(4,nodreac(i))
197 ELSE
198 wa(ijk) = zero
199 ENDIF
200 ELSEIF(k == 624) THEN
201 IF (nodreac(i) /= 0) THEN
202 wa(ijk) = fthreac(5,nodreac(i))
203 ELSE
204 wa(ijk) = zero
205 ENDIF
206 ELSEIF(k == 625) THEN
207 IF (nodreac(i) /= 0) THEN
208 wa(ijk) = fthreac(6,nodreac(i))
209 ELSE
210 wa(ijk) = zero
211 ENDIF
212 ELSEIF(k == 626) THEN
213 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
214 wa(ijk) = dr(1,i)
215 ELSE
216 wa(ijk) = zero
217 ENDIF
218 ELSEIF(k == 627) THEN
219 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
220 wa(ijk) = dr(2,i)
221 ELSE
222 wa(ijk) = zero
223 ENDIF
224 ELSEIF(k == 628) THEN
225 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
226 wa(ijk) = dr(3,i)
227 ELSE
228 wa(ijk) = zero
229 ENDIF
230 ELSEIF(k == 629) THEN
231 wa(ijk) = zero
232 IF(th_has_noda_pext == 1)THEN
233 IF(output%DATA%NODA_SURF(i) > zero)THEN
234 wa(ijk) = output%DATA%NODA_PEXT(i) / output%DATA%NODA_SURF(i)
235 ENDIF
236 ENDIF
237C start of pinching information
238 ELSEIF(k == 630) THEN
239 IF (npinch > 0 )THEN
240 wa(ijk) = pinch_data%APINCH(1,i)
241 ELSE
242 wa(ijk) = zero
243 ENDIF
244 ELSEIF(k == 631) THEN
245 IF (npinch > 0 )THEN
246 wa(ijk) = pinch_data%APINCH(2,i)
247 ELSE
248 wa(ijk) = zero
249 ENDIF
250 ELSEIF(k == 632) THEN
251 IF (npinch > 0 )THEN
252 wa(ijk) = pinch_data%APINCH(3,i)
253 ELSE
254 wa(ijk) = zero
255 ENDIF
256 ELSEIF(k == 633) THEN
257 IF (npinch > 0 )THEN
258 wa(ijk) = pinch_data%VPINCH(1,i)
259 ELSE
260 wa(ijk) = zero
261 ENDIF
262 ELSEIF(k == 634) THEN
263 IF (npinch > 0 )THEN
264 wa(ijk) = pinch_data%VPINCH(2,i)
265 ELSE
266 wa(ijk) = zero
267 ENDIF
268 ELSEIF(k == 635) THEN
269 IF (npinch > 0 )THEN
270 wa(ijk) = pinch_data%VPINCH(3,i)
271 ELSE
272 wa(ijk) = zero
273 ENDIF
274 ELSEIF(k == 636) THEN
275 IF (npinch > 0 )THEN
276 wa(ijk) = pinch_data%DPINCH(1,i)
277 ELSE
278 wa(ijk) = zero
279 ENDIF
280 ELSEIF(k == 637) THEN
281 IF (npinch > 0 )THEN
282 wa(ijk) = pinch_data%DPINCH(2,i)
283 ELSE
284 wa(ijk) = zero
285 ENDIF
286 ELSEIF(k == 638) THEN
287 IF (npinch > 0 )THEN
288 wa(ijk) = pinch_data%DPINCH(3,i)
289 ELSE
290 wa(ijk) = zero
291 ENDIF
292C end of pinching information
293 ENDIF ! K==...
294 ENDDO ! L=IADV,IADV+NVAR-1
295 ijk=ijk+1
296 wa(ijk) = ii_save
297 ELSEIF(isk<=numskw+1+nsubmod)THEN
298! output with respect to a (non global) SKEW.
299 ii_save = ii
300 DO l=iadv,iadv+nvar-1
301 k=ithbuf(l)
302 ii=ii+1
303 ijk=ijk+1
304 IF(k==1)THEN
305 wa(ijk) = d(1,i)*skew(1,isk) + d(2,i)*skew(2,isk) + d(3,i)*skew(3,isk)
306 ELSEIF(k==2)THEN
307 wa(ijk) = d(1,i)*skew(4,isk) + d(2,i)*skew(5,isk) + d(3,i)*skew(6,isk)
308 ELSEIF(k==3)THEN
309 wa(ijk) = d(1,i)*skew(7,isk) + d(2,i)*skew(8,isk) + d(3,i)*skew(9,isk)
310 ELSEIF(k==4)THEN
311 wa(ijk) = v(1,i)*skew(1,isk) + v(2,i)*skew(2,isk) + v(3,i)*skew(3,isk)
312 ELSEIF(k==5)THEN
313 wa(ijk) = v(1,i)*skew(4,isk) + v(2,i)*skew(5,isk) + v(3,i)*skew(6,isk)
314 ELSEIF(k==6)THEN
315 wa(ijk) = v(1,i)*skew(7,isk) + v(2,i)*skew(8,isk) + v(3,i)*skew(9,isk)
316 ELSEIF(k==7)THEN
317 wa(ijk) = a(1,i)*skew(1,isk) + a(2,i)*skew(2,isk) + a(3,i)*skew(3,isk)
318 ELSEIF(k==8)THEN
319 wa(ijk) = a(1,i)*skew(4,isk) + a(2,i)*skew(5,isk) + a(3,i)*skew(6,isk)
320 ELSEIF(k==9)THEN
321 wa(ijk) = a(1,i)*skew(7,isk) + a(2,i)*skew(8,isk) + a(3,i)*skew(9,isk)
322 ELSEIF(k==10)THEN
323 wa(ijk) = vr(1,i)*skew(1,isk) + vr(2,i)*skew(2,isk) + vr(3,i)*skew(3,isk)
324 ELSEIF(k==11)THEN
325 wa(ijk) = vr(1,i)*skew(4,isk) + vr(2,i)*skew(5,isk) + vr(3,i)*skew(6,isk)
326 ELSEIF(k==12)THEN
327 wa(ijk) = vr(1,i)*skew(7,isk) + vr(2,i)*skew(8,isk) + vr(3,i)*skew(9,isk)
328 ELSEIF(k==13)THEN
329 wa(ijk) = ar(1,i)*skew(1,isk) + ar(2,i)*skew(2,isk) + ar(3,i)*skew(3,isk)
330 ELSEIF(k==14)THEN
331 wa(ijk) = ar(1,i)*skew(4,isk) + ar(2,i)*skew(5,isk) + ar(3,i)*skew(6,isk)
332 ELSEIF(k==15)THEN
333 wa(ijk) = ar(1,i)*skew(7,isk) + ar(2,i)*skew(8,isk) + ar(3,i)*skew(9,isk)
334 ELSEIF(k==16)THEN
335 wa(ijk) = x(1,i)*skew(1,isk) + x(2,i)*skew(2,isk) + x(3,i)*skew(3,isk)
336 ELSEIF(k==17)THEN
337 wa(ijk) = x(1,i)*skew(4,isk) + x(2,i)*skew(5,isk) + x(3,i)*skew(6,isk)
338 ELSEIF(k==18)THEN
339 wa(ijk) = x(1,i)*skew(7,isk) + x(2,i)*skew(8,isk) + x(3,i)*skew(9,isk)
340 ELSEIF(k==19)THEN
341C workaround for possible PGI bug
342 call sync_data(i)
343 ELSEIF(k == 620) THEN
344 IF (nodreac(i) /= 0) THEN
345 wa(ijk) = fthreac(1,nodreac(i))*skew(1,isk)
346 . + fthreac(2,nodreac(i))*skew(2,isk)
347 . + fthreac(3,nodreac(i))*skew(3,isk)
348 ELSE
349 wa(ijk) = zero
350 ENDIF
351 ELSEIF(k == 621) THEN
352 IF (nodreac(i) /= 0) THEN
353 wa(ijk) = fthreac(1,nodreac(i))*skew(4,isk)
354 . + fthreac(2,nodreac(i))*skew(5,isk)
355 . + fthreac(3,nodreac(i))*skew(6,isk)
356 ELSE
357 wa(ijk) = zero
358 ENDIF
359 ELSEIF(k == 622) THEN
360 IF (nodreac(i) /= 0) THEN
361 wa(ijk) = fthreac(1,nodreac(i))*skew(7,isk)
362 . + fthreac(2,nodreac(i))*skew(8,isk)
363 . + fthreac(3,nodreac(i))*skew(9,isk)
364 ELSE
365 wa(ijk) = zero
366 ENDIF
367 ELSEIF(k == 623) THEN
368 IF (nodreac(i) /= 0) THEN
369 wa(ijk) = fthreac(4,nodreac(i))*skew(1,isk)
370 . + fthreac(5,nodreac(i))*skew(2,isk)
371 . + fthreac(6,nodreac(i))*skew(3,isk)
372 ELSE
373 wa(ijk) = zero
374 ENDIF
375 ELSEIF(k == 624) THEN
376 IF (nodreac(i) /= 0) THEN
377 wa(ijk) = fthreac(4,nodreac(i))*skew(4,isk)
378 . + fthreac(5,nodreac(i))*skew(5,isk)
379 . + fthreac(6,nodreac(i))*skew(6,isk)
380 ELSE
381 wa(ijk) = zero
382 ENDIF
383 ELSEIF(k == 625) THEN
384 IF (nodreac(i) /= 0) THEN
385 wa(ijk) = fthreac(4,nodreac(i))*skew(7,isk)
386 . + fthreac(5,nodreac(i))*skew(8,isk)
387 . + fthreac(6,nodreac(i))*skew(9,isk)
388 ELSE
389 wa(ijk) = zero
390 ENDIF
391 ELSEIF(k == 626) THEN
392 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
393 wa(ijk) = dr(1,i)*skew(1,isk) + dr(2,i)*skew(2,isk) + dr(3,i)*skew(3,isk)
394 ELSE
395 wa(ijk) = zero
396 ENDIF
397 ELSEIF(k == 627) THEN
398 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
399 wa(ijk) = dr(1,i)*skew(4,isk) + dr(2,i)*skew(5,isk) + dr(3,i)*skew(6,isk)
400 ELSE
401 wa(ijk) = zero
402 ENDIF
403 ELSEIF(k == 628) THEN
404 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
405 wa(ijk) = dr(1,i)*skew(7,isk) + dr(2,i)*skew(8,isk) + dr(3,i)*skew(9,isk)
406 ELSE
407 wa(ijk) = zero
408 ENDIF
409 ELSEIF(k == 629) THEN
410 wa(ijk) = zero
411 IF(th_has_noda_pext == 1)THEN
412 IF(output%DATA%NODA_SURF(i) > zero)THEN
413 wa(ijk) = output%DATA%NODA_PEXT(i) / output%DATA%NODA_SURF(i)
414 ENDIF
415 ENDIF
416C start of pinching information
417 ELSEIF(k == 630) THEN
418 IF (npinch > 0 )THEN
419 wa(ijk) = pinch_data%APINCH(1,i)*skew(1,isk) +pinch_data%APINCH(2,i)*skew(2,isk)
420 . +pinch_data%APINCH(3,i)*skew(3,isk)
421 ELSE
422 wa(ijk) = zero
423 ENDIF
424 ELSEIF(k == 631) THEN
425 IF (npinch > 0 )THEN
426 wa(ijk) = pinch_data%APINCH(1,i)*skew(4,isk) +pinch_data%APINCH(2,i)*skew(5,isk)
427 . +pinch_data%APINCH(3,i)*skew(6,isk)
428 ELSE
429 wa(ijk) = zero
430 ENDIF
431 ELSEIF(k == 632) THEN
432 IF (npinch > 0 )THEN
433 wa(ijk) = pinch_data%APINCH(1,i)*skew(7,isk) +pinch_data%APINCH(2,i)*skew(8,isk)
434 . +pinch_data%APINCH(3,i)*skew(9,isk)
435 ELSE
436 wa(ijk) = zero
437 ENDIF
438 ELSEIF(k == 633) THEN
439 IF (npinch > 0 )THEN
440 wa(ijk) = pinch_data%VPINCH(1,i)*skew(1,isk) +pinch_data%VPINCH(2,i)*skew(2,isk)
441 . +pinch_data%VPINCH(3,i)*skew(3,isk)
442 ELSE
443 wa(ijk) = zero
444 ENDIF
445 ELSEIF(k == 634) THEN
446 IF (npinch > 0 )THEN
447 wa(ijk) = pinch_data%VPINCH(1,i)*skew(4,isk) +pinch_data%VPINCH(2,i)*skew(5,isk)
448 . +pinch_data%VPINCH(3,i)*skew(6,isk)
449 ELSE
450 wa(ijk) = zero
451 ENDIF
452 ELSEIF(k == 635) THEN
453 IF (npinch > 0 )THEN
454 wa(ijk) = pinch_data%VPINCH(1,i)*skew(7,isk) +pinch_data%VPINCH(2,i)*skew(8,isk)
455 . +pinch_data%VPINCH(3,i)*skew(9,isk)
456 ELSE
457 wa(ijk) = zero
458 ENDIF
459 ELSEIF(k == 636) THEN
460 IF (npinch > 0 )THEN
461 wa(ijk) = pinch_data%DPINCH(1,i)*skew(1,isk) +pinch_data%DPINCH(2,i)*skew(2,isk)
462 . +pinch_data%DPINCH(3,i)*skew(3,isk)
463 ELSE
464 wa(ijk) = zero
465 ENDIF
466 ELSEIF(k == 637) THEN
467 IF (npinch > 0 )THEN
468 wa(ijk) = pinch_data%DPINCH(1,i)*skew(4,isk) +pinch_data%DPINCH(2,i)*skew(5,isk)
469 . +pinch_data%DPINCH(3,i)*skew(6,isk)
470 ELSE
471 wa(ijk) = zero
472 ENDIF
473 ELSEIF(k == 638) THEN
474 IF (npinch > 0 )THEN
475 wa(ijk) = pinch_data%DPINCH(1,i)*skew(7,isk) +pinch_data%DPINCH(2,i)*skew(8,isk)
476 . +pinch_data%DPINCH(3,i)*skew(9,isk)
477 ELSE
478 wa(ijk) = zero
479 ENDIF
480C end of pinching information
481 ENDIF
482 ENDDO
483 ijk=ijk+1
484 wa(ijk) = ii_save
485 ELSE ! ISK==
486C---------
487C output with respect to a REFERENCE FRAME.
488 ifra=isk-(numskw+1+nsubmod)-min(iun,nspcond)*numsph
489 CALL relfram(
490 1 x(1,i) ,d(1,i) ,v(1,i) ,a(1,i) ,vr(1,i) ,
491 2 ar(1,i) ,xframe(1,ifra),xframe(10,ifra),
492 . xframe(34,ifra) ,xframe(31,ifra) ,
493 3 xframe(28,ifra) ,xl ,dl ,vl ,al ,
494 4 vrl ,arl )
495 ii_save = ii
496 DO l=iadv,iadv+nvar-1
497 k=ithbuf(l)
498 ii=ii+1
499 ijk=ijk+1
500 IF (k==1)THEN
501 wa(ijk)=dl(1)
502 ELSEIF(k==2)THEN
503 wa(ijk)=dl(2)
504 ELSEIF(k==3)THEN
505 wa(ijk)=dl(3)
506 ELSEIF(k==4)THEN
507 wa(ijk)=vl(1)
508 ELSEIF(k==5)THEN
509 wa(ijk)=vl(2)
510 ELSEIF(k==6)THEN
511 wa(ijk)=vl(3)
512 ELSEIF(k==7)THEN
513 wa(ijk)=al(1)
514 ELSEIF(k==8)THEN
515 wa(ijk)=al(2)
516 ELSEIF(k==9)THEN
517 wa(ijk)=al(3)
518 ELSEIF(k==10)THEN
519 wa(ijk)=vrl(1)
520 ELSEIF(k==11)THEN
521 wa(ijk)=vrl(2)
522 ELSEIF(k==12)THEN
523 wa(ijk)=vrl(3)
524 ELSEIF(k==13)THEN
525 wa(ijk)=arl(1)
526 ELSEIF(k==14)THEN
527 wa(ijk)=arl(2)
528 ELSEIF(k==15)THEN
529 wa(ijk)=arl(3)
530 ELSEIF(k==16)THEN
531 wa(ijk)=xl(1)
532 ELSEIF(k==17)THEN
533 wa(ijk)=xl(2)
534 ELSEIF(k==18)THEN
535 wa(ijk)=xl(3)
536 ELSEIF(k==19)THEN
537C workaround for possible PGI bug
538 call sync_data(i)
539 IF (itherm_fe /= 0) THEN
540 wa(ijk) = temp(i)
541 ELSE
542 wa(ijk) = zero
543 ENDIF
544 ENDIF
545 ENDDO
546 ijk=ijk+1
547 wa(ijk) = ii_save
548 ENDIF ! ISK==
549 ENDDO ! J=IAD,IAD+NN-1
550 ELSE ! IRODDL/=0
551 vrg(1)=zero
552 vrg(2)=zero
553 vrg(3)=zero
554 arg(1)=zero
555 arg(2)=zero
556 arg(3)=zero
557C
558 ii=0
559 DO j=iad,iad+nn-1
560 i=ithbuf(j)
561 isk = 1 + ithbuf(j+nn)
562 condition = (i <= 0)
563 IF(.NOT. condition) condition = (weight(i) == 0)
564 IF (condition) THEN
565 DO l=iadv,iadv+nvar-1
566 ii=ii+1
567 ENDDO
568 ELSEIF(isk==1)THEN
569C output with respect to the global SKEW.
570 ii_save = ii
571 DO l=iadv,iadv+nvar-1
572 k=ithbuf(l)
573 ii=ii+1
574 ijk=ijk+1
575 IF (k==1)THEN
576 wa(ijk)=d(1,i)
577 ELSEIF(k==2)THEN
578 wa(ijk)=d(2,i)
579 ELSEIF(k==3)THEN
580 wa(ijk)=d(3,i)
581 ELSEIF(k==4)THEN
582 wa(ijk)=v(1,i)
583 ELSEIF(k==5)THEN
584 wa(ijk)=v(2,i)
585 ELSEIF(k==6)THEN
586 wa(ijk)=v(3,i)
587 ELSEIF(k==7)THEN
588 wa(ijk)=a(1,i)
589 ELSEIF(k==8)THEN
590 wa(ijk)=a(2,i)
591 ELSEIF(k==9)THEN
592 wa(ijk)=a(3,i)
593 ELSEIF(k==16)THEN
594 wa(ijk)=x(1,i)
595 ELSEIF(k==17)THEN
596 wa(ijk)=x(2,i)
597 ELSEIF(k==18)THEN
598 wa(ijk)=x(3,i)
599 ELSEIF(k==19)THEN
600C workaround for possible PGI bug
601 call sync_data(i)
602 IF (itherm_fe /= 0) THEN
603 wa(ijk) = temp(i)
604 ELSE
605 wa(ijk) = zero
606 ENDIF
607 ELSEIF(k == 620) THEN
608 IF (nodreac(i) /= 0) THEN
609 wa(ijk) = fthreac(1,nodreac(i))
610 ELSE
611 wa(ijk) = zero
612 ENDIF
613 ELSEIF(k == 621) THEN
614 IF (nodreac(i) /= 0) THEN
615 wa(ijk) = fthreac(2,nodreac(i))
616 ELSE
617 wa(ijk) = zero
618 ENDIF
619 ELSEIF(k == 622) THEN
620 IF (nodreac(i) /= 0) THEN
621 wa(ijk) = fthreac(3,nodreac(i))
622 ELSE
623 wa(ijk) = zero
624 ENDIF
625 ELSEIF(k == 623) THEN
626 IF (nodreac(i) /= 0) THEN
627 wa(ijk) = fthreac(4,nodreac(i))
628 ELSE
629 wa(ijk) = zero
630 ENDIF
631 ELSEIF(k == 624) THEN
632 IF (nodreac(i) /= 0) THEN
633 wa(ijk) = fthreac(5,nodreac(i))
634 ELSE
635 wa(ijk) = zero
636 ENDIF
637 ELSEIF(k == 625) THEN
638 IF (nodreac(i) /= 0) THEN
639 wa(ijk) = fthreac(6,nodreac(i))
640 ELSE
641 wa(ijk) = zero
642 ENDIF
643 ELSEIF(k == 626) THEN
644 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND.iroddl/=0 )THEN
645 wa(ijk) = dr(1,i)
646 ELSE
647 wa(ijk) = zero
648 ENDIF
649 ELSEIF(k == 627) THEN
650 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
651 wa(ijk) = dr(2,i)
652 ELSE
653 wa(ijk) = zero
654 ENDIF
655 ELSEIF(k == 628) THEN
656 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
657 wa(ijk) = dr(3,i)
658 ELSE
659 wa(ijk) = zero
660 ENDIF
661 ELSEIF(k == 629) THEN
662 wa(ijk) = zero
663 IF(th_has_noda_pext == 1)THEN
664 IF(output%DATA%NODA_SURF(i) > zero)THEN
665 wa(ijk) = output%DATA%NODA_PEXT(i) / output%DATA%NODA_SURF(i)
666 ENDIF
667 ENDIF
668 ELSE
669 wa(ijk)=zero
670 ENDIF
671 ENDDO ! L=IADV,IADV+NVAR-1
672 ijk=ijk+1
673 wa(ijk) = ii_save
674 ELSEIF(isk<=numskw+1+nsubmod)THEN
675C---------
676C output with respect to a (non global) SKEW.
677 ii_save=ii
678 DO l=iadv,iadv+nvar-1
679 k=ithbuf(l)
680 ii=ii+1
681 ijk=ijk+1
682 IF(k==1)THEN
683 wa(ijk) = d(1,i)*skew(1,isk) + d(2,i)*skew(2,isk) + d(3,i)*skew(3,isk)
684 ELSEIF(k==2)THEN
685 wa(ijk) = d(1,i)*skew(4,isk) + d(2,i)*skew(5,isk) + d(3,i)*skew(6,isk)
686 ELSEIF(k==3)THEN
687 wa(ijk) = d(1,i)*skew(7,isk) + d(2,i)*skew(8,isk) + d(3,i)*skew(9,isk)
688 ELSEIF(k==4)THEN
689 wa(ijk) = v(1,i)*skew(1,isk) + v(2,i)*skew(2,isk) + v(3,i)*skew(3,isk)
690 ELSEIF(k==5)THEN
691 wa(ijk) = v(1,i)*skew(4,isk) + v(2,i)*skew(5,isk) + v(3,i)*skew(6,isk)
692 ELSEIF(k==6)THEN
693 wa(ijk) = v(1,i)*skew(7,isk) + v(2,i)*skew(8,isk) + v(3,i)*skew(9,isk)
694 ELSEIF(k==7)THEN
695 wa(ijk) = a(1,i)*skew(1,isk) + a(2,i)*skew(2,isk) + a(3,i)*skew(3,isk)
696 ELSEIF(k==8)THEN
697 wa(ijk) = a(1,i)*skew(4,isk) + a(2,i)*skew(5,isk) + a(3,i)*skew(6,isk)
698 ELSEIF(k==9)THEN
699 wa(ijk) = a(1,i)*skew(7,isk) + a(2,i)*skew(8,isk) + a(3,i)*skew(9,isk)
700 ELSEIF(k==16)THEN
701 wa(ijk) = x(1,i)*skew(1,isk) + x(2,i)*skew(2,isk) + x(3,i)*skew(3,isk)
702 ELSEIF(k==17)THEN
703 wa(ijk) = x(1,i)*skew(4,isk) + x(2,i)*skew(5,isk) + x(3,i)*skew(6,isk)
704 ELSEIF(k==18)THEN
705 wa(ijk) = x(1,i)*skew(7,isk) + x(2,i)*skew(8,isk) + x(3,i)*skew(9,isk)
706 ELSEIF(k==19)THEN
707C workaround for possible PGI bug
708 call sync_data(i)
709 IF (itherm_fe /= 0) THEN
710 wa(ijk) = temp(i)
711 ELSE
712 wa(ijk) = zero
713 ENDIF
714 ELSEIF(k == 620) THEN
715 IF (nodreac(i) /= 0) THEN
716 wa(ijk) = fthreac(1,nodreac(i))*skew(1,isk) + fthreac(2,nodreac(i))*skew(2,isk)
717 . + fthreac(3,nodreac(i))*skew(3,isk)
718 ELSE
719 wa(ijk) = zero
720 ENDIF
721 ELSEIF(k == 621) THEN
722 IF (nodreac(i) /= 0) THEN
723 wa(ijk) = fthreac(1,nodreac(i))*skew(4,isk) + fthreac(2,nodreac(i))*skew(5,isk)
724 . + fthreac(3,nodreac(i))*skew(6,isk)
725 ELSE
726 wa(ijk) = zero
727 ENDIF
728 ELSEIF(k == 622) THEN
729 IF (nodreac(i) /= 0) THEN
730 wa(ijk) = fthreac(1,nodreac(i))*skew(7,isk) + fthreac(2,nodreac(i))*skew(8,isk)
731 . + fthreac(3,nodreac(i))*skew(9,isk)
732 ELSE
733 wa(ijk) = zero
734 ENDIF
735 ELSEIF(k == 623) THEN
736 IF (nodreac(i) /= 0) THEN
737 wa(ijk) = fthreac(4,nodreac(i))*skew(1,isk) + fthreac(5,nodreac(i))*skew(2,isk)
738 . + fthreac(6,nodreac(i))*skew(3,isk)
739 ELSE
740 wa(ijk) = zero
741 ENDIF
742 ELSEIF(k == 624) THEN
743 IF (nodreac(i) /= 0) THEN
744 wa(ijk) = fthreac(4,nodreac(i))*skew(4,isk) + fthreac(5,nodreac(i))*skew(5,isk)
745 . + fthreac(6,nodreac(i))*skew(6,isk)
746 ELSE
747 wa(ijk) = zero
748 ENDIF
749 ELSEIF(k == 625) THEN
750 IF (nodreac(i) /= 0) THEN
751 wa(ijk) = fthreac(4,nodreac(i))*skew(7,isk) + fthreac(5,nodreac(i))*skew(8,isk)
752 . + fthreac(6,nodreac(i))*skew(9,isk)
753 ELSE
754 wa(ijk) = zero
755 ENDIF
756 ELSEIF(k == 626) THEN
757 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
758 wa(ijk) = dr(1,i)*skew(1,isk) + dr(2,i)*skew(2,isk) + dr(3,i)*skew(3,isk)
759 ELSE
760 wa(ijk) = zero
761 ENDIF
762 ELSEIF(k == 627) THEN
763 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND. iroddl/=0 )THEN
764 wa(ijk) = dr(1,i)*skew(4,isk) + dr(2,i)*skew(5,isk) + dr(3,i)*skew(6,isk)
765 ELSE
766 wa(ijk) = zero
767 ENDIF
768 ELSEIF(k == 628) THEN
769 IF ((idrot == 1 .OR. isecut>0 .OR. iisrot>0 .OR. impose_dr>0) .AND.iroddl/=0 )THEN
770 wa(ijk) = dr(1,i)*skew(7,isk) + dr(2,i)*skew(8,isk) + dr(3,i)*skew(9,isk)
771 ELSE
772 wa(ijk) = zero
773 ENDIF
774 ELSEIF(k == 629) THEN
775 wa(ijk) = zero
776 IF(th_has_noda_pext == 1)THEN
777 IF(output%DATA%NODA_SURF(i) > zero)THEN
778 wa(ijk) = output%DATA%NODA_PEXT(i) / output%DATA%NODA_SURF(i)
779 ENDIF
780 ENDIF
781 ELSE
782 wa(ijk)=zero
783 ENDIF
784 ENDDO
785 ijk=ijk+1
786 wa(ijk)=ii_save
787 ELSE
788C---------
789C output with respect to a REFERENCE FRAME.
790 ifra=isk-(numskw+1+nsubmod)-min(iun,nspcond)*numsph
791 CALL relfram(
792 1 x(1,i) ,d(1,i) ,v(1,i) ,a(1,i) ,vrg ,
793 2 arg , xframe(1,ifra),xframe(10,ifra),
794 . xframe(34,ifra) ,xframe(31,ifra) ,
795 3 xframe(28,ifra) ,xl ,dl ,vl ,al ,
796 4 vrl ,arl )
797 ii_save = ii
798 DO l=iadv,iadv+nvar-1
799 k=ithbuf(l)
800 ii=ii+1
801 ijk=ijk+1
802 IF (k==1)THEN
803 wa(ijk)=dl(1)
804 ELSEIF(k==2)THEN
805 wa(ijk)=dl(2)
806 ELSEIF(k==3)THEN
807 wa(ijk)=dl(3)
808 ELSEIF(k==4)THEN
809 wa(ijk)=vl(1)
810 ELSEIF(k==5)THEN
811 wa(ijk)=vl(2)
812 ELSEIF(k==6)THEN
813 wa(ijk)=vl(3)
814 ELSEIF(k==7)THEN
815 wa(ijk)=al(1)
816 ELSEIF(k==8)THEN
817 wa(ijk)=al(2)
818 ELSEIF(k==9)THEN
819 wa(ijk)=al(3)
820 ELSEIF(k==16)THEN
821 wa(ijk)=xl(1)
822 ELSEIF(k==17)THEN
823 wa(ijk)=xl(2)
824 ELSEIF(k==18)THEN
825 wa(ijk)=xl(3)
826 ELSEIF(k==19)THEN
827C workaround for possible PGI bug
828 call sync_data(i)
829 IF (itherm_fe /= 0) THEN
830 wa(ijk) = temp(i)
831 ELSE
832 wa(ijk) = zero
833 ENDIF
834 ELSE
835 wa(ijk)=zero
836 ENDIF
837 ENDDO
838 ijk=ijk+1
839 wa(ijk) = ii_save
840
841 ENDIF
842 ENDDO
843 ENDIF
844 ENDIF
845 ENDDO
846C-------------------------
847 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
sync_data
subroutine sync_data(ii)
Definition machine.F:383
min
#define min(a, b)
Definition macros.h:20
pinchtype_mod
Definition pinchtype_mod.F:69
pinchtype_mod::npinch
integer npinch
Definition pinchtype_mod.F:73
plyxfem_mod
Definition plyxfem_mod.F:31
plyxfem_mod::ply
type(ply_data), dimension(:), allocatable ply
Definition plyxfem_mod.F:92
th_mod
Definition th_mod.F:42
th_mod::th_has_noda_pext
integer th_has_noda_pext
Definition th_mod.F:121
nvar
integer function nvar(text)
Definition nvar.F:32
relfram
subroutine relfram(xg, dg, vg, ag, vrg, arg, xframe, xo, do, vo, ao, xl, dl, vl, al, vrl, arl)
Definition relfram.F:32