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

Go to the source code of this file.

Functions/Subroutines

subroutine stat_c_strafg (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 get_q4l (jft, jlt, ixc, x, offg, irel, vq)
subroutine get_t3l (jft, jlt, ixtg, x, offg, irel, vq)
subroutine shell2g (eps, qt)

Function/Subroutine Documentation

◆ get_q4l()

subroutine get_q4l ( integer jft,
integer jlt,
integer, dimension(nixc,*) ixc,
x,
offg,
integer irel,
vq )

Definition at line 762 of file stat_c_strafg.F.

764 use element_mod , only : nixc
765C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
766#include "implicit_f.inc"
767c-----------------------------------------------
768c g l o b a l p a r a m e t e r s
769c-----------------------------------------------
770#include "mvsiz_p.inc"
771C-----------------------------------------------
772C D U M M Y A R G U M E N T S
773C-----------------------------------------------
774 INTEGER IXC(NIXC,*),JFT,JLT,IREL
775 my_real
776 . x(3,*), offg(*),vq(3,3,mvsiz)
777C-----------------------------------------------
778C L O C A L V A R I A B L E S
779C-----------------------------------------------
780 INTEGER I
781 INTEGER IXCTMP2,IXCTMP3,IXCTMP4,IXCTMP5
782 my_real
783 . rx(mvsiz),ry(mvsiz),rz(mvsiz),sx(mvsiz),sy(mvsiz),
784 . r11(mvsiz),r12(mvsiz),r13(mvsiz),r21(mvsiz),r22(mvsiz),
785 . r23(mvsiz),r31(mvsiz),r32(mvsiz),r33(mvsiz),
786 . sz(mvsiz),deta1(mvsiz)
787C----------------------------------------------
788 DO i=jft,jlt
789 ixctmp2=ixc(2,i)
790 ixctmp3=ixc(3,i)
791 ixctmp4=ixc(4,i)
792 ixctmp5=ixc(5,i)
793
794 rx(i)=x(1,ixctmp3)+x(1,ixctmp4)-x(1,ixctmp2)-x(1,ixctmp5)
795 sx(i)=x(1,ixctmp4)+x(1,ixctmp5)-x(1,ixctmp2)-x(1,ixctmp3)
796 ry(i)=x(2,ixctmp3)+x(2,ixctmp4)-x(2,ixctmp2)-x(2,ixctmp5)
797 sy(i)=x(2,ixctmp4)+x(2,ixctmp5)-x(2,ixctmp2)-x(2,ixctmp3)
798 rz(i)=x(3,ixctmp3)+x(3,ixctmp4)-x(3,ixctmp2)-x(3,ixctmp5)
799 sz(i)=x(3,ixctmp4)+x(3,ixctmp5)-x(3,ixctmp2)-x(3,ixctmp3)
800 ENDDO
801C----------------------------
802C LOCAL SYSTEM
803C----------------------------
804 CALL clskew3(jft,jlt,irel,
805 . rx, ry, rz,
806 . sx, sy, sz,
807 . r11,r12,r13,r21,r22,r23,r31,r32,r33,deta1,offg )
808 DO i=jft,jlt
809 vq(1,1,i)=r11(i)
810 vq(2,1,i)=r21(i)
811 vq(3,1,i)=r31(i)
812 vq(1,2,i)=r12(i)
813 vq(2,2,i)=r22(i)
814 vq(3,2,i)=r32(i)
815 vq(1,3,i)=r13(i)
816 vq(2,3,i)=r23(i)
817 vq(3,3,i)=r33(i)
818 ENDDO
819C
820 RETURN
clskew3
subroutine clskew3(jft, jlt, irep, rx, ry, rz, sx, sy, sz, e1x, e2x, e3x, e1y, e2y, e3y, e1z, e2z, e3z, det)
Definition clskew.F:34
my_real
#define my_real
Definition cppsort.cpp:32

◆ get_t3l()

subroutine get_t3l ( integer jft,
integer jlt,
integer, dimension(nixtg,*) ixtg,
x,
offg,
integer irel,
vq )

Definition at line 832 of file stat_c_strafg.F.

834 use element_mod , only : nixtg
835C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
836#include "implicit_f.inc"
837c-----------------------------------------------
838c g l o b a l p a r a m e t e r s
839c-----------------------------------------------
840#include "mvsiz_p.inc"
841C-----------------------------------------------
842C D U M M Y A R G U M E N T S
843C-----------------------------------------------
844 INTEGER IXTG(NIXTG,*),JFT,JLT,IREL
845 my_real
846 . x(3,*), offg(*),vq(3,3,mvsiz)
847C-----------------------------------------------
848C L O C A L V A R I A B L E S
849C-----------------------------------------------
850 INTEGER I
851 INTEGER I2,I3,I1
852 my_real
853 . rx(mvsiz),ry(mvsiz),rz(mvsiz),sx(mvsiz),sy(mvsiz),
854 . r11(mvsiz),r12(mvsiz),r13(mvsiz),r21(mvsiz),r22(mvsiz),
855 . r23(mvsiz),r31(mvsiz),r32(mvsiz),r33(mvsiz),
856 . sz(mvsiz),deta1(mvsiz)
857C----------------------------------------------
858 DO i=jft,jlt
859 i1=ixtg(2,i)
860 i2=ixtg(3,i)
861 i3=ixtg(4,i)
862
863 rx(i)=x(1,i2)-x(1,i1)
864 ry(i)=x(2,i2)-x(2,i1)
865 rz(i)=x(3,i2)-x(3,i1)
866 sx(i)=x(1,i3)-x(1,i1)
867 sy(i)=x(2,i3)-x(2,i1)
868 sz(i)=x(3,i3)-x(3,i1)
869 ENDDO
870C----------------------------
871C LOCAL SYSTEM
872C----------------------------
873 CALL clskew3(jft,jlt,irel,
874 . rx, ry, rz,
875 . sx, sy, sz,
876 . r11,r12,r13,r21,r22,r23,r31,r32,r33,deta1,offg )
877 DO i=jft,jlt
878 vq(1,1,i)=r11(i)
879 vq(2,1,i)=r21(i)
880 vq(3,1,i)=r31(i)
881 vq(1,2,i)=r12(i)
882 vq(2,2,i)=r22(i)
883 vq(3,2,i)=r32(i)
884 vq(1,3,i)=r13(i)
885 vq(2,3,i)=r23(i)
886 vq(3,3,i)=r33(i)
887 ENDDO
888C
889 RETURN

◆ shell2g()

subroutine shell2g ( eps,
qt )

Definition at line 898 of file stat_c_strafg.F.

899C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
900#include "implicit_f.inc"
901c-----------------------------------------------
902C-----------------------------------------------
903C D u m m y A r g u m e n t s
904C-----------------------------------------------
905 my_real
906 . eps(6),qt(3,3)
907C------------------------------------------------------
908C L o c a l V a r i a b l e s
909C-----------------------------------------------
910
911 my_real
912 . txx,tyy,tzz,txy,tyz,tzx,uxx,uyy,uzz,uxy,uyz,uzx,a,b,c
913C-Input EPS convention: Exx, Eyy, Exy, Eyz, Ezx, 0;Output Exx, Eyy, Ezz, Exy, Eyz, Ezx
914 txx = eps(1)
915 tyy = eps(2)
916 tzz = zero
917 txy = eps(3)
918 tyz = eps(4)
919 tzx = eps(5)
920C
921 a = qt(1,1)*txx + qt(1,2)*txy + qt(1,3)*tzx
922 b = qt(1,1)*txy + qt(1,2)*tyy + qt(1,3)*tyz
923 c = qt(1,1)*tzx + qt(1,2)*tyz + qt(1,3)*tzz
924 uxx = a*qt(1,1) + b*qt(1,2) + c*qt(1,3)
925 uxy = a*qt(2,1) + b*qt(2,2) + c*qt(2,3)
926 uzx = a*qt(3,1) + b*qt(3,2) + c*qt(3,3)
927 a = qt(2,1)*txx + qt(2,2)*txy + qt(2,3)*tzx
928 b = qt(2,1)*txy + qt(2,2)*tyy + qt(2,3)*tyz
929 c = qt(2,1)*tzx + qt(2,2)*tyz + qt(2,3)*tzz
930 uyy = a*qt(2,1) + b*qt(2,2) + c*qt(2,3)
931 uyz = a*qt(3,1) + b*qt(3,2) + c*qt(3,3)
932 a = qt(3,1)*txx + qt(3,2)*txy + qt(3,3)*tzx
933 b = qt(3,1)*txy + qt(3,2)*tyy + qt(3,3)*tyz
934 c = qt(3,1)*tzx + qt(3,2)*tyz + qt(3,3)*tzz
935 uzz = a*qt(3,1) + b*qt(3,2) + c*qt(3,3)
936C
937 eps(1) = uxx
938 eps(2) = uyy
939 eps(3) = uzz
940 eps(4) = uxy
941 eps(5) = uyz
942 eps(6) = uzx
943C
944 RETURN

◆ stat_c_strafg()

subroutine stat_c_strafg ( 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 43 of file stat_c_strafg.F.

48C-----------------------------------------------
49C M o d u l e s
50C-----------------------------------------------
51 USE elbufdef_mod
52 USE stack_mod
53 USE drape_mod
54 USE my_alloc_mod
55 use element_mod , only : nixc,nixtg
56C-----------------------------------------------
57C I m p l i c i t T y p e s
58C-----------------------------------------------
59#include "implicit_f.inc"
60C-----------------------------------------------
61C C o m m o n B l o c k s
62C-----------------------------------------------
63#include "mvsiz_p.inc"
64#include "com01_c.inc"
65#include "com04_c.inc"
66#include "param_c.inc"
67#include "units_c.inc"
68#include "scr14_c.inc"
69#include "scr16_c.inc"
70#include "task_c.inc"
71C-----------------------------------------------
72C D u m m y A r g u m e n t s
73C-----------------------------------------------
74 INTEGER SIZP0
75 INTEGER IXC(NIXC,*),IXTG(NIXTG,*),
76 . IPARG(NPARG,*),IPM(NPROPMI,*),IGEO(NPROPGI,*),
77 . IPARTC(*), IPARTTG(*), IPART_STATE(*),
78 . STAT_INDXC(*), STAT_INDXTG(*)
79 my_real
80 . thke(*),x(3,*),geo(*)
81 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
82 TYPE (STACK_PLY) :: STACK
83 TYPE (DRAPE_) :: DRAPE_SH4N(NUMELC_DRAPE), DRAPE_SH3N(NUMELTG_DRAPE)
84 TYPE (DRAPEG_) :: DRAPEG
85 double precision WA(*),WAP0(*)
86C-----------------------------------------------
87C L o c a l V a r i a b l e s
88C-----------------------------------------------
89 INTEGER I, J, K, N, JJ, LEN, IOFF, NG, NEL, NFT, ITY, LFT, NPT,
90 . LLT, MLW, ISTRAIN,ID, IPRT0, IPRT,NPG,IPG,IE,NPTR,NPTS,G_STRA,
91 . ITHK,KK(8),NF1,IGTYP,IREL,IHBE,NLAY,IBID0,MAT_1,PID_1,ILAY,NF3,
92 . SEDRAPE,NUMEL_DRAPE
93 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA
94 INTEGER,DIMENSION(:),ALLOCATABLE :: PTWA_P0
95 double precision
96 . THK, EM, EB, H1, H2, H3
97 CHARACTER*100 DELIMIT,LINE
98 TYPE(G_BUFEL_) ,POINTER :: GBUF
99
100 TYPE(BUF_LAY_) ,POINTER :: BUFLY
101 INTEGER LAYNPT_MAX,NLAY_MAX,ISUBSTACK,IPT_ALL,NPTT,IT,IPT,NPT_ALL,MPT
102 my_real,
103 . DIMENSION(:),POINTER :: strain
104 my_real
105 . qt(9,mvsiz),straing(6),zh,thkp ,thk0(mvsiz)
106 INTEGER, DIMENSION(:) , ALLOCATABLE :: MATLY
107 my_real, DIMENSION(:) , ALLOCATABLE :: thkly
108 my_real, DIMENSION(:,:) , ALLOCATABLE :: posly,thk_ly
109
110C-----------------------------------------------
111 DATA delimit(1:60)
112 ./'#---1----|----2----|----3----|----4----|----5----|----6----|'/
113 DATA delimit(61:100)
114 ./'----7----|----8----|----9----|----10---|'/
115C-----------------------------------------------
116C 4-NODE SHELLS
117C-----------------------------------------------
118 CALL my_alloc(ptwa,max(stat_numelc ,stat_numeltg))
119 ALLOCATE(ptwa_p0(0:max(1,stat_numelc_g,stat_numeltg_g)))
120C-----------------------------------------------
121 jj = 0
122 IF(stat_numelc==0) GOTO 200
123
124 ie=0
125 DO ng=1,ngroup
126 ity =iparg(5,ng)
127 IF (ity == 3) THEN
128 gbuf => elbuf_tab(ng)%GBUF
129 mlw =iparg(1,ng)
130 nel =iparg(2,ng)
131 nft =iparg(3,ng)
132 npt = iparg(6,ng)
133 ithk =iparg(28,ng)
134 nptr = elbuf_tab(ng)%NPTR
135 npts = elbuf_tab(ng)%NPTS
136 nlay = elbuf_tab(ng)%NLAY
137 ihbe =iparg(23,ng)
138 igtyp= iparg(38,ng)
139 isubstack=iparg(71,ng)
140 npg = nptr*npts
141 IF (ihbe == 23 .AND. gbuf%G_STRPG>gbuf%G_STRA) npg=4
142 IF (ihbe == 23 .AND. npg/=4) cycle
143 lft=1
144 llt=nel
145 g_stra = gbuf%G_STRA
146 nf1 = nft+1
147 IF (ihbe>10.OR.igtyp==16.OR.ishfram ==0) THEN
148 irel=0
149 ELSEIF (ishfram ==1) THEN
150 irel=2
151 ELSE
152 irel=1
153 END IF
154!
155 DO j=1,8 ! length max of GBUF%G_STRA = 8
156 kk(j) = nel*(j-1)
157 ENDDO
158!
159 ibid0 = 0
160 mat_1 = ixc(1,nf1)
161 pid_1 = ixc(6,nf1)
162 IF (ithk >0 ) THEN
163 thk0(lft:llt) = gbuf%THK(lft:llt)
164 ELSE
165 thk0(lft:llt) = thke(lft+nft:llt+nft)
166 END IF
167 ! Npt_max
168 laynpt_max = 1
169 IF(igtyp == 51 .OR. igtyp == 52) THEN
170 DO ilay=1, nlay
171 laynpt_max = max(laynpt_max , elbuf_tab(ng)%BUFLY(ilay)%NPTT)
172 ENDDO
173 ENDIF
174 nlay_max = max(nlay,npt, elbuf_tab(ng)%NLAY)
175 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
176 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
177 matly = 0
178 thkly = zero
179 posly = zero
180 thk_ly = zero
181 numel_drape = numelc_drape
182 sedrape = scdrape
183 CALL layini(elbuf_tab(ng),lft ,llt ,geo ,igeo ,
184 . mat_1 ,pid_1 ,thkly ,matly ,posly ,
185 . igtyp ,ibid0 ,ibid0 ,nlay ,npt ,
186 . isubstack,stack ,drape_sh4n ,nft ,thke ,
187 . nel ,thk_ly ,drapeg%INDX_SH4N ,sedrape,numel_drape)
188 CALL get_q4l(lft ,llt ,ixc(1,nf1),x ,gbuf%OFF,irel ,qt )
189 npt_all = 0
190 DO ilay=1,nlay
191 npt_all = npt_all + elbuf_tab(ng)%BUFLY(ilay)%NPTT
192 ENDDO
193 mpt = max(1,npt_all)
194 IF (npt==0) mpt=0
195c--------------------
196 DO i=lft,llt
197 n = i + nft
198
199 iprt=ipartc(n)
200 IF(ipart_state(iprt)==0)cycle
201
202 jj = jj + 1
203 IF (mlw /= 0 .AND. mlw /= 13) THEN
204 wa(jj) = gbuf%OFF(i)
205 ELSE
206 wa(jj) = zero
207 ENDIF
208 jj = jj + 1
209 wa(jj) = iprt
210 jj = jj + 1
211 wa(jj) = ixc(nixc,n)
212 jj = jj + 1
213C----
214 wa(jj) = mpt
215 jj = jj + 1
216 wa(jj) = npg
217 jj = jj + 1
218 IF (mlw /= 0 .AND. mlw /= 13) THEN
219 wa(jj) = thk0(i)
220 ELSE
221 wa(jj) = zero
222 ENDIF
223 thkp = wa(jj)
224c Strain in Gauss points
225 IF (mlw == 0 .or. mlw == 13) THEN
226 DO ipg=1,npg
227 DO j=1,14
228 jj = jj + 1
229 wa(jj)=zero
230 END DO
231 END DO
232 ELSEIF (npt==0 .AND. g_stra /= 0) THEN
233 IF (npg > 1) THEN
234 strain => gbuf%STRPG
235 ELSE
236 strain => gbuf%STRA
237 ENDIF
238C------first point Z=0 7 real to print npg w/ QEPH
239 DO ipg=1,npg
240 k = (ipg-1)*nel*g_stra
241 straing(1:2)=strain(kk(1:2)+i+k)
242 straing(3:5)=half*strain(kk(3:5)+i+k)
243 CALL shell2g(straing,qt(1,i))
244C
245 DO j=1,6
246 jj = jj + 1
247 wa(jj) = straing(j)
248 END DO
249 jj = jj + 1
250 wa(jj) = zero
251 END DO
252C------2nd point Z=0.5-> 1.0(LSD) 7 real
253 DO ipg=1,npg
254 k = (ipg-1)*nel*g_stra
255 zh = half*thkp
256 straing(1:3)=strain(kk(1:3)+i+k)+zh*strain(kk(6:8)+i+k)
257 straing(3)=half*straing(3)
258 straing(4:5)=half*strain(kk(4:5)+i+k)
259 CALL shell2g(straing,qt(1,i))
260C
261 DO j=1,6
262 jj = jj + 1
263 wa(jj) = straing(j)
264 END DO
265 jj = jj + 1
266 wa(jj) = one
267 END DO
268 ELSEIF (g_stra /= 0) THEN
269 IF (npg > 1) THEN
270 strain => gbuf%STRPG
271 ELSE
272 strain => gbuf%STRA
273 ENDIF
274 ipt_all = 0
275 DO ilay =1,nlay
276 bufly => elbuf_tab(ng)%BUFLY(ilay)
277 nptt = bufly%NPTT
278 DO it=1,nptt
279 ipt = ipt_all + it
280C--
281 DO ipg=1,npg
282 k = (ipg-1)*nel*g_stra
283 zh = posly(i,ipt)*thkp
284 straing(1:3)=strain(kk(1:3)+i+k)+zh*strain(kk(6:8)+i+k)
285 straing(3)=half*straing(3)
286 straing(4:5)=half*strain(kk(4:5)+i+k)
287 CALL shell2g(straing,qt(1,i))
288C
289 DO j=1,6
290 jj = jj + 1
291 wa(jj) = straing(j)
292 END DO
293 jj = jj + 1
294 wa(jj) = posly(i,ipt)*two
295 END DO
296 END DO !IT=1,NPTT
297 ipt_all = ipt_all + nptt
298 END DO !ILAY =1,NLAY
299 END IF
300
301 ie=ie+1
302C end-of-zone pointer in wa
303 ptwa(ie)=jj
304c
305 ENDDO ! I=LFT,LLT
306 DEALLOCATE(matly, thkly, posly, thk_ly)
307 END IF ! ITY==3
308 ENDDO ! NG=1,NGROUP
309
310 200 CONTINUE
311
312 IF(nspmd == 1)THEN
313 ptwa_p0(0)=0
314 DO n=1,stat_numelc
315 ptwa_p0(n)=ptwa(n)
316 END DO
317 len=jj
318 DO j=1,len
319 wap0(j)=wa(j)
320 END DO
321 ELSE
322C builds the pointers in the global wap0 array
323 CALL spmd_stat_pgather(ptwa,stat_numelc,ptwa_p0,stat_numelc_g)
324 len = 0
325 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
326 END IF
327
328 IF(ispmd==0.AND.len>0) THEN
329
330 iprt0=0
331 DO n=1,stat_numelc_g
332
333C find the nieme elt in the order of an increasing id
334 k=stat_indxc(n)
335C Find the address in WAP0
336 j=ptwa_p0(k-1)
337
338 ioff = nint(wap0(j + 1))
339 IF(ioff >= 1)THEN
340 iprt = nint(wap0(j + 2))
341 IF(iprt /= iprt0)THEN
342 IF (izipstrs == 0) THEN
343 WRITE(iugeo,'(A)') delimit
344 WRITE(iugeo,'(A)')'/INISHE/STRA_F/GLOB'
345 WRITE(iugeo,'(A)')
346 .'#------------------------ REPEAT --------------------------'
347 WRITE(iugeo,'(A)')
348 . '# SHELLID NPT NPG THK'
349 WRITE(iugeo,'(A/A/A)')
350 .'# REPEAT I=1,NPG :',
351 .'# E11, E22, E33,',
352 .'# E12, E23, E31, T,'
353 WRITE(iugeo,'(A)')
354 .'#---------------------- END REPEAT ------------------------'
355 WRITE(iugeo,'(A)') delimit
356 ELSE
357 WRITE(line,'(A)') delimit
358 CALL strs_txt50(line,100)
359 WRITE(line,'(A)')'/INISHE/STRA_F/GLOB'
360 CALL strs_txt50(line,100)
361 WRITE(line,'(A)')
362 .'#------------------------ REPEAT --------------------------'
363 CALL strs_txt50(line,100)
364 WRITE(line,'(A)')
365 . '# SHELLID NPT NPG THK'
366 CALL strs_txt50(line,100)
367 WRITE(line,'(A)')'# REPEAT I=1,NPG :'
368 CALL strs_txt50(line,100)
369 WRITE(line,'(A)')'# E11, E22, E33,'
370 CALL strs_txt50(line,100)
371 WRITE(line,'(A)')'# E12, E23, E31, T '
372 CALL strs_txt50(line,100)
373 WRITE(line,'(A)')
374 .'#---------------------- END REPEAT ------------------------'
375 CALL strs_txt50(line,100)
376 WRITE(line,'(A)') delimit
377 CALL strs_txt50(line,100)
378 ENDIF
379 iprt0=iprt
380 END IF
381 id = nint(wap0(j + 3))
382 npt = nint(wap0(j + 4))
383 npg = nint(wap0(j + 5))
384 thk = wap0(j + 6)
385 j = j + 6
386 IF (izipstrs == 0) THEN
387 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
388 ELSE
389 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
390 CALL strs_txt50(line,100)
391 ENDIF
392 IF (npt == 0) THEN
393 DO ipg=1,npg
394 IF (izipstrs == 0) THEN
395 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
396 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=4,7)
397 ELSE
398 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
399 CALL tab_strs_txt50(wap0(4),4,j,sizp0,4)
400 ENDIF
401 j = j + 7
402 END DO
403C----- 2nd point
404 DO ipg=1,npg
405 IF (izipstrs == 0) THEN
406 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
407 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=4,7)
408 ELSE
409 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
410 CALL tab_strs_txt50(wap0(4),4,j,sizp0,4)
411 ENDIF
412 j = j + 7
413 END DO
414 ELSE
415 DO it=1,npt
416 DO ipg=1,npg
417 IF (izipstrs == 0) THEN
418 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
419 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=4,7)
420 ELSE
421 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
422 CALL tab_strs_txt50(wap0(4),4,j,sizp0,4)
423 ENDIF
424 j = j + 7
425 END DO
426 END DO
427 ENDIF
428 END IF
429C
430 ENDDO
431 ENDIF
432C-----------------------------------------------
433C 3-NODE SHELLS
434C-----------------------------------------------
435 jj = 0
436 IF (stat_numeltg==0) GOTO 300
437 ie=0
438
439 DO ng=1,ngroup
440 ity =iparg(5,ng)
441 IF (ity == 7) THEN
442 gbuf => elbuf_tab(ng)%GBUF
443 g_stra = gbuf%G_STRA
444 mlw =iparg(1,ng)
445 nel =iparg(2,ng)
446 nft =iparg(3,ng)
447 npt = iparg(6,ng)
448 ithk = iparg(28,ng)
449 ihbe =iparg(23,ng)
450 igtyp= iparg(38,ng)
451 isubstack=iparg(71,ng)
452 nptr = elbuf_tab(ng)%NPTR
453 npts = elbuf_tab(ng)%NPTS
454 nlay = elbuf_tab(ng)%NLAY
455 npg = nptr*npts
456 lft=1
457 llt=nel
458 nf1 = nft+1
459 IF (ihbe>=30) THEN
460 irel=0
461 ELSE
462 irel=2
463 END IF
464!
465 DO j=1,8 ! length max of GBUF%G_STRA = 8
466 kk(j) = nel*(j-1)
467 ENDDO
468!
469 ibid0 = 0
470 mat_1 = ixtg(1,nf1)
471 pid_1 = ixtg(nixtg-1,nf1)
472 IF (ithk >0 ) THEN
473 thk0(lft:llt) = gbuf%THK(lft:llt)
474 ELSE
475 nf3 = nft+numelc
476 thk0(lft:llt) = thke(lft+nf3:llt+nf3)
477 END IF
478 ! Npt_max
479 laynpt_max = 1
480 IF(igtyp == 51 .OR. igtyp == 52) THEN
481 DO ilay=1, nlay
482 laynpt_max = max(laynpt_max , elbuf_tab(ng)%BUFLY(ilay)%NPTT)
483 ENDDO
484 ENDIF
485 nlay_max = max(nlay,npt, elbuf_tab(ng)%NLAY)
486 ALLOCATE(matly(mvsiz*nlay_max), thkly(mvsiz*nlay_max*laynpt_max),
487 . posly(mvsiz,nlay_max*laynpt_max),thk_ly(nel,nlay_max*laynpt_max))
488 matly = 0
489 thkly = zero
490 posly = zero
491 thk_ly = zero
492 numel_drape = numeltg_drape
493 sedrape = stdrape
494 CALL layini(elbuf_tab(ng),lft ,llt ,geo ,igeo ,
495 . mat_1 ,pid_1 ,thkly ,matly ,posly ,
496 . igtyp ,ibid0 ,ibid0 ,nlay ,npt ,
497 . isubstack,stack ,drape_sh3n ,nft ,thke ,
498 . nel ,thk_ly ,drapeg%INDX_SH3N,sedrape,numel_drape)
499 CALL get_t3l(lft ,llt ,ixtg(1,nf1),x ,gbuf%OFF,
500 . irel ,qt )
501 npt_all = 0
502 DO ilay=1,nlay
503 npt_all = npt_all + elbuf_tab(ng)%BUFLY(ilay)%NPTT
504 ENDDO
505 mpt = max(1,npt_all)
506 IF (npt==0) mpt=0
507c--------------------
508 DO i=lft,llt
509 n = i + nft
510
511 iprt=iparttg(n)
512 IF(ipart_state(iprt)==0)cycle
513
514
515 jj = jj + 1
516 IF (mlw /= 0 .AND. mlw /= 13) THEN
517 wa(jj) = gbuf%OFF(i)
518 ELSE
519 wa(jj) = zero
520 ENDIF
521 jj = jj + 1
522 wa(jj) = iprt
523 jj = jj + 1
524 wa(jj) = ixtg(nixtg,n)
525 jj = jj + 1
526 wa(jj) = mpt
527 jj = jj + 1
528 wa(jj) = npg
529 jj = jj + 1
530 IF (mlw /= 0 .AND. mlw /= 13) THEN
531 wa(jj) = thk0(i)
532 ELSE
533 wa(jj) = zero
534 ENDIF
535 thkp = wa(jj)
536
537c Strain in Gauss points
538 IF (mlw == 0 .or. mlw == 13) THEN
539 DO ipg=1,npg
540 DO j=1,14
541 jj = jj + 1
542 wa(jj) = zero
543 END DO
544 END DO
545 ELSEIF (npt==0 .AND. g_stra /= 0) THEN
546 IF (npg > 1) THEN
547 strain => gbuf%STRPG
548 ELSE
549 strain => gbuf%STRA
550 ENDIF
551C------first point Z=0 7 real
552 DO ipg=1,npg
553 k = (ipg-1)*nel*g_stra
554 straing(1:2)=strain(kk(1:2)+i+k)
555 straing(3:5)=half*strain(kk(3:5)+i+k)
556 CALL shell2g(straing,qt(1,i))
557C
558 DO j=1,6
559 jj = jj + 1
560 wa(jj) = straing(j)
561 END DO
562 jj = jj + 1
563 wa(jj) = zero
564 END DO
565C------2nd point Z=0.5-> 1.0(LSD) 7 real
566 DO ipg=1,npg
567 k = (ipg-1)*nel*g_stra
568 zh = 1.0*thkp
569 straing(1:3)=strain(kk(1:3)+i+k)+zh*strain(kk(6:8)+i+k)
570 straing(3)=half*straing(3)
571 straing(4:5)=half*strain(kk(4:5)+i+k)
572 CALL shell2g(straing,qt(1,i))
573C
574 DO j=1,6
575 jj = jj + 1
576 wa(jj) = straing(j)
577 END DO
578 jj = jj + 1
579 wa(jj) = one
580 END DO
581 ELSEIF (g_stra > 0) THEN
582 IF (npg > 1) THEN
583 strain => gbuf%STRPG
584 ELSE
585 strain => gbuf%STRA
586 ENDIF
587 ipt_all = 0
588 DO ilay =1,nlay
589 bufly => elbuf_tab(ng)%BUFLY(ilay)
590 nptt = bufly%NPTT
591 DO it=1,nptt
592 ipt = ipt_all + it
593C--
594 DO ipg=1,npg
595 k = (ipg-1)*nel*g_stra
596 zh = posly(i,ipt)*thkp
597 straing(1:3)=strain(kk(1:3)+i+k)+zh*strain(kk(6:8)+i+k)
598 straing(3)=half*straing(3)
599 straing(4:5)=half*strain(kk(4:5)+i+k)
600 CALL shell2g(straing,qt(1,i))
601C
602 DO j=1,6
603 jj = jj + 1
604 wa(jj) = straing(j)
605 END DO
606 jj = jj + 1
607 wa(jj) = posly(i,ipt)*two
608 END DO
609 END DO !IT=1,NPTT
610 ipt_all = ipt_all + nptt
611 END DO !ILAY =1,NLAY
612 END IF ! IF (MLW == 0 .or. MLW == 13)
613
614 ie=ie+1
615C end-of-zone pointer
616 ptwa(ie)=jj
617c
618 ENDDO ! I=LFT,LLT
619 DEALLOCATE(matly, thkly, posly, thk_ly)
620 END IF ! ITY==7
621 ENDDO ! NG=1,NGROUP
622
623 300 CONTINUE
624
625 IF(nspmd == 1)THEN
626 len=jj
627 DO j=1,len
628 wap0(j)=wa(j)
629 END DO
630 ptwa_p0(0)=0
631 DO n=1,stat_numeltg
632 ptwa_p0(n)=ptwa(n)
633 END DO
634 ELSE
635C builds the pointers in the global wap0 array
636 CALL spmd_stat_pgather(ptwa,stat_numeltg,ptwa_p0,stat_numeltg_g)
637 len = 0
638 CALL spmd_rgather9_dp(wa,jj,wap0,sizp0,len)
639 END IF
640
641 IF(ispmd==0.AND.len>0) THEN
642
643 iprt0=0
644 DO n=1,stat_numeltg_g
645
646C find the nieme elt in the order of an increasing id
647 k=stat_indxtg(n)
648C Find the address in WAP0
649 j=ptwa_p0(k-1)
650
651 ioff = nint(wap0(j + 1))
652 IF(ioff >= 1)THEN
653 iprt = nint(wap0(j + 2))
654 IF(iprt /= iprt0)THEN
655 IF (izipstrs == 0) THEN
656 WRITE(iugeo,'(A)') delimit
657 WRITE(iugeo,'(A)')'/INISH3/STRA_F/GLOB'
658 WRITE(iugeo,'(A)')
659 .'#------------------------ REPEAT --------------------------'
660 WRITE(iugeo,'(A)')
661 . '# SH3NID NPT NPG THK'
662 WRITE(iugeo,'(A/A/A)')
663 .'# REPEAT I=1,NPG :',
664 .'# E11, E22, E33,',
665 .'# E12, E23, E31, T '
666 WRITE(iugeo,'(A)')
667 .'#---------------------- END REPEAT ------------------------'
668 WRITE(iugeo,'(A)') delimit
669 ELSE
670 WRITE(line,'(A)') delimit
671 CALL strs_txt50(line,100)
672 WRITE(line,'(A)')'/INISH3/STRA_F/GLOB'
673 CALL strs_txt50(line,100)
674 WRITE(line,'(A)')
675 .'#------------------------ REPEAT --------------------------'
676 CALL strs_txt50(line,100)
677 WRITE(line,'(A)')
678 . '# SH3NID NPT NPG THK'
679 CALL strs_txt50(line,100)
680 WRITE(line,'(A)')'# REPEAT I=1,NPG :'
681 CALL strs_txt50(line,100)
682 WRITE(line,'(A)')'# E11, E22, E33,'
683 CALL strs_txt50(line,100)
684 WRITE(line,'(A)')'# E12, E23, E31, T '
685 CALL strs_txt50(line,100)
686 WRITE(line,'(A)')
687 .'#---------------------- END REPEAT ------------------------'
688 CALL strs_txt50(line,100)
689 WRITE(line,'(A)') delimit
690 CALL strs_txt50(line,100)
691 END IF
692 iprt0=iprt
693 END IF
694 id = nint(wap0(j + 3))
695 npt = nint(wap0(j + 4))
696 npg = nint(wap0(j + 5))
697 thk = wap0(j + 6)
698 j = j + 6
699 IF (izipstrs == 0) THEN
700 WRITE(iugeo,'(3I10,1PE20.13)')id,npt,npg,thk
701 ELSE
702 WRITE(line,'(3I10,1PE20.13)')id,npt,npg,thk
703 CALL strs_txt50(line,100)
704 ENDIF
705 IF (npt == 0) THEN
706 DO ipg=1,npg
707 IF (izipstrs == 0) THEN
708 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
709 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=4,7)
710 ELSE
711 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
712 CALL tab_strs_txt50(wap0(4),4,j,sizp0,4)
713 ENDIF
714 j = j + 7
715 END DO
716C----- 2nd point
717 DO ipg=1,npg
718 IF (izipstrs == 0) THEN
719 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
720 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=4,7)
721 ELSE
722 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
723 CALL tab_strs_txt50(wap0(4),4,j,sizp0,4)
724 ENDIF
725 j = j + 7
726 END DO
727 ELSE
728 DO it=1,npt
729 DO ipg=1,npg
730 IF (izipstrs == 0) THEN
731 WRITE(iugeo,'(1P3E20.13)')(wap0(j + k),k=1,3)
732 WRITE(iugeo,'(1P4E20.13)')(wap0(j + k),k=4,7)
733 ELSE
734 CALL tab_strs_txt50(wap0(1),3,j,sizp0,3)
735 CALL tab_strs_txt50(wap0(4),4,j,sizp0,4)
736 ENDIF
737 j = j + 7
738 END DO
739 END DO
740 ENDIF
741 END IF
742
743 ENDDO
744 ENDIF
745
746c----------
747 DEALLOCATE(ptwa)
748 DEALLOCATE(ptwa_p0)
749c-----------
750 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
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
get_t3l
subroutine get_t3l(jft, jlt, ixtg, x, offg, irel, vq)
Definition stat_c_strafg.F:834
get_q4l
subroutine get_q4l(jft, jlt, ixc, x, offg, irel, vq)
Definition stat_c_strafg.F:764
shell2g
subroutine shell2g(eps, qt)
Definition stat_c_strafg.F:899