OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_build_mat_2.F File Reference
#include "implicit_f.inc"
#include "comlock.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "kincod_c.inc"
#include "param_c.inc"
#include "parit_c.inc"
#include "sms_c.inc"
#include "scr17_c.inc"
#include "task_c.inc"
#include "warn_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sms_build_mat_2 (itask, nodft, nodlt, ixc, iparg, ixs, ixt, ixp, ixr, ixtg, nodnx_sms, ms, ms0, indx1_sms, indx2_sms, jad_sms, jdi_sms, lt_sms, kad_sms, kdi_sms, ltk_sms, pk_sms, nodii_sms, jadc_sms, jads_sms, jadt_sms, jadp_sms, jadr_sms, jadtg_sms, diag_sms, tagprt_sms, tagrel_sms, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartur, iparttg, ipartx, iad_elem, fr_elem, npby, lpby, tagslv_rby_sms, lad_sms, jsm_sms, dmeltg, dmelc, mskyi_sms, iskyi_sms, jadi_sms, jdii_sms, lti_sms, nodxi_sms, dmels, dmeltr, dmelp, dmelrt, igeo, fr_sms, fr_rms, ev, ipari, intbuf_tab, kinet, tagslv_i21_sms, jadi21_sms, intstamp, ixs10, jads10_sms, ilink, rlink, nnlink, lnlink, tag_lnk_sms, ljoint, iadcj, fr_cj, itab, weight, dmint2, elbuf_tab, tagmsr_rby_sms, nprw, lprw, fr_wall, nrwl_sms, rby, x, a, ar, in, v, vr, irbe2, lrbe2, irbe3, lrbe3, iad_rbe3m, fr_rbe3m, nativ_sms, t2main_sms, t2fac_sms, mskyi_fi_sms, list_sms, list_rms, sz_mw6, mw6)

Function/Subroutine Documentation

◆ sms_build_mat_2()

subroutine sms_build_mat_2 ( integer itask,
integer nodft,
integer nodlt,
integer, dimension(nixc,*) ixc,
integer, dimension(nparg,*) iparg,
integer, dimension(nixs,*) ixs,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(*) nodnx_sms,
ms,
ms0,
integer, dimension(*) indx1_sms,
integer, dimension(*) indx2_sms,
integer, dimension(*) jad_sms,
integer, dimension(*) jdi_sms,
lt_sms,
integer, dimension(*) kad_sms,
integer, dimension(*) kdi_sms,
ltk_sms,
integer, dimension(*) pk_sms,
integer, dimension(*) nodii_sms,
integer, dimension(4,*) jadc_sms,
integer, dimension(8,*) jads_sms,
integer, dimension(2,*) jadt_sms,
integer, dimension(2,*) jadp_sms,
integer, dimension(3,*) jadr_sms,
integer, dimension(3,*) jadtg_sms,
diag_sms,
integer, dimension(*) tagprt_sms,
integer, dimension(*) tagrel_sms,
integer, dimension(*) iparts,
integer, dimension(*) ipartq,
integer, dimension(*) ipartc,
integer, dimension(*) ipartt,
integer, dimension(*) ipartp,
integer, dimension(*) ipartr,
integer, dimension(*) ipartur,
integer, dimension(*) iparttg,
integer, dimension(*) ipartx,
integer, dimension(2,nspmd+1) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(*) tagslv_rby_sms,
integer, dimension(*) lad_sms,
integer, dimension(*) jsm_sms,
dmeltg,
dmelc,
mskyi_sms,
integer, dimension(lskyi_sms,*) iskyi_sms,
integer, dimension(*) jadi_sms,
integer, dimension(*) jdii_sms,
lti_sms,
integer, dimension(*) nodxi_sms,
dmels,
dmeltr,
dmelp,
dmelrt,
integer, dimension(npropgi,*) igeo,
integer, dimension(nspmd+1) fr_sms,
integer, dimension(nspmd+1) fr_rms,
ev,
integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) kinet,
integer, dimension(*) tagslv_i21_sms,
integer, dimension(*) jadi21_sms,
type(intstamp_data), dimension(*) intstamp,
integer, dimension(6,*) ixs10,
integer, dimension(6,*) jads10_sms,
integer, dimension(*) ilink,
integer, dimension(*) rlink,
integer, dimension(10,*) nnlink,
integer, dimension(*) lnlink,
integer, dimension(*) tag_lnk_sms,
integer, dimension(*) ljoint,
integer, dimension(nspmd+1,*) iadcj,
integer, dimension(*) fr_cj,
integer, dimension(*) itab,
integer, dimension(*) weight,
dmint2,
type (elbuf_struct_), dimension(ngroup), target elbuf_tab,
integer, dimension(*) tagmsr_rby_sms,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(*) fr_wall,
integer, dimension(*) nrwl_sms,
rby,
x,
a,
ar,
in,
v,
vr,
integer, dimension(*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) irbe3,
integer, dimension(*) lrbe3,
integer, dimension(*) iad_rbe3m,
integer, dimension(*) fr_rbe3m,
integer, dimension(*) nativ_sms,
integer, dimension(6,*) t2main_sms,
t2fac_sms,
intent(inout) mskyi_fi_sms,
integer, dimension(fr_sms(nspmd+1)), intent(inout) list_sms,
integer, dimension(fr_rms(nspmd+1)), intent(inout) list_rms,
integer, intent(in) sz_mw6,
double precision, dimension(6,sz_mw6), intent(inout) mw6 )

Definition at line 41 of file sms_build_mat_2.F.

65C-----------------------------------------------
66C M o d u l e s
67C-----------------------------------------------
68 USE intstamp_mod
69 USE message_mod
70 USE elbufdef_mod
71 USE intbufdef_mod
72 USE my_alloc_mod
73 use element_mod , only : nixs,nixq,nixc,nixt,nixr,nixp,nixtg
74C-----------------------------------------------
75C I m p l i c i t T y p e s
76C-----------------------------------------------
77#include "implicit_f.inc"
78#include "comlock.inc"
79C-----------------------------------------------
80C C o m m o n B l o c k s
81C-----------------------------------------------
82#include "com01_c.inc"
83#include "com04_c.inc"
84#include "kincod_c.inc"
85#include "param_c.inc"
86#include "parit_c.inc"
87#include "sms_c.inc"
88#include "scr17_c.inc"
89#include "task_c.inc"
90#include "warn_c.inc"
91C-----------------------------------------------
92C D u m m y A r g u m e n t s
93C-----------------------------------------------
94 INTEGER ITASK, NODFT, NODLT,
95 . IPARG(NPARG,*), IXC(NIXC,*), IXS(NIXS,*), IXT(NIXT,*),
96 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*),
97 . NODNX_SMS(*), JAD_SMS(*), JDI_SMS(*),
98 . KAD_SMS(*), KDI_SMS(*), PK_SMS(*),
99 . JADC_SMS(4,*), JADS_SMS(8,*),
100 . JADT_SMS(2,*), JADP_SMS(2,*),
101 . JADR_SMS(3,*), JADTG_SMS(3,*),
102 . INDX1_SMS(*), INDX2_SMS(*), TAGPRT_SMS(*), TAGREL_SMS(*),
103 . IPARTS(*), IPARTQ(*), IPARTC(*), IPARTT(*),
104 . IPARTP(*), IPARTR(*), IPARTUR(*), IPARTTG(*), IPARTX(*),
105 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),
106 . NPBY(NNPBY,*), LPBY(*), TAGSLV_RBY_SMS(*),
107 . LAD_SMS(*), JSM_SMS(*),
108 . ISKYI_SMS(LSKYI_SMS,*),
109 . JADI_SMS(*), JDII_SMS(*), NODXI_SMS(*), NODII_SMS(*),
110 . IGEO(NPROPGI,*),
111 . FR_RMS(NSPMD+1), FR_SMS(NSPMD+1),
112 . IPARI(NPARI,*), KINET(*),
113 . TAGSLV_I21_SMS(*), JADI21_SMS(*),
114 . IXS10(6,*), JADS10_SMS(6,*),
115 . ILINK(*), RLINK(*), NNLINK(10,*), LNLINK(*),
116 . TAG_LNK_SMS(*), LJOINT(*), FR_CJ(*),IADCJ(NSPMD+1,*),
117 . ITAB(*), WEIGHT(*), TAGMSR_RBY_SMS(*),
118 . NPRW(*), LPRW(*), FR_WALL(*), NRWL_SMS(*),
119 . IRBE2(*), LRBE2(*),
120 . IRBE3(*), LRBE3(*), IAD_RBE3M(*),FR_RBE3M(*), NATIV_SMS(*),
121 . T2MAIN_SMS(6,*)
122 my_real
123 . ms(*), ms0(*), lt_sms(*), ltk_sms(*), diag_sms(*),
124 . dmeltg(*), dmelc(*), mskyi_sms(*), lti_sms(*),
125 . dmels(*), dmeltr(*), dmelp(*), dmelrt(*), ev(*),
126 . dmint2(4,*), rby(nrby,*), x(3,*), a(3,*), ar(3,*), in(*),
127 . v(3,*), vr(3,*),t2fac_sms(*)
128 my_real,dimension(fr_rms(nspmd+1)),intent(inout) :: mskyi_fi_sms
129 integer,dimension(fr_sms(nspmd+1)),intent(inout) :: LIST_SMS
130 integer,dimension(fr_rms(nspmd+1)),intent(inout) :: LIST_RMS
131 integer,intent(in) :: SZ_mw6
132 DOUBLE PRECISION,dimension(6,SZ_mw6),intent(inout) :: MW6
133
134 TYPE(INTSTAMP_DATA) INTSTAMP(*)
135 TYPE (ELBUF_STRUCT_), DIMENSION(NGROUP), TARGET :: ELBUF_TAB
136 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
137C-----------------------------------------------
138C L o c a l V a r i a b l e s
139C-----------------------------------------------
140 INTEGER I, J, K, JJ, KK, II, IJ, IK, N, M, NN, P, LOC_PROC
141 INTEGER NG, ITY, NEL, NFT, ISOLNOD,MLW,LFT, LLT,
142 . KAD, NPT, IHBE, ICNOD, ISTRA, IEXPAN, IE, J1,
143 . ILOC4(4), IG, IGTYP, IERROR, IPERM1(6), IPERM2(6),IPENTA6(6)
144 INTEGER MSR, NSN, KI, KJ
145 INTEGER IAD, L, JI
146 INTEGER,DIMENSION(:),ALLOCATABLE :: TAGA
147 INTEGER,DIMENSION(:),ALLOCATABLE :: NAD_SMS
148 INTEGER,DIMENSION(:),ALLOCATABLE :: KADI_SMS
149 INTEGER,DIMENSION(:),ALLOCATABLE :: NADI_SMS
150 INTEGER,DIMENSION(:),ALLOCATABLE :: TAG8
151 INTEGER,DIMENSION(:),ALLOCATABLE :: NAD_SMS_0
152 INTEGER NTY, ILAGM, N1, N2, N3, N4,
153 . ILEV, KSN, KMULT
154 my_real
155 . mele4, mele12, ltij,
156 .
157 . xnod,
158 . fac_scal_i,fac_scal_j
159 my_real, dimension(:,:),ALLOCATABLE :: awork
160C-----
161 INTEGER, DIMENSION(:), ALLOCATABLE :: IMV
162 my_real
163 . , DIMENSION(:), ALLOCATABLE :: mv
164 double precision
165 . , DIMENSION(:,:), ALLOCATABLE :: mv6
166 my_real,
167 . DIMENSION(:), POINTER :: offg
168C-----
169 DATA iloc4/1,3,6,5/
170 DATA iperm1/1,2,3,1,2,3/
171 DATA iperm2/2,3,1,4,4,4/
172 DATA ipenta6/1,2,3,5,6,7/
173C-----------------------------------------------
174 CALL my_alloc(taga,numnod)
175 CALL my_alloc(nad_sms,numnod)
176 CALL my_alloc(kadi_sms,numnod+1)
177 CALL my_alloc(nadi_sms,numnod)
178 CALL my_alloc(tag8,numnod)
179 CALL my_alloc(nad_sms_0,numnod)
180 CALL my_alloc(awork,3,numnod)
181C-----------------------------------------------
182C reset enforcement of contact sorting
183!$OMP SINGLE
184 kforsms=0
185!$OMP END SINGLE
186C
187 IF(iparit/=0)THEN
188 IF(debug(9)==0)THEN
189 ALLOCATE(imv(2*nisky_sms+fr_rms(nspmd+1)),
190 . mv(2*nisky_sms+fr_rms(nspmd+1)),
191 . mv6(6,2*nisky_sms+fr_rms(nspmd+1)),stat=ierror)
192 ELSE
193 ALLOCATE(imv(nnz_sms+2*nisky_sms+fr_rms(nspmd+1)),
194 . mv(nnz_sms+2*nisky_sms+fr_rms(nspmd+1)),
195 . mv6(6,nnz_sms+2*nisky_sms+fr_rms(nspmd+1)),stat=ierror)
196 END IF
197 IF(ierror/=0) THEN
198 CALL ancmsg(msgid=19,anmode=aninfo,
199 . c1='(/DT/.../AMS)')
200 CALL arret(2)
201 ENDIF
202 END IF
203
204C
205 nodxi_sms(nodft:nodlt)=nodnx_sms(nodft:nodlt)
206C
207 CALL my_barrier()
208C
209C if /DT/INTER/AMS without /DT/AMS
210 IF(idtmins/=2)GO TO 100
211C
212!$OMP DO SCHEDULE(DYNAMIC,1)
213 DO ng = 1, ngroup
214C
215 IF(tagrel_sms(ng)==0)GOTO 250
216C
217 ity = iparg(5,ng)
218 mlw = iparg(1,ng)
219 nel = iparg(2,ng)
220 nft = iparg(3,ng)
221 kad = iparg(4,ng)
222 npt = iparg(6,ng)
223 icnod = iparg(11,ng)
224 istra = iparg(44,ng)
225 ihbe = iparg(23,ng)
226 isolnod = iparg(28,ng)
227 iexpan = iparg(49,ng)
228 IF (ihbe==101) THEN
229 ihbe=1
230 ELSEIF(ihbe==102) THEN
231 ihbe=0
232 ELSEIF(ihbe==112) THEN
233 ihbe=0
234 ENDIF
235 lft = 1
236 llt = nel
237 IF (ity==1.AND.isolnod==4) THEN
238 offg => elbuf_tab(ng)%GBUF%OFF
239 DO j=lft,llt
240 ie=nft+j
241
242 mele4=zero
243 IF(mlw/=0)THEN
244 IF (offg(j) > zero) THEN
245 mele4=half*dmels(ie)
246 END IF
247 END IF
248C
249C Me=[ 3*dmels -dmels ... -dmels ]
250C [ -dmels 3*dmels ... -dmels ]
251C [...]
252C w^2 < 2k / (m+4*dmels)
253C but dt = 2/w =sqrt( 2*(m+dmels) /k) => 4*dmels=dmels(mqviscb)/2
254C <=> mele12=dmels(mqviscb)/2/4
255 mele12=fourth*mele4
256 DO k=1,4
257 i=ixs(1+iloc4(k),ie)
258
259 ij=jads_sms(k,ie)
260 DO kk=1,4
261 jj = ixs(1+iloc4(kk),ie)
262 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
263 ltk_sms(ij)=-mele12
264 ij=ij+1
265 END IF
266 END DO
267 END DO
268 END DO
269 ELSEIF (ity==1.AND.isolnod==6) THEN
270 offg => elbuf_tab(ng)%GBUF%OFF
271 DO j=lft,llt
272 ie=nft+j
273
274 mele4=zero
275 IF(mlw/=0)THEN
276 IF (offg(j) > zero) THEN
277 mele4=half*dmels(ie)
278 END IF
279 END IF
280C
281C Me=[ 3*dmels -dmels ... -dmels ]
282C [ -dmels 3*dmels ... -dmels ]
283C [...]
284C w^2 < 2k / (m+4*dmels)
285C but dt = 2/w =sqrt( 2*(m+dmels) /k) => 4*dmels=dmels(mqviscb)/2
286C <=> mele12=dmels(mqviscb)/2/4
287 mele12=one_over_6*mele4
288 DO k=1,6
289 i=ixs(1+ipenta6(k),ie)
290
291 ij=jads_sms(k,ie)
292 DO kk=1,6
293 jj = ixs(1+ipenta6(kk),ie)
294 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
295 ltk_sms(ij)=-mele12
296 ij=ij+1
297 END IF
298 END DO
299 END DO
300 END DO
301 ELSEIF(ity==1.AND.isolnod==8)THEN
302 offg => elbuf_tab(ng)%GBUF%OFF
303 DO j=lft,llt
304 ie=nft+j
305
306 kmult=1
307
308 mele4=zero
309 IF(mlw/=0)THEN
310 IF (offg(j) > zero) THEN
311 kmult=0
312 xnod=zero
313 DO k=1,8
314 i=ixs(1+k,ie)
315 taga(i)=0
316 END DO
317 DO k=1,8
318 i=ixs(1+k,ie)
319 IF(taga(i)==0)xnod=xnod+one
320 taga(i)=taga(i)+1
321 kmult=max(kmult,taga(i))
322 END DO
323C may be unstable for prisms
324C MELE4 =HALF*DMELS(IE)
325 mele4 =kmult*half*dmels(ie)
326C
327C Me=[ 7*dmels -dmels ... -dmels ]
328C [ -dmels 7*dmels ... -dmels ]
329C [...]
330C w^2 < 2k / (m+8*dmels)
331C but dt = 2/w =sqrt( 2*(m+dmels) /k) => 8*dmels=dmels(mqviscb)/2
332C <=> mele12=dmels=dmels(mqviscb)/2/8
333C
334C Pentas (note: 2x more mass than necessary on non-double nodes)
335C Me=[ 5*dmels -dmels ... -dmels ]
336C [ -dmels 5*dmels ... -dmels ]
337C [ -dmels -dmels 5*dmels -dmels ]
338C [...]
339C nds doubles w^2 < 4k / (2*m+6*dmels) , nds simples w^2 < 2k / (m+6*dmels)
340C but dt = 2/w =sqrt( 2*(m+dmels) /k) => 3*dmels=dmels(mqviscb)/2
341C <=> mele12=dmels=dmels(mqviscb)/2/3
342C =kmult*dmels(mqviscb)/2/6
343 mele12=(one/xnod)*mele4
344 ELSE
345 mele12=zero
346 END IF
347 ELSE
348C
349C void elements may be into contact
350 mele12=zero
351 END IF
352
353 DO k=1,8
354 i=ixs(1+k,ie)
355 taga(i)=0
356 tag8(k)=0
357 END DO
358
359 DO k=1,8
360 i=ixs(1+k,ie)
361 IF(taga(i)/=0)THEN
362 tag8(k)=1
363 ELSE
364 taga(i)=1
365 END IF
366 END DO
367 DO k=1,8
368 i=ixs(1+k,ie)
369 IF(tag8(k)/=0)cycle
370
371 ij=jads_sms(k,ie)
372 DO kk=1,8
373 jj = ixs(1+kk,ie)
374 IF(tag8(kk)/=0) cycle
375
376 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
377 ltk_sms(ij)=-mele12
378 ij=ij+1
379 END IF
380 END DO
381 END DO
382 END DO
383 ELSEIF(ity==1.AND.isolnod==10)THEN
384 IF(idt1tet10/=0)THEN
385 offg => elbuf_tab(ng)%GBUF%OFF
386 DO j=lft,llt
387 ie=nft+j
388 j1=ie-numels8
389
390 mele4=zero
391 IF(mlw/=0)THEN
392 IF (offg(j) > zero) THEN
393 mele4 = half*dmels(ie)
394C
395C Q: What VP for M-1K?M = [mvettex+9dm, -dm, .....]
396C [ -dm , Medge+9dm, -dm, ....]
397C .........
398C Mvertex = Mass/32, Medge=7*Mass/48
399C
400C A: Supposed lambda(M) > Mvertex+10dm
401C
402 mele4 = mele4/thirty2
403 END IF
404 END IF
405
406 mele12=mele4/ten
407
408 DO k=1,4
409 i=ixs(1+iloc4(k),ie)
410
411 ij=jads_sms(k,ie)
412 DO kk=1,4
413 jj = ixs(1+iloc4(kk),ie)
414 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
415 ltk_sms(ij)=-mele12
416 ij=ij+1
417 END IF
418 END DO
419
420 DO kk=1,6
421 jj = ixs10(kk,j1)
422 IF(jj==0) cycle
423
424 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
425 ltk_sms(ij)=-mele12
426 ij=ij+1
427 END IF
428 END DO
429 END DO
430
431 DO k=1,6
432
433 i =ixs10(k,j1)
434 IF(i==0)cycle
435
436 ij=jads10_sms(k,j1)
437
438 DO kk=1,4
439 jj = ixs(1+iloc4(kk),ie)
440 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
441 ltk_sms(ij)=-mele12
442 ij=ij+1
443 END IF
444 END DO
445
446 DO kk=1,6
447 jj = ixs10(kk,j1)
448 IF(jj==0) cycle
449
450 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
451 ltk_sms(ij)=-mele12
452 ij=ij+1
453 END IF
454 END DO
455
456 END DO
457
458C nd nonexistent midfielder, transfer to the summits (symmetry in jsm_sms ...)
459 DO k=1,6
460
461 i =ixs10(k,j1)
462 IF(i/=0)cycle
463
464 i=ixs(1+iloc4(iperm1(k)),ie)
465 ij=jads_sms(iperm1(k),ie)
466
467 DO kk=1,4
468 jj = ixs(1+iloc4(kk),ie)
469 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
470 ltk_sms(ij)=ltk_sms(ij)-half*mele12
471 ij=ij+1
472 END IF
473 END DO
474
475 DO kk=1,6
476 jj = ixs10(kk,j1)
477 IF(jj==0) cycle
478
479 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
480 ltk_sms(ij)=ltk_sms(ij)-half*mele12
481 ij=ij+1
482 END IF
483 END DO
484
485 i=ixs(1+iloc4(iperm2(k)),ie)
486 ij=jads_sms(iperm2(k),ie)
487
488 DO kk=1,4
489 jj = ixs(1+iloc4(kk),ie)
490 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
491 ltk_sms(ij)=ltk_sms(ij)-half*mele12
492 ij=ij+1
493 END IF
494 END DO
495
496 DO kk=1,6
497 jj = ixs10(kk,j1)
498 IF(jj==0) cycle
499
500 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
501 ltk_sms(ij)=ltk_sms(ij)-half*mele12
502 ij=ij+1
503 END IF
504 END DO
505 END DO
506 END DO
507 ELSE ! IF(IDT1TET10/=0)THEN (old way for ascending compatibility)
508 offg => elbuf_tab(ng)%GBUF%OFF
509 DO j=lft,llt
510 ie=nft+j
511 j1=ie-numels8
512
513 mele4=zero
514 IF(mlw/=0)THEN
515 IF (offg(j) > zero) THEN
516 mele4 = half*dmels(ie)
517C
518C Q: What VP for M-1K?M = [mvettex+9dm, -dm, .....]
519C [ -dm , Medge+9dm, -dm, ....]
520C .........
521C Mvertex = Mass/32, Medge=7*Mass/48
522C
523C A: Supposed lambda(M) > Mvertex+10dm
524C
525 mele4 = mele4*seven/forty8
526 END IF
527 END IF
528
529 mele12=mele4/nine
530
531 DO k=1,4
532 i=ixs(1+iloc4(k),ie)
533
534 ij=jads_sms(k,ie)
535 DO kk=1,4
536 jj = ixs(1+iloc4(kk),ie)
537 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
538 ltk_sms(ij)=-mele12
539 ij=ij+1
540 END IF
541 END DO
542
543 DO kk=1,6
544 jj = ixs10(kk,j1)
545 IF(jj==0) cycle
546
547 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
548 ltk_sms(ij)=-mele12
549 ij=ij+1
550 END IF
551 END DO
552 END DO
553
554 DO k=1,6
555
556 i =ixs10(k,j1)
557 IF(i==0)cycle
558
559 ij=jads10_sms(k,j1)
560
561 DO kk=1,4
562 jj = ixs(1+iloc4(kk),ie)
563 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
564 ltk_sms(ij)=-mele12
565 ij=ij+1
566 END IF
567 END DO
568
569 DO kk=1,6
570 jj = ixs10(kk,j1)
571 IF(jj==0) cycle
572
573 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
574 ltk_sms(ij)=-mele12
575 ij=ij+1
576 END IF
577 END DO
578
579 END DO
580
581C nd milieu inexistant, transfert aux sommets (symetrie dans JSM_SMS...)
582 DO k=1,6
583
584 i =ixs10(k,j1)
585 IF(i/=0)cycle
586
587 i=ixs(1+iloc4(iperm1(k)),ie)
588 ij=jads_sms(iperm1(k),ie)
589
590 DO kk=1,4
591 jj = ixs(1+iloc4(kk),ie)
592 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
593 ltk_sms(ij)=ltk_sms(ij)-half*mele12
594 ij=ij+1
595 END IF
596 END DO
597
598 DO kk=1,6
599 jj = ixs10(kk,j1)
600 IF(jj==0) cycle
601
602 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
603 ltk_sms(ij)=ltk_sms(ij)-half*mele12
604 ij=ij+1
605 END IF
606 END DO
607
608 i=ixs(1+iloc4(iperm2(k)),ie)
609 ij=jads_sms(iperm2(k),ie)
610
611 DO kk=1,4
612 jj = ixs(1+iloc4(kk),ie)
613 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
614 ltk_sms(ij)=ltk_sms(ij)-half*mele12
615 ij=ij+1
616 END IF
617 END DO
618
619 DO kk=1,6
620 jj = ixs10(kk,j1)
621 IF(jj==0) cycle
622
623 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
624 ltk_sms(ij)=ltk_sms(ij)-half*mele12
625 ij=ij+1
626 END IF
627 END DO
628 END DO
629 END DO
630 END IF
631 ELSEIF(ity==3)THEN
632 offg => elbuf_tab(ng)%GBUF%OFF
633 DO j=lft,llt
634 ie=nft+j
635
636 mele4=zero
637 IF(mlw/=0)THEN
638 IF (offg(j) > zero) THEN
639 mele4 =half*dmelc(ie)
640 END IF
641 END IF
642 mele12=third*mele4
643 DO k=1,4
644 i=ixc(1+k,ie)
645
646 ij=jadc_sms(k,ie)
647 DO kk=1,4
648 jj = ixc(1+kk,ie)
649 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
650 ltk_sms(ij)=-mele12
651 ij=ij+1
652 END IF
653 END DO
654 END DO
655 END DO
656 ELSEIF(ity==4)THEN
657 offg => elbuf_tab(ng)%GBUF%OFF
658 DO j=lft,llt
659 ie = nft+j
660
661 mele4=zero
662 IF(mlw/=0)THEN
663 IF (offg(j) > zero) THEN
664 mele4 =half*dmeltr(ie)
665 END IF
666 END IF
667 mele12=mele4
668 DO k=1,2
669 i=ixt(1+k,ie)
670 ij=jadt_sms(k,ie)
671 DO kk=1,2
672 jj = ixt(1+kk,ie)
673 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
674 ltk_sms(ij)=-mele12
675 ij=ij+1
676 END IF
677 END DO
678 END DO
679 END DO
680 ELSEIF(ity==5)THEN
681 offg => elbuf_tab(ng)%GBUF%OFF
682 DO j=lft,llt
683 ie = nft+j
684
685 mele4=zero
686 IF(mlw/=0)THEN
687 IF (offg(j) > zero) THEN
688 mele4 =half*dmelp(ie)
689 END IF
690 END IF
691 mele12=mele4
692 DO k=1,2
693 i=ixp(1+k,ie)
694
695 ij=jadp_sms(k,ie)
696 DO kk=1,2
697 jj = ixp(1+kk,ie)
698 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
699 ltk_sms(ij)=-mele12
700 ij=ij+1
701 END IF
702 END DO
703 END DO
704 END DO
705 ELSEIF(ity==6)THEN
706 ig = ixr(1,nft+1)
707 igtyp = igeo(11,ig)
708 offg => elbuf_tab(ng)%GBUF%OFF
709 IF(igtyp/=12)THEN
710 DO j=lft,llt
711 ie = nft+j
712
713 mele4=zero
714 IF(mlw/=0)THEN
715 IF (offg(j) > zero) THEN
716 mele4=half*dmelrt(ie)
717 END IF
718 END IF
719 mele12=mele4
720 DO k=1,2
721 i=ixr(1+k,ie)
722
723 ij=jadr_sms(k,ie)
724 DO kk=1,2
725 jj = ixr(1+kk,ie)
726 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
727 ltk_sms(ij)=-mele12
728 ij=ij+1
729 END IF
730 END DO
731 END DO
732 END DO
733 ELSE
734 DO j=lft,llt
735 ie = nft+j
736
737 mele12=zero
738 IF(mlw/=0)THEN
739 IF (offg(j) > zero) THEN
740 mele12=half*dmelrt(ie)
741 END IF
742 END IF
743
744 k=1
745 i=ixr(1+k,ie)
746
747 ij=jadr_sms(k,ie)
748 kk=2
749 jj = ixr(1+kk,ie)
750 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
751 ltk_sms(ij)=-mele12
752 ij=ij+1
753 END IF
754
755 k=2
756 i=ixr(1+k,ie)
757
758 ij=jadr_sms(k,ie)
759 kk=1
760 jj = ixr(1+kk,ie)
761 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
762 ltk_sms(ij)=-mele12
763 ij=ij+1
764 END IF
765 kk=3
766 jj = ixr(1+kk,ie)
767 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
768 ltk_sms(ij)=-mele12
769 ij=ij+1
770 END IF
771
772 k=3
773 i=ixr(1+k,ie)
774
775 ij=jadr_sms(k,ie)
776 kk=2
777 jj = ixr(1+kk,ie)
778 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
779 ltk_sms(ij)=-mele12
780 ij=ij+1
781 END IF
782
783 END DO
784 END IF
785 ELSEIF(ity==7)THEN
786 offg => elbuf_tab(ng)%GBUF%OFF
787 DO j=lft,llt
788 ie = nft+j
789
790 mele4=zero
791 IF(mlw/=0)THEN
792 IF (offg(j) > zero) THEN
793 mele4=half*dmeltg(ie)
794 END IF
795 END IF
796C
797C Me=[ 2*dmeltg -dmeltg -dmeltg ]
798C [ -dmeltg 2*dmeltg -dmeltg ]
799C [ -dmeltg -dmeltg 2*dmeltg
800C w^2 < 2k / (m+3*dmeltg)
801C but dt = 2/w =sqrt( 2*(m+dmelc) /k) => 3*dmeltg=dmeltg calculated/2
802C <=> mele12=dmeltg/3=dmeltg calculated/2/3
803 mele12=third*mele4
804 DO k=1,3
805 i=ixtg(1+k,ie)
806
807 ij=jadtg_sms(k,ie)
808 DO kk=1,3
809 jj = ixtg(1+kk,ie)
810 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
811 ltk_sms(ij)=-mele12
812 ij=ij+1
813 END IF
814 END DO
815 END DO
816 END DO
817 END IF
818 250 CONTINUE
819 END DO
820!$OMP END DO
821C
822 CALL my_barrier()
823C
824C-------------------------------------------------------------------------
825C KOMPACTING ELEMENTARY MATRIX
826C-------------------------------------------------------------------------
827 DO i=nodft, nodlt
828 DO ik=jad_sms(i),lad_sms(i)
829 lt_sms(ik)=zero
830 END DO
831
832 DO ij=kad_sms(i),kad_sms(i+1)-1
833 ik =jad_sms(i)+pk_sms(ij)-1
834 lt_sms(ik) = lt_sms(ik) + ltk_sms(ij)
835 END DO
836 END DO
837C
838 CALL my_barrier()
839C
840C------------
841C inter/type2
842C------------
843 IF(itask==0)THEN
844
845 DO i=1,numnod
846 nad_sms(i)=lad_sms(i)+1
847 END DO
848C
849C--- T2MAIN_SMS(6) must be updated if element failure
850 IF (ismsnok==1) THEN
851 DO n=1,ninter
852 nty = ipari(7,n)
853 ilagm = ipari(33,n)
854 ilev = ipari(20,n)
855 IF(nty==2 .AND. ilagm==0 .AND.ilev/=25.AND.ilev/=26)THEN
856 nsn=ipari(5,n)
857 DO ii=1,nsn
858 i=intbuf_tab(n)%NSV(ii)
859 IF (i < 0) t2main_sms(6,-i)=-1
860 ENDDO
861 ENDIF
862 END DO
863 ENDIF
864C
865 ksn=0
866 DO n=1,ninter
867 nty = ipari(7,n)
868 ilagm = ipari(33,n)
869 ilev = ipari(20,n)
870 IF(nty==2 .AND. ilagm==0 .AND.ilev/=25.AND.ilev/=26.AND.ilev/=27.AND.ilev/=28)THEN
871C
872 kad=ipari(1,n)
873 nsn=ipari(5,n)
874 DO ii=1,nsn
875 i=intbuf_tab(n)%NSV(ii)
876 l=intbuf_tab(n)%IRTLM(ii)
877 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
878 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
879 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
880 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
881
882 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
883 . .AND.nativ_sms(n2)==0
884 . .AND.nativ_sms(n3)==0
885 . .AND.nativ_sms(n4)==0) cycle
886
887C
888 IF(i > 0)THEN
889 DO kj=jad_sms(i),lad_sms(i)
890 j =jdi_sms(kj)
891 ltij = lt_sms(kj)
892 lt_sms(kj)=zero
893
894 IF (t2main_sms(1,j) == 1) THEN
895C-- No Type2 + AMS on J
896 lt_sms(nad_sms(j)) = ltij
897 lt_sms(nad_sms(n1))= ltij
898 nad_sms(j) =nad_sms(j)+1
899 nad_sms(n1)=nad_sms(n1)+1
900
901 lt_sms(nad_sms(j)) = ltij
902 lt_sms(nad_sms(n2))= ltij
903 nad_sms(j) =nad_sms(j)+1
904 nad_sms(n2)=nad_sms(n2)+1
905
906 lt_sms(nad_sms(j)) = ltij
907 lt_sms(nad_sms(n3))= ltij
908 nad_sms(j) =nad_sms(j)+1
909 nad_sms(n3)=nad_sms(n3)+1
910
911 lt_sms(nad_sms(j)) = ltij
912 lt_sms(nad_sms(n4))= ltij
913 nad_sms(j) =nad_sms(j)+1
914 nad_sms(n4)=nad_sms(n4)+1
915C
916 ELSEIF(t2main_sms(6,j)==0) THEN
917C-- Type2 crossed connection between main nodes - no failure on J
918C
919 lt_sms(nad_sms(j)) = zero
920 lt_sms(nad_sms(n1))= zero
921 nad_sms(j) =nad_sms(j)+1
922 nad_sms(n1)=nad_sms(n1)+1
923
924 lt_sms(nad_sms(j)) = zero
925 lt_sms(nad_sms(n2))= zero
926 nad_sms(j) =nad_sms(j)+1
927 nad_sms(n2)=nad_sms(n2)+1
928
929 lt_sms(nad_sms(j)) = zero
930 lt_sms(nad_sms(n3))= zero
931 nad_sms(j) =nad_sms(j)+1
932 nad_sms(n3)=nad_sms(n3)+1
933
934 lt_sms(nad_sms(j)) = zero
935 lt_sms(nad_sms(n4))= zero
936 nad_sms(j) =nad_sms(j)+1
937 nad_sms(n4)=nad_sms(n4)+1
938
939 IF (i>j) THEN
940 DO k =2,5
941 DO kk =2,5
942 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
943 lt_sms(nad_sms(t2main_sms(k,i))) = half*ltij
944 lt_sms(nad_sms(t2main_sms(kk,j)))= half*ltij
945 nad_sms(t2main_sms(k,i)) =nad_sms(t2main_sms(k,i))+1
946 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
947 ENDIF
948 ENDDO
949 ENDDO
950 ENDIF
951C
952 ELSE
953C-- Type2 crossed connection between main nodes - failure of main element of j
954C
955 lt_sms(nad_sms(j)) = ltij
956 lt_sms(nad_sms(n1))= ltij
957 nad_sms(j) =nad_sms(j)+1
958 nad_sms(n1)=nad_sms(n1)+1
959
960 lt_sms(nad_sms(j)) = ltij
961 lt_sms(nad_sms(n2))= ltij
962 nad_sms(j) =nad_sms(j)+1
963 nad_sms(n2)=nad_sms(n2)+1
964
965 lt_sms(nad_sms(j)) = ltij
966 lt_sms(nad_sms(n3))= ltij
967 nad_sms(j) =nad_sms(j)+1
968 nad_sms(n3)=nad_sms(n3)+1
969
970 lt_sms(nad_sms(j)) = ltij
971 lt_sms(nad_sms(n4))= ltij
972 nad_sms(j) =nad_sms(j)+1
973 nad_sms(n4)=nad_sms(n4)+1
974
975 IF (i>j) THEN
976 DO k =2,5
977 DO kk =2,5
978 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
979 lt_sms(nad_sms(t2main_sms(k,i))) = zero
980 lt_sms(nad_sms(t2main_sms(kk,j)))= zero
981 nad_sms(t2main_sms(k,i)) =nad_sms(t2main_sms(k,i))+1
982 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
983 ENDIF
984 ENDDO
985 ENDDO
986 ENDIF
987C
988 ENDIF
989C
990 END DO
991 ELSE
992 i=-i
993 DO kj=jad_sms(i),lad_sms(i)
994 j =jdi_sms(kj)
995 ltij = zero
996
997 IF (t2main_sms(1,j) == 1) THEN
998C-- No Type2 + AMS on J
999 lt_sms(nad_sms(j)) = ltij
1000 lt_sms(nad_sms(n1))= ltij
1001 nad_sms(j) =nad_sms(j)+1
1002 nad_sms(n1)=nad_sms(n1)+1
1003
1004 lt_sms(nad_sms(j)) = ltij
1005 lt_sms(nad_sms(n2))= ltij
1006 nad_sms(j) =nad_sms(j)+1
1007 nad_sms(n2)=nad_sms(n2)+1
1008
1009 lt_sms(nad_sms(j)) = ltij
1010 lt_sms(nad_sms(n3))= ltij
1011 nad_sms(j) =nad_sms(j)+1
1012 nad_sms(n3)=nad_sms(n3)+1
1013
1014 lt_sms(nad_sms(j)) = ltij
1015 lt_sms(nad_sms(n4))= ltij
1016 nad_sms(j) =nad_sms(j)+1
1017 nad_sms(n4)=nad_sms(n4)+1
1018
1019 ELSE
1020C-- Type2 crossed connection between main nodes
1021C
1022 lt_sms(nad_sms(j)) = zero
1023 lt_sms(nad_sms(n1))= zero
1024 nad_sms(j) =nad_sms(j)+1
1025 nad_sms(n1)=nad_sms(n1)+1
1026
1027 lt_sms(nad_sms(j)) = zero
1028 lt_sms(nad_sms(n2))= zero
1029 nad_sms(j) =nad_sms(j)+1
1030 nad_sms(n2)=nad_sms(n2)+1
1031
1032 lt_sms(nad_sms(j)) = zero
1033 lt_sms(nad_sms(n3))= zero
1034 nad_sms(j) =nad_sms(j)+1
1035 nad_sms(n3)=nad_sms(n3)+1
1036
1037 lt_sms(nad_sms(j)) = zero
1038 lt_sms(nad_sms(n4))= zero
1039 nad_sms(j) =nad_sms(j)+1
1040 nad_sms(n4)=nad_sms(n4)+1
1041
1042 IF (i>j) THEN
1043 DO k =2,5
1044 DO kk =2,5
1045 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1046 lt_sms(nad_sms(t2main_sms(k,i))) = half*ltij
1047 lt_sms(nad_sms(t2main_sms(kk,j)))= half*ltij
1048 nad_sms(t2main_sms(k,i)) =nad_sms(t2main_sms(k,i))+1
1049 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1050 ENDIF
1051 ENDDO
1052 ENDDO
1053 ENDIF
1054C
1055 ENDIF
1056C
1057 END DO
1058 END IF
1059 END DO
1060C
1061 ELSEIF(nty==2.AND.ilagm==0.AND.(ilev==25.or.ilev==26))THEN
1062C
1063 kad=ipari(1,n)
1064 nsn=ipari(5,n)
1065 DO ii=1,nsn
1066 i=intbuf_tab(n)%NSV(ii)
1067 ksn=ksn+1
1068
1069 IF(weight(abs(i))/=1)cycle
1070
1071 l=intbuf_tab(n)%IRTLM(ii)
1072 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1073 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1074 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1075 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1076
1077 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1078 . .AND.nativ_sms(n2)==0
1079 . .AND.nativ_sms(n3)==0
1080 . .AND.nativ_sms(n4)==0) cycle
1081
1082 IF(i > 0)THEN
1083
1084 lt_sms(nad_sms(i)) = -dmint2(1,ksn)
1085 lt_sms(nad_sms(n1))= -dmint2(1,ksn)
1086 nad_sms(i) =nad_sms(i)+1
1087 nad_sms(n1)=nad_sms(n1)+1
1088
1089
1090 lt_sms(nad_sms(i)) = -dmint2(2,ksn)
1091 lt_sms(nad_sms(n2))= -dmint2(2,ksn)
1092 nad_sms(i) =nad_sms(i)+1
1093 nad_sms(n2)=nad_sms(n2)+1
1094
1095 lt_sms(nad_sms(i)) = -dmint2(3,ksn)
1096 lt_sms(nad_sms(n3))= -dmint2(3,ksn)
1097 nad_sms(i) =nad_sms(i)+1
1098 nad_sms(n3)=nad_sms(n3)+1
1099
1100 lt_sms(nad_sms(i)) = -dmint2(4,ksn)
1101 lt_sms(nad_sms(n4))= -dmint2(4,ksn)
1102 nad_sms(i) =nad_sms(i)+1
1103 nad_sms(n4)=nad_sms(n4)+1
1104
1105 ELSE
1106
1107 i=-i
1108 ltij = zero
1109
1110 lt_sms(nad_sms(i)) = ltij
1111 lt_sms(nad_sms(n1))= ltij
1112 nad_sms(i) =nad_sms(i)+1
1113 nad_sms(n1)=nad_sms(n1)+1
1114
1115
1116 lt_sms(nad_sms(i)) = ltij
1117 lt_sms(nad_sms(n2))= ltij
1118 nad_sms(i) =nad_sms(i)+1
1119 nad_sms(n2)=nad_sms(n2)+1
1120
1121 lt_sms(nad_sms(i)) = ltij
1122 lt_sms(nad_sms(n3))= ltij
1123 nad_sms(i) =nad_sms(i)+1
1124 nad_sms(n3)=nad_sms(n3)+1
1125
1126 lt_sms(nad_sms(i)) = ltij
1127 lt_sms(nad_sms(n4))= ltij
1128 nad_sms(i) =nad_sms(i)+1
1129 nad_sms(n4)=nad_sms(n4)+1
1130 END IF
1131 END DO
1132C
1133 ELSEIF(nty==2.AND.ilagm==0.AND.(ilev==27.or.ilev==28))THEN
1134C
1135 kad=ipari(1,n)
1136 nsn=ipari(5,n)
1137 DO ii=1,nsn
1138 i=intbuf_tab(n)%NSV(ii)
1139 ksn=ksn+1
1140C
1141 IF (intbuf_tab(n)%IRUPT(ii)==0) THEN
1142C
1143 l=intbuf_tab(n)%IRTLM(ii)
1144 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1145 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1146 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1147 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1148 fac_scal_i = t2fac_sms(i)
1149
1150 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1151 . .AND.nativ_sms(n2)==0
1152 . .AND.nativ_sms(n3)==0
1153 . .AND.nativ_sms(n4)==0) cycle
1154
1155 IF(i > 0)THEN
1156 DO kj=jad_sms(i),lad_sms(i)
1157 j =jdi_sms(kj)
1158 ltij = lt_sms(kj)
1159 lt_sms(kj)=zero
1160 fac_scal_j = t2fac_sms(j)
1161
1162 IF (t2main_sms(1,j) == 1) THEN
1163C-- No Type2 + AMS on J
1164 ltij = ltij*fac_scal_i
1165C
1166 lt_sms(nad_sms(j)) = ltij
1167 lt_sms(nad_sms(n1))= ltij
1168 nad_sms(j) =nad_sms(j)+1
1169 nad_sms(n1)=nad_sms(n1)+1
1170
1171 lt_sms(nad_sms(j)) = ltij
1172 lt_sms(nad_sms(n2))= ltij
1173 nad_sms(j) =nad_sms(j)+1
1174 nad_sms(n2)=nad_sms(n2)+1
1175
1176 lt_sms(nad_sms(j)) = ltij
1177 lt_sms(nad_sms(n3))= ltij
1178 nad_sms(j) =nad_sms(j)+1
1179 nad_sms(n3)=nad_sms(n3)+1
1180
1181 lt_sms(nad_sms(j)) = ltij
1182 lt_sms(nad_sms(n4))= ltij
1183 nad_sms(j) =nad_sms(j)+1
1184 nad_sms(n4)=nad_sms(n4)+1
1185C
1186 ELSEIF(t2main_sms(6,j)==0) THEN
1187C-- Type2 crossed connection between main nodes - failure of main element of j
1188C
1189 ltij = ltij*max(fac_scal_i,fac_scal_j)
1190C
1191 lt_sms(nad_sms(j)) = zero
1192 lt_sms(nad_sms(n1))= zero
1193 nad_sms(j) =nad_sms(j)+1
1194 nad_sms(n1)=nad_sms(n1)+1
1195
1196 lt_sms(nad_sms(j)) = zero
1197 lt_sms(nad_sms(n2))= zero
1198 nad_sms(j) =nad_sms(j)+1
1199 nad_sms(n2)=nad_sms(n2)+1
1200
1201 lt_sms(nad_sms(j)) = zero
1202 lt_sms(nad_sms(n3))= zero
1203 nad_sms(j) =nad_sms(j)+1
1204 nad_sms(n3)=nad_sms(n3)+1
1205
1206 lt_sms(nad_sms(j)) = zero
1207 lt_sms(nad_sms(n4))= zero
1208 nad_sms(j) =nad_sms(j)+1
1209 nad_sms(n4)=nad_sms(n4)+1
1210
1211 IF (i>j) THEN
1212 DO k =2,5
1213 DO kk =2,5
1214 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1215 lt_sms(nad_sms(t2main_sms(k,i))) = half*ltij
1216 lt_sms(nad_sms(t2main_sms(kk,j)))= half*ltij
1217 nad_sms(t2main_sms(k,i)) =nad_sms(t2main_sms(k,i))+1
1218 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1219 ENDIF
1220 ENDDO
1221 ENDDO
1222 ENDIF
1223C
1224 ELSE
1225C-- Type2 crossed connection between main nodes - failure of main element of j
1226C
1227 lt_sms(nad_sms(j)) = ltij
1228 lt_sms(nad_sms(n1))= ltij
1229 nad_sms(j) =nad_sms(j)+1
1230 nad_sms(n1)=nad_sms(n1)+1
1231
1232 lt_sms(nad_sms(j)) = ltij
1233 lt_sms(nad_sms(n2))= ltij
1234 nad_sms(j) =nad_sms(j)+1
1235 nad_sms(n2)=nad_sms(n2)+1
1236
1237 lt_sms(nad_sms(j)) = ltij
1238 lt_sms(nad_sms(n3))= ltij
1239 nad_sms(j) =nad_sms(j)+1
1240 nad_sms(n3)=nad_sms(n3)+1
1241
1242 lt_sms(nad_sms(j)) = ltij
1243 lt_sms(nad_sms(n4))= ltij
1244 nad_sms(j) =nad_sms(j)+1
1245 nad_sms(n4)=nad_sms(n4)+1
1246
1247 IF (i>j) THEN
1248 DO k =2,5
1249 DO kk =2,5
1250 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1251 lt_sms(nad_sms(t2main_sms(k,i))) = zero
1252 lt_sms(nad_sms(t2main_sms(kk,j)))= zero
1253 nad_sms(t2main_sms(k,i)) =nad_sms(t2main_sms(k,i))+1
1254 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1255 ENDIF
1256 ENDDO
1257 ENDDO
1258 ENDIF
1259C
1260 ENDIF
1261C
1262 END DO
1263 ELSE
1264 i=-i
1265 DO kj=jad_sms(i),lad_sms(i)
1266 j =jdi_sms(kj)
1267 ltij = zero
1268
1269 IF (t2main_sms(1,j) == 1) THEN
1270C-- No Type2 + AMS on J
1271 lt_sms(nad_sms(j)) = ltij
1272 lt_sms(nad_sms(n1))= ltij
1273 nad_sms(j) =nad_sms(j)+1
1274 nad_sms(n1)=nad_sms(n1)+1
1275
1276 lt_sms(nad_sms(j)) = ltij
1277 lt_sms(nad_sms(n2))= ltij
1278 nad_sms(j) =nad_sms(j)+1
1279 nad_sms(n2)=nad_sms(n2)+1
1280
1281 lt_sms(nad_sms(j)) = ltij
1282 lt_sms(nad_sms(n3))= ltij
1283 nad_sms(j) =nad_sms(j)+1
1284 nad_sms(n3)=nad_sms(n3)+1
1285
1286 lt_sms(nad_sms(j)) = ltij
1287 lt_sms(nad_sms(n4))= ltij
1288 nad_sms(j) =nad_sms(j)+1
1289 nad_sms(n4)=nad_sms(n4)+1
1290C
1291 ELSE
1292C-- Type2 crossed connection between main nodes
1293C
1294 lt_sms(nad_sms(j)) = zero
1295 lt_sms(nad_sms(n1))= zero
1296 nad_sms(j) =nad_sms(j)+1
1297 nad_sms(n1)=nad_sms(n1)+1
1298
1299 lt_sms(nad_sms(j)) = zero
1300 lt_sms(nad_sms(n2))= zero
1301 nad_sms(j) =nad_sms(j)+1
1302 nad_sms(n2)=nad_sms(n2)+1
1303
1304 lt_sms(nad_sms(j)) = zero
1305 lt_sms(nad_sms(n3))= zero
1306 nad_sms(j) =nad_sms(j)+1
1307 nad_sms(n3)=nad_sms(n3)+1
1308
1309 lt_sms(nad_sms(j)) = zero
1310 lt_sms(nad_sms(n4))= zero
1311 nad_sms(j) =nad_sms(j)+1
1312 nad_sms(n4)=nad_sms(n4)+1
1313
1314 IF (i>j) THEN
1315 DO k =2,5
1316 DO kk =2,5
1317 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1318 lt_sms(nad_sms(t2main_sms(k,i))) = half*ltij
1319 lt_sms(nad_sms(t2main_sms(kk,j)))= half*ltij
1320 nad_sms(t2main_sms(k,i)) =nad_sms(t2main_sms(k,i))+1
1321 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1322 ENDIF
1323 ENDDO
1324 ENDDO
1325 ENDIF
1326C
1327 ENDIF
1328C
1329 END DO
1330 END IF
1331C
1332 ELSE
1333C
1334C KSN=KSN+1
1335
1336 IF(weight(abs(i))/=1)cycle
1337
1338 l=intbuf_tab(n)%IRTLM(ii)
1339 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1340 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1341 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1342 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1343
1344 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1345 . .AND.nativ_sms(n2)==0
1346 . .AND.nativ_sms(n3)==0
1347 . .AND.nativ_sms(n4)==0) cycle
1348
1349 IF(i > 0)THEN
1350
1351 lt_sms(nad_sms(i)) = -dmint2(1,ksn)
1352 lt_sms(nad_sms(n1))= -dmint2(1,ksn)
1353 nad_sms(i) =nad_sms(i)+1
1354 nad_sms(n1)=nad_sms(n1)+1
1355
1356
1357 lt_sms(nad_sms(i)) = -dmint2(2,ksn)
1358 lt_sms(nad_sms(n2))= -dmint2(2,ksn)
1359 nad_sms(i) =nad_sms(i)+1
1360 nad_sms(n2)=nad_sms(n2)+1
1361
1362 lt_sms(nad_sms(i)) = -dmint2(3,ksn)
1363 lt_sms(nad_sms(n3))= -dmint2(3,ksn)
1364 nad_sms(i) =nad_sms(i)+1
1365 nad_sms(n3)=nad_sms(n3)+1
1366
1367 lt_sms(nad_sms(i)) = -dmint2(4,ksn)
1368 lt_sms(nad_sms(n4))= -dmint2(4,ksn)
1369 nad_sms(i) =nad_sms(i)+1
1370 nad_sms(n4)=nad_sms(n4)+1
1371
1372 ELSE
1373
1374 i=-i
1375 ltij = zero
1376
1377 lt_sms(nad_sms(i)) = ltij
1378 lt_sms(nad_sms(n1))= ltij
1379 nad_sms(i) =nad_sms(i)+1
1380 nad_sms(n1)=nad_sms(n1)+1
1381
1382
1383 lt_sms(nad_sms(i)) = ltij
1384 lt_sms(nad_sms(n2))= ltij
1385 nad_sms(i) =nad_sms(i)+1
1386 nad_sms(n2)=nad_sms(n2)+1
1387
1388 lt_sms(nad_sms(i)) = ltij
1389 lt_sms(nad_sms(n3))= ltij
1390 nad_sms(i) =nad_sms(i)+1
1391 nad_sms(n3)=nad_sms(n3)+1
1392
1393 lt_sms(nad_sms(i)) = ltij
1394 lt_sms(nad_sms(n4))= ltij
1395 nad_sms(i) =nad_sms(i)+1
1396 nad_sms(n4)=nad_sms(n4)+1
1397 END IF
1398C
1399 ENDIF
1400C
1401 END DO
1402C
1403 END IF
1404 END DO
1405C
1406 END IF
1407C
1408 CALL my_barrier()
1409C
1410C------------
1411C rbodies
1412C------------
1413 IF(nrbody/=0)THEN
1414C
1415!$OMP DO SCHEDULE(DYNAMIC,1)
1416 DO m = 1, nrbody
1417C
1418 iad=0
1419 DO k=1,m-1
1420 nsn = npby(2,k)
1421 iad = iad + nsn
1422 END DO
1423C
1424 msr=npby(1,m)
1425 IF(msr < 0) cycle
1426C
1427 IF(tagmsr_rby_sms(msr) /= 0) THEN
1428C
1429C this node will never be removed from the rwalls ... problem or not?
1430 nodxi_sms(msr)=1
1431C
1432 nsn=npby(2,m)
1433 DO ki=1,nsn
1434 i=lpby(iad+ki)
1435 IF(jad_sms(i+1) > jad_sms(i)) nodxi_sms(i)=1
1436 DO kj=jad_sms(i),jad_sms(i+1)-1
1437 j = jdi_sms(kj)
1438 IF(j > 0)THEN
1439 IF(itf(kinet(j))/=0) THEN
1440 lt_sms(kj)=zero
1441 cycle
1442 END IF
1443 n = tagslv_rby_sms(j)
1444 IF(n==m)THEN
1445 lt_sms(kj)=zero
1446 END IF
1447 END IF
1448 END DO
1449 END DO
1450C
1451 END IF
1452 END DO
1453!$OMP END DO
1454 END IF
1455C------------
1456C symmetrization
1457C------------
1458 DO i=nodft,nodlt
1459 DO ij=jad_sms(i),jad_sms(i+1)-1
1460 j=jdi_sms(ij)
1461 IF(j > i)THEN
1462 ji=jsm_sms(ij)
1463 IF(lt_sms(ij)==zero.OR.lt_sms(ji)==zero)THEN
1464c IJ or JI ask for resetting connection to 0
1465 lt_sms(ij)=zero
1466 lt_sms(ji)=zero
1467 ELSE
1468 ltij=min(lt_sms(ij),lt_sms(ji))
1469 lt_sms(ij)=ltij
1470 lt_sms(ji)=ltij
1471 END IF
1472 END IF
1473 END DO
1474 END DO
1475C-----
1476C Interfaces
1477C-----
1478 100 CONTINUE
1479C
1480 CALL my_barrier()
1481C
1482C-----
1483 loc_proc = ispmd + 1
1484C
1485 DO nn=itask+1,nisky_sms,nthread
1486 p =iskyi_sms(nn,3)
1487 IF(p/=loc_proc) cycle
1488
1489 i =iskyi_sms(nn,1)
1490 j =iskyi_sms(nn,2)
1491 m = tagslv_rby_sms(i)
1492 n = tagslv_rby_sms(j)
1493 IF(m/=0.AND.n==m)THEN
1494 iskyi_sms(nn,1)=0
1495 iskyi_sms(nn,2)=0
1496 END IF
1497 END DO
1498C ---
1499C
1500 CALL my_barrier()
1501C
1502C non //
1503 IF(itask==0)THEN
1504
1505 DO n=1,numnod
1506 nadi_sms(n)=0
1507 END DO
1508
1509 DO nn=1,nisky_sms
1510 p =iskyi_sms(nn,3)
1511 IF(p/=loc_proc) cycle
1512
1513 i =iskyi_sms(nn,1)
1514 j =iskyi_sms(nn,2)
1515 IF(i==0.AND.j==0) cycle
1516
1517 nadi_sms(i)=nadi_sms(i)+1
1518 nadi_sms(j)=nadi_sms(j)+1
1519 END DO
1520
1521 jadi_sms(1)=1
1522 kadi_sms(1)=1
1523 DO n=2,numnod+1
1524 jadi_sms(n)=jadi_sms(n-1)+nadi_sms(n-1)
1525 kadi_sms(n)=jadi_sms(n)
1526 END DO
1527
1528 DO nn=1,nisky_sms
1529 p =iskyi_sms(nn,3)
1530 IF(p/=loc_proc) cycle
1531
1532 i =iskyi_sms(nn,1)
1533 j =iskyi_sms(nn,2)
1534 IF(i==0.AND.j==0) cycle
1535
1536 kk =kadi_sms(i)
1537 jdii_sms(kk)=j
1538 lti_sms(kk) =-mskyi_sms(nn)
1539 kadi_sms(i) = kadi_sms(i)+1
1540
1541 kk =kadi_sms(j)
1542 jdii_sms(kk)=i
1543 lti_sms(kk) =-mskyi_sms(nn)
1544 kadi_sms(j) = kadi_sms(j)+1
1545 END DO
1546
1547 END IF
1548C
1549 CALL my_barrier()
1550C
1551 IF(nspmd > 1)THEN
1552 IF(itask==0)THEN
1553 CALL spmd_list_sms(iskyi_sms,fr_sms,fr_rms,list_sms,list_rms,
1554 . npby ,tagslv_rby_sms)
1555 END IF
1556C
1557 CALL my_barrier
1558C
1559 END IF
1560C
1561C----
1562 CALL sms_build_diag(
1563 1 itask ,nodft ,nodlt ,ms ,nodii_sms ,
1564 2 jad_sms ,jdi_sms ,lt_sms ,diag_sms ,indx1_sms ,
1565 3 indx2_sms,iad_elem,fr_elem ,npby ,lpby ,
1566 4 lad_sms ,kad_sms ,jsm_sms ,mskyi_sms,iskyi_sms ,
1567 5 jadi_sms,jdii_sms ,lti_sms ,nodxi_sms ,fr_sms ,
1568 6 fr_rms ,list_sms ,list_rms ,mskyi_fi_sms,ilink ,
1569 7 rlink ,nnlink ,lnlink ,tag_lnk_sms,ljoint,
1570 8 iadcj ,fr_cj ,itab ,weight ,imv ,
1571 9 mv ,mv6 ,mw6 ,nprw ,lprw ,
1572 a fr_wall ,nrwl_sms ,tagmsr_rby_sms,rby ,awork ,
1573 b x ,a ,ar ,in ,v ,
1574 c vr ,tagslv_rby_sms,irbe2,lrbe2 ,irbe3 ,
1575 d lrbe3 ,iad_rbe3m,fr_rbe3m )
1576C
1577
1578 IF(iparit/=0)THEN
1579 DEALLOCATE(imv, mv, mv6)
1580 END IF
1581c-----------
1582 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
min
#define min(a, b)
Definition macros.h:20
max
#define max(a, b)
Definition macros.h:21
intstamp_mod
Definition intstamp_mod.F:38
message_mod
Definition message_mod.F:1257
sms_build_diag
subroutine sms_build_diag(itask, nodft, nodlt, ms, nodii_sms, jad_sms, jdi_sms, lt_sms, diag_sms, indx1_sms, indx2_sms, iad_elem, fr_elem, npby, lpby, lad_sms, kad_sms, jrb_sms, mskyi_sms, iskyi_sms, jadi_sms, jdii_sms, lti_sms, nodxi_sms, fr_sms, fr_rms, list_sms, list_rms, mskyi_fi_sms, ilink, rlink, nnlink, lnlink, tag_lnk_sms, ljoint, iadcj, fr_cj, itab, weight, imv, mv, mv6, w6, nprw, lprw, fr_wall, nrwl_sms, tagmsr_rby_sms, rby, awork, x, a, ar, in, v, vr, tagslv_rby_sms, irbe2, lrbe2, irbe3, lrbe3, iad_rbe3m, fr_rbe3m)
Definition sms_build_diag.F:57
spmd_list_sms
subroutine spmd_list_sms(iskyi_sms, fr_sms, fr_rms, list_sms, list_rms, npby, tagslv_rby_sms)
Definition spmd_sms.F:263
ancmsg
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)
Definition message.F:895
arret
subroutine arret(nn)
Definition arret.F:86
my_barrier
subroutine my_barrier
Definition machine.F:31