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 758 of file stat_c_strafg.F.

760C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
761#include "implicit_f.inc"
762c-----------------------------------------------
763c g l o b a l p a r a m e t e r s
764c-----------------------------------------------
765#include "mvsiz_p.inc"
766C-----------------------------------------------
767C D U M M Y A R G U M E N T S
768C-----------------------------------------------
769 INTEGER IXC(NIXC,*),JFT,JLT,IREL
770 my_real
771 . x(3,*), offg(*),vq(3,3,mvsiz)
772C-----------------------------------------------
773C L O C A L V A R I A B L E S
774C-----------------------------------------------
775 INTEGER I,J,K,L
776 INTEGER IXCTMP2,IXCTMP3,IXCTMP4,IXCTMP5
777 my_real
778 . rx(mvsiz),ry(mvsiz),rz(mvsiz),sx(mvsiz),sy(mvsiz),
779 . r11(mvsiz),r12(mvsiz),r13(mvsiz),r21(mvsiz),r22(mvsiz),
780 . r23(mvsiz),r31(mvsiz),r32(mvsiz),r33(mvsiz),
781 . sz(mvsiz),deta1(mvsiz)
782C----------------------------------------------
783 DO i=jft,jlt
784 ixctmp2=ixc(2,i)
785 ixctmp3=ixc(3,i)
786 ixctmp4=ixc(4,i)
787 ixctmp5=ixc(5,i)
788
789 rx(i)=x(1,ixctmp3)+x(1,ixctmp4)-x(1,ixctmp2)-x(1,ixctmp5)
790 sx(i)=x(1,ixctmp4)+x(1,ixctmp5)-x(1,ixctmp2)-x(1,ixctmp3)
791 ry(i)=x(2,ixctmp3)+x(2,ixctmp4)-x(2,ixctmp2)-x(2,ixctmp5)
792 sy(i)=x(2,ixctmp4)+x(2,ixctmp5)-x(2,ixctmp2)-x(2,ixctmp3)
793 rz(i)=x(3,ixctmp3)+x(3,ixctmp4)-x(3,ixctmp2)-x(3,ixctmp5)
794 sz(i)=x(3,ixctmp4)+x(3,ixctmp5)-x(3,ixctmp2)-x(3,ixctmp3)
795 ENDDO
796C----------------------------
797C LOCAL SYSTEM
798C----------------------------
799 CALL clskew3(jft,jlt,irel,
800 . rx, ry, rz,
801 . sx, sy, sz,
802 . r11,r12,r13,r21,r22,r23,r31,r32,r33,deta1,offg )
803 DO i=jft,jlt
804 vq(1,1,i)=r11(i)
805 vq(2,1,i)=r21(i)
806 vq(3,1,i)=r31(i)
807 vq(1,2,i)=r12(i)
808 vq(2,2,i)=r22(i)
809 vq(3,2,i)=r32(i)
810 vq(1,3,i)=r13(i)
811 vq(2,3,i)=r23(i)
812 vq(3,3,i)=r33(i)
813 ENDDO
814C
815 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 825 of file stat_c_strafg.F.

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

◆ shell2g()

subroutine shell2g ( eps,
qt )

Definition at line 890 of file stat_c_strafg.F.

891C---+----1----+----2----+----3----+----4----+----5----+----6----+----7----+----8
892#include "implicit_f.inc"
893c-----------------------------------------------
894C-----------------------------------------------
895C D u m m y A r g u m e n t s
896C-----------------------------------------------
897 my_real
898 . eps(6),qt(3,3)
899C------------------------------------------------------
900C L o c a l V a r i a b l e s
901C-----------------------------------------------
902 INTEGER I
903 my_real
904 . txx,tyy,tzz,txy,tyz,tzx,uxx,uyy,uzz,uxy,uyz,uzx,a,b,c
905C--convention input EPS : exx,eyy,exy,eyz,ezx,0; output exx,eyy,ezz,exy,eyz,ezx
906 txx = eps(1)
907 tyy = eps(2)
908 tzz = zero
909 txy = eps(3)
910 tyz = eps(4)
911 tzx = eps(5)
912C
913 a = qt(1,1)*txx + qt(1,2)*txy + qt(1,3)*tzx
914 b = qt(1,1)*txy + qt(1,2)*tyy + qt(1,3)*tyz
915 c = qt(1,1)*tzx + qt(1,2)*tyz + qt(1,3)*tzz
916 uxx = a*qt(1,1) + b*qt(1,2) + c*qt(1,3)
917 uxy = a*qt(2,1) + b*qt(2,2) + c*qt(2,3)
918 uzx = a*qt(3,1) + b*qt(3,2) + c*qt(3,3)
919 a = qt(2,1)*txx + qt(2,2)*txy + qt(2,3)*tzx
920 b = qt(2,1)*txy + qt(2,2)*tyy + qt(2,3)*tyz
921 c = qt(2,1)*tzx + qt(2,2)*tyz + qt(2,3)*tzz
922 uyy = a*qt(2,1) + b*qt(2,2) + c*qt(2,3)
923 uyz = a*qt(3,1) + b*qt(3,2) + c*qt(3,3)
924 a = qt(3,1)*txx + qt(3,2)*txy + qt(3,3)*tzx
925 b = qt(3,1)*txy + qt(3,2)*tyy + qt(3,3)*tyz
926 c = qt(3,1)*tzx + qt(3,2)*tyz + qt(3,3)*tzz
927 uzz = a*qt(3,1) + b*qt(3,2) + c*qt(3,3)
928C
929 eps(1) = uxx
930 eps(2) = uyy
931 eps(3) = uzz
932 eps(4) = uxy
933 eps(5) = uyz
934 eps(6) = uzx
935C
936 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 42 of file stat_c_strafg.F.

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