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