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