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
87 use element_mod ,
only : nixs,nixc,nixt,nixp,nixr,nixtg
91#include "implicit_f.inc"
99#include "vect01_c.inc"
100#include "param_c.inc"
101#include "scr03_c.inc"
102#include "com01_c.inc"
103#include "com04_c.inc"
104#include "scr12_c.inc"
105#include "units_c.inc"
106#include "random_c.inc"
107#include "scr17_c.inc"
111 INTEGER NVC, IHBE, ISOLNOD, ISUBSTACK
112 INTEGER IXC(NIXC,*),IXS(NIXS,*),IXTG(NIXTG,*),
113 . IPARTS(*),IPARTC(*),IPARTT(*),IGEO(NPROPGI,*),
114 . NSHNOD(*), SH4TREE(*), SH3TREE(*),SH3TRIM(*),
115 . PERTURB(NPERTURB),IXT(NIXT,*),IPARTTR(*),IXP(NIXP,*),IPARTP(*),
116 . ITAB(*),IXR(NIXR,*),IMERGE2(NUMNOD+1),NEL,IPARTR(*),
117 . IADMERGE2(NUMNOD+1)
119 INTEGER,
INTENT(IN) :: IBEAM_VECTOR(NUMELP)
121 . PM(NPROPM,*), GEO(NPROPG,*),MS(*),MSC(*),MSS(8,*),
122 . MSTG(*),INTG(*),PTG(3,*),IN(*),INC(*),THKC(*),THKT(*),
123 . X(3,*),V(3,*),VEUL(LVEUL,*),DTELEM(*),PARTSAV(20,*),
124 . MSNF(*), MSSF(8,*), WMA(*), ETNOD(*), STC(*), STTG(*),
125 . MCP(*),MCPC(*),TEMP(*),MCPS(8,*),
126 . XREFC(4,3,*),XREFTG(3,3,*),XREFS(8,3,*), MSSA(*), VOLNOD(*),
127 . (*), BNS(8,*), VNS(8,*),RNOISE(*),PART_AREA(*),ELE_AREA(*),
128 . mst(*),msp(*),stt(*),stp(*),strp(*),inp(*),stifint(*),mcpp(*),
129 . inr(3,*),msr(3,*),msrt(*),str(*)
130 my_real,
INTENT(IN) :: rbeam_vector(3,numelp)
131 TYPE(elbuf_struct_),
TARGET :: ELBUF_STR
132 TYPE(DEFAULTS_),
INTENT(IN) :: DEFAULTS
133 type(glob_therm_) ,
intent(inout) :: glob_therm
137 INTEGER I, IGTYP,IMAT,IPROP, NDEPAR, NREFSTA, NCC, NF1
138 INTEGER MXT(MVSIZ), PID(MVSIZ), NGL(MVSIZ),
139 . IX1(MVSIZ),IX2(MVSIZ),IX3(MVSIZ),IX4(MVSIZ),
140 . IX5(MVSIZ),IX6(MVSIZ),IX7(MVSIZ),IX8(MVSIZ),IBID(MVSIZ),II(6),
141 . ID, IPID, J, I0,I1,I2,I3,ITMP, KK, K,IMASS,KK1,IMAS_DS,
144 . AREA(MVSIZ), RHO(MVSIZ),VOL(MVSIZ),
145 . X1(MVSIZ),X2(MVSIZ),X3(MVSIZ)
148 . z3(mvsiz),z4(mvsiz),z5(mvsiz),z6(mvsiz),z7(mvsiz),z8(mvsiz),
149 . rx(mvsiz) ,ry(mvsiz) ,rz(mvsiz) ,sx(mvsiz) ,
150 . sy(mvsiz) ,sz(mvsiz) ,tx(mvsiz) ,ty(mvsiz) ,tz(mvsiz) ,
151 . e1x(mvsiz),e1y(mvsiz),e1z(mvsiz),e2x(mvsiz),
152 . e2y(mvsiz),e2z(mvsiz),e3x(mvsiz),e3y(mvsiz),e3z(mvsiz),
153 . f1x(mvsiz) ,f1y(mvsiz) ,f1z(mvsiz) ,
154 . f2x(mvsiz) ,f2y(mvsiz) ,f2z(mvsiz),bid(mvsiz),rhocp(mvsiz),
155 . temp0(mvsiz) ,fill(mvsiz),bidg(mvsiz),
156 . px1(mvsiz),px2(mvsiz),px3(mvsiz),px4(mvsiz),
157 . py1(mvsiz),py2(mvsiz),py3(mvsiz),py4(mvsiz),
158 . pz1(mvsiz),pz2(mvsiz),pz3(mvsiz),pz4(mvsiz),volu(mvsiz),
159 . x2l(mvsiz),x3l(mvsiz),y3l(mvsiz),
160 . x31(mvsiz),y31(mvsiz),z31(mvsiz), deltax(mvsiz),
161 .
bidon,
noise, xl(mvsiz),length,uiner(mvsiz),massr(mvsiz),
162 . xm, xine,ratio,kx,ems(mvsiz),rhor,vect(3,mvsiz)
163 my_real,
DIMENSION(:),
ALLOCATABLE :: stifntmp
165 . xd1(mvsiz), xd2(mvsiz), xd3(mvsiz), xd4(mvsiz),
166 . xd5(mvsiz), xd6(mvsiz), xd7(mvsiz), xd8(mvsiz),
167 . yd1(mvsiz), yd2(mvsiz), yd3(mvsiz), yd4(mvsiz),
168 . yd5(mvsiz), yd6(mvsiz), yd7(mvsiz), yd8(mvsiz),
169 . zd1(mvsiz), zd2(mvsiz), zd3(mvsiz), zd4(mvsiz),
170 . zd5(mvsiz), zd6(mvsiz), zd7(mvsiz), zd8(mvsiz),voldp(mvsiz)
171 CHARACTER(LEN=NCHARTITLE) :: TITR
173 TYPE(ELBUF_STRUCT_) ,
POINTER :: BIDBUF
174 TYPE (STACK_PLY) :: STACK
175 TYPE(G_BUFEL_),
POINTER :: GBUF
176 TYPE (DRAPE_),
DIMENSION(NUMELC_DRAPE + NUMELTG_DRAPE) :: DRAPE
179 ALLOCATE(STIFNTMP(NUMNOD))
180 gbuf => elbuf_str%GBUF
189 IF (ity == 1.AND. ismstr == 10) ismstr = 4
190 imas_ds = defaults%SOLID%IMAS
192 IF(ity == 1.AND.isolnod == 4)
THEN
194 CALL s4coor3(x ,xrefs(1,1,nft+1),ixs(1,nft+1),ngl ,
195 . mxt ,pid ,ix1 ,ix2 ,ix3 ,ix4 ,
196 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
197 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 )
199 rho(i) = pm(89,mxt(i))
202 rhocp(i) = pm(69,mxt(i))
203 temp0(i) = pm(79,mxt(i))
205 CALL s4deri3(vol,veul(1,nft+1) ,geo ,igeo ,rx ,
208 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
209 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 ,
210 . px1 ,px2 ,px3 ,px4 ,
211 . py1 ,py2 ,py3 ,py4 ,
212 . pz1 ,pz2 ,pz3 ,pz4 ,bidg,
213 . deltax,volu ,ngl ,pid ,mxt ,
215 IF(jlag+jale+jeul /= 0)
THEN
217 1 rho ,ms ,partsav,x ,v ,
218 2 iparts(nft+1),mss(1,nft+1),msnf ,mssf(1,nft+1),wma ,
219 3 rhocp ,mcp ,mcps(1,nft+1) ,temp0,
220 4 temp ,mssa ,ix1 ,ix2 ,ix3 ,ix4 ,
221 5 fill, volu ,imas_ds ,glob_therm%NINTEMP)
225 CALL sbulk3(volu ,ix1 ,ncc,mxt,pm ,
226 2 volnod,bvolnod,vns(1,nf1),bns(1,nf1),bid,
230 ELSEIF(ity == 1.AND.isolnod == 10)
THEN
232 ELSEIF(ity == 1.AND.isolnod == 16)
THEN
234 ELSEIF(ity == 1.AND.isolnod == 20)
THEN
243 CALL scoor3(x,xrefs(1,1,nft+1),ixs(1,nft+1),geo ,mxt ,pid
244 . ix1 ,ix2 ,ix3 ,ix4 ,ix5 ,ix6 ,ix7 ,ix8 ,
245 . x1 ,x2 ,x3 ,x4 ,x5 ,x6 ,x7 ,x8 ,
246 . y1 ,y2 ,y3 ,y4 ,y5 ,y6 ,y7 ,y8 ,
247 . z1 ,z2 ,z3 ,z4 ,z5 ,z6 ,z7 ,z8 ,
248 . rx ,ry ,rz ,sx ,sy ,sz ,tx ,ty ,tz ,
249 . e1x ,e1y ,e1z ,e2x ,e2y ,e2z ,e3x ,e3y ,e3z ,
250 . f1x ,f1y ,f1z ,f2x ,f2y ,f2z ,temp0, temp,glob_therm%NINTEMP,
251 . xd1 ,xd2 ,xd3 ,xd4 ,xd5 ,xd6 ,xd7 ,xd8 ,
252 . yd1 ,yd2 ,yd3 ,yd4 ,yd5 ,yd6 ,yd7 ,yd8 ,
254 IF((jeul == 0.OR.integ8 == 0).AND. npt /= 8)
THEN
256 rho(i) = pm(89,mxt(i))
260 CALL sderi3(vol ,veul(1,nft+1) ,geo ,igeo ,
261 . xd1 ,xd2 ,xd3 ,xd4 ,xd5 ,xd6 ,xd7 ,xd8 ,
262 . yd1 ,yd2 ,yd3 ,yd4 ,yd5 ,yd6 ,yd7 ,yd8 ,
263 . zd1 ,zd2 ,zd3 ,zd4 ,zd5 ,zd6 ,zd7
264 . rx ,ry ,rz ,sx ,sy ,sz ,ngl ,pid ,
265 . px1 ,px2 ,px3 ,px4 ,py1 ,py2
266 . pz1 ,pz2 ,pz3 ,pz4, volu ,voldp,nel ,jeul ,
269 . x1 ,x2 ,x3 ,x4 ,x5 ,x6 ,x7 ,x8 ,
270 . y1 ,y2 ,y3 ,y4 ,y5 ,y6 ,y7 ,y8 ,
271 . z1 ,z2 ,z3 ,z4 ,z5 ,z6 ,z7 ,z8,
274 1 rho , ms , partsav, x , v ,
275 2 iparts(nft+1), mss(1,nft+1) , volu ,
276 3 msnf , mssf(1,nft+1), bid ,
277 4 bid , bid , wma , rhocp, mcp,
278 5 mcps(1,nft+1), mssa ,bid , bid ,fill ,
279 6 ix1, ix2, ix3, ix4, ix5, ix6, ix7, ix8)
283 CALL sbulk3(volu ,ix1 ,ncc,mxt,pm
284 2 volnod,bvolnod,vns(1,nf1),bns(1,nf1),bid,
288 ELSEIF (ity == 3)
THEN
291 iprop = ixc(nixc-1,1+nft)
293 CALL ccoori(x,xrefc(1,1,nft+1),ixc(1,nft+1),
294 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
295 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 ,
296 . ix1 ,ix2 ,ix3 ,ix4 ,ngl )
297 CALL cveok3(nvc,4,ix1,ix2,ix3,ix4)
299 CALL ceveci(lft ,llt ,area,
300 . x1 ,x2 ,x3 ,x4 ,y1 ,y2 ,
301 . y3 ,y4 ,z1 ,z2 ,z3 ,z4 ,
302 . e1x ,e2x ,e3x ,e1y ,e2y ,e3y ,e1z ,e2z ,e3z )
305 IF (imasadd > 0)
THEN
307 ele_area(i+nft) = area(i)
311 CALL cinmas(x,xrefc(1,1,nft
312 . thkc,ihbe,partsav,v,ipartc(nft+1),
313 . msc(nft+1),inc(nft+1),area,
314 . i8mi ,igeo ,etnod ,imat ,iprop ,
315 . nshnod ,stc(nft+1),sh4tree ,mcp ,mcpc(nft+1) ,
316 . temp ,bid , bid,bid,bid,
317 . bid,bid,isubstack,ibid,bidbuf,
318 . stack,bidg ,rnoise,drape,glob_therm%NINTEMP,
319 . perturb,ix1 ,ix2 ,ix3 ,ix4 ,ibid, ibid)
323 dtelem(ndepar+i) = ep30
329 iprop = ixtg(nixtg-1,1+nft)
331 CALL c3coori(x,xreftg(1,1,nft+1),ixtg(1,nft+1),ngl,
332 . x1 ,x2 ,x3 ,y1 ,y2 ,y3 ,
333 . z1 ,z2 ,z3 ,ix1 ,ix2 ,ix3 )
334 CALL c3veok3(nvc,ix1 ,ix2 ,ix3 )
336 . x1 ,x2 ,x3 ,y1 ,y2 ,y3 ,
337 . z1 ,z2 ,z3 ,e1x ,e2x ,e3x ,
338 . e1y ,e2y ,e3y ,e1z ,e2z ,e3z ,
339 . x31, y31, z31 ,x2l ,x3l ,y3l )
342 IF (imasadd > 0)
THEN
344 ele_area(i+nft+numelc) = area(i)
348 CALL c3inmas(x,xreftg(1,1,nft+1),ixtg,geo,pm,ms,in,thkt,
349 . partsav,v,ipartt(nft+1),mstg
350 . ptg(1,nft+1),igeo ,imat ,iprop ,area ,
351 . etnod,nshnod,sttg(nft+1), sh3tree,mcp ,
352 . mcps(1,nft+1) , temp,sh3trim,isubstack,ibid,
353 . bidbuf, stack,bidg ,rnoise, drape,
354 . perturb,ix1 ,ix2 ,ix3 ,glob_therm%NINTEMP,
355 . x2l ,x3l ,y3l ,ibid, ibid)
357 ndepar=numels+numelc+numelt+numelp+numelr+nft
359 dtelem(ndepar+i) = ep30
364 stifntmp(1:numnod)=zero
365 CALL tcoori(x,ixt(1,nft+1),mxt, pid, ix1, ix2,
366 . x1, x2, y1, y2, z1, z2)
368 gbuf%AREA(1:nel)= geo(1,pid(1:nel))
369 CALL tmass(x ,ixt ,geo ,pm ,ms ,
370 . stifntmp ,partsav ,v ,iparttr(nft+1),mst(nft
371 . stifint,stt(nft+1) ,gbuf%AREA , mxt, ix1, ix2,
372 . x1, x2, y1, y2, z1, z2)
373 ndepar=numels+numelc+nft
375 dtelem(ndepar + i) = ep30
380 stifntmp(1:numnod)=zero
381 CALL pcoori(x,ixp(1,nft+1),
382 . mxt,pid ,ix1,ix2,ix3,deltax,
383 . x1,x2,x3, y1,y2,y3, z1,z2,z3,
384 . ibeam_vector(nft+1),rbeam_vector(1,nft+1),ivect,vect)
387 . stifntmp,stifntmp,partsav,v,ipartp(nft+1),
388 . msp(nft+1),inp(nft+1),igeo , stp(nft+1),
389 . x1,x2, y1,y2, z1,z2,
390 . ix1,ix2,mxt,pid,area,deltax,strp(nft+1),
391 . mcpp,temp,glob_therm%NINTEMP)
392 ndepar=numels+numelc+numelt+nft
394 dtelem(ndepar+i)=ep30
397 ELSEIF (ity == 6)
THEN
405 ii(i) = (i-1)*nel + 1
408 noise = two*sqrt(three)*xalea
413 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i),ltitr)
414 IF(igtyp == 23) geo(4,i) = ep30
419 CALL fretitl2(titr,igeo(npropgi-ltitr+1,ipid),ltitr)
427 IF (i1 == i2 .OR. i1 == i3 .OR. i2 == i3)
THEN
428 IF (i1 == i2 .OR. i1 == i3) itmp = i1
429 IF (i2 == i3) itmp = i2
430 IF (imerge2(itmp) /= 0)
THEN
432 . msgtype=msgwarning,
433 . anmode=aninfo_blind_1,
436 WRITE (iout,1000) itab(itmp)
438 DO k=1,iadmerge2(itmp+1) - iadmerge2(itmp)
441 WRITE (iout,fmt=fmt_10i)
442 . (itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
447 WRITE (iout,fmt=fmt_10i)
448 . (itab(imerge2(iadmerge2(itmp)+kk1)),kk1=0,kk-1)
453 . anmode=aninfo_blind_1,
459 IF (igtyp /= 23 )
THEN
462 . anmode=aninfo_blind_1,
477 + (x(1,i1)-x(1,i2))*(x(1,i1)-x(1,i2))
478 + + (x(2,i1)-x(2,i2))*(x(2,i1)-x(2,i2))
479 + + (x(3,i1)-x(3,i2))*(x(3,i1)-x(3,i2)) )
488 massr(i) = geo(1,i0)*length*rhor
489 IF (length == zero .AND. rhor /= zero)
THEN
491 CALL fretitl2(titr,igeo(npropgi-ltitr+1,i0),ltitr)
494 . anmode=aninfo_blind_1,
499 ELSEIF(imass == 2)
THEN
500 massr(i) = geo(1,i0)*rhor
506 ratio = xm * length * length
511 IF (i7stifs /= 0)
THEN
523 CALL r23mass(ixr ,geo ,ms ,in,partsav ,
524 2 x ,v ,ipartr(nft+1),xl ,msr(1,nft+1),
525 3 inr(1,nft+1),msrt,ems ,massr ,uiner,mtn)
529 ndepar=numels+numelc+numelt+numelp+nft
535 IF (igtyp == 23)
THEN
538 dtelem(ndepar+i) = ep20
539 geo(4,i0)=
min(geo(4,i0),dtelem(ndepar+i))
548 1000
FORMAT(
'LIST OF POSSIBLE CNODES MERGED WITH NODE ID=',i10)
subroutine initia(iparg, elbuf, ms, in, v, x, ixs, ixq, ixc, ixt, ixp, ixr, detonators, geo, pm, rby, npby, lpby, npc, npts, pld, veul, ale_connectivity, skew, fill, ipart, itab, sensors, skvol, ixtg, thk, nloc_dmg, group_param_tab, glob_therm, igrnod, igrsurf, bufsf, vr, bufmat, xlas, las, dtelem, mss, msq, msc, mst, msp, msr, mstg, ptg, inc, nod2eltg, knod2eltg, inp, inr, intg, index, itri, kxx, ixx, xelemwa, iwa, nod2elq, knod2elq, nod2els, knod2els, kxsp, ixsp, nod2sp, ispcond, icode, iskew, iskn, ispsym, xframe, isptag, spbuf, mssx, nsigi, npbyl, lpbyl, rbyl, msnf, mssf, nsigsh, igeo, ipm, nsigs, nsigsph, vns, vnsx, stc, stt, stp, str, sttg, stur, bns, bnsx, volnod, bvolnod, etnod, nshnod, stifint, fxbdep, fxbvit, fxbacc, fxbipm, fxbrpm, fxbelm, fxbsig, fxbmod, ins, ptshel, ptsh3n, ptsol, ptquad, wma, ptsph, fxbnod, mbufel, mdepl, fxani, numel, nsigrs, sh4tree, sh3tree, mcp, temp, imerge2, iadmerge2, slnrbm, nslnrbm, rmstifn, rmstifr, ms_layer, zi_layer, itag, itagel, mcpc, mcptg, xrefc, xreftg, xrefs, mssa, msrt, irbe2, lrbe2, inivol, kvol, nbsubmat, ixs10, ixs16, ixs20, totaddmas, ipmas, stifn, msz2, itagn, sitage, itage, ixr_kj, elbuf_tab, nom_opt, ptr_nopt_rbe2, ptr_nopt_adm, ptr_nopt_fun, sol2sph, irst, sh3trim, xfem_tab, kxig3d, ixig3d, msig3d, knot, nctrlmax, wige, stack, rnoise, drape, sh4ang, sh3ang, geo_stack, igeo_stack, stifintr, strc, strp, strr, strtg, perturb, itagnd, nativ_sms, iloadp, facload, ptspri, nsigbeam, ptbeam, nsigtruss, pttruss, multi_fvm, sigi, sigsh, sigsp, sigsph, sigrs, sigbeam, sigtruss, strsglob, straglob, orthoglob, isigsh, iyldini, ksigsh3, fail_ini, iusolyld, iuser, iddlevel, inimap1d, inimap2d, func2d, fvm_inivel, tagprt_sms, igrbric, igrquad, igrsh4n, igrsh3n, igrpart, totmas, knotlocpc, knotlocel, vnige, bnige, fxbglm, fxbcpm, fxbcps, fxblm, fxbfls, fxbdls, fxb_matrix, fxb_matrix_add, fxb_last_adress, ptr_nopt_fxb, r_skew, knod2el1d, nod2el1d, ebcs_tab, rby_iniaxis, alea, knod2elc, nod2elc, dr, slrbody, drapeg, ipari, intbuf_tab, interfaces, mat_param, npreload_a, preload_a, fail_fractal, fail_brokmann, defaults, ndamp_freq_range, dampr, ibeam_vector, rbeam_vector, ikine, lsigi, lsigsp, srnoise, nprw, lprw, rwstif_pen, sln_pen)