OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
stat_c_strsfg.F File Reference
#include "implicit_f.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "mvsiz_p.inc"
#include "param_c.inc"
#include "units_c.inc"
#include "task_c.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine stat_c_strsfg (elbuf_tab, x, iparg, ipm, igeo, ixc, ixtg, wa, wap0, ipartc, iparttg, ipart_state, stat_indxc, stat_indxtg, thke, sizp0, geo, stack, drape_sh4n, drape_sh3n, drapeg)
subroutine orth2loc (tens, dir_a, dir_b, ii, ilaw, igtyp, nel)
subroutine urotovs (sig, dir1, dir2)
subroutine sheml2g (mom, qt)

Function/Subroutine Documentation

◆ orth2loc()

subroutine orth2loc ( tens,
dir_a,
dir_b,
integer ii,
integer ilaw,
integer igtyp,
integer nel )

Definition at line 1087 of file stat_c_strsfg.F.

1088C-----------------------------------------------
1089C I m p l i c i t T y p e s
1090C-----------------------------------------------
1091#include "implicit_f.inc"
1092C-----------------------------------------------
1093C D u m m y A r g u m e n t s
1094C-----------------------------------------------
1095 INTEGER II,ILAW,IGTYP,NEL
1096 my_real
1097 . tens(5), dir_a(*),dir_b(*)
1098C-----------------------------------------------
1099C L o c a l V a r i a b l e s
1100C-----------------------------------------------
1101
1102 my_real
1103 . r1,r2,r3,s1,s2,s3,r12a,r22a,s12b,s22b,rs1,rs2,rs3,
1104 . t1,t2,t3,phi,sum1,sum2,fact,r3r3,s3s3
1105c------------------------------------------------
1106 IF (igtyp /= 1) THEN
1107c------------------------------------------------
1108 IF (igtyp == 16) THEN
1109c II = JDIR + I-1
1110 r1 = dir_a(ii)
1111 s1 = dir_a(ii+nel)
1112 r2 = dir_b(ii)
1113 s2 = dir_b(ii+nel)
1114
1115 rs1= r1*s1
1116 rs2= r2*s2
1117 r12a = r1*r1
1118 r22a = r2*r2
1119 s12b = s1*s1
1120 s22b = s2*s2
1121
1122 rs3 = s1*s2-r1*r2
1123 r3r3= one+s1*r2+r1*s2
1124 r3r3= half*r3r3
1125 s3s3= one-s1*r2-r1*s2
1126 s3s3= half*s3s3
1127 t1 = tens(1)
1128 t2 = tens(2)
1129 t3 = tens(3)
1130 tens(1) = r12a*t1 + r22a*t2 - rs3*t3
1131 tens(2) = s12b*t1 + s22b*t2 + rs3*t3
1132 tens(3) = rs1*t1 + rs2*t2 + (r3r3 - s3s3)*t3
1133c
1134 ELSEIF ((igtyp == 51 .OR. igtyp == 52) .AND. ilaw == 58) THEN
1135c II = JDIR + I-1
1136 r1 = dir_a(ii)
1137 s1 = dir_a(ii+nel)
1138 r2 = dir_b(ii)
1139 s2 = dir_b(ii+nel)
1140c
1141 rs1= r1*s1
1142 rs2= r2*s2
1143 r12a = r1*r1
1144 r22a = r2*r2
1145 s12b = s1*s1
1146 s22b = s2*s2
1147 rs3 = s1*s2-r1*r2
1148 r3r3= one+s1*r2+r1*s2
1149 r3r3= half*r3r3
1150 s3s3= one-s1*r2-r1*s2
1151 s3s3= half*s3s3
1152 t1 = tens(1)
1153 t2 = tens(2)
1154 t3 = tens(3)
1155c
1156 tens(1) = r12a*t1 + r22a*t2 - rs3*t3
1157 tens(2) = s12b*t1 + s22b*t2 + rs3*t3
1158 tens(3) = rs1*t1 + rs2*t2 + (r3r3 - s3s3)*t3
1159 ELSE
1160 IF (ilaw /= 1 .and. ilaw /= 2 .and. ilaw /= 19 .and. ilaw /= 27 .and. ilaw /= 32)
1161 . CALL urotovs(tens,dir_a(ii),dir_a(ii+nel))
1162 ENDIF
1163 ENDIF ! IGTYP
1164C
1165 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
urotovs
subroutine urotovs(sig, dir1, dir2)
Definition stat_c_strsfg.F:1173

◆ sheml2g()

subroutine sheml2g ( mom,
qt )

Definition at line 1211 of file stat_c_strsfg.F.

1212C-----------------------------------------------
1213C I m p l i c i t T y p e s
1214C-----------------------------------------------
1215#include "implicit_f.inc"
1216C-----------------------------------------------
1217C D u m m y A r g u m e n t s
1218C-----------------------------------------------
1219 my_real
1220 . mom(6),qt(3,3)
1221C------------------------------------------------------
1222C L o c a l V a r i a b l e s
1223C-----------------------------------------------
1224
1225 my_real
1226 . txx,tyy,tzz,txy,tyz,tzx,uxx,uyy,uzz,uxy,uyz,uzx,a,b,c
1227C--convention input MOM : mxx,myy,mxy,0,0,0; output mxx,myy,mzz,mxy,myz,mzx
1228 txx = mom(1)
1229 tyy = mom(2)
1230 tzz = zero
1231 txy = mom(3)
1232 tyz = zero
1233 tzx = zero
1234C
1235 a = qt(1,1)*txx + qt(2,1)*txy
1236 b = qt(1,1)*txy + qt(2,1)*tyy
1237c C = ZERO
1238 uxx = a*qt(1,1) + b*qt(1,2)
1239 uxy = a*qt(2,1) + b*qt(2,2)
1240 uzx = a*qt(3,1) + b*qt(3,2)
1241 a = qt(1,2)*txx + qt(2,2)*txy
1242 b = qt(1,2)*txy + qt(2,2)*tyy
1243c C = ZERO
1244 uyy = a*qt(2,1) + b*qt(2,2)
1245 uyz = a*qt(3,1) + b*qt(3,2)
1246 a = qt(1,3)*txx + qt(2,3)*txy
1247 b = qt(1,3)*txy + qt(2,3)*tyy
1248c C = ZERO
1249 uzz = a*qt(3,1) + b*qt(3,2)
1250C
1251 mom(1) = uxx
1252 mom(2) = uyy
1253 mom(3) = uzz
1254 mom(4) = uxy
1255 mom(5) = uyz
1256 mom(6) = uzx
1257C
1258 RETURN

◆ stat_c_strsfg()

subroutine stat_c_strsfg ( type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
x,
integer, dimension(nparg,*) iparg,
integer, dimension(npropmi,*) ipm,
integer, dimension(npropgi,*) igeo,
integer, dimension(nixc,*) ixc,
integer, dimension(nixtg,*) ixtg,
double precision, dimension(*) wa,
double precision, dimension(*) wap0,
integer, dimension(*) ipartc,
integer, dimension(*) iparttg,
integer, dimension(*) ipart_state,
integer, dimension(*) stat_indxc,
integer, dimension(*) stat_indxtg,
thke,
integer sizp0,
geo,
type (stack_ply) stack,
type (drape_), dimension(numelc_drape) drape_sh4n,
type (drape_), dimension(numeltg_drape) drape_sh3n,
type (drapeg_) drapeg )

Definition at line 45 of file stat_c_strsfg.F.

50C-----------------------------------------------
51C M o d u l e s
52C-----------------------------------------------
53 USE elbufdef_mod
54 USE stack_mod
55 USE drape_mod
56 USE my_alloc_mod
57 use element_mod , only : nixc,nixtg
58C-----------------------------------------------
59C I m p l i c i t T y p e s
60C-----------------------------------------------
61#include "implicit_f.inc"
62C-----------------------------------------------
63C C o m m o n B l o c k s
64C-----------------------------------------------
65#include "com01_c.inc"
66#include "com04_c.inc"
67#include "mvsiz_p.inc"
68#include "param_c.inc"
69#include "units_c.inc"
70#include "task_c.inc"
71#include "scr14_c.inc"
72#include "scr16_c.inc"
73C-----------------------------------------------
74C D u m m y A r g u m e n t s
75C-----------------------------------------------
76 INTEGER SIZP0
77 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
78 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
79 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
80 . STAT_INDXC(*), STAT_INDXTG(*)
81 my_real
82 . thke(*),x(3,*),geo(*)
83 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
84 TYPE (STACK_PLY) :: STACK
85 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
86 TYPE (DRAPEG_) :: DRAPEG
87 double precision WA(*),WAP0(*)
88C-----------------------------------------------
89C L o c a l V a r i a b l e s
90C-----------------------------------------------
91 INTEGER I,J,K,N,II,JJ,LEN,IOFF,IE,NG,NEL,NFT,LFT,NPT,
92 . LLT,ITY,MLW,IH,IHBE, ID, IPRT0, IPRT,IR,IS,IT,J1,J2,
93 . NPG,IPG,MPT,IPT,NPTR,NPTS,NPTT,NLAY,L_PLA,ITHK,NF3,
94 . IGTYP,NPT_ALL,IL,KK(12),NF1,IREL,IBID0,MAT_1,PID_1,ILAY,IDRAPE,
95 . SEDRAPE,NUMEL_DRAPE
96 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
97 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
98 double precision
99 . THK, EM, EB, H1, H2, H3
100 my_real
101 . pg,mpg,qpg(2,4),thkq,
102 . sk(2),st(2),mk(2),mt(2),shk(2),sht(2),zz
103 CHARACTER*100 DELIMIT,LINE
104 TYPE(G_BUFEL_) ,POINTER :: GBUF
105 TYPE(L_BUFEL_) ,POINTER :: LBUF
106 TYPE(BUF_LAY_) ,POINTER :: BUFLY
107 INTEGER LAYNPT_MAX,NLAY_MAX,ISUBSTACK,IPT_ALL,JDIR,L_DIRA,L_DIRB,IREP,
108 . ILAW
109 my_real,
110 . DIMENSION(:),POINTER :: dir_a,dir_b
111 my_real
112 . qt(9,mvsiz),tens(6),zh,thkp ,thk0(mvsiz)
113
114 INTEGER, DIMENSION(:) , ALLOCATABLE :: MATLY
115 my_real, DIMENSION(:) , ALLOCATABLE :: thkly
116 my_real, DIMENSION(:,:) , ALLOCATABLE :: posly,thk_ly
117 my_real, ALLOCATABLE, DIMENSION(:) , TARGET :: dira,dirb
118C-----------------------------------------------
119 PARAMETER (pg = .577350269189626)
120 parameter(mpg=-.577350269189626)
121 DATA qpg/mpg,mpg,pg,mpg,pg,pg,mpg,pg/
122 DATA delimit(1:60)
123 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
124 DATA delimit(61:100)
125 ./'----7----|----8----|----9----|----10---|'/
126!
127 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
128 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
129C=======================================================================
130C 4-NODE SHELLS
131C-----------------------------------------------
132 jj = 0
133 IF (stat_numelc==0) GOTO 200
134C
135 ie=0
136 DO ng=1,ngroup
137 ity = iparg(5,ng)
138 IF (ity == 3) THEN
139 gbuf => elbuf_tab(ng)%GBUF
140 mlw = iparg(1,ng)
141 nel = iparg(2,ng)
142 nft = iparg(3,ng)
143 mpt = iparg(6,ng)
144 ihbe = iparg(23,ng)
145 ithk = iparg(28,ng)
146 igtyp= iparg(38,ng)
147 irep = iparg(35,ng)
148 isubstack=iparg(71,ng)
149 idrape= iparg(92,ng)
150 nptr = elbuf_tab(ng)%NPTR
151 npts = elbuf_tab(ng)%NPTS
152 nptt = elbuf_tab(ng)%NPTT
153 nlay = elbuf_tab(ng)%NLAY
154 npg = nptr*npts
155 npt = nlay*nptt
156 IF (ihbe == 23) npg=4
157 lft=1
158 llt=nel
159 nf1 = nft+1
160 IF (ihbe>10.OR.igtyp==16.OR.ishfram ==0) THEN
161 irel=0
162 ELSEIF (ishfram ==1) THEN
163 irel=2
164 ELSE
165 irel=1
166 END IF
167!
168 DO i=1,12 ! length max of GBUF%G_HOURG = 12
169 kk(i) = nel*(i-1)
170 ENDDO
171!
172 ibid0 = 0
173 mat_1 = ixc(1,nf1)
174 pid_1 = ixc(6,nf1)
175 IF (ithk >0 ) THEN
176 thk0(lft:llt) = gbuf%THK(lft:llt)
177 ELSE
178 thk0(lft:llt) = thke(lft+nft:llt+nft)
179 END IF
180 ! Npt_max
181 laynpt_max = 1
182 IF(igtyp == 51 .OR. igtyp == 52) THEN
183 DO ilay=1, elbuf_tab(ng)%NLAY
184 laynpt_max = max(laynpt_max , elbuf_tab(ng)%BUFLY(ilay)%NPTT)
185 ENDDO
186 ENDIF
187 nlay_max = max(nlay,npt, elbuf_tab(ng)%NLAY)
188 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
189 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
190 matly = 0
191 thkly = zero
192 posly = zero
193 thk_ly = zero
194 numel_drape = numelc_drape
195 sedrape = scdrape
196 CALL layini(elbuf_tab(ng),lft ,llt ,geo ,igeo ,
197 . mat_1 ,pid_1 ,thkly ,matly ,posly ,
198 . igtyp ,ibid0 ,ibid0 ,nlay ,mpt ,
199 . isubstack,stack ,drape_sh4n ,nft ,thke ,
200 . nel ,thk_ly ,drapeg%INDX_SH4N,sedrape,numel_drape)
201 l_dira = elbuf_tab(ng)%BUFLY(1)%LY_DIRA
202 l_dirb = elbuf_tab(ng)%BUFLY(1)%LY_DIRB
203 ALLOCATE(dira(nlay*nel*l_dira))
204 ALLOCATE(dirb(nlay*nel*l_dirb))
205 dira=zero
206 dirb=zero
207 IF (l_dira == 0) THEN
208 CONTINUE
209 ELSEIF (irep == 0) THEN
210 IF(idrape > 0 .AND. (igtyp == 51 .OR. igtyp == 52)) THEN
211 DO j=1,nlay
212 j1 = 1+(j-1)*l_dira*nel
213 j2 = j*l_dira*nel
214 dira(j1:j2) = elbuf_tab(ng)%BUFLY(j)%LBUF_DIR(1)%DIRA(1:nel*l_dira)
215 ENDDO
216 ELSE
217 DO j=1,nlay
218 j1 = 1+(j-1)*l_dira*nel
219 j2 = j*l_dira*nel
220 dira(j1:j2) = elbuf_tab(ng)%BUFLY(j)%DIRA(1:nel*l_dira)
221 ENDDO
222 ENDIF
223 ENDIF
224 dir_a => dira(1:nlay*nel*l_dira)
225 dir_b => dirb(1:nlay*nel*l_dirb)
226 CALL get_q4lsys(lft ,llt ,ixc(1,nf1),x ,gbuf%OFF,
227 . irel ,qt ,nlay ,irep ,nel ,
228 . dir_a ,dir_b,elbuf_tab(ng))
229C
230C pre counting of all NPTT (especially for PID_51)
231C
232 npt_all = 0
233 DO il=1,nlay
234 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
235 ENDDO
236 mpt = max(1,npt_all)
237 IF (iparg(6,ng) == 0) mpt=0
238C
239c------- loop over 4 node shell elements
240C
241 DO i=lft,llt
242 n = i + nft
243 iprt=ipartc(n)
244 IF (ipart_state(iprt)==0) cycle
245 jj = jj + 1
246 IF (mlw /= 0 .AND. mlw /= 13) THEN
247 wa(jj) = gbuf%OFF(i)
248 ELSE
249 wa(jj) = zero
250 ENDIF
251 jj = jj + 1
252 wa(jj) = iprt
253 jj = jj + 1
254 wa(jj) = ixc(nixc,n)
255 jj = jj + 1
256 wa(jj) = mpt
257 jj = jj + 1
258 wa(jj) = npg
259 jj = jj + 1
260 IF (mlw /= 0 .AND. mlw /= 13) THEN
261 wa(jj) = thk0(i)
262 thkq = wa(jj)
263 ELSE
264 wa(jj) = zero
265 thkq = gbuf%THK(i)
266 ENDIF
267 jj = jj + 1
268 IF (mlw /= 0 .AND. mlw /= 13) THEN
269 wa(jj) = gbuf%EINT(i)
270 ELSE
271 wa(jj) = zero
272 ENDIF
273 jj = jj + 1
274 IF (mlw /= 0 .AND. mlw /= 13) THEN
275 wa(jj) = gbuf%EINT(i+llt)
276 ELSE
277 wa(jj) = zero
278 ENDIF
279c ---- Hourglass
280 IF (ihbe==11 .or. ihbe==23 .or. mlw == 0 .or. mlw == 13) THEN
281 jj = jj + 1
282 wa(jj) = zero
283 jj = jj + 1
284 wa(jj) = zero
285 jj = jj + 1
286 wa(jj) = zero
287 ELSE ! not Batoz & not QEPH
288 jj = jj + 1
289 wa(jj) = gbuf%HOURG(kk(1)+i)
290 jj = jj + 1
291 wa(jj) = gbuf%HOURG(kk(2)+i)
292 jj = jj + 1
293 wa(jj) = gbuf%HOURG(kk(3)+i)
294 ENDIF
295c---------6 x2 +1(eps) for MPT=0
296 IF (ihbe /= 23) THEN
297 IF (mpt == 0) THEN ! global integration
298 IF (mlw == 0 .or. mlw == 13) THEN
299 DO ipg=1,npg
300 DO j=1,13 ! forces and moments
301 jj = jj + 1
302 wa(jj) = zero
303 ENDDO
304 ENDDO
305 ELSEIF (npg == 1) THEN
306 tens(1:5) = gbuf%FOR(kk(1:5)+i)
307 CALL shell2g(tens,qt(1,i))
308 DO j =1,6
309 jj = jj + 1
310 wa(jj) = tens(j)
311 END DO
312c
313 tens(1:3) = gbuf%MOM(kk(1:3)+i)
314 CALL sheml2g(tens,qt(1,i))
315 DO j =1,6
316 jj = jj + 1
317 wa(jj) = tens(j)
318 END DO
319c
320 jj = jj + 1
321 IF (gbuf%G_PLA > 0) THEN
322 wa(jj) = gbuf%PLA(i)
323 ELSE
324 wa(jj) = zero
325 ENDIF
326 ELSE ! NPG > 1
327 DO is=1,npts
328 DO ir=1,nptr
329 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ir,is,1)
330 ipg = nptr*(is-1) + ir
331 k = (ipg-1)*nel*5
332C
333 tens(1:5) = gbuf%FORPG(k+kk(1:5)+i)
334 CALL shell2g(tens,qt(1,i))
335 DO j =1,6
336 jj = jj + 1
337 wa(jj) = tens(j)
338 END DO
339c
340 jj = jj + 1
341 IF (gbuf%G_PLA > 0) THEN
342 wa(jj) = lbuf%PLA(i)
343 ELSE
344 wa(jj) = zero
345 ENDIF
346c
347 k = (ipg-1)*nel*3
348 tens(1:3) = gbuf%MOMPG(k+kk(1:3)+i)
349 CALL sheml2g(tens,qt(1,i))
350 DO j =1,6
351 jj = jj + 1
352 wa(jj) = tens(j)
353 END DO
354 ENDDO
355 ENDDO
356 ENDIF ! IF (MLW == 0 .or. MLW == 13)
357C (MPT >0 ):
358 ELSEIF (mlw == 0 .or. mlw == 13) THEN
359 DO k=1,mpt
360 DO ipg=1,npg
361 DO j=1,8 ! Stress + plastic strain + T
362 jj = jj + 1
363 wa(jj) = zero
364 ENDDO
365 ENDDO
366 ENDDO
367 ELSE ! NLAY >= 1,
368 ipt_all = 0
369 DO il = 1,nlay
370 bufly => elbuf_tab(ng)%BUFLY(il)
371 ilaw = bufly%ILAW
372 nptt = bufly%NPTT
373 jdir = 1 + (il-1)*nel*2
374 ii = jdir + i-1
375 DO it=1,nptt
376 ipt = ipt_all + it
377 DO is=1,npts
378 DO ir=1,nptr
379 lbuf => bufly%LBUF(ir,is,it)
380 tens(1:5) = lbuf%SIG(kk(1:5)+i)
381 CALL orth2loc(tens,dir_a,dir_b,ii,ilaw,igtyp,nel)
382 CALL shell2g(tens,qt(1,i))
383 DO j =1,6
384 jj = jj + 1
385 wa(jj) = tens(j)
386 END DO
387 jj = jj + 1
388 IF (bufly%L_PLA > 0) THEN
389 wa(jj) = lbuf%PLA(i)
390 ELSE
391 wa(jj) = zero
392 ENDIF
393 jj = jj + 1
394 wa(jj) = posly(i,ipt)*two
395 ENDDO
396 ENDDO
397 ENDDO
398 ipt_all = ipt_all + nptt
399 ENDDO
400 ENDIF ! MPT, NLAY
401c---------
402 ELSE ! IHBE = 23 (QEPH)
403c---------
404 IF (mlw==0 .or. mlw==13) THEN
405 st(1) = zero
406 st(2) = zero
407 mt(1) = zero
408 mt(2) = zero
409 sk(1) = zero
410 sk(2) = zero
411 mk(1) = zero
412 mk(2) = zero
413 sht(1)= zero
414 sht(2)= zero
415 shk(1)= zero
416 shk(2)= zero
417 IF (mpt == 0) THEN
418 DO ipg=1,npg
419 DO j=1,13
420 jj = jj + 1
421 wa(jj) = zero
422 ENDDO
423 ENDDO
424 ELSE
425 DO ipg=1,npg
426 DO j=1,8
427 jj = jj + 1
428 wa(jj) = zero
429 ENDDO
430 ENDDO
431 ENDIF
432 ELSE ! MLW /= 0
433 st(1) = gbuf%HOURG(kk(1)+i)
434 st(2) =-gbuf%HOURG(kk(2)+i)
435 mt(1) = gbuf%HOURG(kk(3)+i)
436 mt(2) =-gbuf%HOURG(kk(4)+i)
437 sk(1) =-gbuf%HOURG(kk(7)+i)
438 sk(2) = gbuf%HOURG(kk(8)+i)
439 mk(1) =-gbuf%HOURG(kk(9)+i)
440 mk(2) = gbuf%HOURG(kk(10)+i)
441 sht(1)= gbuf%HOURG(kk(5)+i)
442 sht(2)=-gbuf%HOURG(kk(6)+i)
443 shk(1)=-gbuf%HOURG(kk(11)+i)
444 shk(2)= gbuf%HOURG(kk(12)+i)
445 ENDIF
446c
447 IF (mpt == 0 .and. mlw /= 0 .and. mlw /= 13) THEN
448 DO ipg=1,npg
449 tens(1:2) = gbuf%FOR(kk(1:2)+i)
450 . + st(1:2)*qpg(2,ipg)+sk(1:2)*qpg(1,ipg)
451 tens(3) = gbuf%FOR(kk(3)+i)
452 tens(4) = gbuf%FOR(kk(4)+i)
453 . + sht(2)*qpg(2,ipg)+shk(2)*qpg(1,ipg)
454 tens(5) = gbuf%FOR(kk(5)+i)
455 . + sht(1)*qpg(2,ipg)+shk(1)*qpg(1,ipg)
456 CALL shell2g(tens,qt(1,i))
457 DO j =1,6
458 jj = jj + 1
459 wa(jj) = tens(j)
460 END DO
461 tens(1:2) = gbuf%MOM(kk(1:2)+i)
462 . + mt(1:2)*qpg(2,ipg)+mk(1:2)*qpg(1,ipg)
463 tens(3) = gbuf%MOM(kk(3)+i)
464 CALL sheml2g(tens,qt(1,i))
465 DO j =1,6
466 jj = jj + 1
467 wa(jj) = tens(j)
468 END DO
469c
470 jj = jj + 1
471 IF (gbuf%G_PLA > 0) THEN
472 wa(jj) = gbuf%PLA(i)
473 ELSE
474 wa(jj) = zero
475 ENDIF
476 ENDDO
477 ELSEIF (mlw /= 0 .and. mlw /= 13) THEN ! NPT > 0
478 ipt_all = 0
479 DO il = 1,nlay
480 bufly => elbuf_tab(ng)%BUFLY(il)
481 ilaw = bufly%ILAW
482 nptt = bufly%NPTT
483 jdir = 1 + (il-1)*nel*2
484 ii = jdir + i-1
485 DO it=1,nptt
486 ipt = ipt_all + it
487 lbuf => bufly%LBUF(1,1,it)
488 l_pla = bufly%L_PLA
489 zz = posly(i,ipt)*thkq
490 DO ipg=1,npg
491 tens(1:2) = lbuf%SIG(kk(1:2)+i)
492 . + (st(1:2)+zz*mt(1:2))*qpg(2,ipg)
493 . + (sk(1:2)+zz*mk(1:2))*qpg(1,ipg)
494 tens(3) = lbuf%SIG(kk(3)+i)
495 tens(4) = lbuf%SIG(kk(4)+i)
496 . + sht(2)*qpg(2,ipg)+shk(2)*qpg(1,ipg)
497 tens(5) = lbuf%SIG(kk(5)+i)
498 . + sht(1)*qpg(2,ipg)+shk(1)*qpg(1,ipg)
499 CALL orth2loc(tens,dir_a,dir_b,ii,ilaw,igtyp,nel)
500 CALL shell2g(tens,qt(1,i))
501 DO j =1,6
502 jj = jj + 1
503 wa(jj) = tens(j)
504 END DO
505 jj = jj + 1
506 IF (l_pla > 0) THEN
507 wa(jj) = lbuf%PLA(i)
508 ELSE
509 wa(jj) = zero
510 ENDIF
511 jj = jj + 1
512 wa(jj) = posly(i,ipt)*two
513 ENDDO ! DO IPG=1,NPG
514 ENDDO ! DO IT=1,NPTT
515 ipt_all = ipt_all + nptt
516 ENDDO ! DO IL=1,NLAY
517 ENDIF ! IF (MPT == 0 .and. MLW /= 0 .and. MLW /= 13)
518 ENDIF
519C
520 ie=ie+1
521C end-of-zone pointer in wa
522 ptwa(ie)=jj
523 ENDDO ! DO I=LFT,LLT
524c------- end loop over 4 node shell elements
525 IF(ALLOCATED(dirb)) DEALLOCATE(dirb)
526 IF(ALLOCATED(dira)) DEALLOCATE(dira)
527 DEALLOCATE(matly, thkly, posly, thk_ly)
528 ENDIF ! ITY == 3
529 ENDDO ! NG = 1, NGROUP
530C
531 200 CONTINUE
532c-----------------------------------------------------------------------
533c 4N SHELLS - WRITE
534c-----------------------------------------------------------------------
535 IF (nspmd == 1) THEN
536 ptwa_p0(0)=0
537 DO n=1,stat_numelc
538 ptwa_p0(n)=ptwa(n)
539 ENDDO
540 len=jj
541 DO j=1,len
542 wap0(j)=wa(j)
543 ENDDO
544 ELSE
545C builds the pointers in the global array wap0
546 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
547 len = 0
548 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
549 ENDIF
550c-------------------------------------
551 IF (ispmd == 0.AND.len > 0) THEN
552 iprt0=0
553 DO n=1,stat_numelc_g
554C find the nieme elt in the order of an increasing id
555 k=stat_indxc(n)
556C Find the address in WAP0
557 j=ptwa_p0(k-1)
558
559 ioff = nint(wap0(j + 1))
560 IF (ioff >= 1) THEN
561 iprt = nint(wap0(j + 2))
562 IF (iprt /= iprt0) THEN
563 IF (izipstrs == 0) THEN
564 WRITE(iugeo,'(A)') delimit
565 WRITE(iugeo,'(A)')'/INISHE/STRS_F/GLOB'
566 WRITE(iugeo,'(A)')
567 . '#------------------------ REPEAT --------------------------'
568 WRITE(iugeo,'(A)')
569 . '# SHELLID NPT NPG THK'
570 WRITE(iugeo,'(A)') '# EM, EB, H1, H2, H3'
571 WRITE(iugeo,'(A/A/A/A/A)')
572 . '# IF(NPT == 0), REPEAT I=1,NPG :',
573 . '# N1, N2, N3 ',
574 . '# N12, N23, N31',
575 . '# M1, M2, M3 ',
576 . '# M12,M23,M31,EPSP '
577 WRITE(iugeo,'(A/A/A)')
578 . '# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
579 . '# S1, S2, S3 ',
580 . '# S12, S23, S31, EPSP, T '
581 WRITE(iugeo,'(A)')
582 . '#---------------------- END REPEAT ------------------------'
583 WRITE(iugeo,'(A)') delimit
584 ELSE
585 WRITE(line,'(A)') delimit
586 CALL strs_txt50(line,100)
587 WRITE(line,'(A)')'/INISHE/STRS_F/GLOB'
588 CALL strs_txt50(line,100)
589 WRITE(line,'(A)')
590 . '#------------------------ REPEAT --------------------------'
591 CALL strs_txt50(line,100)
592 WRITE(line,'(A)')
593 . '# SHELLID NPT NPG THK'
594 CALL strs_txt50(line,100)
595 WRITE(line,'(A)') '# EM, EB, H1, H2, H3'
596 CALL strs_txt50(line,100)
597 WRITE(line,'(A)') '# IF(NPT == 0), REPEAT I=1,NPG :'
598 CALL strs_txt50(line,100)
599 WRITE(line,'(A)')'# N1, N2, N3 '
600 CALL strs_txt50(line,100)
601 WRITE(line,'(A)')'# N12, N23, N31'
602 CALL strs_txt50(line,100)
603 WRITE(line,'(A)')'# M1, M2, M3 '
604 CALL strs_txt50(line,100)
605 WRITE(line,'(A)')'# M12, M23, M31, EPSP'
606 CALL strs_txt50(line,100)
607 WRITE(line,'(A)')
608 . '# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
609 CALL strs_txt50(line,100)
610 WRITE(line,'(A)')'# S1, S2, S3'
611 CALL strs_txt50(line,100)
612 WRITE(line,'(A)')'# S12,S23,S31, EPSP, T '
613 CALL strs_txt50(line,100)
614 WRITE(line,'(A)')
615 . '#---------------------- END REPEAT ------------------------'
616 CALL strs_txt50(line,100)
617 WRITE(line,'(A)') delimit
618 CALL strs_txt50(line,100)
619 ENDIF
620 iprt0=iprt
621 ENDIF
622c
623 id = nint(wap0(j + 3))
624 npt = nint(wap0(j + 4))
625 npg = nint(wap0(j + 5))
626 thk = wap0(j + 6)
627 em = wap0(j + 7)
628 eb = wap0(j + 8)
629 h1 = wap0(j + 9)
630 h2 = wap0(j + 10)
631 h3 = wap0(j + 11)
632 j = j + 11
633 IF (izipstrs == 0) THEN
634 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
635 WRITE(iugeo,'(1P5E20.13)')em,eb,h1,h2,h3
636 ELSE
637 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
638 CALL strs_txt50(line,100)
639 WRITE(line,'(1P5E20.13)')em,eb,h1,h2,h3
640 CALL strs_txt50(line,100)
641 ENDIF
642 IF (npt == 0) THEN
643 DO ipg=1,npg
644 IF (izipstrs == 0) THEN
645 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,9)
646 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=10,13)
647 ELSE
648 CALL tab_strs_txt50(wap0(1),9,j,sizp0,3)
649 CALL tab_strs_txt50(wap0(10),4,j,sizp0,4)
650 ENDIF
651 j = j + 13
652 ENDDO
653 ELSE
654 DO it=1,npt
655 DO ipg=1,npg
656 IF (izipstrs == 0) THEN
657 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
658 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=4,8)
659 ELSE
660 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
661 CALL tab_strs_txt50(wap0(4),5,j,sizp0,5)
662 ENDIF
663 j = j + 8
664 END DO
665 END DO
666 ENDIF ! IF (NPT == 0)
667 ENDIF ! IF (IOFF >= 1)
668 ENDDO ! DO N=1,STAT_NUMELC_G
669 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
670C-----------------------------------------------
671C 3-NODE SHELLS
672C-----------------------------------------------
673 jj = 0
674 IF (stat_numeltg==0) GOTO 300
675 ie=0
676C
677 DO ng=1,ngroup
678 ity = iparg(5,ng)
679 IF (ity == 7) THEN
680 gbuf => elbuf_tab(ng)%GBUF
681 mlw = iparg(1,ng)
682 nel = iparg(2,ng)
683 nft = iparg(3,ng)
684 mpt = iparg(6,ng)
685 ihbe = iparg(23,ng)
686 ithk = iparg(28,ng)
687 igtyp= iparg(38,ng)
688 irep = iparg(35,ng)
689 isubstack=iparg(71,ng)
690 nptr = elbuf_tab(ng)%NPTR
691 npts = elbuf_tab(ng)%NPTS
692 nptt = elbuf_tab(ng)%NPTT
693 nlay = elbuf_tab(ng)%NLAY
694 npg = nptr*npts
695 npt = nlay*nptt
696 lft=1
697 llt=nel
698 nf1 = nft+1
699 IF (ihbe>=30) THEN
700 irel=0
701 ELSE
702 irel=2
703 END IF
704!
705 DO i=1,5
706 kk(i) = nel*(i-1)
707 ENDDO
708 ibid0 = 0
709 mat_1 = ixtg(1,nf1)
710 pid_1 = ixtg(nixtg-1,nf1)
711 IF (ithk >0 ) THEN
712 thk0(lft:llt) = gbuf%THK(lft:llt)
713 ELSE
714 nf3 = nft+numelc
715 thk0(lft:llt) = thke(lft+nf3:llt+nf3)
716 END IF
717 ! Npt_max
718 laynpt_max = 1
719 IF(igtyp == 51 .OR. igtyp == 52) THEN
720 DO ilay=1, elbuf_tab(ng)%NLAY
721 laynpt_max = max(laynpt_max , elbuf_tab(ng)%BUFLY(ilay)%NPTT)
722 ENDDO
723 ENDIF
724 nlay_max = max(nlay,npt, elbuf_tab(ng)%NLAY)
725 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
726 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
727 matly = 0
728 thkly = zero
729 posly = zero
730 thk_ly = zero
731 numel_drape = numeltg_drape
732 sedrape = stdrape
733 CALL layini(elbuf_tab(ng),lft ,llt ,geo ,igeo ,
734 . mat_1 ,pid_1 ,thkly ,matly ,posly ,
735 . igtyp ,ibid0 ,ibid0 ,nlay ,mpt ,
736 . isubstack,stack ,drape_sh3n ,nft ,thke ,
737 . nel ,thk_ly ,drapeg%INDX_SH3N, sedrape,numel_drape)
738!
739 l_dira = elbuf_tab(ng)%BUFLY(1)%LY_DIRA
740 l_dirb = elbuf_tab(ng)%BUFLY(1)%LY_DIRB
741 ALLOCATE(dira(nlay*nel*l_dira))
742 ALLOCATE(dirb(nlay*nel*l_dirb))
743 dira=zero
744 dirb=zero
745 IF (l_dira == 0) THEN
746 CONTINUE
747 ELSEIF (irep == 0) THEN
748 DO j=1,nlay
749 j1 = 1+(j-1)*l_dira*nel
750 j2 = j*l_dira*nel
751 dira(j1:j2) = elbuf_tab(ng)%BUFLY(j)%DIRA(1:nel*l_dira)
752 ENDDO
753 ENDIF
754 dir_a => dira(1:nlay*nel*l_dira)
755 dir_b => dirb(1:nlay*nel*l_dirb)
756 CALL get_t3lsys(lft ,llt ,ixtg(1,nf1),x ,gbuf%OFF,
757 . irel ,qt ,nlay ,irep ,nel ,
758 . dir_a ,dir_b,elbuf_tab(ng))
759C
760C pre counting of all NPTT (especially for PID_51)
761C
762 npt_all = 0
763 DO il=1,nlay
764 npt_all = npt_all + elbuf_tab(ng)%BUFLY(il)%NPTT
765 ENDDO
766 mpt = max(1,npt_all)
767 IF (iparg(6,ng) == 0) mpt=0
768C
769c------- loop over 3 node shell elements
770C
771 DO i=lft,llt
772 n = i + nft
773 iprt=iparttg(n)
774 IF (ipart_state(iprt) == 0) cycle
775 jj = jj + 1
776 IF (mlw /= 0 .AND. mlw /= 13) THEN
777 wa(jj) = gbuf%OFF(i)
778 ELSE
779 wa(jj) = zero
780 ENDIF
781 jj = jj + 1
782 wa(jj) = iprt
783 jj = jj + 1
784 wa(jj) = ixtg(nixtg,n)
785 jj = jj + 1
786 wa(jj) = mpt
787 jj = jj + 1
788 wa(jj) = npg
789 jj = jj + 1
790 IF (mlw /= 0 .AND. mlw /= 13) THEN
791 wa(jj) = thk0(i)
792 thkq = wa(jj)
793 ELSE
794 wa(jj) = zero
795 thkq = gbuf%THK(i)
796 ENDIF
797 jj = jj + 1
798 IF (mlw /= 0 .AND. mlw /= 13) THEN
799 wa(jj) = gbuf%EINT(i)
800 ELSE
801 wa(jj) = zero
802 ENDIF
803 jj = jj + 1
804 IF (mlw /= 0 .AND. mlw /= 13) THEN
805 wa(jj) = gbuf%EINT(i+llt)
806 ELSE
807 wa(jj) = zero
808 ENDIF
809 jj = jj + 1
810 wa(jj) = zero
811 jj = jj + 1
812 wa(jj) = zero
813 jj = jj + 1
814 wa(jj) = zero
815c----
816 IF (mpt == 0) THEN ! global integration
817 IF (mlw == 0 .or. mlw == 13) THEN
818 DO ipg=1,npg
819 DO j=1,13
820 jj = jj + 1
821 wa(jj) = zero
822 ENDDO
823 ENDDO
824 ELSEIF (npg == 1) THEN
825 tens(1:5) = gbuf%FOR(kk(1:5)+i)
826 CALL shell2g(tens,qt(1,i))
827 DO j =1,6
828 jj = jj + 1
829 wa(jj) = tens(j)
830 END DO
831c
832 tens(1:3) = gbuf%MOM(kk(1:3)+i)
833 CALL sheml2g(tens,qt(1,i))
834 DO j =1,6
835 jj = jj + 1
836 wa(jj) = tens(j)
837 END DO
838c
839 jj = jj + 1
840 IF (gbuf%G_PLA > 0) THEN
841 wa(jj) = gbuf%PLA(i)
842 ELSE
843 wa(jj) = zero
844 ENDIF
845 ELSE
846 DO ipg=1,npg
847 lbuf => elbuf_tab(ng)%BUFLY(1)%LBUF(ipg,1,1)
848 k = (ipg-1)*nel*5
849C
850 tens(1:5) = gbuf%FORPG(k+kk(1:5)+i)
851 CALL shell2g(tens,qt(1,i))
852 DO j =1,6
853 jj = jj + 1
854 wa(jj) = tens(j)
855 END DO
856c
857 jj = jj + 1
858 IF (gbuf%G_PLA > 0) THEN
859 wa(jj) = lbuf%PLA(i)
860 ELSE
861 wa(jj) = zero
862 ENDIF
863c
864 k = (ipg-1)*nel*3
865 tens(1:3) = gbuf%MOMPG(k+kk(1:3)+i)
866 CALL sheml2g(tens,qt(1,i))
867 DO j =1,6
868 jj = jj + 1
869 wa(jj) = tens(j)
870 END DO
871 ENDDO
872 ENDIF ! IF (MLW == 0 .or. MLW == 13)
873 ELSE ! MPT > 0
874 IF (mlw == 0 .or. mlw == 13) THEN
875 DO k=1,mpt
876 DO ipg=1,npg
877 DO j=1,8
878 jj = jj + 1
879 wa(jj) = zero
880 ENDDO
881 ENDDO
882 ENDDO
883 ELSE
884 ipt_all = 0
885 DO il = 1,nlay
886 bufly => elbuf_tab(ng)%BUFLY(il)
887 ilaw = bufly%ILAW
888 nptt = bufly%NPTT
889 jdir = 1 + (il-1)*nel*2
890 ii = jdir + i-1
891 DO it=1,nptt
892 ipt = ipt_all + it
893 DO ipg=1,npg
894 lbuf => bufly%LBUF(ipg,1,it)
895 tens(1:5) = lbuf%SIG(kk(1:5)+i)
896 CALL orth2loc(tens,dir_a,dir_b,ii,ilaw,igtyp,nel)
897 CALL shell2g(tens,qt(1,i))
898 DO j =1,6
899 jj = jj + 1
900 wa(jj) = tens(j)
901 END DO
902 jj = jj + 1
903 IF (bufly%L_PLA > 0) THEN
904 wa(jj) = lbuf%PLA(i)
905 ELSE
906 wa(jj) = zero
907 ENDIF
908 jj = jj + 1
909 wa(jj) = posly(i,ipt)*two
910 ENDDO !IPG=1,NPG
911 ENDDO
912 ipt_all = ipt_all + nptt
913 ENDDO
914 ENDIF ! IF (MLW == 0 .or. MLW == 13)
915 ENDIF ! IF (mpt == 0)
916C
917 ie=ie+1
918C end-of-zone pointer
919 ptwa(ie)=jj
920 ENDDO ! DO I=LFT,LLT
921
922 IF(ALLOCATED(dirb)) DEALLOCATE(dirb)
923 IF(ALLOCATED(dira)) DEALLOCATE(dira)
924 DEALLOCATE(matly, thkly, posly, thk_ly)
925 ENDIF ! IF (ITY == 7)
926 ENDDO ! DO NG=1,NGROUP
927C
928 300 CONTINUE
929c-----------------------------------------------------------------------
930 IF (nspmd == 1) THEN
931 len=jj
932 DO j=1,len
933 wap0(j)=wa(j)
934 ENDDO
935 ptwa_p0(0)=0
936 DO n=1,stat_numeltg
937 ptwa_p0(n)=ptwa(n)
938 ENDDO
939 ELSE
940C builds the pointers in the global array wap0
941 CALL spmd_stat_pgather(ptwa,stat_numeltg,ptwa_p0,stat_numeltg_g)
942 len = 0
943 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
944 ENDIF
945
946 IF (ispmd == 0.AND.len > 0) THEN
947 iprt0=0
948 DO n=1,stat_numeltg_g
949C find the nieme elt in the order of an increasing id
950 k=stat_indxtg(n)
951C Find the address in WAP0
952 j=ptwa_p0(k-1)
953C
954 ioff = nint(wap0(j + 1))
955 IF (ioff >= 1) THEN
956 iprt = nint(wap0(j + 2))
957 IF (iprt /= iprt0) THEN
958 IF (izipstrs == 0) THEN
959 WRITE(iugeo,'(A)') delimit
960 WRITE(iugeo,'(A)')'/INISH3/STRS_F/GLOB'
961 WRITE(iugeo,'(A)')
962 .'#------------------------ REPEAT --------------------------'
963 WRITE(iugeo,'(A)')
964 . '# SH3NID NPT NPG THK'
965 WRITE(iugeo,'(A)')
966 .'# EM, EB, H1, H2, H3'
967 WRITE(iugeo,'(A/A/A/A/A)')
968 .'# IF(NPT == 0), REPEAT I=1,NPG :',
969 .'# N1, N2, N3',
970 .'# N12,N23,N31',
971 .'# M1, M2, M3 ',
972 .'# M12,M23,M31,EPSP '
973 WRITE(iugeo,'(A/A/A)')
974 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :',
975 .'# S1, S2, S3 ',
976 .'# S12,S23,S31, EPSP, T '
977 WRITE(iugeo,'(a)')
978 .'#---------------------- END REPEAT ------------------------'
979 WRITE(iugeo,'(A)') delimit
980 ELSE
981 WRITE(line,'(A)') delimit
982 CALL strs_txt50(line,100)
983 WRITE(line,'(A)')'/INISH3/STRS_F/GLOB'
984 CALL strs_txt50(line,100)
985 WRITE(line,'(A)')
986 .'#------------------------ REPEAT --------------------------'
987 CALL strs_txt50(line,100)
988 WRITE(line,'(A)')
989 . '# SH3NID NPT NPG THK'
990 CALL strs_txt50(line,100)
991 WRITE(line,'(A)')
992 .'# EM, EB, H1, H2, H3'
993 CALL strs_txt50(line,100)
994 WRITE(line,'(A)')
995 .'# IF(NPT == 0), REPEAT I=1,NPG :'
996 CALL strs_txt50(line,100)
997 WRITE(line,'(A)')'# N1, N2, N3'
998 CALL strs_txt50(line,100)
999 WRITE(line,'(A)')'# N12, N23, N31'
1000 CALL strs_txt50(line,100)
1001 WRITE(line,'(A)')'# M1, M2, M3 '
1002 CALL strs_txt50(line,100)
1003 WRITE(line,'(A)')'# M12, M23, M31,EPSP '
1004 CALL strs_txt50(line,100)
1005 WRITE(line,'(A)')
1006 .'# IF(NPT /= 0) REPEAT K=1,NPT : REPEAT I=1,NPG :'
1007 CALL strs_txt50(line,100)
1008 WRITE(line,'(A)')'# S1, S2, S3 '
1009 CALL strs_txt50(line,100)
1010 WRITE(line,'(A)')'# S12, S23, S31, EPSP, T '
1011 CALL strs_txt50(line,100)
1012 WRITE(line,'(A)')
1013 .'#---------------------- END REPEAT ------------------------'
1014 CALL strs_txt50(line,100)
1015 WRITE(line,'(A)') delimit
1016 CALL strs_txt50(line,100)
1017 ENDIF ! IF (IZIPSTRS == 0)
1018 iprt0=iprt
1019 ENDIF ! IF (IPRT /= IPRT0)
1020 id = nint(wap0(j + 3))
1021 npt = nint(wap0(j + 4))
1022 npg = nint(wap0(j + 5))
1023 thk = wap0(j + 6)
1024 em = wap0(j + 7)
1025 eb = wap0(j + 8)
1026 h1 = wap0(j + 9)
1027 h2 = wap0(j + 10)
1028 h3 = wap0(j + 11)
1029 j = j + 11
1030 IF (izipstrs == 0) THEN
1031 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
1032 WRITE(iugeo,'(1P5E20.13)')em,eb,h1,h2,h3
1033 ELSE
1034 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
1035 CALL strs_txt50(line,100)
1036 WRITE(line,'(1P5E20.13)')em,eb,h1,h2,h3
1037 CALL strs_txt50(line,100)
1038 ENDIF
1039 IF (npt == 0) THEN
1040 DO ipg=1,npg
1041 IF (izipstrs == 0) THEN
1042 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,9)
1043 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=10,13)
1044 ELSE
1045 CALL tab_strs_txt50(wap0(1),9,j,sizp0,3)
1046 CALL tab_strs_txt50(wap0(10),4,j,sizp0,4)
1047 ENDIF
1048 j = j + 13
1049 ENDDO
1050 ELSE
1051 DO it=1,npt
1052 DO ipg=1,npg
1053 IF (izipstrs == 0) THEN
1054 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
1055 WRITE(iugeo,'(1P5E20.13)')(wap0(j + k),k=4,8)
1056 ELSE
1057 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
1058 CALL tab_strs_txt50(wap0(4),5,j,sizp0,5)
1059 ENDIF
1060 j = j + 8
1061 END DO
1062 END DO
1063 ENDIF ! IF (NPT == 0)
1064 ENDIF ! IF (IOFF >= 1)
1065 ENDDO ! DO N=1,STAT_NUMELTG_G
1066 ENDIF ! IF (ISPMD == 0.AND.LEN > 0)
1067
1068C
1069c----------
1070 DEALLOCATE(ptwa)
1071 DEALLOCATE(ptwa_p0)
1072c-----------
1073 RETURN
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
id
initmumps id
Definition multiplerhs_example.m:4
drape_mod
Definition drape_mod.F:54
drape_mod::numeltg_drape
integer numeltg_drape
Definition drape_mod.F:92
drape_mod::scdrape
integer scdrape
Definition drape_mod.F:92
drape_mod::stdrape
integer stdrape
Definition drape_mod.F:92
drape_mod::numelc_drape
integer numelc_drape
Definition drape_mod.F:92
stack_mod
Definition stack_mod.F:75
spmd_rgather9_dp
subroutine spmd_rgather9_dp(v, len, vp0, lenp0, iad)
Definition spmd_outp.F:1019
spmd_stat_pgather
subroutine spmd_stat_pgather(ptv, ptlen, ptv_p0, ptlen_p0)
Definition spmd_stat.F:53
get_q4lsys
subroutine get_q4lsys(jft, jlt, ixc, x, offg, irel, vq, nlay, irep, nel, dir_a, dir_b, elbuf_str)
Definition sta_c_get_q4lsys.F:37
get_t3lsys
subroutine get_t3lsys(jft, jlt, ixtg, x, offg, irel, vq, nlay, irep, nel, dir_a, dir_b, elbuf_str)
Definition sta_c_get_t3lsys.F:37
strs_txt50
subroutine strs_txt50(text, length)
Definition sta_txt.F:87
tab_strs_txt50
subroutine tab_strs_txt50(wap0, cpt, j, sizp0, nbpline)
Definition sta_txt.F:127
shell2g
subroutine shell2g(eps, qt)
Definition stat_c_strafg.F:899
sheml2g
subroutine sheml2g(mom, qt)
Definition stat_c_strsfg.F:1212
orth2loc
subroutine orth2loc(tens, dir_a, dir_b, ii, ilaw, igtyp, nel)
Definition stat_c_strsfg.F:1088

◆ urotovs()

subroutine urotovs ( sig,
dir1,
dir2 )

Definition at line 1172 of file stat_c_strsfg.F.

1173C-----------------------------------------------
1174C I m p l i c i t T y p e s
1175C-----------------------------------------------
1176#include "implicit_f.inc"
1177C-----------------------------------------------
1178C D u m m y A r g u m e n t s
1179C-----------------------------------------------
1180 my_real
1181 . sig(5), dir1,dir2
1182C-----------------------------------------------
1183C L o c a l V a r i a b l e s
1184C-----------------------------------------------
1185
1186 my_real
1187 . s1, s2, s3, s4, s5
1188C-----------------------------------------------
1189 s1 = dir1*dir1*sig(1)
1190 . + dir2*dir2*sig(2)-two*dir1*dir2*sig(3)
1191 s2 = dir2*dir2*sig(1)
1192 . + dir1*dir1*sig(2)+two*dir2*dir1*sig(3)
1193 s3 = dir1*dir2*sig(1)
1194 . - dir2*dir1*sig(2)
1195 . +(dir1*dir1-dir2*dir2)*sig(3)
1196 s4 = dir2*sig(5)+dir1*sig(4)
1197 s5 = dir1*sig(5)-dir2*sig(4)
1198 sig(1)=s1
1199 sig(2)=s2
1200 sig(3)=s3
1201 sig(4)=s4
1202 sig(5)=s5
1203C
1204 RETURN