35
36
37
38 USE elbufdef_mod
39 use element_mod , only : nixs
40
41
42
43#include "implicit_f.inc"
44
45
46
47#include "vect01_c.inc"
48#include "mvsiz_p.inc"
49#include "com01_c.inc"
50#include "com04_c.inc"
51#include "param_c.inc"
52#include "scr17_c.inc"
53
54
55
56
58 . tens(6,*),pm(npropm,*),x(3,*)
59 INTEGER (NPARG,*),ITENS, ISPH3D,NBF,
60 . IXS(NIXS,*),EL2FA(*),IPM(NPROPMI,*),IPART(LIPART1,*),IPARTSP(*)
61 REAL WA(6*NBF)
62 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
63
64
66 . evar(6,mvsiz),off, fac, a1, a2, a3, thk, gama(6)
67 REAL R4(18)
68 INTEGER I, II,NG, NEL, IPT,MT1,NLAY,IL,
69 . N, J, MLW,IALEL,NN1,NN2,NN3,IPRT, KCVT,ISOLNOD,
70 . NPTR, NPTS, NPTT,NPTG, IS, IR, IT,
71 . JHBE, JIVF, JCLOSE, JPLASOL, , IGTYP,
72 . ICSEN, ISORTHG, IFAILURE, IINT,JJ(6)
73 TYPE(G_BUFEL_) ,POINTER :: GBUF
74 TYPE(L_BUFEL_) ,POINTER :: LBUF
75
76 DO j=1,18
77 r4(j) = zero
78 ENDDO
79 nn1 = 1
80 nn2 = 1
81 nn3 = nn2 + numels
82
83 DO 490 ng=1,ngroup
84 isolnod = iparg(28,ng)
86 2 mlw ,nel ,nft ,iad ,ity ,
87 3 npt ,jale ,ismstr ,jeul ,jtur ,
88 4 jthe ,jlag ,jmult ,jhbe ,jivf ,
89 5 jpor ,kcvt ,jclose ,jplasol ,
90 6 irep ,iint ,igtyp ,israt ,isrot ,
91 7 icsen ,isorth ,isorthg ,ifailure)
92 lft=1
93 llt=nel
94
95 DO j=1,6
96 jj(j) = (j-1)*nel
97 ENDDO
98
99
100
101
102 IF (ity == 1) THEN
103 gbuf => elbuf_tab(ng)%GBUF
104 nlay = elbuf_tab(ng)%NLAY
105 nptr = elbuf_tab(ng)%NPTR
106 npts = elbuf_tab(ng)%NPTS
107 nptt = elbuf_tab(ng)%NPTT
108 nptg = nptt*npts*nptr
109 npt = nptg*nlay
110 mt1 = ixs(1,1 + nft)
111 IF (kcvt==1 .AND. isorth/=0) kcvt=2
112
113 IF (itens == 1)THEN
114
115
116 DO i=lft,llt
117 n = i + nft
118 evar(1,i) = gbuf%SIG(jj(1) + i)
119 evar(2,i) = gbuf%SIG(jj(2) + i)
120 evar(3,i) = gbuf%SIG(jj(3) + i)
121 evar(4,i) = gbuf%SIG(jj(4) + i)
122 evar(5,i) = gbuf%SIG(jj(5) + i)
123 evar(6,i) = gbuf%SIG(jj(6) + i)
124 ENDDO
125 IF (kcvt/=0) THEN
126
127 DO i=lft,llt
128 n = i + nft
129 IF(el2fa(nn2+n)/=0)THEN
130
131 IF (kcvt==2.AND.jhbe/=14) THEN
132 gama(1)=gbuf%GAMA(jj(1) + i)
133 gama(2)=gbuf%GAMA(jj(2) + i)
134 gama(3)=gbuf%GAMA(jj(3) + i)
135 gama(4)=gbuf%GAMA(jj(4) + i)
136 gama(5)=gbuf%GAMA(jj(5) + i)
137 gama(6)=gbuf%GAMA(jj(6) + i)
138 ELSE
139 gama(1)=one
140 gama(2)=zero
141 gama(3)=zero
142 gama(4)=zero
143 gama(5)=one
144 gama(6)=zero
145 END IF
146 CALL srota6(x,ixs(1:nixs,n),kcvt,evar(1:6,i),gama)
147 ENDIF
148 ENDDO
149 ENDIF
150
151 ELSEIF(itens == 2)THEN
152
153
154 DO i=lft,llt
155 DO j=1,6
156 evar(j,i) = zero
157 ENDDO
158 ENDDO
159
160 IF (isolnod == 8.AND.npt == 8.AND.jhbe/=14.AND.
161 . jhbe/=24.AND.jhbe/=15 )THEN
162 IF (mlw >= 28) THEN
163 DO i=lft,llt
164 n = i + nft
165 DO j=1,8
166 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,j)
167 evar(1,i) = evar(1,i) + lbuf%STRA(jj(1)+i)*one_over_8
168 evar(2,i) = evar(2,i) + lbuf%STRA(jj(2)+i)*one_over_8
169 evar(3,i) = evar(3,i) + lbuf%STRA(jj(3)+i)*one_over_8
170 evar(4,i) = evar(4,i) + lbuf%STRA(jj(4)+i)*one_over_8
171 evar(5,i) = evar(5,i) + lbuf%STRA(jj(5)+i)*one_over_8
172 evar(6,i) = evar(6,i) + lbuf%STRA(jj(6)+i)*one_over_8
173 ENDDO
174 ENDDO
175 ENDIF
176
177 ELSEIF(isolnod == 8 .AND. npt == 1 .AND.
178 . jhbe/=14.AND.jhbe/=15.AND.jhbe/=24)THEN
179 IF (mlw>=28) THEN
180 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
181 DO i=lft,llt
182 n = i + nft
183 evar(1,i) = lbuf%STRA(jj(1)+i)*one_over_8
184 evar(2,i) = lbuf%STRA(jj(2)+i)*one_over_8
185 evar(3,i) = lbuf%STRA(jj(3)+i)*one_over_8
186 evar(4,i) = lbuf%STRA(jj(4)+i)*one_over_8
187 evar(5,i) = lbuf%STRA(jj(5)+i)*one_over_8
188 evar(6,i) = lbuf%STRA(jj(6)+i)*one_over_8
189 ENDDO
190 ELSEIF(mlw == 14)THEN
191 DO i=lft,llt
192 n = i + nft
193 evar(1,i) = evar(1,i) + lbuf%EPE(jj(1)+i)
194 evar(2,i) = evar(2,i) + lbuf%EPE(jj(2)+i)
195 evar(3,i) = evar(3,i) + lbuf%EPE(jj(3)+i)
196 ENDDO
197 ELSEIF(mlw == 24)THEN
198 DO i=lft,llt
199 n = i + nft
200 evar(1,i) = lbuf%STRA(jj(1)+i)
201 evar(2,i) = lbuf%STRA(jj(2)+i)
202 evar(3,i) = lbuf%STRA(jj(3)+i)
203 evar(4,i) = lbuf%STRA(jj(4)+i)*half
204 evar(5,i) = lbuf%STRA(jj(5)+i)*half
205 evar(6,i) = lbuf%STRA(jj(6)+i)*half
206 ENDDO
207 ENDIF
208
209 ELSEIF (isolnod == 16 .OR. isolnod == 20 .OR.
210 . (isolnod == 8 .AND. jhbe == 14)) THEN
211 IF (mlw>=28) THEN
212 DO i=lft,llt
213 DO il=1,nlay
214 DO is=1,npts
215 DO it=1,nptt
216 DO ir=1,nptr
217 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
218 evar(1,i) = evar(1,i) + lbuf%STRA(jj(1)+i)/nptg
219 evar(2,i) = evar(2,i) + lbuf%STRA(jj(2)+i)/nptg
220 evar(3,i) = evar(3,i) + lbuf%STRA(jj(3)+i)/nptg
221 evar(4,i) = evar(4,i) + lbuf%STRA(jj(4)+i)/nptg
222 evar(5,i) = evar(5,i) + lbuf%STRA(jj(5)+i)/nptg
223 evar(6,i) = evar(6,i) + lbuf%STRA(jj(6)+i)/nptg
224 ENDDO
225 ENDDO
226 ENDDO
227 ENDDO
228 ENDDO
229 ELSEIF (mlw == 14) THEN
230 DO i=lft,llt
231
232 DO il=1,nlay
233 DO is=1,npts
234 DO it=1,nptt
235 DO ir=1,nptr
236 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir
237 evar(1,i) = evar(1,i) + lbuf%EPE(jj(1)+i)/nptg
238 evar(2,i) = evar(2,i) + lbuf%EPE(jj(2)+i)/nptg
239 evar(3,i) = evar(3,i) + lbuf%EPE(jj(3)+i)/nptg
240 ENDDO
241 ENDDO
242 ENDDO
243 ENDDO
244 ENDDO
245 ELSEIF(mlw == 24)THEN
246 DO i=lft,llt
247 n = i + nft
248 DO il=1,nlay
249 DO is=1,npts
250 DO it=1,nptt
251 DO ir=1,nptr
252 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ir,is,it)
253 IF (elbuf_tab(ng)%BUFLY(il)%L_STRA > 0) THEN
254 evar(1,i) = evar(1,i) + lbuf%STRA(jj(1)+i)/nptg
255 evar(2,i) = evar(2,i) + lbuf%STRA(jj(2)+i)/nptg
256 evar(3,i) = evar(3,i) + lbuf%STRA(jj(3)+i)/nptg
257 evar(4,i) = evar(4,i) + lbuf%STRA(jj(4)+i)/nptg
258 evar(5,i) = evar(5,i) + lbuf%STRA(jj(5)+i)/nptg
259 evar(6,i) = evar(6,i) + lbuf%STRA(jj(6)+i)/nptg
260 ENDIF
261 ENDDO
262 ENDDO
263 ENDDO
264 ENDDO
265 ENDDO
266 ENDIF
267
268 ELSEIF (isolnod == 10) THEN
269 IF(mlw>=28)THEN
270 DO i=lft,llt
271 n = i + nft
272 DO ipt=1,npt
273 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ipt,1,1)
274 evar(1,i) = evar(1,i)+lbuf%STRA(jj(1)+i)/npt
275 evar(2,i) = evar(2,i)+lbuf%STRA(jj(2)+i)/npt
276 evar(3,i) = evar(3,i)+lbuf%STRA(jj(3)+i)/npt
277 evar(4,i) = evar(4,i)+lbuf%STRA(jj(4)+i)/npt
278 evar(5,i) = evar(5,i)+lbuf%STRA(jj(5)+i)/npt
279 evar(6,i) = evar(6,i)+lbuf%STRA(jj(6)+i)/npt
280 ENDDO
281 ENDDO
282 ELSEIF(mlw == 14)THEN
283 DO i=lft,llt
284 n = i + nft
285 DO ipt=1,npt
286 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ipt,1,1)
287 evar(1,i) = evar(1,i) + lbuf%EPE(jj(1)+i)/npt
288 evar(2,i) = evar(2,i) + lbuf%EPE(jj(2)+i)/npt
289 evar(3,i) = evar(3,i) + lbuf%EPE(jj(3)+i)/npt
290 ENDDO
291 ENDDO
292 ELSEIF (mlw == 24) THEN
293 DO i=lft,llt
294 n = i + nft
295 DO ipt=1,npt
296 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ipt,1,1)
297 evar(1,i) = evar(1,i)+lbuf%STRA(jj(1)+i)/npt
298 evar(2,i) = evar(2,i)+lbuf%STRA(jj(2)+i)/npt
299 evar(3,i) = evar(3,i)+lbuf%STRA(jj(3)+i)/npt
300 evar(4,i) = evar(4,i)+lbuf%STRA(jj(4)+i)/npt
301 evar(5,i) = evar(5,i)+lbuf%STRA(jj(5)+i)/npt
302 evar(6,i) = evar(6,i)+lbuf%STRA(jj(6)+i)/npt
303 ENDDO
304 ENDDO
305 ENDIF
306 ELSEIF ((isolnod == 6.OR.isolnod == 8) .AND. jhbe == 15) THEN
307 IF (mlw>=28) THEN
308 DO i=lft,llt
309 n = i + nft
310 DO il= 1,nlay
311 DO ipt=1,nptg
312 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ipt,1,1)
313 evar(1,i) = evar(1,i)+lbuf%STRA(jj(1)+i)/nptg
314 evar(2,i) = evar(2,i)+lbuf%STRA(jj(2)+i)/nptg
315
316 evar(4,i) = evar(4,i)+lbuf%STRA(jj(4)+i)/nptg
317 evar(5,i) = evar(5,i)+lbuf%STRA(jj(5)+i)/nptg
318 evar(6,i) = evar(6,i)+lbuf%STRA(jj(6)+i)/nptg
319 ENDDO
320 ENDDO
321 ENDDO
322 ELSEIF(mlw == 14)THEN
323 DO i=lft,llt
324 n = i + nft
325 DO il= 1,nlay
326 DO ipt=1,nptg
327 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ipt,1,1)
328 evar(1,i) = evar(1,i) + lbuf%EPE(jj(1)+i)/nptg
329 evar(2,i) = evar(2,i) + lbuf%EPE(jj(2)+i)/nptg
330 evar(3,i) = evar(3,i) + lbuf%EPE(jj(3)+i)/nptg
331 ENDDO
332 ENDDO
333 ENDDO
334 ELSEIF (mlw == 24) THEN
335 DO i=lft,llt
336 n = i + nft
337 DO il= 1,nlay
338 DO ipt=1,nptg
339 lbuf => elbuf_tab(ng)%BUFLY(il)%LBUF(ipt,1,1)
340 evar(1,i) = evar(1,i)+lbuf%STRA(jj(1)+i)/nptg
341 evar(2,i) = evar(2,i)+lbuf%STRA(jj(2)+i)/nptg
342 evar(3,i) = evar(3,i)+lbuf%STRA(jj(3)+i)/nptg
343 evar(4,i) = evar(4,i)+lbuf%STRA(jj(4)+i)/nptg
344 evar(5,i) = evar(5,i)+lbuf%STRA(jj(5)+i)/nptg
345 evar(6,i) = evar(6,i)+lbuf%STRA(jj(6)+i)/nptg
346 ENDDO
347 ENDDO
348 ENDDO
349 ENDIF
350 ENDIF
351
352 ELSEIF (itens == 4.AND.mlw == 24.AND.
353 . nint(pm(56,mt1)) == 1) THEN
354
355
356 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
357 DO i=lft,llt
358 evar(1,i) = lbuf%DGLO(jj(1)+i)
359 evar(2,i) = lbuf%DGLO(jj(2)+i)
360 evar(3,i) = lbuf%DGLO(jj(3)+i)
361 evar(4,i) = lbuf%DGLO(jj(4)+i)
362 evar(5,i) = lbuf%DGLO(jj(5)+i)
363 evar(6,i) = lbuf%DGLO(jj(6)+i)
364 ENDDO
365 IF (kcvt/=0) THEN
366
367 DO i=lft,llt
368 n = i + nft
369 IF(el2fa(nn2+n)/=0)THEN
370 IF(kcvt==2)THEN
371 gama(1)= gbuf%GAMA(jj(1) + i)
372 gama(2)= gbuf%GAMA(jj(2) + i)
373 gama(3)= zero
374 gama(4)=-gama(2)
375 gama(5)= gama(1)
376 gama(6)= zero
377 ELSE
378 gama(1)=one
379 gama(2)=zero
380 gama(3)=zero
381 gama(4)=zero
382 gama(5)=one
383 gama(6)=zero
384 END IF
385 CALL srota6(x,ixs(1:nixs,n),kcvt,evar(1:6,i),gama)
386 ENDIF
387 ENDDO
388 ENDIF
389
390 ELSE
391
392 DO i=lft,llt
393 n = i + nft
394 evar(1,i) = zero
395 evar(2,i) = zero
396 evar(3,i) = zero
397 evar(4,i) = zero
398 evar(5,i) = zero
399 evar(6,i) = zero
400 ENDDO
401 ENDIF
402
403 IF(isolnod == 16)THEN
404 DO i=lft,llt
405 n = i + nft
406 IF(el2fa(nn2+n)/=0)THEN
407 tens(1,el2fa(nn2+n)) = evar(1,i)
408 tens(2,el2fa(nn2+n)) = evar(2,i)
409 tens(3,el2fa(nn2+n)) = evar(3,i)
410 tens(4,el2fa(nn2+n)) = evar(4,i)
411 tens(5,el2fa(nn2+n)) = evar(5,i)
412 tens(6,el2fa(nn2+n)) = evar(6,i)
413 tens(1,el2fa(nn2+n)+1) = evar(1,i)
414 tens(2,el2fa(nn2+n)+1) = evar(2,i)
415 tens(3,el2fa(nn2+n)+1) = evar(3,i)
416 tens(4,el2fa(nn2+n)+1) = evar(4,i)
417 tens(5,el2fa(nn2+n)+1) = evar(5,i)
418 tens(6,el2fa(nn2+n)+1) = evar(6,i)
419 tens(1,el2fa(nn2+n)+2) = evar(1,i)
420 tens(2,el2fa(nn2+n)+2) = evar(2,i)
421 tens(3,el2fa(nn2+n)+2) = evar(3,i)
422 tens(4,el2fa(nn2+n)+2) = evar(4,i)
423 tens(5,el2fa(nn2+n)+2) = evar(5,i)
424 tens(6,el2fa(nn2+n)+2) = evar(6,i)
425 tens(1,el2fa(nn2+n)+3) = evar(1,i)
426 tens(2,el2fa(nn2+n)+3) = evar(2,i)
427 tens(3,el2fa(nn2+n)+3) = evar(3,i)
428 tens(4,el2fa(nn2+n)+3) = evar(4,i)
429 tens(5,el2fa(nn2+n)+3) = evar(5,i)
430 tens(6,el2fa(nn2+n)+3) = evar(6,i)
431 ENDIF
432 ENDDO
433 ELSE
434 DO i=lft,llt
435 n = i + nft
436 IF(el2fa(nn2+n)/=0)THEN
437 tens(1,el2fa(nn2+n)) = evar(1,i)
438 tens(2,el2fa(nn2+n)) = evar(2,i)
439 tens(3,el2fa(nn2+n)) = evar(3,i)
440 tens(4,el2fa(nn2+n)) = evar(4,i)
441 tens(5,el2fa(nn2+n)) = evar(5,i)
442 tens(6,el2fa(nn2+n)) = evar(6,i)
443 ENDIF
444 ENDDO
445 ENDIF
446
447 ELSEIF(isph3d == 1.AND.ity == 51)THEN
448
449
450
451 iprt=ipartsp(1 + nft)
452 mt1 =ipart(1,iprt)
453
454 IF (itens == 1) THEN
455
456
457 DO i=lft,llt
458 n = i + nft
459 IF(el2fa(nn3+n)/=0)THEN
460 tens(1,el2fa(nn3+n)) = lbuf%SIG(jj(1) + i)
461 tens(2,el2fa(nn3+n)) = lbuf%SIG(jj(2) + i)
462 tens(3,el2fa(nn3+n)) = lbuf%SIG(jj(3) + i)
463 tens(4,el2fa(nn3+n)) = lbuf%SIG(jj(4) + i)
464 tens(5,el2fa(nn3+n)) = lbuf%SIG(jj(5) + i)
465 tens(6,el2fa(nn3+n)) = lbuf%SIG(jj(6) + i)
466 ENDIF
467 ENDDO
468
469 ELSEIF(itens == 4.AND.mlw == 24.
470 . and.nint(pm(56,mt1)) == 1)THEN
471
472
473 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(1,1,1)
474 DO i=lft,llt
475 n = i + nft
476 IF (el2fa(nn3+n)/=0) THEN
477 evar(1,i) = lbuf%DGLO(jj(1)+i)
478 evar(2,i) = lbuf%DGLO(jj(2)+i)
479 evar(3,i) = lbuf%DGLO(jj(3)+i)
480 evar(4,i) = lbuf%DGLO(jj(4)+i)
481 evar(5,i) = lbuf%DGLO(jj(5)+i)
482 evar(6,i) = lbuf%DGLO(jj(6)+i)
483 ENDIF
484 ENDDO
485 ELSE
486 DO i=lft,llt
487 n = i + nft
488 IF(el2fa(nn3+n)/=0)THEN
489 tens(1,el2fa(nn3+n)) = zero
490 tens(2,el2fa(nn3+n)) = zero
491 tens(3,el2fa(nn3+n)) = zero
492 tens(4,el2fa(nn3+n)) = zero
493 tens(5,el2fa(nn3+n)) = zero
494 tens(6,el2fa(nn3+n)) = zero
495 ENDIF
496 ENDDO
497 ENDIF
498
499 ENDIF
500
501 490 CONTINUE
502
503 DO n=1,nbf
504 r4(1) = tens(1,n)
505 r4(2) = tens(2,n)
506 r4(3) = tens(3,n)
507 r4(4) = tens(4,n)
508 r4(5) = tens(5,n)
509 r4(6) = tens(6,n)
511 ENDDO
512
513 RETURN
subroutine initbuf(iparg, ng, mtn, llt, nft, iad, ity, npt, jale, ismstr, jeul, jtur, jthe, jlag, jmult, jhbe, jivf, jpor, jcvt, jclose, jpla, irep, iint, igtyp, israt, isrot, icsen, isorth, isorthg, ifailure)
subroutine srota6(x, ixs, kcvt, tens, gama)
void write_r_c(float *w, int *len)