57
58
59
67 use element_mod , only : nixs,nixq,nixc,nixp,nixt,nixr,nixtg
68
69
70
71#include "implicit_f.inc"
72
73
74
75#include "analyse_name.inc"
76
77
78
79#include "com04_c.inc"
80#include "scr17_c.inc"
81#include "param_c.inc"
82#include "sphcom.inc"
83
84
85
86 TYPE (UNIT_TYPE_),INTENT(IN) ::UNITAB
87 INTEGER IXC(NIXC,*), IXTG(NIXTG,*), NSTRF(*), ITAB(*),
88 . ITABM1(*),IXS(NIXS,*), IXQ(NIXQ,*), IXT(NIXT,*),
89 . IXP(NIXP,*), IXR(NIXR,*), IPARI(NPARI,*),
90 . IXS10(6,*),IXS20(12,*),IXS16(8,*),ISKN(LISKN,*),
91 . ISOLNOD(*),NOM_SECT(*)
92 INTEGER NOM_OPT(LNOPT1,*)
93 TYPE(SUBMODEL_DATA) LSUBMODEL(*)
95 . x0(3,*),secbuf(*),xframe(nxframe,*),
96 . rtrans(ntransf,*)
97
98 TYPE (GROUP_) ,DIMENSION(NGRNOD) :: IGRNOD
99 TYPE (GROUP_) ,DIMENSION(NGRBRIC) :: IGRBRIC
100
101
102
103 INTEGER ,DIMENSION(NSECT) :: SECTIDS
104 INTEGER K1, I, J, L, KK, K2, K,LREC,
105 . NNOD, NBINTER,K0,K3,K4,K5,K6,K7,K8,K9,KR0,
106 . NSEGQ,NSEGS,NSEGC,NSEGT,NSEGP,,NSEGTG,ID,
107 . IGU,IGS,IGUS,IGUQ,IGUC,IGUT,IGUP,IGUR,IGUTG,IFRAM,
108 . NNSK1,NNSK2,NNSK3,UID,IFLAGUNIT,
109 . NFRAM,JJ,IUN,
110 .
111 . N1,CPT,
112 . NG,NOPRINT,ILEN
113 INTEGER FLAG_FMT, L0
114INTEGER, DIMENSION(:), ALLOCATABLE :: NODTAG,TAGELEMS
116 . deltat,
alpha,fac_t,a,b,c,d,e,f,r
117 CHARACTER MESS*40
118 CHARACTER(LEN=NCHARTITLE) :: TITR
119 CHARACTER(LEN=NCHARLINE) ::CHAR8
120 CHARACTER(LEN=NCHARFIELD) :: KEY2
122 . bid, xm, ym, zm, x1, y1, z1, x2, y2, z2,
norm,
123 . x3, y3, z3, n3, pnor1, pnor2, pnorm1, det, det1, det2, det3
124 LOGICAL IS_AVAILABLE
125
126
127
128 INTEGER USR2SYS,NODGRNR5,ELEGROR
130
131
132 DATA mess/'SECTION DEFINITION '/
133 DATA iun/1/
134
135 ALLOCATE(tagelems(1+numelc+numels+numelt+numelq+numelp+numelr+numeltg))
136 ALLOCATE(nodtag(numnod))
137
138 noprint = 1
139 flag_fmt = 0
140 nfram = 0
141 nodtag = 0
142 tagelems = 0
143
144 nstrf(1)=0
145
146 nstrf(2)=0
147
148 nstrf(3)=0
149
150 nstrf(4)=1
151
152 nstrf(5)=2
153
154 lrec=0
155
156 nstrf(7)=0
157
158 k0 = 31
159 kr0= 11
160 nstrf(25)=k0
161 nstrf(26)=kr0
162 l0 = 7
163 ng = 0
164 iguq=0
165
167
168 DO i=1,nsect
169 igu = 0
170 istyp = 0
171 ng=ng+1
172 lrec = lrec+3
173 k1 = k0+30
174 CALL hm_option_read_key(lsubmodel, option_id=
id, option_titr=titr, unit_id=uid, submodel_id=sub_id, keyword2=key2)
175
176 CALL hm_get_intv(
'Axis_Origin_Node_N1', nstrf(k0+3), is_available, lsubmodel)
177 CALL hm_get_intv(
'Axis_Node_N2', nstrf(k0+4), is_available, lsubmodel)
178 CALL hm_get_intv(
'Axis_Node_N3', nstrf(k0+5), is_available, lsubmodel)
179 CALL hm_get_intv(
'ISAVE', nstrf(k0), is_available, lsubmodel)
180
182 ilen=len(char8)
183 ilen=len_trim(char8)
187 char8(k:k)=' '
188 ENDDO
189 ENDIF
190
191 IF(key2(1:5) == 'PARAL') THEN
192 istyp = 1
193 ELSEIF(key2(1:6) == 'CIRCLE') THEN
194 istyp = 2
195 ELSE
196 CALL hm_get_intv(
'Grnod_ID', igu, is_available, lsubmodel)
197 CALL hm_get_intv(
'System_Id', nfram, is_available, lsubmodel)
198 istyp = 0
199 ENDIF
200
201 CALL hm_get_floatv(
'detltaT', deltat, is_available, lsubmodel, unitab)
203 CALL hm_get_intv(
'grbrick_id', igus, is_available, lsubmodel)
204 CALL hm_get_intv(
'grshel_id', iguc, is_available, lsubmodel)
205 CALL hm_get_intv(
'grtrus_id', igut, is_available, lsubmodel)
206 CALL hm_get_intv(
'grbeam_id', igup, is_available, lsubmodel)
207 CALL hm_get_intv(
'grsprg_id', igur, is_available, lsubmodel)
208 CALL hm_get_intv(
'grtria_id', igutg, is_available, lsubmodel)
209 CALL hm_get_intv(
'Niter', nbinter, is_available, lsubmodel)
210 CALL hm_get_intv(
'Iframe', ifram, is_available, lsubmodel)
211
212 IF (nbinter < 0 .OR. nbinter > 10) THEN
214 ENDIF
215
216 iflagunit = 0
217 DO j=1,unitab%NUNITS
218 IF (unitab%UNIT_ID(j) == uid) THEN
219 fac_t = unitab%FAC_T(j)
220 iflagunit = 1
221 EXIT
222 ENDIF
223 ENDDO
224 IF (uid/=0.AND.iflagunit==0) THEN
225 CALL ancmsg(msgid=659,anmode=aninfo,msgtype=msgerror,i2=uid,i1=
id,c1=
'SECTION',c2=
'SECTION',c3=titr)
226 ENDIF
227
229
230 IF(igu == 0 .AND. nfram == 0 .AND. istyp == 0) THEN
232 . msgtype=msgwarning,
233 . anmode=aninfo_blind_1,
235 . c1=titr)
236 ENDIF
237
239 nom_sect((i-1)*
ncharline+j) = ichar(char8(j:j))
240 ENDDO
241
242 DO j=1,nbinter
244 ENDDO
245
246 IF (istyp == 1) THEN
247 CALL hm_get_floatv(
'XTail', xm, is_available, lsubmodel, unitab)
248 CALL hm_get_floatv(
'YTail', ym, is_available, lsubmodel, unitab)
249 CALL hm_get_floatv(
'ZTail', zm, is_available, lsubmodel, unitab)
250 IF(sub_id /= 0)
CALL subrotpoint(xm,ym,zm,rtrans,sub_id,lsubmodel)
251
252 CALL hm_get_floatv(
'cnode1_x', x1, is_available, lsubmodel, unitab)
253 CALL hm_get_floatv(
'cnode1_y', y1, is_available, lsubmodel, unitab)
255 IF(sub_id /= 0)
CALL subrotpoint(x1,y1,z1,rtrans,sub_id,lsubmodel)
256
258 CALL hm_get_floatv(
'cnode2_y', y2, is_available, lsubmodel, unitab)
259 CALL hm_get_floatv(
'cnode2_z', z2, is_available, lsubmodel, unitab)
260 IF(sub_id /= 0)
CALL subrotpoint(x2,y2,z2,rtrans,sub_id,lsubmodel)
261
262 d = xm
263 e = ym
264 f = zm
265 a = ((y1-ym)*(z2-zm))-((y2-ym)*(z1-zm))
266 b = ((x2-xm)*(z1-zm))-((x1-xm)*(z2-zm))
267 c = ((x1-xm)*(y2-ym))-((x2-xm)*(y1-ym))
272
273 ELSEIF (istyp == 2) THEN
274 CALL hm_get_floatv(
'XTail', xm, is_available, lsubmodel, unitab)
275 CALL hm_get_floatv(
'YTail', ym, is_available, lsubmodel, unitab)
276 CALL hm_get_floatv(
'ZTail', zm, is_available, lsubmodel, unitab)
277 IF(sub_id /= 0)
CALL subrotpoint(xm,ym,zm,rtrans,sub_id,lsubmodel)
278
279 CALL hm_get_floatv(
'Normal_x', a, is_available, lsubmodel, unitab)
280 CALL hm_get_floatv(
'Normal_y', b, is_available, lsubmodel, unitab)
281 CALL hm_get_floatv(
'Normal_z', c, is_available, lsubmodel, unitab)
282 IF(sub_id /= 0)
CALL subrotvect(a,b,c,rtrans,sub_id,lsubmodel)
283
284 CALL hm_get_floatv(
'Radius', r, is_available, lsubmodel, unitab)
285
286 d = xm
287 e = ym
288 f = zm
293 ENDIF
294
295 DO j=1,nbinter
296 DO l=1,ninter
297 IF(nstrf(k1-1+j)==ipari(15,l))THEN
298 ipari(28,l) = ipari(28,l) + 1
299
300 ENDIF
301 ENDDO
302 ENDDO
303
304
305
306
307
308
309 IF (istyp >= 1 .OR. nfram > 0) THEN
310 IF(istyp == 0) THEN
311 DO k=1,numfram
312 j=k+1
313 jj=(numskw+1)+
nsubmod+
min(iun,nspcond)*numsph+k+1
314 IF(nfram==iskn(4,jj)) THEN
315 a = xframe(7,j)
316 b = xframe(8,j)
317 c = xframe(9,j)
318 d = xframe(10,j)
319 e = xframe(11,j)
320 f = xframe(12,j)
321 n1 = iskn(1,jj)
322 IF (nstrf(k0+3) == 0 ) THEN
323 IF (iskn(1,jj) /= 0) THEN
324 nstrf(k0+3) = itab(iskn(1,jj))
325 ELSE
327 . msgtype=msgerror,
328 . anmode=aninfo,
330 . c1=titr,
331 . c2='N1',
332 . i2=nfram)
333 ENDIF
334 ENDIF
335 IF (nstrf(k0+4) == 0 ) THEN
336 IF (iskn(2,jj) /= 0) THEN
337 nstrf(k0+4) = itab(iskn(2,jj))
338 ELSE
340 . msgtype=msgerror,
341 . anmode=aninfo,
343 . c1=titr,
344 . c2='N2',
345 . i2=nfram)
346 ENDIF
347 ENDIF
348 IF (nstrf(k0+5) == 0 ) THEN
349 IF (iskn(3,jj) /= 0) THEN
350 nstrf(k0+5) = itab(iskn(3,jj))
351 ELSE
353 . msgtype=msgerror,
354 . anmode=aninfo,
356 . c1=titr,
357 . c2='N3',
358 . i2=nfram)
359 ENDIF
360 ENDIF
361 ENDIF
362 ENDDO
363 ENDIF
364 kk=1+ngrnod
365 nnod = 0
366 cpt = 1
368 2 b,c,d,e,f,ixs,ixs10,ixs16,ixs20,
369 3 nixs,nnod,nstrf,nbinter,k1,
370 4 cpt,nodtag,isolnod,tagelems,
371 5 x1,y1,z1,x2,y2,z2,r)
372
373 kk=kk+ngrbric
374 ENDIF
375
376 k2=k1+nbinter
377
378 IF (nfram == 0 .AND. istyp == 0) THEN
379 nnod=
nodgrnr5(igu,igs,nstrf(k2),igrnod,itabm1,mess)
380 ENDIF
381
382 k3=k2+nnod
383 nsegs=
elegror(igus,igrbric,ngrbric,
'BRIC',nstrf(k3),2,mess,nfram,tagelems,istyp,
id,titr)
384 k4=k3+2*nsegs
385 nsegq=0
386 k5=k4+2*nsegq
387 nsegc=0
388 k6=k5+2*nsegc
389 nsegt=0
390 k7=k6+2*nsegt
391 nsegp=0
392 k8=k7+2*nsegp
393 nsegr=0
394 k9=k8+2*nsegr
395 nsegtg=0
396
397 nstrf(k0+6)=nnod
398 nstrf(k0+7)=nsegs
399 nstrf(k0+8)=nsegq
400 nstrf(k0+9)=nsegc
401 nstrf(k0+10)=nsegt
402 nstrf(k0+11)=nsegp
403 nstrf(k0+12)=nsegr
404 nstrf(k0+13) = nsegtg
405 nstrf(k0+26) = ifram
406 DO l=k0+3,k0+5
407 IF (nstrf(l)/=0) THEN
408 nstrf(l)=
usr2sys(nstrf(l),itabm1,mess,
id)
409 CALL anodset(nstrf(l), check_used)
410 ENDIF
411 ENDDO
412 nnsk1=itab(nstrf(k0+3))
413 nnsk2=itab(nstrf(k0+4))
414 nnsk3=itab(nstrf(k0+5))
415 x1=x0(1,nstrf(k0+4))-x0(1,nstrf(k0+3))
416 y1=x0(2,nstrf(k0+4))-x0(2,nstrf(k0+3))
417 z1=x0(3,nstrf(k0+4))-x0(3,nstrf(k0+3))
418 x2=x0(1,nstrf(k0+5))-x0(1,nstrf(k0+4))
419 y2=x0(2,nstrf(k0+5))-x0(2,nstrf(k0+4))
420 z2=x0(3,nstrf(k0+5))-x0(3,nstrf(k0+4))
421 x3=y1*z2-z1*y2
422 y3=z1*x2-z2*x1
423 z3=x1*y2-x2*y1
424 n3=x3*x3+y3*y3+z3*z3
425
426 pnor1=sqrt(x1*x1+y1*y1+z1*z1)
427 IF (pnor1 < em20) THEN
429 . msgtype=msgerror,
430 . anmode=aninfo_blind_1,
432 . c1=titr)
433 ELSE
434 pnor2=sqrt(n3)
435 IF (pnor2 > em20) THEN
436 pnorm1=one/(pnor1*pnor2)
437 det1=abs((y3*z1-z3*y1)*pnorm1)
438 det2=abs((z3*x1-x3*z1)*pnorm1)
439 det3=abs((x3*y1-y3*x1)*pnorm1)
440 det=
max(det1,det2,det3)
441 ELSE
442 det=zero
443 ENDIF
444 IF (det < em5) THEN
446 . msgtype=msgerror,
447 . anmode=aninfo_blind_1,
449 . c1=titr)
450 ENDIF
451 ENDIF
452
453
454
455
456 CALL secstri(nsegs,nstrf(k3),ixs,ixs10,ixs16,ixs20,nstrf(k2),nnod,noprint)
457 IF(nstrf(k0)>=102)THEN
458 CALL zerore(1,10+30*nnod,secbuf(kr0))
459 ELSEIF(nstrf(k0)>=101)THEN
460 CALL zerore(1,10+24*nnod,secbuf(kr0))
461 ELSEIF(nstrf(k0)>=100)THEN
462 CALL zerore(1,10+12*nnod,secbuf(kr0))
463 ELSE
464 CALL zerore(1,10,secbuf(kr0))
465 ENDIF
466 secbuf(kr0) = deltat
467 secbuf(kr0+1) = zero
468 secbuf(kr0+2) =
alpha
469 secbuf(kr0+3) = zero
470
471 IF(nstrf(k0)==1.OR.nstrf(k0)==2)THEN
472 IF(secbuf(1)==zero)THEN
473 secbuf(1) = deltat
474 ELSEIF(abs((secbuf(1)-deltat)/secbuf(1)) > em06 )THEN
476 . msgtype=msgerror,
477 . anmode=aninfo_blind_2,
479 . c1=titr)
480 ENDIF
481 ENDIF
482
483 IF(nstrf(k0)>=1.AND.nstrf(k0)<=10)THEN
484 nstrf(1)=nstrf(1)+1
485 ELSEIF(nstrf(k0)>=100.AND.nstrf(k0)<=200)THEN
486 nstrf(2)=nstrf(2)+1
487 DO j=1,8
488 nstrf(15+j)=nstrf(k0+14+j)
489 ENDDO
490 ENDIF
491 IF(nstrf(k0)==1)THEN
492 lrec = lrec+6*nnod
493 ELSEIF(nstrf(k0)==2)THEN
494 lrec = lrec+12*nnod
495 ENDIF
496
498 nstrf(k0+24) = k9+2*nsegtg
499 nstrf(k0+25) = kr0+10
500 IF(nstrf(k0)>=100)nstrf(k0+25) = nstrf(k0+25)+12*nnod
501 IF(nstrf(k0)>=101)nstrf(k0+25) = nstrf(k0+25)+12*nnod
502 IF(nstrf(k0)>=102)nstrf(k0+25) = nstrf(k0+25)+6*nnod
503
504 kr0 = nstrf(k0+25)
505 k0 = nstrf(k0+24)
506
507 nodtag = 0
508 tagelems = 0
509 ENDDO
510 CALL udouble(sectids,1,nsect,mess,0,bid)
511
512
513 nstrf(6)=lrec*4
514
515
516 DEALLOCATE(nodtag)
517 DEALLOCATE(tagelems)
518 RETURN
void anodset(int *id, int *type)
norm(diag(diag(diag(inv(mat))) -id.SOL), 2) % destroy mumps instance id.JOB
integer function elegror(igu, igrele, ngrele, mot, ibuf, nib, mess, nfram, tagelems, istyp, id, titr)
subroutine hm_get_floatv(name, rval, is_available, lsubmodel, unitab)
subroutine hm_get_int_array_index(name, ival, index, is_available, lsubmodel)
subroutine hm_get_intv(name, ival, is_available, lsubmodel)
subroutine hm_get_string(name, sval, size, is_available)
subroutine hm_option_start(entity_type)
subroutine sec_nodes_sol(igu1, istyp, igrbric, x0, a, b, c, d, e, f, ixs, ixs10, ixs16, ixs20, nix, nnod, nstrf, nbinter, k1, j, nodtag, isolnod, tagelems, x1, y1, z1, x2, y2, z2, r)
subroutine secstri(nseg, isecbuf, ixs, ixs10, ixs16, ixs20, nod, nnod, noprint)
integer, parameter nchartitle
integer, parameter ncharfield
integer, parameter ncharline
subroutine ancmsg(msgid, msgtype, anmode, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, r1, r2, r3, r4, r5, r6, r7, r8, r9, c1, c2, c3, c4, c5, c6, c7, c8, c9, prmode)
integer function usr2sys(iu, itabm1, mess, id)
subroutine udouble(list, ilist, nlist, mess, ir, rlist)
subroutine subrotvect(x, y, z, rtrans, sub_id, lsubmodel)
subroutine subrotpoint(x, y, z, rtrans, sub_id, lsubmodel)
subroutine zerore(n1, n2, am)