OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
c_tf_ne.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!|| c_tf_ne ../engine/source/output/sty/c_tf_ne.F
25!||--- called by ------------------------------------------------------
26!|| outp_c_tf ../engine/source/output/sty/outp_c_t.F
27!||--- calls -----------------------------------------------------
28!|| layini ../engine/source/elements/shell/coque/layini.F
29!||--- uses -----------------------------------------------------
30!|| drape_mod ../engine/share/modules/drape_mod.F
31!|| elbufdef_mod ../common_source/modules/mat_elem/elbufdef_mod.F90
32!|| stack_mod ../engine/share/modules/stack_mod.F
33!||====================================================================
34 SUBROUTINE c_tf_ne(ELBUF_STR,IHBE ,NEL ,NPT ,MLW ,
35 . ITY ,ISTRAIN ,JJ ,WA ,IW ,
36 . NLAY ,NPTR ,NPTS ,ITHK ,NFT ,
37 . THKE ,NPG ,IGTYP,GEO ,IGEO ,
38 . IXFEM ,ISUBSTACK,STACK,DRAPE_SH4N, DRAPE_SH3N,
39 . IXC ,IXTG ,MPT ,DRAPEG )
40C-----------------------------------------------
41C M o d u l e s
42C-----------------------------------------------
43 USE elbufdef_mod
44 USE stack_mod
45 USE drape_mod
46C-----------------------------------------------
47C I m p l i c i t T y p e s
48C-----------------------------------------------
49#include "implicit_f.inc"
50#include "mvsiz_p.inc"
51C-----------------------------------------------
52C C o m m o n B l o c k s
53C-----------------------------------------------
54#include "com04_c.inc"
55#include "param_c.inc"
56#include "units_c.inc"
57#include "scr16_c.inc"
58C
59C-----------------------------------------------
60C D u m m y A r g u m e n t s
61C-----------------------------------------------
62 INTEGER IHBE,NEL,NPT,JJ,MLW,ITY,ISTRAIN,IW,NLAY,
63 . NPTR,NPTS,ITHK,NFT,NPG,IGTYP,IGEO(NPROPGI,*),
64 . IXFEM,ISUBSTACK,IXC(NIXC,*),
65 . IXTG(NIXTG,*),MPT
66 my_real
67 . wa(*),thke(*),geo(npropg,*)
68 !
69 TYPE (ELBUF_STRUCT_), TARGET :: ELBUF_STR
70 TYPE (STACK_PLY) :: STACK
71 TYPE(drape_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
72 TYPE(DRAPEG_) :: DRAPEG
73C-----------------------------------------------
74C L o c a l V a r i a b l e s
75C-----------------------------------------------
76 INTEGER I,J,K,IPT,I1,I2,I3,I4,I5,II(12),
77 . ptf,ptm,ptep,pts,ng,ir,is,lenf,lenm,
78 . lens,mat_1,pid_1,laynpt_max,nlay_max,ixlay,ipt_all,
79 . jpos,it,nptt,ilay,shift,sedrape,numel_drape
80 INTEGER MAT(MVSIZ),PID(MVSIZ)
81 my_real
82 . func(6),qpg(2,4),pg,mpg,
83 . sig0(6,mvsiz),eps(mvsiz),mom0(3,mvsiz),
84 . sk(2,mvsiz),st(2,mvsiz),mk(2,mvsiz),mt(2,mvsiz),
85 . shk(2,mvsiz),sht(2,mvsiz),z01(11,11),zz
86 !
87 INTEGER, DIMENSION(:) , ALLOCATABLE :: MATLY
88 my_real, DIMENSION(:) , ALLOCATABLE :: THKLY
89 my_real, DIMENSION(:,:) , ALLOCATABLE :: POSLY,THK_LY
90 PARAMETER (PG = .577350269189626)
91 parameter (mpg=-.577350269189626)
92 DATA qpg/mpg,mpg,pg,mpg,pg,pg,mpg,pg/
93 DATA z01/
94 1 0. ,0. ,0. ,0. ,0. ,
95 1 0. ,0. ,0. ,0. ,0. ,0. ,
96 2 -.5 ,0.5 ,0. ,0. ,0. ,
97 2 0. ,0. ,0. ,0. ,0. ,0. ,
98 3 -.5 ,0. ,0.5 ,0. ,0. ,
99 3 0. ,0. ,0. ,0. ,0. ,0. ,
100 4 -.5 ,-.1666667,0.1666667,0.5 ,0. ,
101 4 0. ,0. ,0. ,0. ,0. ,0. ,
102 5 -.5 ,-.25 ,0. ,0.25 ,0.5 ,
103 5 0. ,0. ,0. ,0. ,0. ,0. ,
104 6 -.5 ,-.3 ,-.1 ,0.1 ,0.3 ,
105 6 0.5 ,0. ,0. ,0. ,0. ,0. ,
106 7 -.5 ,-.3333333,-.1666667,0.0 ,0.1666667,
107 7 0.3333333,0.5 ,0. ,0. ,0. ,0. ,
108 8 -.5 ,-.3571429,-.2142857,-.0714286,0.0714286,
109 8 0.2142857,0.3571429,0.5 ,0. ,0. ,0. ,
110 9 -.5 ,-.375 ,-.25 ,-.125 ,0.0 ,
111 9 0.125 ,0.25 ,0.375 ,0.5 ,0. ,0. ,
112 a -.5 ,-.3888889,-.2777778,-.1666667,0.0555555,
113 a 0.0555555,0.1666667,0.2777778,0.3888889,0.5 ,0. ,
114 b -.5 ,-.4 ,-.3 ,-.2 ,-.1 ,
115 b 0. ,0.1 ,0.2 ,0.3 ,0.4 ,0.5 /
116C
117 TYPE(buf_lay_) ,POINTER :: BUFLY
118 TYPE(G_BUFEL_) ,POINTER :: GBUF
119 TYPE(L_BUFEL_) ,POINTER :: LBUF
120C-----------------------------------------------
121 GBUF => elbuf_str%GBUF
122!
123 DO i=1,12 ! length max of GBUF%G_HOURG = 12
124 ii(i) = nel*(i-1)
125 ENDDO
126!
127 ! Npt_max
128 laynpt_max = 1
129 IF(igtyp == 51 .OR. igtyp == 52) THEN
130 DO ilay=1,nlay
131 laynpt_max = max(laynpt_max , elbuf_str%BUFLY(ilay)%NPTT)
132 ENDDO
133 ENDIF
134 nlay_max = max(nlay,npt, elbuf_str%NLAY)
135 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
136 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
137 matly = 0
138 thkly = zero
139 posly = zero
140 thk_ly = zero
141C
142 shift = 1+nft
143 IF (ity == 7) shift = shift + numelc
144C
145 IF (ity == 3) THEN
146 mat_1 = ixc(1,1+nft)
147 pid_1 = ixc(6,1+nft)
148 ELSEIF (ity == 7) THEN
149 mat_1 = ixtg(1,1+nft)
150 pid_1 = ixtg(5,1+nft)
151 ENDIF
152 DO i=1,nel
153 mat(i)= mat_1
154 pid(i)= pid_1
155 ENDDO
156C
157 ixlay = 0
158C
159 IF(ity == 7) THEN
160 numel_drape = numeltg_drape
161 sedrape = stdrape
162 CALL layini(
163 . elbuf_str,1 ,nel ,geo ,igeo ,
164 . mat ,pid ,thkly ,matly ,posly ,
165 . igtyp ,ixfem,ixlay ,nlay ,npt ,
166 . isubstack,stack,drape_sh3n ,nft ,thke ,
167 . nel ,thk_ly ,drapeg%INDX_SH3N ,sedrape,numel_drape )
168 ELSE
169 numel_drape = numelc_drape
170 sedrape = scdrape
171 CALL layini(
172 . elbuf_str,1 ,nel ,geo ,igeo ,
173 . mat ,pid ,thkly ,matly ,posly ,
174 . igtyp ,ixfem,ixlay ,nlay ,npt ,
175 . isubstack,stack,drape_sh4n ,nft ,thke ,
176 . nel ,thk_ly ,drapeg%INDX_SH4N,sedrape,numel_drape )
177 ENDIF
178C------------------------
179C STRESS
180C------------------------
181 IF (mlw == 1 .OR. mlw == 3 .OR. mlw == 23) mpt=0
182C
183 IF (ihbe == 23) THEN
184 npg = 4
185 DO i=1,nel
186 st(1,i)= gbuf%HOURG(ii(1)+i)
187 st(2,i)= -gbuf%HOURG(ii(2)+i)
188 mt(1,i)= gbuf%HOURG(ii(3)+i)
189 mt(2,i)= -gbuf%HOURG(ii(4)+i)
190 sk(1,i)= -gbuf%HOURG(ii(7)+i)
191 sk(2,i)= gbuf%HOURG(ii(8)+i)
192 mk(1,i)= -gbuf%HOURG(ii(9)+i)
193 mk(2,i)= gbuf%HOURG(ii(10)+i)
194 sht(1,i)= gbuf%HOURG(ii(5)+i)
195 sht(2,i)= -gbuf%HOURG(ii(6)+i)
196 shk(1,i)= -gbuf%HOURG(ii(11)+i)
197 shk(2,i)= gbuf%HOURG(ii(12)+i)
198 ENDDO
199 ENDIF
200C
201 IF (iw == 0) THEN
202C
203C------SMP-USE--------------
204C
205 IF (ihbe == 23) THEN ! QEPH
206 IF (mpt == 0) THEN
207 DO i=1,nel
208 sig0(1,i) = gbuf%FOR(ii(1)+i)
209 sig0(2,i) = gbuf%FOR(ii(2)+i)
210 sig0(3,i) = gbuf%FOR(ii(3)+i)
211 sig0(4,i) = gbuf%FOR(ii(4)+i)
212 sig0(5,i) = gbuf%FOR(ii(5)+i)
213 IF (gbuf%G_PLA > 0) THEN
214 eps(i) = gbuf%PLA(i)
215 ELSE
216 eps(i) = zero
217 ENDIF
218 mom0(1,i) = gbuf%MOM(ii(1)+i)
219 mom0(2,i) = gbuf%MOM(ii(2)+i)
220 mom0(3,i) = gbuf%MOM(ii(3)+i)
221 ENDDO
222c
223 DO i=1,nel
224 IF (outyy_fmt == 2) THEN
225 IF (ithk > 0) THEN
226 WRITE(iugeo,'(2I8/,1P3E12.5)')
227 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
228 ELSE
229 WRITE(iugeo,'(2I8/,1P3E12.5)')
230 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
231 ENDIF
232 ELSE
233 IF (ithk > 0) THEN
234 WRITE(iugeo,'(2I10/,1P3E20.13)')
235 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
236 ELSE
237 WRITE(iugeo,'(2I10/,1P3E20.13)')
238 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
239 ENDIF
240 ENDIF
241 DO k=1,npg
242 func(1)=sig0(1,i)+st(1,i)*qpg(2,k)+sk(1,i)*qpg(1,k)
243 func(2)=sig0(2,i)+st(2,i)*qpg(2,k)+sk(2,i)*qpg(1,k)
244 func(3)=sig0(3,i)
245 func(4)=sig0(4,i)+sht(2,i)*qpg(2,k)+shk(2,i)*qpg(1,k)
246 func(5)=sig0(5,i)+sht(1,i)*qpg(2,k)+shk(1,i)*qpg(1,k)
247 func(6)=eps(i)
248 IF (outyy_fmt == 2) THEN
249 WRITE(iugeo,'(1P6E12.5)')(func(j),j=1,6)
250 ELSE
251 WRITE(iugeo,'(1P6E20.13)')(func(j),j=1,6)
252 ENDIF
253 func(1)=mom0(1,i)+mt(1,i)*qpg(2,k)+mk(1,i)*qpg(1,k)
254 func(2)=mom0(2,i)+mt(2,i)*qpg(2,k)+mk(2,i)*qpg(1,k)
255 func(3)=mom0(3,i)
256 IF (outyy_fmt == 2) THEN
257 WRITE(iugeo,'(1P3E12.5)')(func(j),j=1,3)
258 ELSE
259 WRITE(iugeo,'(1P3E20.13)')(func(j),j=1,3)
260 ENDIF
261 ENDDO ! DO K=1,NPG
262 ENDDO ! DO I=1,NEL
263c---
264 ELSE ! qeph, mpt > 0
265c---
266 DO i=1,nel
267!! I5 = (I-1) * 2
268 IF (outyy_fmt == 2) THEN
269 IF (ithk > 0) THEN
270 WRITE(iugeo,'(2I8/,1P3E12.5)')
271 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
272 ELSE
273 WRITE(iugeo,'(2I8/,1P3E12.5)')
274 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
275 ENDIF
276 ELSE
277 IF (ithk > 0) THEN
278 WRITE(iugeo,'(2I10/,1P3E20.13)')
279 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
280 ELSE
281 WRITE(iugeo,'(2I10/,1P3E20.13)')
282 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
283 ENDIF
284 ENDIF
285C
286 IF (nlay == 1) THEN
287 bufly => elbuf_str%BUFLY(1)
288 nptt = bufly%NPTT ! MPT = NPTT
289 DO it = 1,nptt
290 lbuf => bufly%LBUF(1,1,it)
291 zz = gbuf%THK(i)*z01(it,nptt)
292 sig0(1,i) = lbuf%SIG(ii(1)+i)
293 sig0(2,i) = lbuf%SIG(ii(2)+i)
294 sig0(3,i) = lbuf%SIG(ii(3)+i)
295 sig0(4,i) = lbuf%SIG(ii(4)+i)
296 sig0(5,i) = lbuf%SIG(ii(5)+i)
297 DO k=1,npg
298 func(1)=sig0(1,i)+(st(1,i)+zz*mt(1,i))*qpg(2,k)+
299 . (sk(1,i)+zz*mk(1,i))*qpg(1,k)
300 func(2)=sig0(2,i)+(st(2,i)+zz*mt(2,i))*qpg(2,k)+
301 . (sk(2,i)+zz*mk(2,i))*qpg(1,k)
302 func(3)=sig0(3,i)
303 func(4)=sig0(4,i)+sht(2,i)*qpg(2,k)+shk(2,i)*qpg(1,k)
304 func(5)=sig0(5,i)+sht(1,i)*qpg(2,k)+shk(1,i)*qpg(1,k)
305 IF (bufly%L_PLA > 0) THEN
306 func(6)=lbuf%PLA(i)
307 ELSE
308 func(6)=zero
309 ENDIF
310 IF (outyy_fmt == 2) THEN
311 WRITE(iugeo,'(1P6E12.5)')(func(j),j=1,6)
312 ELSE
313 WRITE(iugeo,'(1P6E20.13)')(func(j),j=1,6)
314 ENDIF
315 ENDDO ! DO K=1,NPG
316 ENDDO ! DO IT = 1,NPTT
317 ELSEIF (nlay > 1) THEN
318 ipt_all = 0
319 DO ilay = 1,nlay
320 bufly => elbuf_str%BUFLY(ilay)
321 nptt = bufly%NPTT
322 DO it=1,nptt
323 ipt = ipt_all + it ! count all NPTT through all layers
324 zz = gbuf%THK(i)*posly(i,ipt)
325 lbuf => bufly%LBUF(1,1,it)
326 sig0(1,i) = lbuf%SIG(ii(1)+i)
327 sig0(2,i) = lbuf%SIG(ii(2)+i)
328 sig0(3,i) = lbuf%SIG(ii(3)+i)
329 sig0(4,i) = lbuf%SIG(ii(4)+i)
330 sig0(5,i) = lbuf%SIG(ii(5)+i)
331 DO k=1,npg
332 func(1)=sig0(1,i)+(st(1,i)+zz*mt(1,i))*qpg(2,k)+
333 . (sk(1,i)+zz*mk(1,i))*qpg(1,k)
334 func(2)=sig0(2,i)+(st(2,i)+zz*mt(2,i))*qpg(2,k)+
335 . (sk(2,i)+zz*mk(2,i))*qpg(1,k)
336 func(3)=sig0(3,i)
337 func(4)=sig0(4,i)+sht(2,i)*qpg(2,k)+shk(2,i)*qpg(1,k)
338 func(5)=sig0(5,i)+sht(1,i)*qpg(2,k)+shk(1,i)*qpg(1,k)
339C
340 IF (bufly%L_PLA > 0) THEN
341 func(6)=lbuf%PLA(i)
342 ELSE
343 func(6)=zero
344 ENDIF
345 IF (outyy_fmt == 2) THEN
346 WRITE(iugeo,'(1P6E12.5)')(func(j),j=1,6)
347 ELSE
348 WRITE(iugeo,'(1P6E20.13)')(func(j),j=1,6)
349 ENDIF
350 ENDDO ! DO K=1,NPG
351 ENDDO ! DO IT=1,NPTT
352 ipt_all = ipt_all + nptt
353 ENDDO ! DO ILAY = 1,NLAY
354 ENDIF ! IF (NLAY == 1)
355 ENDDO ! DO I=1,NEL
356 ENDIF ! IF (MPT == 0)
357c------
358 ELSEIF (ihbe == 11) THEN ! QBAT,DKT18
359c------
360 lenf = nel*gbuf%G_FORPG/npg
361 lenm = nel*gbuf%G_MOMPG/npg
362 lens = nel*gbuf%G_STRPG/npg
363 IF (mpt == 0) THEN
364 DO i=1,nel
365 IF (outyy_fmt == 2) THEN
366 IF (ithk > 0) THEN
367 WRITE(iugeo,'(2I8/,1P3E12.5)')
368 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
369 ELSE
370 WRITE(iugeo,'(2I8/,1P3E12.5)')
371 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
372 ENDIF
373 ELSE
374 IF (ithk > 0) THEN
375 WRITE(iugeo,'(2I10/,1P3E20.13)')
376 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
377 ELSE
378 WRITE(iugeo,'(2I10/,1P3E20.13)')
379 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
380 ENDIF
381 ENDIF
382C---
383 bufly => elbuf_str%BUFLY(1)
384 DO is=1,npts
385 DO ir=1,nptr
386 lbuf => elbuf_str%BUFLY(1)%LBUF(ir,is,1)
387 ng = nptr*(is-1) + ir
388 ptf = (ng-1)*lenf
389 ptm = (ng-1)*lenm
390 func(1) = gbuf%FORPG(ptf+ii(1)+i)
391 func(2) = gbuf%FORPG(ptf+ii(2)+i)
392 func(3) = gbuf%FORPG(ptf+ii(3)+i)
393 func(4) = gbuf%FORPG(ptf+ii(4)+i)
394 func(5) = gbuf%FORPG(ptf+ii(5)+i)
395 IF (bufly%L_PLA > 0) THEN
396 func(6) = lbuf%PLA(i)
397 ELSE
398 func(6) = zero
399 ENDIF
400 IF (outyy_fmt == 2) THEN
401 WRITE(iugeo,'(1P6E12.5)')(func(j),j=1,6)
402 ELSE
403 WRITE(iugeo,'(1P6E20.13)')(func(j),j=1,6)
404 ENDIF
405 func(1) = gbuf%MOMPG(ptm+ii(1)+i)
406 func(2) = gbuf%MOMPG(ptm+ii(2)+i)
407 func(3) = gbuf%MOMPG(ptm+ii(3)+i)
408 IF (outyy_fmt == 2) THEN
409 WRITE(iugeo,'(1P3E12.5)')(func(j),j=1,3)
410 ELSE
411 WRITE(iugeo,'(1P3E20.13)')(func(j),j=1,3)
412 ENDIF
413 ENDDO ! DO IR=1,NPTR
414 ENDDO ! DO IS=1,NPTS
415 ENDDO ! DO I=1,NEL
416c---
417 ELSE ! MPT > 0
418 DO i=1,nel
419!! I5 = (I-1) * 2
420 IF (outyy_fmt == 2) THEN
421 IF (ithk > 0) THEN
422 WRITE(iugeo,'(2I8/,1P3E12.5)')
423 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
424 ELSE
425 WRITE(iugeo,'(2I8/,1P3E12.5)')
426 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
427 ENDIF
428 ELSE
429 IF (ithk > 0) THEN
430 WRITE(iugeo,'(2I10/,1P3E20.13)')
431 . mpt,npg,gbuf%THK(i),gbuf%EINT(i),gbuf%EINT(i+nel)
432 ELSE
433 WRITE(iugeo,'(2I10/,1P3E20.13)')
434 . mpt,npg,thke(i+nft),gbuf%EINT(i),gbuf%EINT(i+nel)
435 ENDIF
436 ENDIF
437c---
438 IF (nlay == 1) THEN
439 bufly => elbuf_str%BUFLY(1)
440 nptt = bufly%NPTT ! MPT = NPTT
441 DO it = 1,nptt
442 DO is = 1,npts
443 DO ir = 1,nptr
444 lbuf => bufly%LBUF(ir,is,it)
445 func(1) = lbuf%SIG(ii(1)+i)
446 func(2) = lbuf%SIG(ii(2)+i)
447 func(3) = lbuf%SIG(ii(3)+i)
448 func(4) = lbuf%SIG(ii(4)+i)
449 func(5) = lbuf%SIG(ii(5)+i)
450 IF (bufly%L_PLA > 0) THEN
451 func(6)=lbuf%PLA(i)
452 ELSE
453 func(6)=zero
454 ENDIF
455 IF (outyy_fmt == 2) THEN
456 WRITE(iugeo,'(1P6E12.5)')(func(j),j=1,6)
457 ELSE
458 WRITE(iugeo,'(1P6E20.13)')(func(j),j=1,6)
459 ENDIF
460 ENDDO ! DO IR = 1,NPTR
461 ENDDO ! DO IS = 1,NPTS
462 ENDDO ! IT = 1,NPTT
463 ELSEIF (nlay > 1) THEN
464 DO ilay=1,nlay
465 bufly => elbuf_str%BUFLY(ilay)
466 nptt = bufly%NPTT
467 DO it = 1,nptt
468 DO is = 1,npts
469 DO ir = 1,nptr
470 lbuf => elbuf_str%BUFLY(ilay)%LBUF(ir,is,it)
471 func(1) = lbuf%SIG(ii(1)+i)
472 func(2) = lbuf%SIG(ii(2)+i)
473 func(3) = lbuf%SIG(ii(3)+i)
474 func(4) = lbuf%SIG(ii(4)+i)
475 func(5) = lbuf%SIG(ii(5)+i)
476 IF (bufly%L_PLA > 0) THEN
477 func(6) = lbuf%PLA(i)
478 ELSE
479 func(6)=zero
480 ENDIF
481 IF (outyy_fmt == 2) THEN
482 WRITE(iugeo,'(1P6E12.5)')(func(j),j=1,6)
483 ELSE
484 WRITE(iugeo,'(1P6E20.13)')(func(j),j=1,6)
485 ENDIF
486 ENDDO ! DO IR = 1,NPTR
487 ENDDO ! DO IS = 1,NPTS
488 ENDDO ! DO IT = 1,NPTT
489 ENDDO ! DO ILAY=1,NLAY
490 ENDIF ! IF (NLAY == 1)
491c---
492 ENDDO ! DO I=1,NEL
493 ENDIF ! IF (MPT == 0)
494 ELSE ! IF (IHBE == 23)
495C----error message------
496 ENDIF
497C
498C------SPMD-USE--------------
499C
500 ELSE ! IF (IW == 1)
501C---QEPH:------
502 IF (ihbe == 23) THEN
503C---Transfer to QBAT------
504 IF (mpt == 0) THEN
505 DO i=1,nel
506 sig0(1,i) = gbuf%FOR(ii(1)+i)
507 sig0(2,i) = gbuf%FOR(ii(2)+i)
508 sig0(3,i) = gbuf%FOR(ii(3)+i)
509 sig0(4,i) = gbuf%FOR(ii(4)+i)
510 sig0(5,i) = gbuf%FOR(ii(5)+i)
511 IF (gbuf%G_PLA > 0) THEN
512 eps(i) = gbuf%PLA(i)
513 ELSE
514 eps(i) = zero
515 ENDIF
516 mom0(1,i) = gbuf%MOM(ii(1)+i)
517 mom0(2,i) = gbuf%MOM(ii(2)+i)
518 mom0(3,i) = gbuf%MOM(ii(3)+i)
519 ENDDO
520C
521 DO i=1,nel
522 wa(jj+1) = ihbe
523 jj=jj+1
524 wa(jj+1) = mpt
525 wa(jj+2) = npg
526 IF (ithk > 0) THEN
527 wa(jj+3) = gbuf%THK(i)
528 ELSE
529 wa(jj+3) = thke(i+nft)
530 ENDIF
531 wa(jj+4) = gbuf%EINT(i)
532 wa(jj+5) = gbuf%EINT(i+nel)
533 jj = jj + 5
534 DO k=1,npg
535 wa(jj+1)=sig0(1,i)+st(1,i)*qpg(2,k)+sk(1,i)*qpg(1,k)
536 wa(jj+2)=sig0(2,i)+st(2,i)*qpg(2,k)+sk(2,i)*qpg(1,k)
537 wa(jj+3)=sig0(3,i)
538 wa(jj+4)=sig0(4,i)+sht(2,i)*qpg(2,k)+shk(2,i)*qpg(1,k)
539 wa(jj+5)=sig0(5,i)+sht(1,i)*qpg(2,k)+shk(1,i)*qpg(1,k)
540 wa(jj+6)=eps(i)
541 wa(jj+7)=mom0(1,i)+mt(1,i)*qpg(2,k)+mk(1,i)*qpg(1,k)
542 wa(jj+8)=mom0(2,i)+mt(2,i)*qpg(2,k)+mk(2,i)*qpg(1,k)
543 wa(jj+9)=mom0(3,i)
544 jj = jj + 9
545 ENDDO
546 ENDDO
547 ELSE ! IF (MPT /= 0)
548 DO i=1,nel
549!! I5 = (I-1) * 2
550 wa(jj+1) = ihbe
551 jj=jj+1
552 wa(jj+1) = mpt
553 wa(jj+2) = npg
554 IF (ithk > 0) THEN
555 wa(jj+3) = gbuf%THK(i)
556 ELSE
557 wa(jj+3) = thke(i+nft)
558 ENDIF
559 wa(jj+4) = gbuf%EINT(i)
560 wa(jj+5) = gbuf%EINT(i+nel)
561 jj = jj + 5
562C
563 IF (nlay == 1) THEN
564 bufly => elbuf_str%BUFLY(1)
565 nptt = bufly%NPTT ! MPT = NPTT
566 DO it=1,nptt
567 lbuf => bufly%LBUF(1,1,it)
568 zz = gbuf%THK(i)*z01(it,nptt)
569 sig0(1,i) = lbuf%SIG(ii(1)+i)
570 sig0(2,i) = lbuf%SIG(ii(2)+i)
571 sig0(3,i) = lbuf%SIG(ii(3)+i)
572 sig0(4,i) = lbuf%SIG(ii(4)+i)
573 sig0(5,i) = lbuf%SIG(ii(5)+i)
574C
575 DO k=1,npg
576 wa(jj+1)=sig0(1,i)+(st(1,i)+zz*mt(1,i))*qpg(2,k)+
577 . (sk(1,i)+zz*mk(1,i))*qpg(1,k)
578 wa(jj+2)=sig0(2,i)+(st(2,i)+zz*mt(2,i))*qpg(2,k)+
579 . (sk(2,i)+zz*mk(2,i))*qpg(1,k)
580 wa(jj+3)=sig0(3,i)
581 wa(jj+4)=sig0(4,i)+sht(2,i)*qpg(2,k)+shk(2,i)*qpg(1,k)
582 wa(jj+5)=sig0(5,i)+sht(1,i)*qpg(2,k)+shk(1,i)*qpg(1,k)
583C
584 IF (bufly%L_PLA > 0) THEN
585 wa(jj+6)=lbuf%PLA(i)
586 ELSE
587 wa(jj+6)=zero
588 ENDIF
589 jj = jj + 6
590 ENDDO ! DO K=1,NPG
591 ENDDO ! DO IT=1,NPTT
592 ELSEIF (nlay > 1) THEN
593 ipt_all = 0
594 DO ilay=1,nlay
595 bufly => elbuf_str%BUFLY(ilay)
596 nptt = bufly%NPTT
597 DO it=1,nptt
598 ipt = ipt_all + it ! count all NPTT through all layers
599 zz = gbuf%THK(i)*posly(i,ipt)
600 lbuf => bufly%LBUF(1,1,it)
601 sig0(1,i) = lbuf%SIG(ii(1)+i)
602 sig0(2,i) = lbuf%SIG(ii(2)+i)
603 sig0(3,i) = lbuf%SIG(ii(3)+i)
604 sig0(4,i) = lbuf%SIG(ii(4)+i)
605 sig0(5,i) = lbuf%SIG(ii(5)+i)
606 DO k=1,npg
607 wa(jj+1)=sig0(1,i)+(st(1,i)+zz*mt(1,i))*qpg(2,k)+
608 . (sk(1,i)+zz*mk(1,i))*qpg(1,k)
609 wa(jj+2)=sig0(2,i)+(st(2,i)+zz*mt(2,i))*qpg(2,k)+
610 . (sk(2,i)+zz*mk(2,i))*qpg(1,k)
611 wa(jj+3)=sig0(3,i)
612 wa(jj+4)=sig0(4,i)+sht(2,i)*qpg(2,k)+shk(2,i)*qpg(1,k)
613 wa(jj+5)=sig0(5,i)+sht(1,i)*qpg(2,k)+shk(1,i)*qpg(1,k)
614C
615 IF (bufly%L_PLA > 0) THEN
616 wa(jj+6)=lbuf%PLA(i)
617 ELSE
618 wa(jj+6)=zero
619 ENDIF
620 jj = jj + 6
621 ENDDO ! DO K=1,NPG
622 ENDDO ! DO IT=1,NPTT
623 ipt_all = ipt_all + nptt
624 ENDDO ! DO ILAY=1,NLAY
625 ENDIF ! IF (NLAY == 1)
626 ENDDO ! DO I=1,NEL
627 ENDIF ! IF (MPT == 0)
628 ELSEIF (ihbe == 11) THEN
629C-------QBAT,DKT18-----
630 lenf = nel*gbuf%G_FORPG/npg
631 lenm = nel*gbuf%G_MOMPG/npg
632 lens = nel*gbuf%G_STRPG/npg
633 IF (mpt == 0) THEN
634 DO i=1,nel
635 wa(jj+1) = ihbe
636 jj=jj+1
637 wa(jj+1) = mpt
638 wa(jj+2) = npg
639 IF (ithk > 0) THEN
640 wa(jj+3) = gbuf%THK(i)
641 ELSE
642 wa(jj+3) = thke(i+nft)
643 ENDIF
644 wa(jj+4) = gbuf%EINT(i)
645 wa(jj+5) = gbuf%EINT(i+nel)
646 jj = jj + 5
647C---
648 DO ir=1,nptr
649 DO is=1,npts
650 ng = nptr*(is-1) + ir
651 ptf = (ng-1)*lenf
652 ptm = (ng-1)*lenm
653 pts = (ng-1)*lens
654!! I3 = PTS + I
655 wa(jj+1) = gbuf%FORPG(ptf+ii(1)+i)
656 wa(jj+2) = gbuf%FORPG(ptf+ii(2)+i)
657 wa(jj+3) = gbuf%FORPG(ptf+ii(3)+i)
658 wa(jj+4) = gbuf%FORPG(ptf+ii(4)+i)
659 wa(jj+5) = gbuf%FORPG(ptf+ii(5)+i)
660 wa(jj+6) = gbuf%STRPG(pts+ii(1)+i)
661 wa(jj+7) = gbuf%MOMPG(ptm+ii(1)+i)
662 wa(jj+8) = gbuf%MOMPG(ptm+ii(2)+i)
663 wa(jj+9) = gbuf%MOMPG(ptm+ii(3)+i)
664 jj = jj + 9
665 ENDDO
666 ENDDO
667 ENDDO ! DO I=1,NEL
668c---
669 ELSE ! IF (MPT /= 0)
670 DO i=1,nel
671 wa(jj+1) = ihbe
672 jj=jj+1
673 wa(jj+1) = mpt
674 wa(jj+2) = npg
675 IF (ithk > 0) THEN
676 wa(jj+3) = gbuf%THK(i)
677 ELSE
678 wa(jj+3) = thke(i+nft)
679 ENDIF
680 wa(jj+4) = gbuf%EINT(i)
681 wa(jj+5) = gbuf%EINT(i+nel)
682 jj = jj + 5
683c---
684 IF (nlay == 1) THEN
685 bufly => elbuf_str%BUFLY(1)
686 nptt = bufly%NPTT ! MPT = NPTT
687 DO it = 1,nptt
688 DO is = 1,npts
689 DO ir = 1,nptr
690 lbuf => bufly%LBUF(ir,is,it)
691 wa(jj+1) = lbuf%SIG(ii(1)+i)
692 wa(jj+2) = lbuf%SIG(ii(2)+i)
693 wa(jj+3) = lbuf%SIG(ii(3)+i)
694 wa(jj+4) = lbuf%SIG(ii(4)+i)
695 wa(jj+5) = lbuf%SIG(ii(5)+i)
696 IF (bufly%L_PLA > 0) THEN
697 wa(jj+6) = lbuf%PLA(i)
698 ELSE
699 wa(jj+6)=zero
700 ENDIF
701 jj = jj + 6
702 ENDDO ! DO IR = 1,NPTR
703 ENDDO ! DO IR = 1,NPTR
704 ENDDO !IT = 1,NPTT
705 ELSEIF (nlay > 1) THEN
706 DO ilay=1,nlay
707 bufly => elbuf_str%BUFLY(ilay)
708 nptt = bufly%NPTT
709 DO it = 1,nptt
710 DO is = 1,npts
711 DO ir = 1,nptr
712 lbuf => elbuf_str%BUFLY(ilay)%LBUF(ir,is,it)
713 wa(jj+1) = lbuf%SIG(ii(1)+i)
714 wa(jj+2) = lbuf%SIG(ii(2)+i)
715 wa(jj+3) = lbuf%SIG(ii(3)+i)
716 wa(jj+4) = lbuf%SIG(ii(4)+i)
717 wa(jj+5) = lbuf%SIG(ii(5)+i)
718 IF (bufly%L_PLA > 0) THEN
719 wa(jj+6) = lbuf%PLA(i)
720 ELSE
721 wa(jj+6)=zero
722 ENDIF
723 jj = jj + 6
724 ENDDO ! DO IR = 1,NPTR
725 ENDDO ! DO is = 1,npts
726 ENDDO ! DO IT=1,NPTT
727 ENDDO ! DO ILAY=1,NLAY
728 ENDIF ! IF (NLAY == 1)
729c---
730 ENDDO ! DO I=1,NEL
731 ENDIF ! IF (MPT == 0)
732 ELSE
733C----error message------
734 ENDIF ! IF (IHBE == 23)
735 ENDIF ! IF (IW == 0)
736 DEALLOCATE(matly, thkly, posly, thk_ly)
737C-----------
738 RETURN
739 END
c_tf_ne
subroutine c_tf_ne(elbuf_str, ihbe, nel, npt, mlw, ity, istrain, jj, wa, iw, nlay, nptr, npts, ithk, nft, thke, npg, igtyp, geo, igeo, ixfem, isubstack, stack, drape_sh4n, drape_sh3n, ixc, ixtg, mpt, drapeg)
Definition c_tf_ne.F:40
layini
subroutine layini(elbuf_str, jft, jlt, geo, igeo, mat, pid, thkly, matly, posly, igtyp, ixfem, ixlay, nlay, npt, isubstack, stack, drape, nft, thk, nel, ratio_thkly, indx_drape, sedrape, numel_drape)
Definition layini.F:47
max
#define max(a, b)
Definition macros.h:21
drape_mod
Definition drape_mod.F:54
drape_mod::scdrape
integer scdrape
Definition drape_mod.F:92
drape_mod::stdrape
integer stdrape
Definition drape_mod.F:92
stack_mod
Definition stack_mod.F:72
drape_mod::drape_
Definition drape_mod.F:71