43
44
45
49 USE my_alloc_mod
50
51
52
53#include "implicit_f.inc"
54#include "comlock.inc"
55
56
57
58#include "com01_c.inc"
59#include "com04_c.inc"
60#include "task_c.inc"
61#include "scr02_c.inc"
62#include "scr07_c.inc"
63#include "scr14_c.inc"
64#include "scr16_c.inc"
65#include "scr18_c.inc"
66#include "units_c.inc"
67#include "com08_c.inc"
68#include "param_c.inc"
69#include "parit_c.inc"
70#include "sms_c.inc"
71
72
73
74 INTEGER NODFT, NODLT,NELTST,ITYPTST,ITAB(*),
75 . WEIGHT(*),IMSCH,
76 . ISMSCH, NODNX_SMS(*), NPBY(NNPBY,*), TAGMSR_RBY_SMS(*)
77
79 . ms(*) ,in(*) ,stifn(*), stifr(*),adt(*) ,adm(*) ,
80 . a(3,*) ,ar(3,*) ,adi(*) ,rbym(nfrbym,*),arby(3,*),
81 . arrby(3,*), diag_sms(*)
82 TYPE(H3D_DATABASE) :: H3D_DATA
83
84 TYPE (GROUP_) , DIMENSION(NGRNOD) :: IGRNOD
85
86
87
88 INTEGER N, NN, K1, KMAX1, K2, KMAX2, ISTOP,I,J,
89 . (1024), INDTN2(1024), IOK, K, M, MSR, NSN, IAD
90 INTEGER,DIMENSION(:),ALLOCATABLE ::
91 INTEGER,DIMENSION(:),ALLOCATABLE :: TAGR
93 . dtnod1, dtnod2, dt2p, mas, iner, mas0, dmm, mass, sti,
94 . dt2x, dt2s
95
96 CALL my_alloc(tag,numnod)
97 CALL my_alloc(tagr,numnod)
98
99
100
101 IF(idtgr(11)<0)THEN
102 iok = 0
103 DO n=1,ngrnod
104 IF (-idtgr(11)==igrnod(n)%ID) THEN
105 idtgr(11)=n
106 iok = 1
107 ENDIF
108 ENDDO
109 IF (iok == 0) THEN
110 CALL ancmsg(msgid=237,anmode=aninfo,
111 . i1=-idtgr(11))
113 ENDIF
114 ENDIF
115 IF(idtgr(11)/=0)THEN
116 DO n=nodft,nodlt
117 tag(n) = 0
118 tagr(n) = 0
119 ENDDO
120 DO n=1,igrnod(idtgr(11))%NENTITY
121 IF(nodnx_sms(igrnod(idtgr(11))%ENTITY(n))==0)THEN
122 tag(igrnod(idtgr(11))%ENTITY(n)) = 1
123 tagr(igrnod(idtgr(11))%ENTITY(n)) = 1
124 END IF
125 ENDDO
126 ELSE
127 DO n=nodft,nodlt
128 IF(nodnx_sms(n)==0)THEN
129 tag(n) = 1
130 tagr(n) = 1
131 ELSE
132 tag(n) = 0
133 tagr(n) = 0
134 END IF
135 ENDDO
136 ENDIF
137
138
139
140
141 imsch = 0
142
143 IF(anim_n(1)+outp_n(1)+h3d_data%N_SCAL_DT >0)THEN
144#include "vectorize.inc"
145 DO nn=nodft,nodlt
146 adt(nn) = ep06
147 ENDDO
148 ENDIF
149
150
151
152 istop = 0
153
154
155
156 dt2s=dt2t
157
158 IF(i7kglo > 0 .OR. nodadt /= 0)THEN
159 DO 370 i=nodft,nodlt,1024
160 k1 = 0
161 dtnod1 = ep20
162#include "vectorize.inc"
163 DO n=i,
min(nodlt,i+1023)
164 IF(stifn(n)<=zero)THEN
165 istop = -itab(n)
166 ELSEIF(nodnx_sms(n)==0)THEN
167 IF(ms(n)>zero)THEN
168 k1 = k1 + 1
169
170 dtn1(k1) = dtfac1(11)*sqrt(two * ms(n) / stifn(n))
171 dtnod1 =
min(dtnod1,dtn1(k1))
172 indtn1(k1) = n
173 ENDIF
174 ENDIF
175 ENDDO
176 kmax1 = k1
177
178 IF(dtnod1<dtmin1(11))THEN
179 IF(idtmin(11)==1.OR.idtmin(11)==5)THEN
180 DO k1=1,kmax1
181
182
183
184
185 dtn1(k1)=dtmin1(11)
186 ENDDO
187 ELSEIF(idtmin(11)==3.OR.idtmin(11)==8)THEN
188
189 IF (anim_n(2)+outp_n(2)+h3d_data%N_SCAL_DMAS >0) THEN
190#include "vectorize.inc"
191 DO k1=1,kmax1
192 IF(dtn1(k1)<dtmin1(11))THEN
193 n = indtn1(k1)
194 dt2p = dtmin1(11)/dtfac1(11)
195 mas = half * stifn(n) * dt2p * dt2p * onep00001
196 IF(tag(n)==1)THEN
197 IF(weight(n)==1) THEN
198 dmast = dmast + mas - ms(n)
199 adm(n) = mas*(one+adm(n))/ms(n) - one
200 ENDIF
201 ms(n) = mas
202 imsch = 1
203 ENDIF
204 dtn1(k1)=dtmin1(11)
205 ENDIF
206 ENDDO
207 ELSE
208#include "vectorize.inc"
209 DO k1=1,kmax1
210 IF(dtn1(k1)<dtmin1(11))THEN
211 n = indtn1(k1)
212 dt2p = dtmin1(11)/dtfac1(11)
213 mas = half * stifn(n) * dt2p * dt2p * onep00001
214 IF(tag(n)==1)THEN
215 dmast = dmast + (mas - ms(n))*weight(n)
216 ms(n) = mas
217 imsch = 1
218 ENDIF
219 dtn1(k1)=dtmin1(11)
220 ENDIF
221 ENDDO
222 ENDIF
223 ELSEIF(idtmin(11)==4)THEN
224#include "vectorize.inc"
225 DO k1=1,kmax1
226 IF(dtn1(k1)<dtmin1(11))THEN
227 n = indtn1(k1)
228 dt2p = dtmin1(11)/dtfac1(11)
229 mas = half * stifn(n) * dt2p * dt2p
230 mas=ms(n)/mas
231 dtn1(k1)=dtmin1(11)
232 a(1,n)=a(1,n)*mas
233 a(2,n)=a(2,n)*mas
234 a(3,n)=a(3,n)*mas
235 ENDIF
236 ENDDO
237 ENDIF
238 ENDIF
239
240 IF(dtnod1<dt2t)THEN
241 DO k1=1,kmax1
242 IF(dtn1(k1)<dt2t)THEN
243 n = indtn1(k1)
244 neltst = itab(n)
245 ityptst = 11
246 dt2t = dtn1(k1)
247 ENDIF
248 ENDDO
249 ENDIF
250#include "vectorize.inc"
251 DO n=i,
min(nodlt,i+1023)
252 stifn(n) = em20
253 ENDDO
254
255
256
257 IF(anim_n(1)+outp_n(1)+h3d_data%N_SCAL_DT >0)THEN
258#include "vectorize.inc"
259 DO k1=1,kmax1
260 adt(indtn1(k1))=dtn1(k1)
261 ENDDO
262 ENDIF
263 370 CONTINUE
264 END IF
265
266
267
268 IF (iroddl/=0) THEN
269 DO 450 i=nodft,nodlt,1024
270 dtnod1 = ep20
271 dtnod2 = ep20
272 k1 = 0
273 k2 = 0
274#include "vectorize.inc"
275 DO n=i,
min(nodlt,i+1023)
276 IF(stifr(n)<=zero)THEN
277 istop=-itab(n)
278 ELSEIF(nodadt/=0 .AND. nodnx_sms(n)==0)THEN
279 IF(in(n)>zero)THEN
280 k1 = k1 + 1
281 indtn1(k1) = n
282 dtn1(k1) = dtfac1(11)*sqrt(two * in(n) / stifr(n))
283 dtnod1 =
min(dtnod1,dtn1(k1))
284 ENDIF
285 ELSEIF(nodnx_sms(n)/=0)THEN
286 IF(in(n)>zero)THEN
287 k2 = k2 + 1
288 indtn2(k2) = n
289 dtn2(k2) = dtfacs*sqrt(two * in(n) / stifr(n))
290 dtnod2 =
min(dtnod2,dtn2(k2))
291 ENDIF
292 ENDIF
293 ENDDO
294 kmax1 = k1
295 kmax2 = k2
296 IF(dtnod1<dtmin1(11))THEN
297 IF(idtmin(11)==1.OR.idtmin(11)==5)THEN
298 DO k1=1,kmax1
299 dtn1(k1)=dtmin1(11)
300
301
302
303
304 ENDDO
305 ELSEIF(idtmin(11)==3.OR.idtmin(11)==8)THEN
306 IF (anim_n(12)+outp_n(3)+h3d_data%N_SCAL_DINER >0) THEN
307#include "vectorize.inc"
308 DO k1=1,kmax1
309 IF(dtn1(k1)<dtmin1(11))THEN
310 n = indtn1(k1)
311 iner = in(n)
312 dt2p = dtmin1(11)/dtfac1(11)
313 iner = half * stifr(n) * dt2p * dt2p * onep00001
314 IF(tagr(n)==1)THEN
315 IF(weight(n)==1)THEN
316 dinert = dinert + ( iner - in(n))
317 adi(n) = iner*(one+adi(n))/in(n) - one
318 END IF
319 in(n) =
max(iner,in(n))
320 imsch = 1
321 ENDIF
322 dtn1(k1)=dtmin1(11)
323 ENDIF
324 ENDDO
325
326 ELSE
327#include "vectorize.inc"
328 DO k1=1,kmax1
329 IF(dtn1(k1)<dtmin1(11))THEN
330 n = indtn1(k1)
331 iner = in(n)
332 dt2p = dtmin1(11)/dtfac1(11)
333 iner = half * stifr(n) * dt2p * dt2p * onep00001
334 IF(tagr(n)==1)THEN
335 dinert = dinert + ( iner - in(n))*weight(n)
336 in(n) =
max(iner,in(n))
337 imsch = 1
338 ENDIF
339 dtn1(k1)=dtmin1(11)
340 ENDIF
341 ENDDO
342 ENDIF
343 ELSEIF(idtmin(11)==4)THEN
344#include "vectorize.inc"
345 DO k1=1,kmax1
346 IF(dtn1(k1)<dtmin1(11))THEN
347 n = indtn1(k1)
348 dt2p = dtmin1(11)/dtfac1(11)
349 mas = half * stifr(n) * dt2p * dt2p
350 mas=in(n)/mas
351 dtn1(k1)=dtmin1(11)
352 ar(1,n)=ar(1,n)*mas
353 ar(2,n)=ar(2,n)*mas
354 ar(3,n)=ar(3,n)*mas
355 ENDIF
356 ENDDO
357 ENDIF
358 ENDIF
359
360 IF(dtnod1<dt2t)THEN
361 DO k1=1,kmax1
362 IF(dtn1(k1)<dt2t)THEN
363 n = indtn1(k1)
364 neltst = itab(n)
365 ityptst = 11
366 dt2t = dtn1(k1)
367 ENDIF
368 ENDDO
369 ENDIF
370
371 IF(dtnod2<dtmins)THEN
372 IF (anim_n(12)+outp_n(3)+h3d_data%N_SCAL_DINER >0) THEN
373#include "vectorize.inc"
374 DO k2=1,kmax2
375 IF(dtn2(k2)<dtmins)THEN
376 n = indtn2(k2)
377 iner = in(n)
378 dt2p = dtmins/dtfacs
379 iner = half * stifr(n) * dt2p * dt2p * onep00001
380 IF(nodnx_sms(n)/=0)THEN
381 IF(weight(n)==1)THEN
382 dinert = dinert + ( iner - in(n))
383 adi(n) = iner*(one+adi(n))/in(n) - one
384 END IF
385 in(n) =
max(iner,in(n))
386 imsch = 1
387 dtn2(k2)=dtmins
388 ENDIF
389 ENDIF
390 ENDDO
391
392 ELSE
393#include "vectorize.inc"
394 DO k2=1,kmax2
395 IF(dtn2(k2)<dtmins)THEN
396 n = indtn2(k2)
397 iner = in(n)
398 dt2p = dtmins/dtfacs
399 iner = half * stifr(n) * dt2p * dt2p * onep00001
400 IF(nodnx_sms(n)/=0)THEN
401 dinert = dinert + ( iner - in(n))*weight(n)
402 in(n) =
max(iner,in(n))
403 imsch = 1
404 dtn2(k2)=dtmins
405 ENDIF
406 ENDIF
407 ENDDO
408 ENDIF
409 ENDIF
410
411 IF(dtnod2<dt2t)THEN
412 DO k2=1,kmax2
413 IF(dtn2(k2)<dt2t)THEN
414 n = indtn2(k2)
415 neltst = itab(n)
416 ityptst = 11
417 dt2t = dtn2(k2)
418 ENDIF
419 ENDDO
420 ENDIF
421#include "vectorize.inc"
422 DO n=i,
min(nodlt,i+1023)
423 stifn(n) = em20
424 ENDDO
425#include "vectorize.inc"
426 DO n=i,
min(nodlt,i+1023)
427 stifr(n) = em20
428 ENDDO
429
430
431
432 IF(anim_n(1)+outp_n(1)+h3d_data%N_SCAL_DT >0)THEN
433#include "vectorize.inc"
434 DO k1=1,kmax1
435 n = indtn1(k1)
436 adt(n)=
min(adt(n),dtn1(k1))
437 ENDDO
438#include "vectorize.inc"
439 DO k2=1,kmax2
440 n = indtn2(k2)
441 adt(n)=
min(adt(n),dtn2(k2))
442 ENDDO
443 ENDIF
444 450 CONTINUE
445
446 ENDIF
447
448 IF(idtmin(11)==8) THEN
449 IF(dt2t < dtmin1(11)) dt2t=
min(dt2s,dtmin1(11))
450 END IF
451
452
453 IF (idtmin(11)/=5)THEN
454 IF(istop>0)THEN
455 tstop = tt
456#include "lockon.inc"
457 WRITE(iout,*)
458 . ' **ERROR : NODAL TIME STEP LESS OR EQUAL DTMIN N=',istop
459 WRITE(istdo,*)
460 . ' **ERROR : NODAL TIME STEP LESS OR EQUAL DTMIN N=',istop
461#include "lockoff.inc"
462 ELSEIF(istop<0)THEN
463 tstop = tt
464#include "lockon.inc"
465 WRITE(iout,*)
466 . ' **ERROR : NEGATIVE STIFFNESS NODE',-istop
467 WRITE(istdo,*)
468 . ' **ERROR : NEGATIVE STIFFNESS NODE',-istop
469 IF ( istamping == 1) THEN
470 WRITE(istdo,'(A)')'The run encountered a problem in an in
471 .terface Type 7.'
472 WRITE(istdo,'(A)')'You may need to check if there is enou
473 .gh clearance between the tools,'
474 WRITE(istdo,'(A)')'and that they do not penetrate each ot
475 .her during their travel'
476 WRITE(iout, '(A)')'The run encountered a problem in an in
477 .terface Type 7.'
478 WRITE(iout, '(A)')'You may need to check if there is enou
479 .gh clearance between the tools,'
480 WRITE(iout, '(A)')'and that they do not penetrate each ot
481 .her during their travel'
482 ENDIF
483#include "lockoff.inc"
484 ENDIF
485 ELSE
486 IF(istop>0)THEN
487 mstop = 2
488#include "lockon.inc"
489 WRITE(iout,*)
490 . ' **ERROR : NODAL TIME STEP LESS OR EQUAL DTMIN N=',istop
491 WRITE(istdo,*)
492 . ' **ERROR : NODAL TIME STEP LESS OR EQUAL DTMIN N=',istop
493#include "lockoff.inc"
494 ELSEIF(istop<0)THEN
495 mstop = 2
496#include "lockon.inc"
497 WRITE(iout,*)
498 . ' **ERROR : NEGATIVE STIFFNESS NODE',-istop
499 WRITE(istdo,*)
500 . ' **ERROR : NEGATIVE STIFFNESS NODE',-istop
501 IF ( istamping == 1) THEN
502 WRITE(istdo,'(A)')'The run encountered a problem in an in
503 .terface Type 7.'
504 WRITE(istdo,'(A)')'You may need to check if there is enou
505 .gh clearance between the tools,'
506 WRITE(istdo,'(A)')'and that they do not penetrate each ot
507 .her during their travel'
508 WRITE(iout, '(A)')'The run encountered a problem in an in
509 .terface Type 7.'
510 WRITE(iout, '(A)')'You may need to check if there is enou
511 .gh clearance between the tools,'
512 WRITE(iout, '(A)')'and that they do not penetrate each ot
513 .her during their travel'
514 ENDIF
515#include "lockoff.inc"
516 ENDIF
517 ENDIF
518 IF(iparit==0) THEN
519 IF(iroddl==0) THEN
520 DO n = nodft, nodlt
521 stifn(n) = stifn(n)*weight(n)
522 ENDDO
523 ELSE
524 DO n = nodft, nodlt
525 stifn(n) = stifn(n)*weight(n)
526 stifr(n) = stifr(n)*weight(n)
527 ENDDO
528 ENDIF
529 ENDIF
530
531 DEALLOCATE(tag)
532 DEALLOCATE(tagr)
533
534 RETURN
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)
1.15.0