59 + IXC ,IXS ,IXTG ,X ,V ,
60 1 PM ,GEO ,MS ,IN ,PTG ,
61 2 MSC ,MSS ,MSTG ,INC ,INTG ,
62 3 THKC ,THKT ,PARTSAV,IPARTS ,
63 4 IPARTC ,IPARTT ,VEUL ,DTELEM ,IHBE ,
64 5 ISOLNOD,NVC ,I8MI ,MSNF ,MSSF ,
65 6 IGEO ,ETNOD ,NSHNOD ,STC ,STTG ,
66 7 WMA ,SH4TREE,SH3TREE,MCP ,MCPC ,
67 8 TEMP ,MCPS ,XREFC ,XREFTG ,XREFS ,
68 9 MSSA ,VOLNOD ,BVOLNOD,VNS ,BNS ,
69 A SH3TRIM,ISUBSTACK,STACK,RNOISE ,PERTURB,
70 B ELE_AREA,PART_AREA,IPARTTR,IXT ,IPARTP,
71 C IXP ,MST ,MSP ,STT ,STP ,
72 D STRP ,INP ,STIFINT,MCPP ,INR ,
73 E MSR ,MSRT ,STR ,IPARTR ,ITAB ,
74 F IXR ,IMERGE2 , IADMERGE2,NEL,DEFAULTS,
75 G GLOB_THERM,IBEAM_VECTOR,RBEAM_VECTOR)
84 USE format_mod ,
ONLY : fmt_10i
90#include "implicit_f.inc"
98#include "vect01_c.inc"
100#include "scr03_c.inc"
101#include "com01_c.inc"
102#include "com04_c.inc"
103#include "scr12_c.inc"
104#include "units_c.inc"
105#include "random_c.inc"
106#include "scr17_c.inc"
110 INTEGER NVC, IHBE, ISOLNOD, NDDIM, ILEV,ISUBSTACK
111 INTEGER (NIXC,*),IXS(NIXS,*),IXTG(NIXTG,*),
112 . IPARTS(*),IPARTC(*),IPARTT(*),IGEO(NPROPGI,*),
113 . NSHNOD(*), SH4TREE(*), SH3TREE(*),SH3TRIM(*),
114 . PERTURB(NPERTURB),IXT(NIXT,*),IPARTTR(*),(NIXP,*),IPARTP(*),
115 . ITAB(*),IXR(NIXR,*),IMERGE2(NUMNOD+1),NEL,IPARTR(*),
116 . IADMERGE2(NUMNOD+1)
118 INTEGER,
INTENT(IN) :: IBEAM_VECTOR(NUMELP)
120 . PM(NPROPM,*), GEO(NPROPG,*),MS(*),MSC(*),MSS(8,*),
121 . MSTG(*),INTG(*),PTG(3,*),IN(*),INC(*),THKC(*),THKT(*),
122 . X(3,*),V(3,*),VEUL(LVEUL,*),DTELEM(*),PARTSAV(20,*),
123 . MSNF(*), MSSF(8,*), WMA(*), ETNOD(*), STC(*), STTG(*),
124 . MCP(*),MCPC(*),TEMP(*),MCPS(8,*),
125 . XREFC(4,3,*),XREFTG(3,3,*),XREFS(8,3,*), MSSA(*), VOLNOD(*),
126 . BVOLNOD(*), BNS(8,*), VNS(8,*),RNOISE(*),PART_AREA(*),ELE_AREA(*),
127 . mst(*),msp(*),stt(*),stp(*),strp(*),inp(*),stifint(*),mcpp(*),
128 . inr(3,*),msr(3,*),msrt(*),str(*)
129 my_real,
INTENT(IN) :: rbeam_vector(3,numelp)
130 TYPE(elbuf_struct_),
TARGET :: ELBUF_STR
131 TYPE(DEFAULTS_),
INTENT(IN) :: DEFAULTS
132 type(glob_therm_) ,
intent(inout) :: glob_therm
136 INTEGER I, IGTYP,IMAT,IPROP, NDEPAR, NREFSTA, NCC, NF1
137 INTEGER MXT(MVSIZ), PID(MVSIZ), NGL(),
138 . IX1(MVSIZ),IX2(MVSIZ),IX3(MVSIZ),IX4(MVSIZ),
139 . IX5(MVSIZ),IX6(MVSIZ),IX7(MVSIZ),IX8(MVSIZ),IBID(MVSIZ),IP,II(6),
140 . ID, IPID, J, I0,I1,I2,I3,ITMP, KK, K,ILENG,IMASS,KK1,IMAS_DS,
143 . AREA(MVSIZ), RHO(MVSIZ),VOL(MVSIZ),
144 . X1(MVSIZ),X2(MVSIZ),X3(MVSIZ),X4(MVSIZ),X5(MVSIZ),X6(MVSIZ),
145 . X7(MVSIZ),X8(MVSIZ),Y1(MVSIZ),Y2(MVSIZ),Y3(MVSIZ),Y4(MVSIZ),
146 . y5(mvsiz),y6(mvsiz),y7(mvsiz),y8(mvsiz),z1(mvsiz),z2(mvsiz),
147 . z3(mvsiz),z4(mvsiz),z5(mvsiz),z6(mvsiz),z7(mvsiz),z8(mvsiz),
148 . rx(mvsiz) ,ry(mvsiz) ,rz(mvsiz) ,sx(mvsiz) ,
149 . sy(mvsiz) ,sz(mvsiz) ,tx(mvsiz) ,ty(mvsiz) ,tz(mvsiz) ,
150 . e1x(mvsiz),e1y(mvsiz),e1z(mvsiz),e2x(mvsiz),
151 . e2y(mvsiz),e2z(mvsiz),e3x(mvsiz),e3y(mvsiz),e3z(mvsiz),
152 . f1x(mvsiz) ,f1y(mvsiz) ,f1z(mvsiz) ,
153 . f2x(mvsiz) ,f2y(mvsiz) ,f2z(mvsiz),bid(mvsiz),rhocp(mvsiz),
154 . temp0(mvsiz) ,fill(mvsiz),bidg(mvsiz),
155 . px1(mvsiz),px2(mvsiz),px3(mvsiz),px4(mvsiz),
156 . py1(mvsiz),py2(mvsiz),py3(mvsiz),py4(mvsiz),
157 . pz1(mvsiz),pz2(mvsiz),pz3(mvsiz),pz4(mvsiz
158 . x2l(mvsiz),x3l(mvsiz),y3l(mvsiz),
159 . x31(mvsiz),y31(mvsiz),z31(mvsiz), deltax(mvsiz),
160 .
bidon,
noise, xl(mvsiz),length,uiner(mvsiz),massr(mvsiz),
161 . xm, xine,ratio,sti,kx,ems(mvsiz),rhor,vect(3,mvsiz)
162 my_real,
DIMENSION(:),
ALLOCATABLE :: stifntmp
164 . xd1(mvsiz), xd2(mvsiz), xd3(mvsiz), xd4(mvsiz),
165 . xd5(mvsiz), xd6(mvsiz), xd7(mvsiz), xd8(mvsiz),
166 . yd1(mvsiz), yd2(mvsiz), yd3(mvsiz), yd4(mvsiz),
167 . yd5(mvsiz), yd6(mvsiz), yd7(mvsiz), yd8(mvsiz),
168 . zd1(mvsiz), zd2(mvsiz), zd3(mvsiz), zd4(mvsiz),
169 . zd5(mvsiz), zd6(mvsiz), zd7(mvsiz), zd8(mvsiz),voldp(mvsiz)
170 CHARACTER(LEN=NCHARTITLE) :: TITR
172 TYPE(ELBUF_STRUCT_) ,
POINTER :: BIDBUF
173 TYPE (STACK_PLY) :: STACK
174 TYPE(G_BUFEL_),
POINTER :: GBUF
175 TYPE (DRAPE_),
DIMENSION(NUMELC_DRAPE + NUMELTG_DRAPE) :: DRAPE
178 ALLOCATE(STIFNTMP(NUMNOD))
179 gbuf => elbuf_str%GBUF
188 IF (ity == 1.AND. ismstr == 10) ismstr = 4
189 imas_ds = defaults%SOLID%IMAS
191 IF(ity == 1.AND.isolnod == 4)
THEN
193 CALL s4coor3(x ,xrefs(1,1,nft+1),ixs(1,nft+1),ngl ,
194 . mxt ,pid ,ix1 ,ix2 ,ix3 ,ix4 ,
195 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
196 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 )
198 rho(i) = pm(89,mxt(i))
201 rhocp(i) = pm(69,mxt(i))
202 temp0(i) = pm(79,mxt(i))
204 CALL s4deri3(vol,veul(1,nft+1) ,geo ,igeo ,rx ,
207 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
208 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 ,
209 . px1 ,px2 ,px3 ,px4 ,
210 . py1 ,py2 ,py3 ,py4 ,
211 . pz1 ,pz2 ,pz3 ,pz4 ,bidg,
212 . deltax,volu ,ngl ,pid ,mxt ,
214 IF(jlag+jale+jeul /= 0)
THEN
216 1 rho ,ms ,partsav,x ,v ,
217 2 iparts(nft+1),mss(1,nft+1),msnf ,mssf(1,nft+1),wma ,
218 3 rhocp ,mcp ,mcps(1,nft+1) ,temp0,
219 4 temp ,mssa ,ix1 ,ix2 ,ix3 ,ix4 ,
220 5 fill, volu ,imas_ds ,glob_therm%NINTEMP)
224 CALL sbulk3(volu ,ix1 ,ncc,mxt,pm ,
225 2 volnod,bvolnod,vns(1,nf1),bns(1,nf1),bid,
229 ELSEIF(ity == 1.AND.isolnod == 10)
THEN
231 ELSEIF(ity == 1.AND.isolnod == 16)
THEN
233 ELSEIF(ity == 1.AND.isolnod == 20)
THEN
242 CALL scoor3(x,xrefs(1,1,nft+1),ixs(1,nft+1),geo ,mxt ,pid ,ngl ,
243 . ix1 ,ix2 ,ix3 ,ix4 ,ix5 ,ix6 ,ix7 ,ix8 ,
244 . x1 ,x2 ,x3 ,x4 ,x5 ,x6 ,x7 ,x8 ,
245 . y1 ,y2 ,y3 ,y4 ,y5 ,y6 ,y7 ,y8 ,
246 . z1 ,z2 ,z3 ,z4 ,z5 ,z6 ,z7 ,z8 ,
247 . rx ,ry ,rz ,sx ,sy ,sz ,tx ,ty ,tz ,
248 . e1x ,e1y ,e1z ,e2x ,e2y ,e2z ,e3x ,e3y ,e3z ,
249 . f1x ,f1y ,f1z ,f2x ,f2y ,f2z ,temp0, temp,glob_therm%NINTEMP,
250 . xd1 ,xd2 ,xd3 ,xd4 ,xd5 ,xd6 ,xd7 ,xd8 ,
251 . yd1 ,yd2 ,yd3 ,yd4 ,yd5 ,yd6 ,yd7 ,yd8 ,
252 . zd1 ,zd2 ,zd3 ,zd4 ,zd5 ,zd6 ,zd7 ,zd8 )
253 IF((jeul == 0.OR.integ8 == 0).AND. npt /= 8)
THEN
255 rho(i) = pm(89,mxt(i))
259 CALL sderi3(vol ,veul(1,nft+1) ,geo ,igeo ,
260 . xd1 ,xd2 ,xd3 ,xd4 ,xd5 ,xd6 ,xd7 ,xd8 ,
261 . yd1 ,yd2 ,yd3 ,yd4 ,yd5 ,yd6 ,yd7 ,yd8 ,
262 . zd1 ,zd2 ,zd3 ,zd4 ,zd5 ,zd6 ,zd7 ,zd8 ,
263 . rx ,ry ,rz ,sx ,sy ,sz ,ngl ,pid ,
264 . px1 ,px2 ,px3 ,px4 ,py1 ,py2 ,py3 ,py4 ,
265 . pz1 ,pz2 ,pz3 ,pz4, volu ,voldp,nel ,jeul ,
268 . x1 ,x2 ,x3 ,x4 ,x5 ,x6 ,x7 ,x8 ,
269 . y1 ,y2 ,y3 ,y4 ,y5 ,y6
270 . z1 ,z2 ,z3 ,z4 ,z5 ,z6 ,z7 ,z8,
273 1 rho , ms , partsav, x , v ,
274 2 iparts(nft+1), mss(1,nft+1) , volu ,
275 3 msnf , mssf(1,nft+1), bid ,
276 4 bid , bid , wma , rhocp, mcp,
277 5 mcps(1,nft+1), mssa ,bid , bid ,fill ,
278 6 ix1, ix2, ix3, ix4, ix5, ix6, ix7, ix8)
282 CALL sbulk3(volu ,ix1 ,ncc,mxt,pm ,
283 2 volnod,bvolnod,vns(1,nf1),bns(1,nf1),bid,
287 ELSEIF (ity == 3)
THEN
290 iprop = ixc(nixc-1,1+nft)
292 CALL ccoori(x,xrefc(1,1,nft+1),ixc(1,nft+1),
293 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
294 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 ,
295 . ix1 ,ix2 ,ix3 ,ix4 ,ngl )
296 CALL cveok3(nvc,4,ix1,ix2,ix3,ix4)
298 CALL ceveci(lft ,llt ,area,
299 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
300 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 ,
301 . e1x ,e2x ,e3x ,e1y ,e2y ,e3y ,e1z ,e2z ,e3z )
304 IF (imasadd > 0)
THEN
306 ele_area(i+nft) = area(i)
310 CALL cinmas(x,xrefc(1,1,nft+1),ixc,geo,pm,ms,in,
311 . thkc,ihbe,partsav,v,ipartc(nft+1),
312 . msc(nft+1),inc(nft+1),area,
313 . i8mi ,igeo ,etnod ,imat ,iprop ,
314 . nshnod ,stc(nft+1),sh4tree ,mcp ,mcpc(nft+1) ,
315 . temp ,bid , bid,bid,bid,
316 . bid,bid,isubstack,ibid,bidbuf,
317 . stack,bidg ,rnoise,drape,glob_therm%NINTEMP,
318 . perturb,ix1 ,ix2 ,ix3 ,ix4 ,ibid, ibid)
322 dtelem(ndepar+i) = ep30
328 iprop = ixtg(nixtg-1,1+nft)
330 CALL c3coori(x,xreftg(1,1,nft+1),ixtg(1,nft+1),ngl,
331 . x1 ,x2 ,x3 ,y1 ,y2 ,y3 ,
332 . z1 ,z2 ,z3 ,ix1 ,ix2 ,ix3 )
333 CALL c3veok3(nvc,ix1 ,ix2 ,ix3 )
335 . x1 ,x2 ,x3 ,y1 ,y2 ,y3 ,
336 . z1 ,z2 ,z3 ,e1x ,e2x ,e3x ,
337 . e1y ,e2y ,e3y ,e1z ,e2z ,e3z ,
338 . x31, y31, z31 ,x2l ,x3l ,y3l )
341 IF (imasadd > 0)
THEN
343 ele_area(i+nft+numelc) = area(i)
347 CALL c3inmas(x,xreftg(1,1,nft+1),ixtg,geo,pm,ms,in,thkt,
348 . partsav,v,ipartt(nft+1),mstg(nft+1),intg(nft+1),
349 . ptg(1,nft+1),igeo ,imat ,iprop ,area ,
350 . etnod,nshnod,sttg(nft+1), sh3tree,mcp ,
351 . mcps(1,nft+1) , temp,sh3trim,isubstack,ibid,
352 . bidbuf, stack,bidg ,rnoise, drape,
353 . perturb,ix1 ,ix2 ,ix3 ,glob_therm%NINTEMP,
354 . x2l ,x3l ,y3l ,ibid, ibid)
356 ndepar=numels+numelc+numelt+numelp+numelr+nft
358 dtelem(ndepar+i) = ep30
365 . x1, x2, y1, y2, z1, z2)
367 gbuf%AREA(1:nel)= geo(1,pid(1:nel))
368 CALL tmass(x ,ixt ,geo ,pm ,ms ,
369 . stifntmp ,partsav ,v ,iparttr(nft+1),mst(nft+1),
370 . stifint,stt(nft+1) ,gbuf%AREA , mxt, ix1, ix2,
371 . x1, x2, y1, y2, z1, z2)
372 ndepar=numels+numelc+nft
374 dtelem(ndepar + i) = ep30
379 stifntmp(1:numnod)=zero
380 CALL pcoori(x,ixp(1,nft+1),
382 . x1,x2,x3, y1,y2,y3, z1,z2,z3,
383 . ibeam_vector(nft+1),rbeam_vector(1,nft+1),ivect,vect)
386 . stifntmp,stifntmp,partsav,v,ipartp
387 . msp(nft+1),inp(nft+1),igeo , stp
388 . x1,x2, y1,y2, z1,z2,
389 . ix1,ix2,mxt,pid,area,deltax,strp(nft+1),
390 . mcpp,temp,glob_therm%NINTEMP)
391 ndepar=numels+numelc+numelt+nft
393 dtelem(ndepar+i)=ep30
396 ELSEIF (ity == 6)
THEN
404 ii(i) = (i-1)*nel + 1
407 noise = two*sqrt(three)*xalea
412 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i),ltitr)
413 IF(igtyp == 23) geo(4,i) = ep30
418 CALL fretitl2(titr,igeo(npropgi-ltitr+1,ipid),ltitr)
427 IF (i1 == i2 .OR. i1 == i3) itmp = i1
428 IF (i2 == i3) itmp = i2
429 IF (imerge2(itmp) /= 0)
THEN
431 . msgtype=msgwarning,
432 . anmode=aninfo_blind_1,
435 WRITE (iout,1000) itab(itmp)
437 DO k=1,iadmerge2(itmp+1) - iadmerge2(itmp)
440 WRITE (iout,fmt=fmt_10i)
441 . (itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
446 WRITE (iout,fmt=fmt_10i)
447 . (itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
452 . anmode=aninfo_blind_1,
458 IF (igtyp /= 23 )
THEN
461 . anmode=aninfo_blind_1,
476 + (x(1,i1)-x(1,i2))*(x(1,i1)-x(1,i2))
477 + + (x(2,i1)-x(2,i2))*(x(2,i1)-x
478 + + (x(3,i1)-x(3,i2))*(x(3,i1)-x(3,i2)) )
487 massr(i) = geo(1,i0)*length*rhor
488 IF (length == zero .AND. rhor /= zero)
THEN
493 . anmode=aninfo_blind_1,
498 ELSEIF(imass == 2)
THEN
499 massr(i) = geo(1,i0)*rhor
505 ratio = xm * length * length
510 IF (i7stifs /= 0)
THEN
522 CALL r23mass(ixr ,geo ,ms ,in,partsav ,
523 2 x ,v ,ipartr(nft+1),xl ,msr(1,nft+1),
524 3 inr(1,nft+1),msrt,ems ,massr ,uiner,mtn)
528 ndepar=numels+numelc+numelt+numelp+nft
534 IF (igtyp == 23)
THEN
537 dtelem(ndepar+i) = ep20
538 geo(4,i0)=
min(geo(4,i0),dtelem(ndepar+i))
547 1000
FORMAT(
'LIST OF POSSIBLE CNODES MERGED WITH NODE ID=',i10)