OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
sms_init.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "sms_c.inc"
#include "kincod_c.inc"
#include "param_c.inc"
#include "com01_c.inc"
#include "scr17_c.inc"
#include "comlock.inc"
#include "task_c.inc"
#include "lockon.inc"
#include "lockoff.inc"
#include "scr03_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine sms_ini_part (igrpart, tagprt_sms)
subroutine sms_ini_rby (kinet, nprw, lprw, npby, lpby, tagmsr_rby_sms, tagslv_rby_sms)
subroutine sms_ini_kad (ixs, ixq, ixc, ixt, ixp, ixr, ixtg, ixtg1, ixs10, ixs16, ixs20, iparg, ms, ms0, nodnx_sms, icodt, icodr, kinet, indx1_sms, kad_sms, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartur, iparttg, ipartx, tagprt_sms, tagrel_sms, itab, weight, irbe2, irbe3, lrbe2, lrbe3, iad_elem, fr_elem, nprw, lprw, ipart, igeo, nativ_sms)
subroutine nodnx_sms_ini (numnod, numel, nix, mix, lix, ix, ipartx, tagprt_sms, nodnx_sms)
subroutine sms_ini_kdi (ixc, iparg, ixs, ixt, ixp, ixr, ixtg, ixs10, nodnx_sms, kad_sms, kdi_sms, jadc_sms, jads_sms, jads10_sms, jadt_sms, jadp_sms, jadr_sms, jadtg_sms, indx1_sms, tagprt_sms, iad_sms, tagrel_sms, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartur, iparttg, ipartx, iad_elem, fr_elem, npby, lpby, kinet, tagslv_rby_sms, ipari, intbuf_tab, irect, lad_sms, ipart, igeo, weight, nativ_sms)
subroutine sms_ini_jad_1 (ixc, iparg, ixs, ixt, ixp, ixr, ixtg, ixs10, nodnx_sms, jadc_sms, jads_sms, jads10_sms, jadt_sms, jadp_sms, jadr_sms, jadtg_sms, indx1_sms, tagprt_sms, kad_sms, kdi_sms, pk_sms, tagrel_sms, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartur, iparttg, ipartx, iad_elem, fr_elem, npby, lpby, kinet, tagslv_rby_sms, ipari, intbuf_tab, irect, lad_sms, ipart, igeo, weight, nativ_sms, iad_sms, idi_sms, jad_sms, jdi_sms, t2main_sms)
subroutine sms_ini_jad_2 (ixc, iparg, ixs, ixt, ixp, ixr, ixtg, ixs10, nodnx_sms, jadc_sms, jads_sms, jads10_sms, jadt_sms, jadp_sms, jadr_sms, jadtg_sms, indx1_sms, tagprt_sms, kad_sms, kdi_sms, tagrel_sms, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartur, iparttg, ipartx, iad_elem, fr_elem, npby, lpby, kinet, tagslv_rby_sms, ipari, intbuf_tab, irect, lad_sms, nprw, lprw, tagmsr_rby_sms, tagslv_i21_sms, tagmsr_i21_sms, jadi21_sms, intstamp, ipart, igeo, weight, nativ_sms, irbe2, lrbe2, iad_sms, idi_sms, jad_sms, jdi_sms, t2main_sms)
subroutine sms_ini_jad_3 (ixc, iparg, ixs, ixt, ixp, ixr, ixtg, ixs10, nodnx_sms, jadc_sms, jads_sms, jads10_sms, jadt_sms, jadp_sms, jadr_sms, jadtg_sms, indx1_sms, tagprt_sms, kad_sms, kdi_sms, tagrel_sms, iparts, ipartq, ipartc, ipartt, ipartp, ipartr, ipartur, iparttg, ipartx, iad_elem, fr_elem, npby, lpby, kinet, tagslv_rby_sms, ipari, intbuf_tab, irect, lad_sms, jsm_sms, tagslv_i21_sms, intstamp, ipart, igeo, tagmsr_rby_sms, weight, nativ_sms, iad_sms, idi_sms, jad_sms, jdi_sms, t2main_sms)
subroutine sms_ini_kin_1 (nodnx_sms, indx1_sms, ilink, rlink, nnlink, lnlink, tag_lnk_sms, fr_ll, fr_rl, weight, itab, ljoint, iadcj, fr_cj, nprw, lprw, fr_wall, nrwl_sms, iad_elem, fr_elem, intbuf_tab)
subroutine sms_ini_kin_2 (ilink, rlink, nnlink, lnlink, tag_lnk_sms, fr_ll, fr_rl, weight, itab, ljoint, iadcj, fr_cj, nprw, lprw, fr_wall, nrwl_sms, iad_elem, fr_elem)
subroutine sms_ini_int (ipari, intbuf_tab, iad_elem, fr_elem, intlist, nbintc)
subroutine sms_ini_err (nprw, lprw, kinet)

Function/Subroutine Documentation

◆ nodnx_sms_ini()

subroutine nodnx_sms_ini ( integer numnod,
integer numel,
integer nix,
integer mix,
integer lix,
integer, dimension(nix,*) ix,
integer, dimension(*) ipartx,
integer, dimension(*) tagprt_sms,
integer, dimension(*) nodnx_sms )

Definition at line 551 of file sms_init.F.

554C-----------------------------------------------
555C M o d u l e s
556C-----------------------------------------------
557 USE my_alloc_mod
558C-----------------------------------------------
559C I m p l i c i t T y p e s
560C-----------------------------------------------
561#include "implicit_f.inc"
562C-----------------------------------------------
563C D u m m y A r g u m e n t s
564C-----------------------------------------------
565 INTEGER NUMNOD , NUMEL ,NIX ,MIX, LIX,
566 . IX(NIX,*), IPARTX(*), TAGPRT_SMS(*), NODNX_SMS(*)
567C-----------------------------------------------
568C L o c a l V a r i a b l e s
569C-----------------------------------------------
570 INTEGER I, J, K
571 INTEGER,DIMENSION(:), ALLOCATABLE :: TAG
572C-----------------------------------------------
573C S o u r c e L i n e s
574C-----------------------------------------------
575 CALL my_alloc(tag,numnod)
576C-----------------------------------------------
577
578 DO j=1,numel
579 IF(tagprt_sms(ipartx(j))==0) cycle
580
581 DO k=1,lix
582 i = ix(mix+k,j)
583 IF(i/=0) tag(i)=0
584 ENDDO
585 DO k=1,lix
586 i = ix(mix+k,j)
587 IF(i/=0)THEN
588 IF(tag(i)==0)THEN
589 nodnx_sms(i)=nodnx_sms(i)+1
590 tag(i)=1
591 END IF
592 END IF
593 ENDDO
594 ENDDO
595
596 DEALLOCATE(tag)
597 RETURN

◆ sms_ini_err()

subroutine sms_ini_err ( integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(*) kinet )

Definition at line 2729 of file sms_init.F.

2730C-----------------------------------------------
2731C M o d u l e s
2732C-----------------------------------------------
2733 USE message_mod
2734C-----------------------------------------------
2735C I m p l i c i t T y p e s
2736C-----------------------------------------------
2737#include "implicit_f.inc"
2738#include "comlock.inc"
2739C-----------------------------------------------
2740C C o m m o n B l o c k s
2741C-----------------------------------------------
2742#include "com04_c.inc"
2743#include "kincod_c.inc"
2744#include "task_c.inc"
2745C-----------------------------------------------
2746C D u m m y A r g u m e n t s
2747C-----------------------------------------------
2748 INTEGER
2749 . KINET(*), NPRW(*), LPRW(*)
2750C-----------------------------------------------
2751C L o c a l V a r i a b l e s
2752C-----------------------------------------------
2753 INTEGER I, J, K, M, N, NSN,
2754 . N1, N2, N3, N4, N5, N6
2755 INTEGER ITY, IMOV, ILAGM, ISMS, IERR
2756C-----------------------------------------------
2757C
2758 ierr=0
2759C
2760C-----
2761 isms=0
2762 DO i=1,numnod
2763 IF(irv(kinet(i))/=0)THEN
2764 isms=1
2765 END IF
2766 END DO
2767 CALL spmd_allglob_isum9(isms,1)
2768 IF(isms/=0)THEN
2769 IF(ispmd==0)THEN
2770 CALL ancmsg(msgid=22,anmode=aninfo_blind,
2771 . c1='RIVETS')
2772 END IF
2773 ierr=1
2774 END IF
2775C
2776C-----
2777 isms=0
2778 DO i=1,numnod
2779 IF(ilmult(kinet(i))/=0)THEN
2780 isms=1
2781 END IF
2782 END DO
2783 CALL spmd_allglob_isum9(isms,1)
2784 IF(isms/=0)THEN
2785 IF(ispmd==0)THEN
2786 CALL ancmsg(msgid=22,anmode=aninfo_blind,
2787 . c1='LAGRANGE MULTIPLIERS')
2788 END IF
2789 ierr=1
2790 END IF
2791C
2792C-----------------------------------------------
2793 IF(ierr/=0) CALL arret(2)
2794 RETURN
message_mod
Definition message_mod.F:1249
spmd_allglob_isum9
subroutine spmd_allglob_isum9(v, len)
Definition spmd_allglob_isum9.F:46
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

◆ sms_ini_int()

subroutine sms_ini_int ( integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) intlist,
integer nbintc )

Definition at line 2564 of file sms_init.F.

2567C-----------------------------------------------
2568C M o d u l e s
2569C-----------------------------------------------
2570 USE intbufdef_mod
2571 USE my_alloc_mod
2572C-----------------------------------------------
2573C I m p l i c i t T y p e s
2574C-----------------------------------------------
2575#include "implicit_f.inc"
2576C-----------------------------------------------
2577C C o m m o n B l o c k s
2578C-----------------------------------------------
2579#include "com01_c.inc"
2580#include "com04_c.inc"
2581#include "param_c.inc"
2582C-----------------------------------------------
2583C D u m m y A r g u m e n t s
2584C-----------------------------------------------
2585 INTEGER IPARI(NPARI,*), IAD_ELEM(2,*), FR_ELEM(*)
2586 INTEGER INTLIST(*),NBINTC
2587C REAL
2588 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
2589C-----------------------------------------------
2590C L o c a l V a r i a b l e s
2591C-----------------------------------------------
2592 INTEGER K, I, N, J
2593 INTEGER NTY, ILEV, NSN, NMN, NRTS, NRTM,
2594 . NLINS, NLINM, II, SIZE, LENR
2595 INTEGER,DIMENSION(:), ALLOCATABLE :: TAG
2596C-----------------------------------------------
2597 CALL my_alloc(tag,numnod)
2598C-----------------------------------------------
2599C supprime nds d'interf type 2 des interfs a penalite
2600C /DT/AMS or /DT/INTER/AMS
2601C
2602 tag(1:numnod)=0
2603 DO n=1,ninter
2604 nty=ipari(7,n)
2605 ilev = ipari(20,n)
2606 IF(nty==2 .AND. ilev/=25 .and. ilev /= 26)THEN
2607 nrts =ipari(3,n)
2608 nrtm =ipari(4,n)
2609 nsn =ipari(5,n)
2610 nmn =ipari(6,n)
2611 ilev =ipari(20,n)
2612C
2613 DO ii=1,nsn
2614 j=intbuf_tab(n)%NSV(ii)
2615 IF ((ilev==27.OR.ilev==28).AND.intbuf_tab(n)%IRUPT(ii)==1) cycle
2616 tag(j)=1
2617 ENDDO
2618 ENDIF
2619 ENDDO
2620C
2621 IF(nspmd > 1) THEN
2622 SIZE = 1
2623 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2624 CALL spmd_exch_icont(tag,iad_elem ,fr_elem,SIZE,lenr)
2625 CALL spmd_exch_smst2(ipari,tag,intlist,nbintc,intbuf_tab)
2626 END IF
2627C
2628 DO n=1,ninter
2629 nty=ipari(7,n)
2630 nsn =ipari(5,n)
2631 nrts =ipari(3,n)
2632 nrtm =ipari(4,n)
2633 IF(nty==7.OR.nty==10.OR.nty==20.OR.nty==25)THEN
2634 DO ii=1,nsn
2635 j=intbuf_tab(n)%NSV(ii)
2636 IF(tag(j)/=0) THEN
2637 intbuf_tab(n)%STFNS(ii) = zero
2638 END IF
2639 END DO
2640 DO ii=1,nrtm
2641 j=intbuf_tab(n)%IRECTM(4*(ii-1)+1)
2642 IF(tag(j)/=0)THEN
2643 intbuf_tab(n)%STFM(ii)=zero
2644 END IF
2645 j=intbuf_tab(n)%IRECTM(4*(ii-1)+2)
2646 IF(tag(j)/=0)THEN
2647 intbuf_tab(n)%STFM(ii)=zero
2648 END IF
2649 j=intbuf_tab(n)%IRECTM(4*(ii-1)+3)
2650 IF(tag(j)/=0)THEN
2651 intbuf_tab(n)%STFM(ii)=zero
2652 END IF
2653 j=intbuf_tab(n)%IRECTM(4*(ii-1)+4)
2654 IF(tag(j)/=0)THEN
2655 intbuf_tab(n)%STFM(ii)=zero
2656 END IF
2657 END DO
2658 IF(nty==20)THEN
2659 nlins =ipari(51,n)
2660 nlinm =ipari(52,n)
2661 IF(nlins+nlinm /= 0)THEN
2662 DO ii=1,nlins
2663 j=intbuf_tab(n)%IXLINS(2*(ii-1)+1)
2664 IF(tag(j)/=0)THEN
2665 intbuf_tab(n)%STFS(ii) = zero
2666 END IF
2667 j=intbuf_tab(n)%IXLINS(2*(ii-1)+2)
2668 IF(tag(j)/=0)THEN
2669 intbuf_tab(n)%STFS(ii) = zero
2670 END IF
2671 END DO
2672 DO ii=1,nlinm
2673 j=intbuf_tab(n)%IXLINM(2*(ii-1)+1)
2674 IF(tag(j)/=0)THEN
2675 intbuf_tab(n)%STF(ii) = zero
2676 END IF
2677 j=intbuf_tab(n)%IXLINM(2*(ii-1)+2)
2678 IF(tag(j)/=0)THEN
2679 intbuf_tab(n)%STF(ii) = zero
2680 END IF
2681 END DO
2682 END IF
2683 END IF
2684 ELSEIF(nty==11)THEN
2685 DO ii=1,nrts
2686 j=intbuf_tab(n)%IRECTS(2*(ii-1)+1)
2687 IF(tag(j)/=0)THEN
2688 intbuf_tab(n)%STFS(ii) = zero
2689 END IF
2690 j=intbuf_tab(n)%IRECTS(2*(ii-1)+2)
2691 IF(tag(j)/=0)THEN
2692 intbuf_tab(n)%STFS(ii) = zero
2693 END IF
2694 END DO
2695 DO ii=1,nrtm
2696 j=intbuf_tab(n)%IRECTM(2*(ii-1)+1)
2697 IF(tag(j)/=0)THEN
2698 intbuf_tab(n)%STFM(ii) = zero
2699 END IF
2700 j=intbuf_tab(n)%IRECTM(2*(ii-1)+2)
2701 IF(tag(j)/=0)THEN
2702 intbuf_tab(n)%STFM(ii) = zero
2703 END IF
2704 END DO
2705 ELSEIF(nty==21)THEN
2706 DO ii=1,nsn
2707 j=intbuf_tab(n)%NSV(ii)
2708 IF(tag(j)/=0) THEN
2709 intbuf_tab(n)%STFNS(ii) = zero
2710 END IF
2711 END DO
2712 END IF
2713 END DO
2714C-----------------------------------------------
2715 DEALLOCATE(tag)
2716 RETURN
spmd_exch_icont
subroutine spmd_exch_icont(icontact, iad_elem, fr_elem, size, lenr)
Definition spmd_exch_icont.F:34
spmd_exch_smst2
subroutine spmd_exch_smst2(ipari, tag, intlist, nbintc, intbuf_tab)
Definition spmd_exch_smst2.F:40

◆ sms_ini_jad_1()

subroutine sms_ini_jad_1 ( 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(6,*) ixs10,
integer, dimension(*) nodnx_sms,
integer, dimension(4,*) jadc_sms,
integer, dimension(8,*) jads_sms,
integer, dimension(6,*) jads10_sms,
integer, dimension(2,*) jadt_sms,
integer, dimension(2,*) jadp_sms,
integer, dimension(3,*) jadr_sms,
integer, dimension(3,*) jadtg_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) tagprt_sms,
integer, dimension(*) kad_sms,
integer, dimension(*) kdi_sms,
integer, dimension(*) pk_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(*) kinet,
integer, dimension(*) tagslv_rby_sms,
integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(4,*) irect,
integer, dimension(*) lad_sms,
integer, dimension(lipart1,*) ipart,
integer, dimension(npropgi,*) igeo,
integer, dimension(*) weight,
integer, dimension(*) nativ_sms,
integer, dimension(*) iad_sms,
integer, dimension(*) idi_sms,
integer, dimension(*) jad_sms,
integer, dimension(*) jdi_sms,
integer, dimension(6,*) t2main_sms )

Definition at line 1046 of file sms_init.F.

1058C-----------------------------------------------
1059C M o d u l e s
1060C-----------------------------------------------
1061 USE intbufdef_mod
1062 USE my_alloc_mod
1063C-----------------------------------------------
1064C I m p l i c i t T y p e s
1065C-----------------------------------------------
1066#include "implicit_f.inc"
1067#include "comlock.inc"
1068C-----------------------------------------------
1069C C o m m o n B l o c k s
1070C-----------------------------------------------
1071#include "com01_c.inc"
1072#include "com04_c.inc"
1073#include "param_c.inc"
1074#include "sms_c.inc"
1075#include "scr17_c.inc"
1076C-----------------------------------------------------------------
1077C D u m m y A r g u m e n t s
1078C-----------------------------------------------
1079 INTEGER
1080 . IPARG(NPARG,*), IXC(NIXC,*), IXS(NIXS,*), IXT(NIXT,*),
1081 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*), IXS10(6,*),
1082 . NODNX_SMS(*), KAD_SMS(*), KDI_SMS(*), PK_SMS(*),
1083 . IAD_SMS(*), IDI_SMS(*), JAD_SMS(*), JDI_SMS(*),
1084 . JADC_SMS(4,*),
1085 . JADS_SMS(8,*), JADS10_SMS(6,*),
1086 . JADT_SMS(2,*),
1087 . JADP_SMS(2,*),
1088 . JADR_SMS(3,*),
1089 . JADTG_SMS(3,*),NATIV_SMS(*),
1090 . INDX1_SMS(*), TAGPRT_SMS(*), TAGREL_SMS(*),
1091 . IPARTS(*), IPARTQ(*), IPARTC(*), IPARTT(*),
1092 . IPARTP(*), IPARTR(*), IPARTUR(*), IPARTTG(*), IPARTX(*),
1093 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),
1094 . NPBY(NNPBY,*), LPBY(*), KINET(*), TAGSLV_RBY_SMS(*),
1095 . IPARI(NPARI,*), IRECT(4,*),
1096 . LAD_SMS(*),
1097 . IPART(LIPART1,*), IGEO(NPROPGI,*), WEIGHT(*),T2MAIN_SMS(6,*)
1098 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1099C-----------------------------------------------
1100C L o c a l V a r i a b l e s
1101C-----------------------------------------------
1102 INTEGER I, J, K, JJ, KK, II, IJ, M, N, IERROR, KL
1103 INTEGER MSR, NSN, KI, KJ, NSR
1104 INTEGER SIZE, LENR, IAD, L, LLT
1105 INTEGER NTY, ILAGM, K10, K11, K12, K13, K14, JI,
1106 . N1, N2, N3, N4, LNEW, ILEV
1107 INTEGER IK, NK, IKK,WORK(70000)
1108 INTEGER,DIMENSION(:),ALLOCATABLE :: NAD_SMS
1109 INTEGER,DIMENSION(:),ALLOCATABLE :: TAGK
1110 INTEGER,DIMENSION(:),ALLOCATABLE :: ITRI
1111 INTEGER,DIMENSION(:),ALLOCATABLE :: INDEX1
1112 INTEGER,DIMENSION(:),ALLOCATABLE :: INDEX2
1113C-------------------------------------------------------------------------
1114 CALL my_alloc(nad_sms,numnod)
1115 CALL my_alloc(tagk,numnod)
1116 CALL my_alloc(itri,numnod)
1117 CALL my_alloc(index1,2*numnod)
1118 CALL my_alloc(index2,numnod)
1119C-------------------------------------------------------------------------
1120C PREPARE KOMPACTION OF ELEMENTARY MATRIX
1121C construit IDI_SMS et pointeurs KAD_SMS vers JAD_SMS
1122C KJ = KAD_SMS(I),KAD_SMS(I+1)-1 => PK_SMS(KJ) = rang de KDI_SMS(KJ) dans IDI_SMS(I),IDI_SMS(I+1)-1
1123C-------------------------------------------------------------------------
1124 tagk(1:numnod)=0
1125C
1126 DO i=1,numnod
1127 nk=0
1128 DO kj=kad_sms(i),kad_sms(i+1)-1
1129 ik =kdi_sms(kj)
1130 IF(tagk(ik)==0)THEN
1131 idi_sms(iad_sms(i)+nk)=ik
1132 nk=nk+1
1133 tagk(ik)=nk
1134 END IF
1135 END DO
1136C
1137C reordonne IDI_SMS(KJ), KJ=IAD_SMS(I),IAD_SMS(I)+LAD_SMS(I)-1
1138 DO ik=1,nk
1139 kj=iad_sms(i)+ik-1
1140 itri(ik) =idi_sms(kj)
1141 index1(ik)=ik
1142 END DO
1143 IF(nk/=0) CALL my_orders(0,work,itri,index1,nk,1)
1144 DO ik=1,nk
1145 kj=iad_sms(i)+ik-1
1146 idi_sms(kj)=itri(index1(ik))
1147 END DO
1148
1149 DO ik=1,nk
1150 ikk =index1(ik)
1151 index2(ikk)=ik
1152 END DO
1153
1154 DO kj=kad_sms(i),kad_sms(i+1)-1
1155 ik = kdi_sms(kj)
1156 pk_sms(kj)= index2(tagk(ik))
1157 END DO
1158
1159 DO kj=kad_sms(i),kad_sms(i+1)-1
1160 ik =kdi_sms(kj)
1161 tagk(ik)=0
1162 END DO
1163
1164 END DO
1165C-------------------------------------------------------------------------
1166 DO i=1,numnod+1
1167 jad_sms(i)=iad_sms(i)
1168 END DO
1169 DO i=1,numnod
1170 DO kj=iad_sms(i),iad_sms(i+1)-1
1171 jdi_sms(kj)=idi_sms(kj)
1172 END DO
1173 END DO
1174C-------------------------------------------------------------------------
1175C inter/type2 : numbering
1176C------------
1177C
1178C T2MAIN_SMS(1) : nb of type2 main nodes (4 or 1)
1179C T2MAIN_SMS(2-5) : id of type2 main nodes
1180C T2MAIN_SMS(6) : flag for deleted main element
1181C
1182 DO i=1,numnod
1183C--- If node is not secnd of type2 kinematic interface it is its own main --
1184 t2main_sms(1,i) = 1
1185 t2main_sms(2,i) = i
1186 ENDDO
1187C
1188C---- First pass - detection of main nodes for crossed type 2 connection
1189C
1190 DO n=1,ninter
1191 nty = ipari(7,n)
1192 ilagm = ipari(33,n)
1193 ilev = ipari(20,n)
1194 nsn = ipari(5,n)
1195 IF(nty==2 .AND. ilagm==0 .AND.ilev/=25 .and. ilev/=26.AND. ilev/=27 .and. ilev/=28)THEN
1196 DO ii=1,nsn
1197 i=abs(intbuf_tab(n)%NSV(ii))
1198 l=intbuf_tab(n)%IRTLM(ii)
1199 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1200 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1201 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1202 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1203C
1204 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1205 . .AND.nativ_sms(n2)==0
1206 . .AND.nativ_sms(n3)==0
1207 . .AND.nativ_sms(n4)==0) cycle
1208C
1209 t2main_sms(1,i) = 4
1210 t2main_sms(2,i) = n1
1211 t2main_sms(3,i) = n2
1212 t2main_sms(4,i) = n3
1213 t2main_sms(5,i) = n4
1214 ENDDO
1215 ELSEIF(nty==2 .AND. ilagm==0 .AND.(ilev==27.or.ilev==28))THEN
1216 DO ii=1,nsn
1217 i=abs(intbuf_tab(n)%NSV(ii))
1218 IF (intbuf_tab(n)%IRUPT(ii)==0) THEN
1219C Kinematic node
1220 l=intbuf_tab(n)%IRTLM(ii)
1221 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1222 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1223 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1224 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1225C
1226 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1227 . .AND.nativ_sms(n2)==0
1228 . .AND.nativ_sms(n3)==0
1229 . .AND.nativ_sms(n4)==0) cycle
1230C
1231 t2main_sms(1,i) = 4
1232 t2main_sms(2,i) = n1
1233 t2main_sms(3,i) = n2
1234 t2main_sms(4,i) = n3
1235 t2main_sms(5,i) = n4
1236 ENDIF
1237 ENDDO
1238 ENDIF
1239 ENDDO
1240C
1241 DO n=1,ninter
1242 nty = ipari(7,n)
1243 ilagm = ipari(33,n)
1244 ilev = ipari(20,n)
1245 IF(nty==2 .AND. ilagm==0 .AND.ilev/=25 .and. ilev/=26.AND. ilev/=27 .and. ilev/=28)THEN
1246 nsn=ipari(5,n)
1247 DO ii=1,nsn
1248 i=abs(intbuf_tab(n)%NSV(ii))
1249 l=intbuf_tab(n)%IRTLM(ii)
1250 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1251 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1252 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1253 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1254
1255 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1256 . .AND.nativ_sms(n2)==0
1257 . .AND.nativ_sms(n3)==0
1258 . .AND.nativ_sms(n4)==0) cycle
1259
1260 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1261 j =jdi_sms(kj)
1262 nodnx_sms(j) =nodnx_sms(j) +4
1263 nodnx_sms(n1)=nodnx_sms(n1)+1
1264 nodnx_sms(n2)=nodnx_sms(n2)+1
1265 nodnx_sms(n3)=nodnx_sms(n3)+1
1266 nodnx_sms(n4)=nodnx_sms(n4)+1
1267 nnz_sms = nnz_sms + 8
1268C-- Type2 crossed connection between main nodes
1269 IF ((t2main_sms(1,j) > 1).AND.(i > j)) THEN
1270 DO k =2,5
1271 DO kk =2,5
1272 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1273 nodnx_sms(t2main_sms(k,i))=nodnx_sms(t2main_sms(k,i))+1
1274 nodnx_sms(t2main_sms(kk,j))=nodnx_sms(t2main_sms(kk,j))+1
1275 nnz_sms = nnz_sms + 2
1276 ENDIF
1277 ENDDO
1278 ENDDO
1279 ENDIF
1280 END DO
1281 END DO
1282 ELSEIF(nty==2 .AND. ilagm==0 .AND.(ilev==25.or.ilev==26))THEN
1283 nsn=ipari(5,n)
1284 DO ii=1,nsn
1285 i=abs(intbuf_tab(n)%NSV(ii))
1286
1287 IF(weight(i)/=1)cycle
1288
1289 l=intbuf_tab(n)%IRTLM(ii)
1290 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1291 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1292 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1293 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1294
1295 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1296 . .AND.nativ_sms(n2)==0
1297 . .AND.nativ_sms(n3)==0
1298 . .AND.nativ_sms(n4)==0) cycle
1299
1300 nodnx_sms(i) =nodnx_sms(i) +4
1301 nodnx_sms(n1)=nodnx_sms(n1)+1
1302 nodnx_sms(n2)=nodnx_sms(n2)+1
1303 nodnx_sms(n3)=nodnx_sms(n3)+1
1304 nodnx_sms(n4)=nodnx_sms(n4)+1
1305 nnz_sms = nnz_sms + 8
1306 END DO
1307 ELSEIF(nty==2 .AND. ilagm==0 .AND.(ilev==27.or.ilev==28))THEN
1308 nsn=ipari(5,n)
1309 DO ii=1,nsn
1310 i=abs(intbuf_tab(n)%NSV(ii))
1311 IF (intbuf_tab(n)%IRUPT(ii)==0) THEN
1312C Kinematic node
1313 l=intbuf_tab(n)%IRTLM(ii)
1314 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1315 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1316 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1317 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1318
1319 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1320 . .AND.nativ_sms(n2)==0
1321 . .AND.nativ_sms(n3)==0
1322 . .AND.nativ_sms(n4)==0) cycle
1323
1324 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1325 j =jdi_sms(kj)
1326 nodnx_sms(j) =nodnx_sms(j) +4
1327 nodnx_sms(n1)=nodnx_sms(n1)+1
1328 nodnx_sms(n2)=nodnx_sms(n2)+1
1329 nodnx_sms(n3)=nodnx_sms(n3)+1
1330 nodnx_sms(n4)=nodnx_sms(n4)+1
1331 nnz_sms = nnz_sms + 8
1332C-- Type2 crossed connection between main nodes
1333 IF ((t2main_sms(1,j) > 1).AND.(i > j)) THEN
1334 DO k =2,5
1335 DO kk =2,5
1336 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1337 nodnx_sms(t2main_sms(k,i))=nodnx_sms(t2main_sms(k,i))+1
1338 nodnx_sms(t2main_sms(kk,j))=nodnx_sms(t2main_sms(kk,j))+1
1339 nnz_sms = nnz_sms + 2
1340 ENDIF
1341 ENDDO
1342 ENDDO
1343 ENDIF
1344 END DO
1345 ELSE
1346C Penalty node
1347 IF(weight(i)/=1)cycle
1348 l=intbuf_tab(n)%IRTLM(ii)
1349 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1350 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1351 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1352 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1353
1354 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1355 . .AND.nativ_sms(n2)==0
1356 . .AND.nativ_sms(n3)==0
1357 . .AND.nativ_sms(n4)==0) cycle
1358
1359 nodnx_sms(i) =nodnx_sms(i) +4
1360 nodnx_sms(n1)=nodnx_sms(n1)+1
1361 nodnx_sms(n2)=nodnx_sms(n2)+1
1362 nodnx_sms(n3)=nodnx_sms(n3)+1
1363 nodnx_sms(n4)=nodnx_sms(n4)+1
1364 nnz_sms = nnz_sms + 8
1365 ENDIF
1366 END DO
1367 END IF
1368 END DO
1369C
1370C reconstruit JAD_SMS
1371 jad_sms(1)=1
1372 DO i=1,numnod
1373 jad_sms(i+1)=jad_sms(i)+nodnx_sms(i)
1374 END DO
1375C-----------------------------------------------
1376 DEALLOCATE(nad_sms)
1377 DEALLOCATE(tagk)
1378 DEALLOCATE(itri)
1379 DEALLOCATE(index1)
1380 DEALLOCATE(index2)
1381 RETURN
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82

◆ sms_ini_jad_2()

subroutine sms_ini_jad_2 ( 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(6,*) ixs10,
integer, dimension(*) nodnx_sms,
integer, dimension(4,*) jadc_sms,
integer, dimension(8,*) jads_sms,
integer, dimension(6,*) jads10_sms,
integer, dimension(2,*) jadt_sms,
integer, dimension(2,*) jadp_sms,
integer, dimension(3,*) jadr_sms,
integer, dimension(3,*) jadtg_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) tagprt_sms,
integer, dimension(*) kad_sms,
integer, dimension(*) kdi_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(*) kinet,
integer, dimension(*) tagslv_rby_sms,
integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(4,*) irect,
integer, dimension(*) lad_sms,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(*) tagmsr_rby_sms,
integer, dimension(*) tagslv_i21_sms,
integer, dimension(*) tagmsr_i21_sms,
integer, dimension(*) jadi21_sms,
type(intstamp_data), dimension(*) intstamp,
integer, dimension(lipart1,*) ipart,
integer, dimension(npropgi,*) igeo,
integer, dimension(*) weight,
integer, dimension(*) nativ_sms,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(*) lrbe2,
integer, dimension(*) iad_sms,
integer, dimension(*) idi_sms,
integer, dimension(*) jad_sms,
integer, dimension(*) jdi_sms,
integer, dimension(6,*) t2main_sms )

Definition at line 1394 of file sms_init.F.

1408C-----------------------------------------------
1409C M o d u l e s
1410C-----------------------------------------------
1411 USE intstamp_mod
1412 USE intbufdef_mod
1413 USE message_mod
1414 USE my_alloc_mod
1415C-----------------------------------------------
1416C I m p l i c i t T y p e s
1417C-----------------------------------------------
1418#include "implicit_f.inc"
1419#include "comlock.inc"
1420C-----------------------------------------------
1421C C o m m o n B l o c k s
1422C-----------------------------------------------
1423#include "com01_c.inc"
1424#include "com04_c.inc"
1425#include "param_c.inc"
1426#include "sms_c.inc"
1427#include "scr17_c.inc"
1428C-----------------------------------------------------------------
1429C D u m m y A r g u m e n t s
1430C-----------------------------------------------
1431 INTEGER
1432 . IPARG(NPARG,*), IXC(NIXC,*), IXS(NIXS,*), IXT(NIXT,*),
1433 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*), IXS10(6,*),
1434 . NODNX_SMS(*), KAD_SMS(*), KDI_SMS(*),
1435 . IAD_SMS(*), IDI_SMS(*), JAD_SMS(*), JDI_SMS(*),
1436 . JADC_SMS(4,*),
1437 . JADS_SMS(8,*), JADS10_SMS(6,*),
1438 . JADT_SMS(2,*),
1439 . JADP_SMS(2,*),
1440 . JADR_SMS(3,*),
1441 . JADTG_SMS(3,*),
1442 . INDX1_SMS(*), TAGPRT_SMS(*), TAGREL_SMS(*),
1443 . IPARTS(*), IPARTQ(*), IPARTC(*), IPARTT(*),
1444 . IPARTP(*), IPARTR(*), IPARTUR(*), IPARTTG(*), IPARTX(*),
1445 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),
1446 . NPBY(NNPBY,*), LPBY(*), KINET(*), TAGSLV_RBY_SMS(*),
1447 . IPARI(NPARI,*), IRECT(4,*),
1448 . LAD_SMS(*),
1449 . NPRW(*), LPRW(*), TAGMSR_RBY_SMS(*),
1450 . TAGSLV_I21_SMS(*), TAGMSR_I21_SMS(*), JADI21_SMS(*),
1451 . IPART(LIPART1,*), IGEO(NPROPGI,*), WEIGHT(*), NATIV_SMS(*),
1452 . IRBE2(NRBE2L,*), LRBE2(*), T2MAIN_SMS(6,*)
1453
1454 TYPE(INTSTAMP_DATA) INTSTAMP(*)
1455 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1456C-----------------------------------------------
1457C L o c a l V a r i a b l e s
1458C-----------------------------------------------
1459 INTEGER I, J, K, JJ, KK, II, IJ, M, N, IERROR, KL,
1460 . NHI, NS
1461 INTEGER MSR, NSN, KI, KJ, NSR, NSMS(2)
1462 INTEGER NSNW, IMOV
1463 INTEGER SIZE, LENR, IAD, L, LLT
1464 INTEGER NTY, ILAGM, JI,
1465 . N1, N2, N3, N4, N5, N6, ISMS,
1466 . NMN, ILEV
1467 INTEGER IK
1468 INTEGER,DIMENSION(:),ALLOCATABLE :: NAD_SMS
1469C-------------------------------------------------------------------------
1470 CALL my_alloc(nad_sms,numnod)
1471C-------------------------------------------------------------------------
1472C PREPARE KOMPACTION OF ELEMENTARY MATRIX
1473C KJ = KAD_SMS(I),KAD_SMS(I+1)-1 => PK_SMS(KJ) = rang de KDI_SMS(KJ) dans JDI_SMS(I),JDI_SMS(I+1)-1
1474C
1475C Reconstruit JDI_SMS :: Recopie IDI_SMS (connectivite elementaire compactee et triee)
1476C-------------------------------------------------------------------------
1477 DO i=1,numnod
1478 DO kj=iad_sms(i),iad_sms(i+1)-1
1479 ik=kj-iad_sms(i)
1480 jdi_sms(jad_sms(i)+ik)=idi_sms(kj)
1481 END DO
1482 END DO
1483C-------------------------------------------------------------------------
1484C inter/type2 : construction de JDI_SMS
1485C-------------------------------------------------------------------------
1486 DO i=1,numnod
1487 nad_sms(i)=jad_sms(i)+lad_sms(i)
1488 END DO
1489
1490C
1491 DO n=1,ninter
1492 nty = ipari(7,n)
1493 ilagm = ipari(33,n)
1494 ilev = ipari(20,n)
1495 IF(nty==2 .AND. ilagm==0 .AND.ilev/=25 .and. ilev/=26 .AND.ilev/=27 .and. ilev/=28)THEN
1496C
1497 nsn=ipari(5,n)
1498 DO ii=1,nsn
1499 i=abs(intbuf_tab(n)%NSV(ii))
1500 l=intbuf_tab(n)%IRTLM(ii)
1501 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1502 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1503 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1504 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1505
1506 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1507 . .AND.nativ_sms(n2)==0
1508 . .AND.nativ_sms(n3)==0
1509 . .AND.nativ_sms(n4)==0) cycle
1510
1511 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1512 j =jdi_sms(kj)
1513C
1514 jdi_sms(nad_sms(n1))=j
1515 nad_sms(n1)=nad_sms(n1)+1
1516 jdi_sms(nad_sms(j))=n1
1517 nad_sms(j)=nad_sms(j)+1
1518C
1519 jdi_sms(nad_sms(n2))=j
1520 nad_sms(n2)=nad_sms(n2)+1
1521 jdi_sms(nad_sms(j))=n2
1522 nad_sms(j)=nad_sms(j)+1
1523C
1524 jdi_sms(nad_sms(n3))=j
1525 nad_sms(n3)=nad_sms(n3)+1
1526 jdi_sms(nad_sms(j))=n3
1527 nad_sms(j)=nad_sms(j)+1
1528C
1529 jdi_sms(nad_sms(n4))=j
1530 nad_sms(n4)=nad_sms(n4)+1
1531 jdi_sms(nad_sms(j))=n4
1532 nad_sms(j)=nad_sms(j)+1
1533C
1534C-- Type2 crossed connection between main nodes
1535 IF ((t2main_sms(1,j) > 1).AND.(i > j)) THEN
1536 DO k =2,5
1537 DO kk =2,5
1538 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1539 jdi_sms(nad_sms(t2main_sms(k,i)))=t2main_sms(kk,j)
1540 nad_sms(t2main_sms(k,i))=nad_sms(t2main_sms(k,i))+1
1541 jdi_sms(nad_sms(t2main_sms(kk,j)))=t2main_sms(k,i)
1542 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1543 ENDIF
1544 ENDDO
1545 ENDDO
1546 ENDIF
1547C
1548 END DO
1549 END DO
1550 ELSEIF(nty==2.AND.ilagm==0.AND.(ilev==25.or.ilev==26))THEN
1551 nsn=ipari(5,n)
1552 DO ii=1,nsn
1553 i=abs(intbuf_tab(n)%NSV(ii))
1554
1555 IF(weight(i)/=1)cycle
1556
1557 l=intbuf_tab(n)%IRTLM(ii)
1558 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1559 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1560 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1561 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1562
1563 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1564 . .AND.nativ_sms(n2)==0
1565 . .AND.nativ_sms(n3)==0
1566 . .AND.nativ_sms(n4)==0) cycle
1567
1568 jdi_sms(nad_sms(n1))=i
1569 nad_sms(n1)=nad_sms(n1)+1
1570 jdi_sms(nad_sms(i))=n1
1571 nad_sms(i)=nad_sms(i)+1
1572
1573 jdi_sms(nad_sms(n2))=i
1574 nad_sms(n2)=nad_sms(n2)+1
1575 jdi_sms(nad_sms(i))=n2
1576 nad_sms(i)=nad_sms(i)+1
1577
1578 jdi_sms(nad_sms(n3))=i
1579 nad_sms(n3)=nad_sms(n3)+1
1580 jdi_sms(nad_sms(i))=n3
1581 nad_sms(i)=nad_sms(i)+1
1582
1583 jdi_sms(nad_sms(n4))=i
1584 nad_sms(n4)=nad_sms(n4)+1
1585 jdi_sms(nad_sms(i))=n4
1586 nad_sms(i)=nad_sms(i)+1
1587 END DO
1588C
1589 ELSEIF(nty==2.AND.ilagm==0.AND.(ilev==27.or.ilev==28))THEN
1590C
1591 nsn=ipari(5,n)
1592 DO ii=1,nsn
1593 i=abs(intbuf_tab(n)%NSV(ii))
1594 IF (intbuf_tab(n)%IRUPT(ii)==0) THEN
1595C Kinematic node
1596 l=intbuf_tab(n)%IRTLM(ii)
1597 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1598 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1599 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1600 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1601
1602 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1603 . .AND.nativ_sms(n2)==0
1604 . .AND.nativ_sms(n3)==0
1605 . .AND.nativ_sms(n4)==0) cycle
1606
1607 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1608 j =jdi_sms(kj)
1609C
1610 jdi_sms(nad_sms(n1))=j
1611 nad_sms(n1)=nad_sms(n1)+1
1612 jdi_sms(nad_sms(j))=n1
1613 nad_sms(j)=nad_sms(j)+1
1614C
1615 jdi_sms(nad_sms(n2))=j
1616 nad_sms(n2)=nad_sms(n2)+1
1617 jdi_sms(nad_sms(j))=n2
1618 nad_sms(j)=nad_sms(j)+1
1619C
1620 jdi_sms(nad_sms(n3))=j
1621 nad_sms(n3)=nad_sms(n3)+1
1622 jdi_sms(nad_sms(j))=n3
1623 nad_sms(j)=nad_sms(j)+1
1624C
1625 jdi_sms(nad_sms(n4))=j
1626 nad_sms(n4)=nad_sms(n4)+1
1627 jdi_sms(nad_sms(j))=n4
1628 nad_sms(j)=nad_sms(j)+1
1629C
1630C-- Type2 crossed connection between main nodes
1631 IF ((t2main_sms(1,j) > 1).AND.(i > j)) THEN
1632 DO k =2,5
1633 DO kk =2,5
1634 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1635 jdi_sms(nad_sms(t2main_sms(k,i)))=t2main_sms(kk,j)
1636 nad_sms(t2main_sms(k,i))=nad_sms(t2main_sms(k,i))+1
1637 jdi_sms(nad_sms(t2main_sms(kk,j)))=t2main_sms(k,i)
1638 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1639 ENDIF
1640 ENDDO
1641 ENDDO
1642C
1643 ENDIF
1644 END DO
1645C
1646 ELSE
1647C Penalty node
1648 IF(weight(i)/=1)cycle
1649 l=intbuf_tab(n)%IRTLM(ii)
1650 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1651 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1652 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1653 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1654
1655 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1656 . .AND.nativ_sms(n2)==0
1657 . .AND.nativ_sms(n3)==0
1658 . .AND.nativ_sms(n4)==0) cycle
1659
1660 jdi_sms(nad_sms(n1))=i
1661 nad_sms(n1)=nad_sms(n1)+1
1662 jdi_sms(nad_sms(i))=n1
1663 nad_sms(i)=nad_sms(i)+1
1664
1665 jdi_sms(nad_sms(n2))=i
1666 nad_sms(n2)=nad_sms(n2)+1
1667 jdi_sms(nad_sms(i))=n2
1668 nad_sms(i)=nad_sms(i)+1
1669
1670 jdi_sms(nad_sms(n3))=i
1671 nad_sms(n3)=nad_sms(n3)+1
1672 jdi_sms(nad_sms(i))=n3
1673 nad_sms(i)=nad_sms(i)+1
1674
1675 jdi_sms(nad_sms(n4))=i
1676 nad_sms(n4)=nad_sms(n4)+1
1677 jdi_sms(nad_sms(i))=n4
1678 nad_sms(i)=nad_sms(i)+1
1679 ENDIF
1680 END DO
1681 END IF
1682 END DO
1683C------------
1684C Recalcule NNZ_SMS de la matrice compactee
1685C------------
1686 nnz_sms=0
1687 DO i=1,numnod
1688 nodnx_sms(i)=nad_sms(i)-jad_sms(i)
1689 nnz_sms=nnz_sms+nodnx_sms(i)
1690 END DO
1691C------------
1692C reconstruit JAD_SMS
1693 jad_sms(1)=1
1694 DO i=1,numnod
1695 jad_sms(i+1)=jad_sms(i)+nodnx_sms(i)
1696 END DO
1697C-----------------------------------------------
1698 DEALLOCATE(nad_sms)
1699 RETURN
intstamp_mod
Definition intstamp_mod.F:38

◆ sms_ini_jad_3()

subroutine sms_ini_jad_3 ( 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(6,*) ixs10,
integer, dimension(*) nodnx_sms,
integer, dimension(4,*) jadc_sms,
integer, dimension(8,*) jads_sms,
integer, dimension(6,*) jads10_sms,
integer, dimension(2,*) jadt_sms,
integer, dimension(2,*) jadp_sms,
integer, dimension(3,*) jadr_sms,
integer, dimension(3,*) jadtg_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) tagprt_sms,
integer, dimension(*) kad_sms,
integer, dimension(*) kdi_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(*) kinet,
integer, dimension(*) tagslv_rby_sms,
integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(4,*) irect,
integer, dimension(*) lad_sms,
integer, dimension(*) jsm_sms,
integer, dimension(*) tagslv_i21_sms,
type(intstamp_data), dimension(*) intstamp,
integer, dimension(lipart1,*) ipart,
integer, dimension(npropgi,*) igeo,
integer, dimension(*) tagmsr_rby_sms,
integer, dimension(*) weight,
integer, dimension(*) nativ_sms,
integer, dimension(*) iad_sms,
integer, dimension(*) idi_sms,
integer, dimension(*) jad_sms,
integer, dimension(*) jdi_sms,
integer, dimension(6,*) t2main_sms )

Definition at line 1716 of file sms_init.F.

1729C-----------------------------------------------
1730C M o d u l e s
1731C-----------------------------------------------
1732 USE intstamp_mod
1733 USE intbufdef_mod
1734 USE message_mod
1735 USE my_alloc_mod
1736C-----------------------------------------------
1737C I m p l i c i t T y p e s
1738C-----------------------------------------------
1739#include "implicit_f.inc"
1740#include "comlock.inc"
1741C-----------------------------------------------
1742C C o m m o n B l o c k s
1743C-----------------------------------------------
1744#include "com01_c.inc"
1745#include "com04_c.inc"
1746#include "param_c.inc"
1747#include "sms_c.inc"
1748#include "scr17_c.inc"
1749C-----------------------------------------------------------------
1750C D u m m y A r g u m e n t s
1751C-----------------------------------------------
1752 INTEGER
1753 . IPARG(NPARG,*), IXC(NIXC,*), IXS(NIXS,*), IXT(NIXT,*),
1754 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*), IXS10(6,*),
1755 . NODNX_SMS(*), KAD_SMS(*), KDI_SMS(*),
1756 . IAD_SMS(*), IDI_SMS(*), JAD_SMS(*), JDI_SMS(*),
1757 . JADC_SMS(4,*),
1758 . JADS_SMS(8,*), JADS10_SMS(6,*),
1759 . JADT_SMS(2,*),
1760 . JADP_SMS(2,*),
1761 . JADR_SMS(3,*),
1762 . JADTG_SMS(3,*),NATIV_SMS(*),
1763 . INDX1_SMS(*), TAGPRT_SMS(*), TAGREL_SMS(*),
1764 . IPARTS(*), IPARTQ(*), IPARTC(*), IPARTT(*),
1765 . IPARTP(*), IPARTR(*), IPARTUR(*), IPARTTG(*), IPARTX(*),
1766 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),
1767 . NPBY(NNPBY,*), LPBY(*), KINET(*), TAGSLV_RBY_SMS(*),
1768 . IPARI(NPARI,*), IRECT(4,*),
1769 . LAD_SMS(*), JSM_SMS(*),
1770 . TAGSLV_I21_SMS(*),
1771 . IPART(LIPART1,*), IGEO(NPROPGI,*), TAGMSR_RBY_SMS(*),
1772 . WEIGHT(*),T2MAIN_SMS(6,*)
1773 TYPE(INTSTAMP_DATA) INTSTAMP(*)
1774 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
1775C-----------------------------------------------
1776C L o c a l V a r i a b l e s
1777C-----------------------------------------------
1778 INTEGER I, J, K, JJ, KK, II, IJ, M, N, IERROR, KL
1779 INTEGER MSR, NSN, KI, KJ, NSR
1780 INTEGER SIZE, LENR, IAD, L, LLT
1781 INTEGER NTY, ILAGM, K10, K11, K12, K13, K14, JI,
1782 . N1, N2, N3, N4,
1783 . NMN, ILEV, ERROR
1784 INTEGER LSMSPCG
1785 INTEGER IK, K1, K2, KM
1786 INTEGER, DIMENSION(:), ALLOCATABLE :: NAD_SMS
1787 INTEGER, DIMENSION(:), ALLOCATABLE :: NAD_SMS_0
1788C-------------------------------------------------------------------------
1789 CALL my_alloc(nad_sms,numnod)
1790 CALL my_alloc(nad_sms_0,numnod)
1791C-------------------------------------------------------------------------
1792C PREPARE KOMPACTION OF ELEMENTARY MATRIX
1793C KJ = KAD_SMS(I),KAD_SMS(I+1)-1 => PK_SMS(KJ) = rang de KDI_SMS(KJ) dans JDI_SMS(I),JDI_SMS(I+1)-1
1794C
1795C Reconstruit JDI_SMS :: Recopie IDI_SMS (connectivite elementaire compactee et triee)
1796C-------------------------------------------------------------------------
1797 DO i=1,numnod
1798 DO kj=iad_sms(i),iad_sms(i+1)-1
1799 ik=kj-iad_sms(i)
1800 jdi_sms(jad_sms(i)+ik)=idi_sms(kj)
1801 END DO
1802 END DO
1803C-------------------------------------------------------------------------
1804C PREPARE JSM_SMS
1805C-------------------------------------------------------------------------
1806C
1807 DO i=1,numnod
1808 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1809 j =jdi_sms(kj)
1810cc IF(I < J)THEN
1811C
1812C dichotomie (recherche parmi les voisins ordonnes de J)
1813 k1=jad_sms(j)
1814 k2=jad_sms(j)+lad_sms(j)-1
1815 100 CONTINUE
1816 km=(k1+k2)/2
1817 IF(jdi_sms(k1) == i)THEN
1818 jsm_sms(kj)=k1
1819cc JSM_SMS(K1)=KJ
1820 GOTO 200
1821 ELSEIF(jdi_sms(k2) == i)THEN
1822 jsm_sms(kj)=k2
1823cc JSM_SMS(K2)=KJ
1824 GOTO 200
1825 ELSEIF(jdi_sms(km) == i)THEN
1826 jsm_sms(kj)=km
1827cc JSM_SMS(KM)=KJ
1828 GOTO 200
1829 ELSEIF(jdi_sms(km) < i)THEN
1830 k1=km
1831 GOTO 100
1832 ELSE ! JDI_SMS(KM) > I
1833 k2=km
1834 GOTO 100
1835 END IF
1836 WRITE(6,*) ' ** internal error in AMS initialization'
1837 200 CONTINUE
1838cc END IF
1839 END DO
1840 END DO
1841C
1842 DO i=1,numnod
1843 nad_sms(i)=jad_sms(i)+lad_sms(i)
1844 END DO
1845C-------------------------------------------------------------------------
1846 lsmspcg=0
1847C------------
1848C inter/type2 : reconstruction (jsm)
1849C------------
1850 DO n=1,ninter
1851 nty = ipari(7,n)
1852 ilagm = ipari(33,n)
1853 ilev = ipari(20,n)
1854 IF(nty==2 .AND. ilagm==0 .AND.ilev/=25 .and. ilev/=26.AND.ilev/=27 .and. ilev/=28)THEN
1855C
1856 nsn=ipari(5,n)
1857 DO ii=1,nsn
1858 i=abs(intbuf_tab(n)%NSV(ii))
1859 IF(nodnx_sms(i)/=0) lsmspcg=lsmspcg-1
1860
1861 l=intbuf_tab(n)%IRTLM(ii)
1862 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1863 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1864 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1865 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1866
1867 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1868 . .AND.nativ_sms(n2)==0
1869 . .AND.nativ_sms(n3)==0
1870 . .AND.nativ_sms(n4)==0) cycle
1871
1872 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1873 j =jdi_sms(kj)
1874
1875 jsm_sms(nad_sms(n1))=nad_sms(j)
1876 jsm_sms(nad_sms(j)) =nad_sms(n1)
1877 jdi_sms(nad_sms(n1))=j
1878 nad_sms(n1)=nad_sms(n1)+1
1879 jdi_sms(nad_sms(j))=n1
1880 nad_sms(j)=nad_sms(j)+1
1881
1882 jsm_sms(nad_sms(n2))=nad_sms(j)
1883 jsm_sms(nad_sms(j)) =nad_sms(n2)
1884 jdi_sms(nad_sms(n2))=j
1885 nad_sms(n2)=nad_sms(n2)+1
1886 jdi_sms(nad_sms(j))=n2
1887 nad_sms(j)=nad_sms(j)+1
1888
1889 jsm_sms(nad_sms(n3))=nad_sms(j)
1890 jsm_sms(nad_sms(j)) =nad_sms(n3)
1891 jdi_sms(nad_sms(n3))=j
1892 nad_sms(n3)=nad_sms(n3)+1
1893 jdi_sms(nad_sms(j))=n3
1894 nad_sms(j)=nad_sms(j)+1
1895
1896 jsm_sms(nad_sms(n4))=nad_sms(j)
1897 jsm_sms(nad_sms(j)) =nad_sms(n4)
1898 jdi_sms(nad_sms(n4))=j
1899 nad_sms(n4)=nad_sms(n4)+1
1900 jdi_sms(nad_sms(j))=n4
1901 nad_sms(j)=nad_sms(j)+1
1902C
1903C-- Type2 crossed connection between main nodes
1904 IF ((t2main_sms(1,j) > 1).AND.(i > j)) THEN
1905 DO k =2,5
1906 DO kk =2,5
1907 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
1908 jsm_sms(nad_sms(t2main_sms(k,i)))=nad_sms(t2main_sms(kk,j))
1909 jsm_sms(nad_sms(t2main_sms(kk,j)))=nad_sms(t2main_sms(k,i))
1910 jdi_sms(nad_sms(t2main_sms(k,i)))=t2main_sms(kk,j)
1911 nad_sms(t2main_sms(k,i))=nad_sms(t2main_sms(k,i))+1
1912 jdi_sms(nad_sms(t2main_sms(kk,j)))=t2main_sms(k,i)
1913 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
1914 ENDIF
1915 ENDDO
1916 ENDDO
1917 ENDIF
1918C
1919 END DO
1920 END DO
1921 ELSEIF(nty==2.AND.ilagm==0.AND.(ilev==25.or.ilev==26))THEN
1922 k10=ipari(1,n)
1923 k11=k10+4*ipari(3,n)
1924 k12=k11+4*ipari(4,n)
1925 k13=k12+ipari(5,n)
1926 k14=k13+ipari(6,n)
1927 nsn=ipari(5,n)
1928 DO ii=1,nsn
1929 i=abs(intbuf_tab(n)%NSV(ii))
1930
1931 IF(weight(i)/=1)cycle
1932
1933 l=intbuf_tab(n)%IRTLM(ii)
1934 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1935 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1936 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1937 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1938
1939 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1940 . .AND.nativ_sms(n2)==0
1941 . .AND.nativ_sms(n3)==0
1942 . .AND.nativ_sms(n4)==0) cycle
1943
1944 jsm_sms(nad_sms(n1))=nad_sms(i)
1945 jsm_sms(nad_sms(i)) =nad_sms(n1)
1946 jdi_sms(nad_sms(n1))=i
1947 nad_sms(n1)=nad_sms(n1)+1
1948 jdi_sms(nad_sms(i))=n1
1949 nad_sms(i)=nad_sms(i)+1
1950
1951 jsm_sms(nad_sms(n2))=nad_sms(i)
1952 jsm_sms(nad_sms(i)) =nad_sms(n2)
1953 jdi_sms(nad_sms(n2))=i
1954 nad_sms(n2)=nad_sms(n2)+1
1955 jdi_sms(nad_sms(i))=n2
1956 nad_sms(i)=nad_sms(i)+1
1957
1958 jsm_sms(nad_sms(n3))=nad_sms(i)
1959 jsm_sms(nad_sms(i)) =nad_sms(n3)
1960 jdi_sms(nad_sms(n3))=i
1961 nad_sms(n3)=nad_sms(n3)+1
1962 jdi_sms(nad_sms(i))=n3
1963 nad_sms(i)=nad_sms(i)+1
1964
1965 jsm_sms(nad_sms(n4))=nad_sms(i)
1966 jsm_sms(nad_sms(i)) =nad_sms(n4)
1967 jdi_sms(nad_sms(n4))=i
1968 nad_sms(n4)=nad_sms(n4)+1
1969 jdi_sms(nad_sms(i))=n4
1970 nad_sms(i)=nad_sms(i)+1
1971 END DO
1972 ELSEIF(nty==2.AND.ilagm==0.AND.(ilev==27.or.ilev==28))THEN
1973C
1974 nsn=ipari(5,n)
1975 DO ii=1,nsn
1976 i=abs(intbuf_tab(n)%NSV(ii))
1977 IF (intbuf_tab(n)%IRUPT(ii)==0) THEN
1978C Kinematic node
1979 IF(nodnx_sms(i)/=0) lsmspcg=lsmspcg-1
1980
1981 l=intbuf_tab(n)%IRTLM(ii)
1982 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
1983 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
1984 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
1985 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
1986
1987 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
1988 . .AND.nativ_sms(n2)==0
1989 . .AND.nativ_sms(n3)==0
1990 . .AND.nativ_sms(n4)==0) cycle
1991
1992 DO kj=jad_sms(i),jad_sms(i)+lad_sms(i)-1
1993 j =jdi_sms(kj)
1994
1995 jsm_sms(nad_sms(n1))=nad_sms(j)
1996 jsm_sms(nad_sms(j)) =nad_sms(n1)
1997 jdi_sms(nad_sms(n1))=j
1998 nad_sms(n1)=nad_sms(n1)+1
1999 jdi_sms(nad_sms(j))=n1
2000 nad_sms(j)=nad_sms(j)+1
2001
2002 jsm_sms(nad_sms(n2))=nad_sms(j)
2003 jsm_sms(nad_sms(j)) =nad_sms(n2)
2004 jdi_sms(nad_sms(n2))=j
2005 nad_sms(n2)=nad_sms(n2)+1
2006 jdi_sms(nad_sms(j))=n2
2007 nad_sms(j)=nad_sms(j)+1
2008
2009 jsm_sms(nad_sms(n3))=nad_sms(j)
2010 jsm_sms(nad_sms(j)) =nad_sms(n3)
2011 jdi_sms(nad_sms(n3))=j
2012 nad_sms(n3)=nad_sms(n3)+1
2013 jdi_sms(nad_sms(j))=n3
2014 nad_sms(j)=nad_sms(j)+1
2015
2016 jsm_sms(nad_sms(n4))=nad_sms(j)
2017 jsm_sms(nad_sms(j)) =nad_sms(n4)
2018 jdi_sms(nad_sms(n4))=j
2019 nad_sms(n4)=nad_sms(n4)+1
2020 jdi_sms(nad_sms(j))=n4
2021 nad_sms(j)=nad_sms(j)+1
2022C
2023C-- Type2 crossed connection between main nodes
2024 IF ((t2main_sms(1,j) > 1).AND.(i > j)) THEN
2025 DO k =2,5
2026 DO kk =2,5
2027 IF (t2main_sms(k,i)/=t2main_sms(kk,j)) THEN
2028 jsm_sms(nad_sms(t2main_sms(k,i)))=nad_sms(t2main_sms(kk,j))
2029 jsm_sms(nad_sms(t2main_sms(kk,j)))=nad_sms(t2main_sms(k,i))
2030 jdi_sms(nad_sms(t2main_sms(k,i)))=t2main_sms(kk,j)
2031 nad_sms(t2main_sms(k,i))=nad_sms(t2main_sms(k,i))+1
2032 jdi_sms(nad_sms(t2main_sms(kk,j)))=t2main_sms(k,i)
2033 nad_sms(t2main_sms(kk,j))=nad_sms(t2main_sms(kk,j))+1
2034 ENDIF
2035 ENDDO
2036 ENDDO
2037 ENDIF
2038C
2039 END DO
2040 ELSE
2041C Penalty node
2042 IF(weight(i)/=1)cycle
2043
2044 l=intbuf_tab(n)%IRTLM(ii)
2045 n1 = intbuf_tab(n)%IRECTM(4*(l-1)+1)
2046 n2 = intbuf_tab(n)%IRECTM(4*(l-1)+2)
2047 n3 = intbuf_tab(n)%IRECTM(4*(l-1)+3)
2048 n4 = intbuf_tab(n)%IRECTM(4*(l-1)+4)
2049
2050 IF(nativ_sms(i)==0.AND.nativ_sms(n1)==0
2051 . .AND.nativ_sms(n2)==0
2052 . .AND.nativ_sms(n3)==0
2053 . .AND.nativ_sms(n4)==0) cycle
2054
2055 jsm_sms(nad_sms(n1))=nad_sms(i)
2056 jsm_sms(nad_sms(i)) =nad_sms(n1)
2057 jdi_sms(nad_sms(n1))=i
2058 nad_sms(n1)=nad_sms(n1)+1
2059 jdi_sms(nad_sms(i))=n1
2060 nad_sms(i)=nad_sms(i)+1
2061
2062 jsm_sms(nad_sms(n2))=nad_sms(i)
2063 jsm_sms(nad_sms(i)) =nad_sms(n2)
2064 jdi_sms(nad_sms(n2))=i
2065 nad_sms(n2)=nad_sms(n2)+1
2066 jdi_sms(nad_sms(i))=n2
2067 nad_sms(i)=nad_sms(i)+1
2068
2069 jsm_sms(nad_sms(n3))=nad_sms(i)
2070 jsm_sms(nad_sms(i)) =nad_sms(n3)
2071 jdi_sms(nad_sms(n3))=i
2072 nad_sms(n3)=nad_sms(n3)+1
2073 jdi_sms(nad_sms(i))=n3
2074 nad_sms(i)=nad_sms(i)+1
2075
2076 jsm_sms(nad_sms(n4))=nad_sms(i)
2077 jsm_sms(nad_sms(i)) =nad_sms(n4)
2078 jdi_sms(nad_sms(n4))=i
2079 nad_sms(n4)=nad_sms(n4)+1
2080 jdi_sms(nad_sms(i))=n4
2081 nad_sms(i)=nad_sms(i)+1
2082 ENDIF
2083 END DO
2084 END IF
2085 END DO
2086C------------
2087 DO i=1,numnod
2088 nad_sms_0(i)=nad_sms(i)
2089 END DO
2090C------------
2091 DO i=1,numnod
2092 lad_sms(i)=jad_sms(i) + lad_sms(i) - 1
2093 END DO
2094c DO I=1,NUMNOD
2095c do kj=JAD_SMS(I),JAD_SMS(I+1)-1
2096c print *,i,jdi_sms(kj),jdi_sms(jsm_sms(kj))
2097c end do
2098c END DO
2099C-----------------------------------------------
2100C Check of the symmetrization operator JSM_SMS
2101C-----------------------------------------------
2102 error = 0
2103 DO i=1,numnod
2104 DO ij=jad_sms(i),jad_sms(i+1)-1
2105 j=jdi_sms(ij)
2106 IF(j > i)THEN
2107 ji=jsm_sms(ij)
2108 IF (ij/=jsm_sms(ji)) error = 1
2109 END IF
2110 END DO
2111 END DO
2112C
2113 IF (error==1) THEN
2114 CALL ancmsg(msgid=273,anmode=aninfo)
2115 CALL arret(2)
2116 ENDIF
2117C-----------------------------------------------
2118C COMMUNICATION
2119C-----------------------------------------------
2120 IF(nspmd>1) THEN
2121 SIZE = 1
2122 lenr = iad_elem(1,nspmd+1)-iad_elem(1,1)
2123C
2124C Echange NODNX_SMS
2125C
2126 CALL spmd_exch_nodnx(nodnx_sms,iad_elem ,fr_elem,lenr)
2127 END IF
2128C-----------------------------------------------
2129 nindx1_sms=0
2130 DO i=1,numnod
2131 IF(nodnx_sms(i)/=0)THEN
2132 nindx1_sms=nindx1_sms+1
2133 indx1_sms(nindx1_sms)=i
2134 END IF
2135 END DO
2136 lsmspcg=lsmspcg+nindx1_sms
2137 IF(nspmd>1)
2138 . CALL spmd_allglob_isum9(lsmspcg,1)
2139 nsmspcg=min(nsmspcg,3*lsmspcg)
2140C
2141C------------
2142C CHeck of the symmetrization operator JSM_SMS
2143C------------
2144 error = 0
2145 DO i=1,numnod
2146 DO ij=jad_sms(i),jad_sms(i+1)-1
2147 j=jdi_sms(ij)
2148 IF(j > i)THEN
2149 ji=jsm_sms(ij)
2150 IF (ij/=jsm_sms(ji)) error = 1
2151 END IF
2152 END DO
2153 END DO
2154C
2155 IF (error==1) THEN
2156 CALL ancmsg(msgid=273,anmode=aninfo)
2157 CALL arret(2)
2158 ENDIF
2159C-----------------------------------------------
2160 DEALLOCATE(nad_sms)
2161 DEALLOCATE(nad_sms_0)
2162
2163 RETURN
min
#define min(a, b)
Definition macros.h:20
spmd_exch_nodnx
subroutine spmd_exch_nodnx(nodnx_sms, iad_elem, fr_elem, lenr)
Definition spmd_exch_nodnx.F:33

◆ sms_ini_kad()

subroutine sms_ini_kad ( integer, dimension(nixs,*) ixs,
integer, dimension(nixq,*) ixq,
integer, dimension(nixc,*) ixc,
integer, dimension(nixt,*) ixt,
integer, dimension(nixp,*) ixp,
integer, dimension(nixr,*) ixr,
integer, dimension(nixtg,*) ixtg,
integer, dimension(4,*) ixtg1,
integer, dimension(6,*) ixs10,
integer, dimension(6,*) ixs16,
integer, dimension(12,*) ixs20,
integer, dimension(nparg,*) iparg,
ms,
ms0,
integer, dimension(*) nodnx_sms,
integer, dimension(*) icodt,
integer, dimension(*) icodr,
integer, dimension(*) kinet,
integer, dimension(*) indx1_sms,
integer, dimension(*) kad_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(*) tagprt_sms,
integer, dimension(*) tagrel_sms,
integer, dimension(*) itab,
integer, dimension(*) weight,
integer, dimension(nrbe2l,*) irbe2,
integer, dimension(nrbe3l,*) irbe3,
integer, dimension(*) lrbe2,
integer, dimension(*) lrbe3,
integer, dimension(2,nspmd+1) iad_elem,
integer, dimension(*) fr_elem,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(lipart1,*) ipart,
integer, dimension(npropgi,*) igeo,
integer, dimension(*) nativ_sms )

Definition at line 203 of file sms_init.F.

214C-----------------------------------------------
215 USE my_alloc_mod
216C-----------------------------------------------
217C I m p l i c i t T y p e s
218C-----------------------------------------------
219#include "implicit_f.inc"
220C-----------------------------------------------
221C C o m m o n B l o c k s
222C-----------------------------------------------
223#include "com01_c.inc"
224#include "com04_c.inc"
225#include "param_c.inc"
226#include "scr17_c.inc"
227#include "sms_c.inc"
228C-----------------------------------------------
229C D u m m y A r g u m e n t s
230C-----------------------------------------------
231 INTEGER
232 . IXS(NIXS,*),IXS10(6,*) ,IXS16(6,*) ,IXS20(12,*),
233 . IXQ(NIXQ,*),IXC(NIXC,*), IXT(NIXT,*), IXP(NIXP,*),
234 . IXR(NIXR,*), IXTG(NIXTG,*), IXTG1(4,*),
235 . IPARG(NPARG,*),
236 . NODNX_SMS(*), ICODT(*), ICODR(*), KINET(*),
237 . INDX1_SMS(*),
238 . KAD_SMS(*),
239 . IPARTS(*),IPARTQ(*),IPARTC(*),IPARTT(*),
240 . IPARTP(*),IPARTR(*),IPARTUR(*),IPARTTG(*),IPARTX(*),
241 . TAGPRT_SMS(*), TAGREL_SMS(*),
242 . ITAB(*), WEIGHT(*),
243 . IRBE2(NRBE2L,*), IRBE3(NRBE3L,*), LRBE2(*), LRBE3(*),
244 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*), NPRW(*), LPRW(*),
245 . IPART(LIPART1,*), IGEO(NPROPGI,*), NATIV_SMS(*)
246C REAL
247 my_real
248 . ms(*), ms0(*)
249C-----------------------------------------------
250C L o c a l V a r i a b l e s
251C-----------------------------------------------
252 INTEGER I, J, K, NG, N, JJ, KK, ITY, NEL, NFT, ISOLNOD,
253 . IAD, IP, ILOC4(4),
254 . TAG8(8), IG, IGTYP
255 INTEGER J1, IPERM1(6), IPERM2(6),IPENTA6(6)
256 INTEGER,DIMENSION(:),ALLOCATABLE :: NAD_SMS
257 INTEGER,DIMENSION(:),ALLOCATABLE :: IWORK
258 DATA iloc4/1,3,6,5/
259 DATA iperm1/1,2,3,1,2,3/
260 DATA iperm2/2,3,1,4,4,4/
261 DATA ipenta6/1,2,3,5,6,7/
262C-----------------------------------------------
263 CALL my_alloc(nad_sms,numnod)
264 CALL my_alloc(iwork,numnod)
265C-----------------------------------------------
266 DO i=1,numnod
267 nad_sms(i)=0
268 END DO
269
270 knz_sms = 0
271
272 tagrel_sms(1:ngroup)=0
273 DO ng=1,ngroup
274 ity =iparg(5,ng)
275
276 nel = iparg(2,ng)
277 nft = iparg(3,ng)
278 isolnod = iparg(28,ng)
279 IF(ity==1.AND.isolnod==4)THEN
280 DO j=nft+1,nft+nel
281 DO k=1,4
282
283 i=ixs(1+iloc4(k),j)
284 DO kk=1,4
285 jj = ixs(1+iloc4(kk),j)
286 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
287 tagrel_sms(ng)=1
288 nad_sms(i)=nad_sms(i)+1
289 knz_sms =knz_sms+1
290 END IF
291 END DO
292
293 END DO
294 END DO
295 ELSEIF(ity==1.AND.isolnod==6)THEN
296 DO j=nft+1,nft+nel
297 DO k=1,6
298
299 i=ixs(1+ipenta6(k),j)
300 DO kk=1,6
301 jj = ixs(1+ipenta6(kk),j)
302 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
303 tagrel_sms(ng)=1
304 nad_sms(i)=nad_sms(i)+1
305 knz_sms =knz_sms+1
306 END IF
307 END DO
308
309 END DO
310 END DO
311 ELSEIF(ity==1.AND.isolnod==8)THEN
312 DO j=nft+1,nft+nel
313
314 DO k=1,8
315 i=ixs(1+k,j)
316 iwork(i)=0
317 tag8(k)=0
318 END DO
319
320 DO k=1,8
321 i=ixs(1+k,j)
322 IF(iwork(i)/=0)THEN
323 tag8(k)=1
324 ELSE
325 iwork(i)=1
326 END IF
327 END DO
328
329 DO k=1,8
330
331 i=ixs(1+k,j)
332 IF(tag8(k)/=0)cycle
333
334 DO kk=1,8
335 jj = ixs(1+kk,j)
336 IF(tag8(kk)/=0) cycle
337
338 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
339 tagrel_sms(ng)=1
340 nad_sms(i)=nad_sms(i)+1
341 knz_sms =knz_sms+1
342 END IF
343 END DO
344
345 END DO
346 END DO
347 ELSEIF(ity==1.AND.isolnod==10)THEN
348 DO j=nft+1,nft+nel
349 j1=j-numels8
350
351 DO k=1,4
352
353 i=ixs(1+iloc4(k),j)
354 DO kk=1,4
355 jj = ixs(1+iloc4(kk),j)
356 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
357 tagrel_sms(ng)=1
358 nad_sms(i)=nad_sms(i)+1
359 knz_sms =knz_sms+1
360 END IF
361 END DO
362
363 DO kk=1,6
364 jj=ixs10(kk,j1)
365 IF(jj==0) cycle
366
367 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
368 tagrel_sms(ng)=1
369 nad_sms(i)=nad_sms(i)+1
370 knz_sms =knz_sms+1
371 END IF
372 END DO
373
374 END DO
375
376 DO k=1,6
377
378 i=ixs10(k,j1)
379 IF(i==0) cycle
380
381 DO kk=1,4
382 jj = ixs(1+iloc4(kk),j)
383 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
384 tagrel_sms(ng)=1
385 nad_sms(i)=nad_sms(i)+1
386 knz_sms =knz_sms+1
387 END IF
388 END DO
389
390 DO kk=1,6
391 jj=ixs10(kk,j1)
392 IF(jj==0) cycle
393
394 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
395 tagrel_sms(ng)=1
396 nad_sms(i)=nad_sms(i)+1
397 knz_sms =knz_sms+1
398 END IF
399 END DO
400
401 END DO
402
403 END DO
404 ELSEIF(ity==3)THEN
405 DO j=nft+1,nft+nel
406 DO k=1,4
407
408 i=ixc(1+k,j)
409 DO kk=1,4
410 jj = ixc(1+kk,j)
411 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
412 tagrel_sms(ng)=1
413 nad_sms(i)=nad_sms(i)+1
414 knz_sms =knz_sms+1
415 END IF
416 END DO
417
418 END DO
419 END DO
420 ELSEIF(ity==4)THEN
421 DO j=nft+1,nft+nel
422 DO k=1,2
423
424 i=ixt(1+k,j)
425 DO kk=1,2
426 jj = ixt(1+kk,j)
427 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
428 tagrel_sms(ng)=1
429 nad_sms(i)=nad_sms(i)+1
430 knz_sms =knz_sms+1
431 END IF
432 END DO
433
434 END DO
435 END DO
436 ELSEIF(ity==5)THEN
437 DO j=nft+1,nft+nel
438 DO k=1,2
439 i=ixp(1+k,j)
440 DO kk=1,2
441 jj = ixp(1+kk,j)
442 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
443 tagrel_sms(ng)=1
444 nad_sms(i)=nad_sms(i)+1
445 knz_sms =knz_sms+1
446 END IF
447 END DO
448 END DO
449 END DO
450 ELSEIF(ity==6)THEN
451 ig = ipart(2,ipartr(nft+1))
452 igtyp = igeo(11,ig)
453 IF(igtyp/=12)THEN
454 DO j=nft+1,nft+nel
455 DO k=1,2
456 i=ixr(1+k,j)
457 DO kk=1,2
458 jj = ixr(1+kk,j)
459 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
460 tagrel_sms(ng)=1
461 nad_sms(i)=nad_sms(i)+1
462 knz_sms =knz_sms+1
463 END IF
464 END DO
465 END DO
466 END DO
467 ELSE
468 DO j=nft+1,nft+nel
469 k=1
470
471 i=ixr(1+k,j)
472
473 kk=2
474 jj = ixr(1+kk,j)
475 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
476 tagrel_sms(ng)=1
477 nad_sms(i)=nad_sms(i)+1
478 knz_sms =knz_sms+1
479 END IF
480
481 k=2
482
483 i=ixr(1+k,j)
484
485 kk=1
486 jj = ixr(1+kk,j)
487 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
488 tagrel_sms(ng)=1
489 nad_sms(i)=nad_sms(i)+1
490 knz_sms =knz_sms+1
491 END IF
492
493 kk=3
494 jj = ixr(1+kk,j)
495 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
496 tagrel_sms(ng)=1
497 nad_sms(i)=nad_sms(i)+1
498 knz_sms =knz_sms+1
499 END IF
500
501 k=3
502
503 i=ixr(1+k,j)
504
505 kk=2
506 jj = ixr(1+kk,j)
507 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
508 tagrel_sms(ng)=1
509 nad_sms(i)=nad_sms(i)+1
510 knz_sms =knz_sms+1
511 END IF
512
513 END DO
514 END IF
515 ELSEIF(ity==7)THEN
516 DO j=nft+1,nft+nel
517 DO k=1,3
518
519 i=ixtg(1+k,j)
520 DO kk=1,3
521 jj = ixtg(1+kk,j)
522 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
523 tagrel_sms(ng)=1
524 nad_sms(i)=nad_sms(i)+1
525 knz_sms =knz_sms+1
526 END IF
527 END DO
528
529 END DO
530 END DO
531 END IF
532 END DO
533C
534 kad_sms(1)=1
535 DO i=1,numnod
536 kad_sms(i+1)=kad_sms(i)+nad_sms(i)
537 END DO
538C-----------------------------------------------
539 DEALLOCATE(nad_sms)
540 DEALLOCATE(iwork)
541
542
543 RETURN
my_real
#define my_real
Definition cppsort.cpp:32

◆ sms_ini_kdi()

subroutine sms_ini_kdi ( 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(6,*) ixs10,
integer, dimension(*) nodnx_sms,
integer, dimension(*) kad_sms,
integer, dimension(*) kdi_sms,
integer, dimension(4,*) jadc_sms,
integer, dimension(8,*) jads_sms,
integer, dimension(6,*) jads10_sms,
integer, dimension(2,*) jadt_sms,
integer, dimension(2,*) jadp_sms,
integer, dimension(3,*) jadr_sms,
integer, dimension(3,*) jadtg_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) tagprt_sms,
integer, dimension(*) iad_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(*) kinet,
integer, dimension(*) tagslv_rby_sms,
integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(4,*) irect,
integer, dimension(*) lad_sms,
integer, dimension(lipart1,*) ipart,
integer, dimension(npropgi,*) igeo,
integer, dimension(*) weight,
integer, dimension(*) nativ_sms )

Definition at line 610 of file sms_init.F.

622C-----------------------------------------------
623C M o d u l e s
624C-----------------------------------------------
625 USE intbufdef_mod
626 USE my_alloc_mod
627C-----------------------------------------------
628C I m p l i c i t T y p e s
629C-----------------------------------------------
630#include "implicit_f.inc"
631#include "comlock.inc"
632C-----------------------------------------------
633C C o m m o n B l o c k s
634C-----------------------------------------------
635#include "com01_c.inc"
636#include "com04_c.inc"
637#include "param_c.inc"
638#include "sms_c.inc"
639#include "task_c.inc"
640#include "scr17_c.inc"
641C-----------------------------------------------------------------
642C D u m m y A r g u m e n t s
643C-----------------------------------------------
644 INTEGER
645 . IPARG(NPARG,*), IXC(NIXC,*), IXS(NIXS,*), IXT(NIXT,*),
646 . IXP(NIXP,*), IXR(NIXR,*), IXTG(NIXTG,*), IXS10(6,*),
647 . NODNX_SMS(*), KAD_SMS(*), IAD_SMS(*),
648 . JADC_SMS(4,*),
649 . JADS_SMS(8,*), JADS10_SMS(6,*),
650 . JADT_SMS(2,*),
651 . JADP_SMS(2,*),
652 . JADR_SMS(3,*),
653 . JADTG_SMS(3,*), NATIV_SMS(*),
654 . INDX1_SMS(*), TAGPRT_SMS(*), TAGREL_SMS(*),
655 . IPARTS(*), IPARTQ(*), IPARTC(*), IPARTT(*),
656 . IPARTP(*), IPARTR(*), IPARTUR(*), IPARTTG(*), IPARTX(*),
657 . IAD_ELEM(2,NSPMD+1) ,FR_ELEM(*),
658 . NPBY(NNPBY,*), LPBY(*), KINET(*), TAGSLV_RBY_SMS(*),
659 . IPARI(NPARI,*), IRECT(4,*),
660 . LAD_SMS(*), KDI_SMS(*),
661 . IPART(LIPART1,*), IGEO(NPROPGI,*), WEIGHT(*)
662 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
663C-----------------------------------------------
664C L o c a l V a r i a b l e s
665C-----------------------------------------------
666 INTEGER I, J, K, JJ, KK, II, IJ, M, N, IERROR, KL
667 INTEGER NG, ITY, NEL, NFT, ISOLNOD,ILOC4(4),
668 . TAG8(8), IG, IGTYP
669 INTEGER MSR, NSN, KI, KJ, NSR
670 INTEGER SIZE, LENR, IAD, L, LLT
671 INTEGER NTY, ILAGM, K10, K11, K12, K13, K14, JI,
672 . N1, N2, N3, N4, LNEW, ILEV
673 INTEGER J1, IPERM1(6), IPERM2(6),IPENTA6(6)
674 INTEGER LSMSPCG
675 INTEGER IK, NK
676 INTEGER,DIMENSION(:),ALLOCATABLE :: TAGA
677 INTEGER,DIMENSION(:),ALLOCATABLE :: NAD_SMS
678 INTEGER,DIMENSION(:),ALLOCATABLE :: TAGK
679
680 DATA iloc4/1,3,6,5/
681 DATA iperm1/1,2,3,1,2,3/
682 DATA iperm2/2,3,1,4,4,4/
683 DATA ipenta6/1,2,3,5,6,7/
684C-----------------------------------------------
685 CALL my_alloc(taga,numnod)
686 CALL my_alloc(nad_sms,numnod)
687 CALL my_alloc(tagk,numnod)
688C-----------------------------------------------
689C
690C Construit JDI_SMS, JADS_SMS, etc
691C -----------------
692 DO i=1,numnod
693 nad_sms(i)=kad_sms(i)
694 END DO
695C
696 250 CONTINUE
697#include "lockon.inc"
698 IF(nsgdone>ngroup) THEN
699#include "lockoff.inc"
700 GOTO 252
701 ENDIF
702 ng=nsgdone
703 nsgdone = ng + 1
704#include "lockoff.inc"
705C
706 IF(tagrel_sms(ng)==0)GOTO 250
707 ity =iparg(5,ng)
708 IF (iddw>0) CALL startimeg(ng)
709
710 nel = iparg(2,ng)
711 nft = iparg(3,ng)
712 isolnod = iparg(28,ng)
713 IF(ity==1.AND.isolnod==4)THEN
714 DO j=nft+1,nft+nel
715
716 DO k=1,4
717 i=ixs(1+iloc4(k),j)
718 jads_sms(k,j)=nad_sms(i)
719
720 ij=jads_sms(k,j)
721 DO kk=1,4
722 jj = ixs(1+iloc4(kk),j)
723 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
724 nad_sms(i)=nad_sms(i)+1
725 kdi_sms(ij)=jj
726 ij=ij+1
727 END IF
728 END DO
729 END DO
730 END DO
731 ELSEIF(ity==1.AND.isolnod==6)THEN
732 DO j=nft+1,nft+nel
733
734 DO k=1,6
735 i=ixs(1+ipenta6(k),j)
736 jads_sms(k,j)=nad_sms(i)
737
738 ij=jads_sms(k,j)
739 DO kk=1,6
740 jj = ixs(1+ipenta6(kk),j)
741 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
742 nad_sms(i)=nad_sms(i)+1
743 kdi_sms(ij)=jj
744 ij=ij+1
745 END IF
746 END DO
747 END DO
748 END DO
749 ELSEIF(ity==1.AND.isolnod==8)THEN
750 DO j=nft+1,nft+nel
751
752 DO k=1,8
753 i=ixs(1+k,j)
754 taga(i)=0
755 tag8(k)=0
756 END DO
757
758 DO k=1,8
759 i=ixs(1+k,j)
760 IF(taga(i)/=0)THEN
761 tag8(k)=1
762 ELSE
763 taga(i)=1
764 END IF
765 END DO
766
767 DO k=1,8
768 i=ixs(1+k,j)
769 jads_sms(k,j)=nad_sms(i)
770 END DO
771
772 DO k=1,8
773
774 i=ixs(1+k,j)
775 IF(tag8(k)/=0)cycle
776
777 ij=jads_sms(k,j)
778 DO kk=1,8
779 jj = ixs(1+kk,j)
780 IF(tag8(kk)/=0) cycle
781
782 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
783 nad_sms(i)=nad_sms(i)+1
784 kdi_sms(ij)=jj
785 ij=ij+1
786 END IF
787 END DO
788
789 END DO
790
791 END DO
792 ELSEIF(ity==1.AND.isolnod==10)THEN
793 DO j=nft+1,nft+nel
794 j1=j-numels8
795
796 DO k=1,4
797
798 i=ixs(1+iloc4(k),j)
799 jads_sms(k,j)=nad_sms(i)
800
801 ij=jads_sms(k,j)
802 DO kk=1,4
803 jj = ixs(1+iloc4(kk),j)
804 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
805 nad_sms(i)=nad_sms(i)+1
806 kdi_sms(ij)=jj
807 ij=ij+1
808 END IF
809 END DO
810
811 DO kk=1,6
812 jj=ixs10(kk,j1)
813 IF(jj==0) cycle
814
815 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
816 nad_sms(i)=nad_sms(i)+1
817 kdi_sms(ij)=jj
818 ij=ij+1
819 END IF
820 END DO
821
822 END DO
823
824
825 DO k=1,6
826
827 i=ixs10(k,j1)
828 IF(i==0) cycle
829
830 jads10_sms(k,j1)=nad_sms(i)
831
832 ij=jads10_sms(k,j1)
833 DO kk=1,4
834 jj = ixs(1+iloc4(kk),j)
835 IF(.NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
836 nad_sms(i)=nad_sms(i)+1
837 kdi_sms(ij)=jj
838 ij=ij+1
839 END IF
840 END DO
841
842 DO kk=1,6
843 jj=ixs10(kk,j1)
844 IF(jj==0) cycle
845
846 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
847 nad_sms(i)=nad_sms(i)+1
848 kdi_sms(ij)=jj
849 ij=ij+1
850 END IF
851 END DO
852
853 END DO
854
855 END DO
856 ELSEIF(ity==3)THEN
857 DO j=nft+1,nft+nel
858
859 DO k=1,4
860 i=ixc(1+k,j)
861 jadc_sms(k,j)=nad_sms(i)
862
863 ij=jadc_sms(k,j)
864 DO kk=1,4
865 jj = ixc(1+kk,j)
866 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
867 nad_sms(i)=nad_sms(i)+1
868 kdi_sms(ij)=jj
869 ij=ij+1
870 END IF
871 END DO
872 END DO
873 END DO
874 ELSEIF(ity==4)THEN
875 DO j=nft+1,nft+nel
876
877 DO k=1,2
878 i=ixt(1+k,j)
879 jadt_sms(k,j)=nad_sms(i)
880
881 ij=jadt_sms(k,j)
882 DO kk=1,2
883 jj = ixt(1+kk,j)
884 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
885 nad_sms(i)=nad_sms(i)+1
886 kdi_sms(ij)=jj
887 ij=ij+1
888 END IF
889 END DO
890 END DO
891 END DO
892 ELSEIF(ity==5)THEN
893 DO j=nft+1,nft+nel
894
895 DO k=1,2
896 i=ixp(1+k,j)
897 jadp_sms(k,j)=nad_sms(i)
898
899 ij=jadp_sms(k,j)
900 DO kk=1,2
901 jj = ixp(1+kk,j)
902 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
903 nad_sms(i)=nad_sms(i)+1
904 kdi_sms(ij)=jj
905 ij=ij+1
906 END IF
907 END DO
908 END DO
909 END DO
910 ELSEIF(ity==6)THEN
911 ig = ipart(2,ipartr(nft+1))
912 igtyp = igeo(11,ig)
913 IF(igtyp/=12)THEN
914 DO j=nft+1,nft+nel
915
916 DO k=1,2
917 i=ixr(1+k,j)
918 jadr_sms(k,j)=nad_sms(i)
919
920 ij=jadr_sms(k,j)
921 DO kk=1,2
922 jj = ixr(1+kk,j)
923 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
924 nad_sms(i)=nad_sms(i)+1
925 kdi_sms(ij)=jj
926 ij=ij+1
927 END IF
928 END DO
929 END DO
930 END DO
931 ELSE
932 DO j=nft+1,nft+nel
933 k=1
934 i=ixr(1+k,j)
935 jadr_sms(k,j)=nad_sms(i)
936
937 ij=jadr_sms(k,j)
938 kk=2
939 jj = ixr(1+kk,j)
940 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
941 nad_sms(i)=nad_sms(i)+1
942 kdi_sms(ij)=jj
943 ij=ij+1
944 END IF
945
946 k=2
947 i=ixr(1+k,j)
948 jadr_sms(k,j)=nad_sms(i)
949
950 ij=jadr_sms(k,j)
951 kk=1
952 jj = ixr(1+kk,j)
953 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
954 nad_sms(i)=nad_sms(i)+1
955 kdi_sms(ij)=jj
956 ij=ij+1
957 END IF
958
959 kk=3
960 jj = ixr(1+kk,j)
961 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
962 nad_sms(i)=nad_sms(i)+1
963 kdi_sms(ij)=jj
964 ij=ij+1
965 END IF
966
967 k=3
968 i=ixr(1+k,j)
969 jadr_sms(k,j)=nad_sms(i)
970
971 ij=jadr_sms(k,j)
972 kk=2
973 jj = ixr(1+kk,j)
974 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
975 nad_sms(i)=nad_sms(i)+1
976 kdi_sms(ij)=jj
977 ij=ij+1
978 END IF
979 END DO
980 END IF
981 ELSEIF(ity==7)THEN
982 DO j=nft+1,nft+nel
983
984 DO k=1,3
985 i=ixtg(1+k,j)
986 jadtg_sms(k,j)=nad_sms(i)
987
988 ij=jadtg_sms(k,j)
989 DO kk=1,3
990 jj = ixtg(1+kk,j)
991 IF(jj/=i.AND..NOT.(nativ_sms(i)==0.AND.nativ_sms(jj)==0))THEN
992 nad_sms(i)=nad_sms(i)+1
993 kdi_sms(ij)=jj
994 ij=ij+1
995 END IF
996 END DO
997 END DO
998 END DO
999 END IF
1000 IF (iddw>0) CALL stoptimeg(ng)
1001 GOTO 250
1002 252 CONTINUE
1003C-------------------------------------------------------------------------
1004C PREPARE KOMPACTION OF ELEMENTARY MATRIX
1005C NODNX_SMS(I) devient le nb de nds connectes a I
1006C-------------------------------------------------------------------------
1007 tagk(1:numnod)=0
1008 DO i=1,numnod
1009 nodnx_sms(i)=0
1010 DO kj=kad_sms(i),kad_sms(i+1)-1
1011 ik =kdi_sms(kj)
1012 IF(tagk(ik)==0)THEN
1013 nodnx_sms(i)=nodnx_sms(i)+1
1014 tagk(ik)=1
1015 END IF
1016 END DO
1017 DO kj=kad_sms(i),kad_sms(i+1)-1
1018 ik =kdi_sms(kj)
1019 tagk(ik)=0
1020 END DO
1021 END DO
1022C
1023 iad_sms(1)=1
1024 DO i=1,numnod
1025 iad_sms(i+1)=iad_sms(i)+nodnx_sms(i)
1026 lad_sms(i) =nodnx_sms(i)
1027 END DO
1028C
1029 nnz_sms = iad_sms(numnod+1)
1030C
1031 DEALLOCATE(taga)
1032 DEALLOCATE(nad_sms)
1033 DEALLOCATE(tagk)
1034 RETURN
startimeg
subroutine startimeg(ng)
Definition timer.F:1487
stoptimeg
subroutine stoptimeg(ng)
Definition timer.F:1535

◆ sms_ini_kin_1()

subroutine sms_ini_kin_1 ( integer, dimension(*) nodnx_sms,
integer, dimension(*) indx1_sms,
integer, dimension(*) ilink,
integer, dimension(*) rlink,
integer, dimension(10,*) nnlink,
integer, dimension(*) lnlink,
integer, dimension(*) tag_lnk_sms,
integer, dimension(nspmd+2,*) fr_ll,
integer, dimension(nspmd+2,*) fr_rl,
integer, dimension(*) weight,
integer, dimension(*) itab,
integer, dimension(*) ljoint,
integer, dimension(nspmd+1,*) iadcj,
integer, dimension(*) fr_cj,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(nspmd+2,*) fr_wall,
integer, dimension(*) nrwl_sms,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem,
type(intbuf_struct_), dimension(*) intbuf_tab )

Definition at line 2177 of file sms_init.F.

2183C-----------------------------------------------
2184C M o d u l e s
2185C-----------------------------------------------
2186 USE intbufdef_mod
2187 USE my_alloc_mod
2188C-----------------------------------------------
2189C I m p l i c i t T y p e s
2190C-----------------------------------------------
2191#include "implicit_f.inc"
2192C-----------------------------------------------
2193C C o m m o n B l o c k s
2194C-----------------------------------------------
2195#include "com01_c.inc"
2196#include "com04_c.inc"
2197#include "scr03_c.inc"
2198#include "sms_c.inc"
2199#include "task_c.inc"
2200C-----------------------------------------------
2201C D u m m y A r g u m e n t s
2202C-----------------------------------------------
2203 INTEGER
2204 . NODNX_SMS(*), INDX1_SMS(*),
2205 . ILINK(*), RLINK(*), NNLINK(10,*), LNLINK(*),
2206 . TAG_LNK_SMS(*), FR_LL(NSPMD+2,*), FR_RL(NSPMD+2,*),
2207 . WEIGHT(*), ITAB(*), LJOINT(*), FR_CJ(*),IADCJ(NSPMD+1,*)
2208 INTEGER NPRW(*), LPRW(*), FR_WALL(NSPMD+2,*) ,NRWL_SMS(*),
2209 . IAD_ELEM(2,*), FR_ELEM(*)
2210 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
2211C REAL
2212C-----------------------------------------------
2213C L o c a l V a r i a b l e s
2214C-----------------------------------------------
2215 INTEGER K1, K, I, N, J, IC, NSN, ISMS,
2216 . ICSIZE, IMOV, ITYP, ILAGM, ICOUNT
2217 INTEGER NTY, ILEV, NMN, NRTS, NRTM,
2218 . NLINS, NLINM, II, SIZE, LENR
2219 my_real
2220 . idmax,id
2221 INTEGER,DIMENSION(:),ALLOCATABLE :: NOD2ADD
2222 INTEGER,DIMENSION(:),ALLOCATABLE :: TAG
2223C-----------------------------------------------
2224 CALL my_alloc(nod2add,numnod)
2225 CALL my_alloc(tag,numnod)
2226C-----------------------------------------------
2227C
2228 nod2add(1:numnod)=0
2229C
2230 IF(nrlink/=0)THEN
2231 k = 1
2232 DO i=1,nrlink
2233
2234 k1=4*i-3
2235 ic=ilink(k1+1)
2236 IF(ic==0) cycle
2237 nsn = ilink(k1)
2238
2239
2240 idmax=0
2241 DO j=1,nsn
2242 n=rlink(k+j-1)
2243 IF(weight(n)==1)THEN
2244 id=itab(n)
2245 idmax=max(idmax,id)
2246 END IF
2247 END DO
2248
2249 IF(nspmd > 1) THEN
2250 CALL spmd_glob_imax9(idmax,1)
2251 CALL spmd_ibcast(idmax,idmax,1,1,0,2)
2252 END IF
2253
2254 tag_lnk_sms(i)=-idmax
2255
2256 isms=0
2257 DO j=1,nsn
2258 n=rlink(k+j-1)
2259 IF(nodnx_sms(n)/=0)THEN
2260 isms=1
2261 EXIT
2262 END IF
2263 END DO
2264
2265 IF(nspmd > 1) CALL spmd_allglob_isum9(isms,1)
2266
2267 IF(isms/=0) tag_lnk_sms(i) = abs(tag_lnk_sms(i))
2268
2269 IF(isms/=0)THEN
2270C
2271C propagate AMS to all nodes of the rlink
2272 DO j=1,nsn
2273 n=rlink(k+j-1)
2274 IF(nodnx_sms(n)==0.AND.nod2add(n)==0)THEN
2275 nindx1_sms=nindx1_sms+1
2276 indx1_sms(nindx1_sms)=n
2277 nod2add(n)=1
2278 END IF
2279 END DO
2280C
2281 END IF
2282 k = k + nsn
2283 END DO
2284 END IF
2285C-----------------------------------------------
2286 IF(nlink/=0)THEN
2287 k = 1
2288 DO i=1,nlink
2289 ic=nnlink(3,i)
2290 IF(ic==0) cycle
2291 nsn = nnlink(1,i)
2292
2293
2294 idmax=zero
2295 DO j=1,nsn
2296 n=lnlink(k+j-1)
2297 IF(weight(n)==1)THEN
2298 id=itab(n)
2299 idmax=max(idmax,id)
2300 END IF
2301 END DO
2302
2303 IF(nspmd > 1) THEN
2304 CALL spmd_glob_imax9(idmax,1)
2305 CALL spmd_ibcast(idmax,idmax,1,1,0,2)
2306 END IF
2307
2308 tag_lnk_sms(nrlink+i)=-idmax
2309
2310 isms=0
2311 DO j=1,nsn
2312 n=lnlink(k+j-1)
2313 IF(nodnx_sms(n)/=0)THEN
2314 isms=1
2315 EXIT
2316 END IF
2317 END DO
2318
2319 IF(nspmd > 1) CALL spmd_allglob_isum9(isms,1)
2320
2321 IF(isms/=0) tag_lnk_sms(nrlink+i) = abs(tag_lnk_sms(nrlink+i))
2322
2323 IF(isms/=0)THEN
2324C
2325C propagate AMS to all nodes of the rlink
2326 DO j=1,nsn
2327 n=lnlink(k+j-1)
2328 IF(nodnx_sms(n)==0.AND.nod2add(n)==0)THEN
2329 nindx1_sms=nindx1_sms+1
2330 indx1_sms(nindx1_sms)=n
2331 nod2add(n)=1
2332 END IF
2333 END DO
2334C
2335 END IF
2336 k = k + nsn
2337 END DO
2338 END IF
2339C-----------------------------------------------
2340 IF(njoint/=0)THEN
2341 IF(ispmd==0)THEN
2342 k=1
2343 DO j=1,njoint
2344 nsn=ljoint(k)
2345 isms=0
2346 DO i=1,nsn
2347 n=ljoint(k+i)
2348 IF(nodnx_sms(n)/=0)THEN
2349 isms=1
2350 EXIT
2351 END IF
2352 END DO
2353
2354 tag_lnk_sms(nrlink+nlink+j)=isms
2355
2356 k=k+nsn+1
2357 END DO
2358 END IF
2359
2360 IF(nspmd > 1)
2361 . CALL spmd_ibcast(tag_lnk_sms(nrlink+nlink+1),
2362 . tag_lnk_sms(nrlink+nlink+1),njoint,1,0,2)
2363
2364 IF(nspmd==1)THEN
2365 k=1
2366 DO j=1,njoint
2367 isms=tag_lnk_sms(nrlink+nlink+j)
2368 IF(isms/=0)THEN
2369 nsn=ljoint(k)
2370 DO i=1,nsn
2371 n=ljoint(k+i)
2372 IF(nodnx_sms(n)==0.AND.nod2add(n)==0)THEN
2373 nindx1_sms=nindx1_sms+1
2374 indx1_sms(nindx1_sms)=n
2375 nod2add(n)=1
2376 END IF
2377 END DO
2378 END IF
2379 k=k+nsn+1
2380 END DO
2381 ELSE
2382 IF(ispmd==0)THEN
2383 k=1
2384 DO j=1,njoint
2385 isms=tag_lnk_sms(nrlink+nlink+j)
2386 IF(isms/=0)THEN
2387 nsn=ljoint(k)
2388 DO i=1,nsn
2389 n=ljoint(k+i)
2390 IF(nodnx_sms(n)==0.AND.nod2add(n)==0)THEN
2391 nindx1_sms=nindx1_sms+1
2392 indx1_sms(nindx1_sms)=n
2393 nod2add(n)=1
2394 END IF
2395 END DO
2396 END IF
2397 k=k+nsn+1
2398 END DO
2399 END IF
2400 icsize=0
2401 DO n=1,njoint
2402 IF(tag_lnk_sms(nrlink+nlink+n)/=0)
2403 . icsize=icsize+iadcj(nspmd+1,n)-iadcj(1,n)
2404 END DO
2405 CALL spmd_sd_cj_2(nod2add,ljoint,fr_cj,iadcj,icsize,
2406 . tag_lnk_sms(nrlink+nlink+1),nodnx_sms,
2407 . indx1_sms)
2408 END IF
2409 END IF
2410C-----------------------------------------------
2411 DO n=1,numnod
2412 IF(nod2add(n)/=0)nodnx_sms(n)=1
2413 END DO
2414C-----------------------------------------------
2415C liste des noeuds sms du mur dans NRWL_SMS (memoire non optimisee).
2416 IF(nrwall/=0)THEN
2417 k = 1
2418 DO n=1,nrwall
2419 nsn=nprw(n)
2420 icount =k
2421 imov =nprw(2*nrwall+n)
2422 ityp =nprw(3*nrwall+n)
2423 ilagm=nprw(5*nrwall+n)
2424 IF(ilagm==0)THEN
2425 DO j=1,nsn
2426 i=lprw(k+j-1)
2427 IF(nodnx_sms(i)/=0)THEN
2428 nrwl_sms(icount)=j
2429 icount=icount+1
2430 END IF
2431 END DO
2432 END IF
2433C nb de noeuds sms dans le mur.
2434 nprw(6*nrwall+n)=icount-k
2435C for sms_fixvel, etc
2436 IF(imov /= 0)THEN
2437 nod2add(imov)=0
2438 IF(icount > k.AND.nodnx_sms(imov)==0)nod2add(imov)=1
2439 IF(nspmd > 1)
2440 . CALL spmd_frwall_nn(fr_wall(1,n),nod2add(imov))
2441 IF(nod2add(imov)/=0)THEN
2442 nindx1_sms=nindx1_sms+1
2443 indx1_sms(nindx1_sms)=imov
2444 END IF
2445 END IF
2446 k =k+nsn
2447 END DO
2448 END IF
2449C-----------------------------------------------
2450 DEALLOCATE(nod2add)
2451 DEALLOCATE(tag)
2452C-----------------------------------------------
2453 RETURN
max
#define max(a, b)
Definition macros.h:21
id
initmumps id
Definition multiplerhs_example.m:4
spmd_frwall_nn
subroutine spmd_frwall_nn(fr_wall, iwadd)
Definition spmd_frwall_nn.F:34
spmd_glob_imax9
subroutine spmd_glob_imax9(v, len)
Definition spmd_glob_imax9.F:36
spmd_ibcast
subroutine spmd_ibcast(tabi, tabr, n1, n2, from, add)
Definition spmd_ibcast.F:57
spmd_sd_cj_2
subroutine spmd_sd_cj_2(nod2add, ljoint, fr_cj, iadcj, icsize, tag_lnk_sms, nodnx_sms, indx1_sms)
Definition spmd_sd_cj_2.F:35

◆ sms_ini_kin_2()

subroutine sms_ini_kin_2 ( integer, dimension(*) ilink,
integer, dimension(*) rlink,
integer, dimension(10,*) nnlink,
integer, dimension(*) lnlink,
integer, dimension(*) tag_lnk_sms,
integer, dimension(nspmd+2,*) fr_ll,
integer, dimension(nspmd+2,*) fr_rl,
integer, dimension(*) weight,
integer, dimension(*) itab,
integer, dimension(*) ljoint,
integer, dimension(nspmd+1,*) iadcj,
integer, dimension(*) fr_cj,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(nspmd+2,*) fr_wall,
integer, dimension(*) nrwl_sms,
integer, dimension(2,*) iad_elem,
integer, dimension(*) fr_elem )

Definition at line 2463 of file sms_init.F.

2468C-----------------------------------------------
2469C I m p l i c i t T y p e s
2470C-----------------------------------------------
2471#include "implicit_f.inc"
2472C-----------------------------------------------
2473C C o m m o n B l o c k s
2474C-----------------------------------------------
2475#include "com01_c.inc"
2476#include "com04_c.inc"
2477#include "scr03_c.inc"
2478C-----------------------------------------------
2479C D u m m y A r g u m e n t s
2480C-----------------------------------------------
2481 INTEGER
2482 . ILINK(*), RLINK(*), NNLINK(10,*), LNLINK(*),
2483 . TAG_LNK_SMS(*), FR_LL(NSPMD+2,*), FR_RL(NSPMD+2,*),
2484 . WEIGHT(*), ITAB(*), LJOINT(*), FR_CJ(*),IADCJ(NSPMD+1,*)
2485 INTEGER NPRW(*), LPRW(*), FR_WALL(NSPMD+2,*) ,NRWL_SMS(*),
2486 . IAD_ELEM(2,*), FR_ELEM(*)
2487C REAL
2488C-----------------------------------------------
2489C L o c a l V a r i a b l e s
2490C-----------------------------------------------
2491 INTEGER K1, K, I, N, J, IC, NSN
2492 my_real
2493 . idmax,id
2494C-----------------------------------------------
2495 IF(nrlink/=0)THEN
2496 k = 1
2497 DO i=1,nrlink
2498
2499 k1=4*i-3
2500 ic=ilink(k1+1)
2501 IF(ic==0) cycle
2502 nsn = ilink(k1)
2503
2504 idmax=0
2505 DO j=1,nsn
2506 n=rlink(k+j-1)
2507 IF(weight(n)==1)THEN
2508 id=itab(n)
2509 idmax=max(idmax,id)
2510 END IF
2511 END DO
2512
2513 IF(nspmd > 1) THEN
2514 CALL spmd_glob_imax9(idmax,1)
2515 CALL spmd_ibcast(idmax,idmax,1,1,0,2)
2516 END IF
2517
2518 tag_lnk_sms(i)=-idmax
2519
2520 k = k + nsn
2521 END DO
2522 END IF
2523C-----------------------------------------------
2524 IF(nlink/=0)THEN
2525 k = 1
2526 DO i=1,nlink
2527 ic=nnlink(3,i)
2528 IF(ic==0) cycle
2529 nsn = nnlink(1,i)
2530
2531 idmax=zero
2532 DO j=1,nsn
2533 n=lnlink(k+j-1)
2534 IF(weight(n)==1)THEN
2535 id=itab(n)
2536 idmax=max(idmax,id)
2537 END IF
2538 END DO
2539
2540 IF(nspmd > 1) THEN
2541 CALL spmd_glob_imax9(idmax,1)
2542 CALL spmd_ibcast(idmax,idmax,1,1,0,2)
2543 END IF
2544
2545 tag_lnk_sms(nrlink+i)=-idmax
2546
2547 k = k + nsn
2548 END DO
2549 END IF
2550C-----------------------------------------------
2551 RETURN

◆ sms_ini_part()

subroutine sms_ini_part ( type (group_), dimension(ngrpart) igrpart,
integer, dimension(*) tagprt_sms )

Definition at line 34 of file sms_init.F.

35C-----------------------------------------------
36C M o d u l e s
37C-----------------------------------------------
38 USE message_mod
39 USE groupdef_mod
40C-----------------------------------------------
41C I m p l i c i t T y p e s
42C-----------------------------------------------
43#include "implicit_f.inc"
44C-----------------------------------------------
45C C o m m o n B l o c k s
46C-----------------------------------------------
47#include "com04_c.inc"
48#include "sms_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER
53 . TAGPRT_SMS(*)
54C-----------------------------------------------
55 TYPE (GROUP_) , DIMENSION(NGRPART) :: IGRPART
56C-----------------------------------------------
57C L o c a l V a r i a b l e s
58C-----------------------------------------------
59 INTEGER I,IP,IAD,N
60C-----------------------------------------------
61C
62 IF(idtgrs==0)THEN
63 DO ip=1,npart
64 tagprt_sms(ip)=1
65 END DO
66 ELSE
67 DO ip=1,npart
68 tagprt_sms(ip)=0
69 END DO
70 IF(idtgrs < 0)THEN
71 DO n=1,ngrpart
72 IF (igrpart(n)%ID==-idtgrs) THEN
73 idtgrs=n
74 GO TO 120
75 END IF
76 END DO
77 100 CONTINUE
78 CALL ancmsg(msgid=21,anmode=aninfo_blind,
79 . i1=-idtgrs)
80 CALL arret(2)
81 120 CONTINUE
82 END IF
83!
84 DO i=1,igrpart(idtgrs)%NENTITY
85 ip=igrpart(idtgrs)%ENTITY(i)
86 tagprt_sms(ip)=1
87 END DO
88 END IF
89C
90C-----------------------------------------------
91 RETURN
groupdef_mod
Definition groupdef_mod.F:662

◆ sms_ini_rby()

subroutine sms_ini_rby ( integer, dimension(*) kinet,
integer, dimension(*) nprw,
integer, dimension(*) lprw,
integer, dimension(nnpby,*) npby,
integer, dimension(*) lpby,
integer, dimension(*) tagmsr_rby_sms,
integer, dimension(*) tagslv_rby_sms )

Definition at line 100 of file sms_init.F.

103C-----------------------------------------------
104C M o d u l e s
105C-----------------------------------------------
106 USE message_mod
107C-----------------------------------------------
108C I m p l i c i t T y p e s
109C-----------------------------------------------
110#include "implicit_f.inc"
111C-----------------------------------------------
112C C o m m o n B l o c k s
113C-----------------------------------------------
114#include "com04_c.inc"
115#include "kincod_c.inc"
116#include "param_c.inc"
117C-----------------------------------------------
118C D u m m y A r g u m e n t s
119C-----------------------------------------------
120 INTEGER
121 . KINET(*),NPRW(*), LPRW(*),NPBY(NNPBY,*), LPBY(*),
122 . TAGMSR_RBY_SMS(*), TAGSLV_RBY_SMS(*)
123C-----------------------------------------------
124C L o c a l V a r i a b l e s
125C-----------------------------------------------
126 INTEGER I, J, K, NG, N, JJ, KK, ITY, NEL, NFT, ISOLNOD,
127 . IAD, IP, ILOC4(4)
128 INTEGER SIZE, LENR, ISMS, NM, NS, IMOV, NSN, ILAGM,
129 . N2, N3, N4, N5, N6
130 INTEGER M, MSR, NSNW, KI, NHI, NSMS(2)
131 INTEGER J1, IPERM1(6), IPERM2(6)
132 DATA iloc4/1,3,6,5/
133 DATA iperm1/1,2,3,1,2,3/
134 DATA iperm2/2,3,1,4,4,4/
135C
136C-----------------------------------------------
137C rbodies : numbering
138C------------
139 tagmsr_rby_sms(1:numnod) =0
140 tagslv_rby_sms(1:numnod) =0
141C
142 iad=0
143 isms=0
144 DO m=1,nrbody
145C
146 msr=npby(1,m)
147 nsn=npby(2,m)
148 IF(msr >= 0) THEN
149C if msr secnd of lagrange wall => no ams
150 isms=0
151 k = 1
152 DO n=1,nrwall
153 n2=n +nrwall
154 n3=n2+nrwall
155 n4=n3+nrwall
156 n5=n4+nrwall
157 n6=n5+nrwall
158 nsnw =nprw(n)
159 imov =nprw(n3)
160 ity =nprw(n4)
161 ilagm=nprw(n6)
162 IF(ilagm/=0)THEN
163 DO j=1,nsnw
164 i=lprw(k+j-1)
165 IF(i==msr)THEN
166 isms=1
167 GOTO 100
168 END IF
169 END DO
170 END IF
171 k =k+nsn
172 END DO
173 100 CONTINUE
174 IF(isms==0.AND.npby(7,m)>0 .AND.
175 . (kinet(msr) <=1
176 . .OR. ivf(kinet(msr)) ==1
177 . .OR. irlk(kinet(msr))==1
178 . .OR. ijo(kinet(msr)) ==1
179 . .OR. iwl(kinet(msr)) ==1 )) THEN
180C
181 tagmsr_rby_sms(msr)=m
182 DO ki=1,nsn
183 i=lpby(iad+ki)
184 tagslv_rby_sms(i)=m
185 END DO
186C
187 END IF
188 END IF
189 iad = iad + nsn
190 END DO
191
192C-----------------------------------------------
193 RETURN