OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
i25slid.F File Reference
#include "implicit_f.inc"
#include "assert.inc"
#include "com01_c.inc"
#include "comlock.inc"
#include "com04_c.inc"
#include "task_c.inc"
#include "sms_c.inc"
#include "vectorize.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine i25prep_add (nin, ni25, nsn, nsnr, itab, nadmsr, admsr, iad_frnor, fr_nor, nadd, kadd, islide)
subroutine i25prep_slid_1 (jlt, cand_n, cand_e, nin, nsn, nsnr, inacti, mseglo, irtlm, time_s, itab, farm, penm, irect, nadmsr, admsr, lbm, lcm, islide, nsv)
subroutine i25prep_slid_2 (cand_n, cand_e, nin, ni25, nsn, nsnr, nrtm, sizopt, k_stok, mseglo, msegtyp, i_stok_opt, itab, irect, nadmsr, admsr, islide, nsv, knor2msr, nor2msr, irtlm, stfm, flagremn, kremnor, remnor)
subroutine i25keepf (i_stok, index, cand_n, cand_e, nin, nsn, nsnr, inacti, mseglo, irtlm, penm, pene_old, jtask, itab, nsv, secnd_fr, time_s, stif_old)
subroutine i25prep_nindex (nin, ni25, nsn, nsnr, itab, nsv, iad_frnor, fr_nor, nadd, kadd, sizbufs, nsendtot)
subroutine i25prep_sizbufs (nin, ni25, nsn, nsnr, ityp, ifq, inacti, igap, intth, ilev, itab, nsv, iad_frnor, fr_nor, nadd, kadd, rsiz, isiz, sizbufs, fr_slide, index, intfric, ivis2, istif_msdt, ifsub_carea)
subroutine i25prep_send (nin, ni25, nsn, nsnr, ityp, ifq, inacti, igap, intth, ilev, itab, iad_frnor, fr_nor, lens, nadd, kadd, kinet, nodnx_sms, x, v, ms, temp, intbuf_tab, rbuf, ibuf, rsiz, isiz, sizbufs, fr_slide, index, main_proc, intfric, ivis2, icodt, iskew, istif_msdt, ifsub_carea, intarean)

Function/Subroutine Documentation

◆ i25keepf()

subroutine i25keepf ( integer i_stok,
integer, dimension(*) index,
integer, dimension(*) cand_n,
integer, dimension(*) cand_e,
integer nin,
integer nsn,
integer nsnr,
integer inacti,
integer, dimension(*) mseglo,
integer, dimension(4,nsn) irtlm,
penm,
pene_old,
integer jtask,
integer, dimension(*) itab,
integer, dimension(*) nsv,
secnd_fr,
time_s,
stif_old )

Definition at line 623 of file i25slid.F.

628C-----------------------------------------------
629C M o d u l e s
630C-----------------------------------------------
631 USE tri7box
632C-----------------------------------------------
633C I m p l i c i t T y p e s
634C-----------------------------------------------
635#include "implicit_f.inc"
636C-----------------------------------------------
637C G l o b a l P a r a m e t e r s
638C-----------------------------------------------
639#include "task_c.inc"
640#include "comlock.inc"
641C-----------------------------------------------
642C D u m m y A r g u m e n t s
643C-----------------------------------------------
644 INTEGER I_STOK, NIN, NSN, NSNR, INACTI, INDEX(*),
645 . CAND_N(*),CAND_E(*), JTASK, ITAB(*), NSV(*)
646 INTEGER MSEGLO(*), IRTLM(4,NSN)
647 my_real
648 . penm(4,*), pene_old(5,*), secnd_fr(6,*), time_s(2,*), stif_old(2,*)
649C-----------------------------------------------
650C L o c a l V a r i a b l e s
651C-----------------------------------------------
652 INTEGER I, J, K, L, N, IKEEP
653C--------------------------------------------------------
654C Ne garder que les couples candidats rellement impacts
655C--------------------------------------------------------
656 DO i=1,i_stok
657 j=index(i)
658 n =cand_n(j)
659 l =cand_e(j)
660 ikeep = 0
661 IF(n<=nsn)THEN
662c if(itab(nsv(n))==31774)
663c . print *,'keepf natif',ispmd+1,itab(nsv(n)),IRTLM(1,N),
664c . mseglo(l),PENM(1,J)+PENM(2,J)+PENM(3,J)+PENM(4,J)
665 IF(iabs(irtlm(1,n))==mseglo(l))THEN
666 IF(penm(1,j)+penm(2,j)+penm(3,j)+penm(4,j)/=zero)THEN
667 ikeep=1
668c print *,'keepf natif',itab(nsv(n)),mseglo(l),PENM(1,J)+PENM(2,J)+PENM(3,J)+PENM(4,J)
669 ELSE
670C
671C attention si ici <=> pb parith/on
672 print *,'i25keepf native - internal problem',itab(nsv(n)),irtlm(1,n),ispmd+1,time_s(1,n),
673 . penm(1,j),penm(2,j),penm(3,j),penm(4,j)
674 irtlm(1,n)=0
675 irtlm(2,n)=0
676 irtlm(3,n)=0
677 irtlm(4,n)=0
678 END IF
679 END IF
680 ELSE
681c if(itafi(nin)%p(n-nsn)==31774)
682c . print *,'keepf remote',ispmd+1,itafi(nin)%p(n-nsn),IRTLM_FI(NIN)%P(1,N-NSN),
683c . mseglo(l),PENM(1,J)+PENM(2,J)+PENM(3,J)+PENM(4,J)
684 IF(iabs(irtlm_fi(nin)%P(1,n-nsn))==mseglo(l))THEN
685 IF(penm(1,j)+penm(2,j)+penm(3,j)+penm(4,j)/=zero)THEN
686 ikeep=1
687 ELSE
688C
689C attention si ici <=> pb parith/on
690 print *,'i25keepf remote - internal problem',itafi(nin)%p(n-nsn),irtlm_fi(nin)%p(1,n-nsn),
691 . ispmd+1,time_sfi(nin)%p(2*(n-nsn-1)+1),
692 . penm(1,j)+penm(2,j)+penm(3,j)+penm(4,j)
693 irtlm_fi(nin)%P(1,n-nsn)=0
694 irtlm_fi(nin)%P(2,n-nsn)=0
695 irtlm_fi(nin)%P(3,n-nsn)=0
696 irtlm_fi(nin)%P(4,n-nsn)=0
697 END IF
698 END IF
699 END IF
700C
701C switch to negative value if no more kept
702 IF(ikeep == 0) cand_n(j)=-cand_n(j)
703 END DO
704C----------------------------------------------------------------------
705 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
tri7box::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
tri7box::itafi
type(int_pointer), dimension(:), allocatable itafi
Definition tri7box.F:440

◆ i25prep_add()

subroutine i25prep_add ( integer nin,
integer ni25,
integer nsn,
integer nsnr,
integer, dimension(*) itab,
integer nadmsr,
integer, dimension(4,*) admsr,
integer, dimension(ninter25,nspmd+1) iad_frnor,
integer, dimension(*) fr_nor,
integer, dimension(*) nadd,
integer, dimension(*) kadd,
integer, dimension(4,*) islide )

Definition at line 30 of file i25slid.F.

34C-----------------------------------------------
35C M o d u l e s
36C-----------------------------------------------
37 USE tri7box
38C-----------------------------------------------
39C I m p l i c i t T y p e s
40C-----------------------------------------------
41#include "implicit_f.inc"
42C-----------------------------------------------
43C C o m m o n B l o c k s
44C-----------------------------------------------
45#include "assert.inc"
46#include "com01_c.inc"
47#include "comlock.inc"
48#include "com04_c.inc"
49C-----------------------------------------------
50C D u m m y A r g u m e n t s
51C-----------------------------------------------
52 INTEGER NIN, NI25, NSN, NSNR, NADMSR,
53 . ITAB(*), ADMSR(4,*), ISLIDE(4,*)
54 INTEGER IAD_FRNOR(NINTER25,NSPMD+1), FR_NOR(*)
55 INTEGER NADD(*), KADD(*)
56C-----------------------------------------------
57C L o c a l V a r i a b l e s
58C-----------------------------------------------
59 INTEGER I, J, K, L, N, NOR
60C
61C preparer TAGFR ds le starter
62 INTEGER TAGFR(NADMSR)
63C--------------------------------------------------------
64C
65 tagfr(1:nadmsr)=0
66 DO i=iad_frnor(ni25,1),iad_frnor(ni25,nspmd+1)-1
67 nor=fr_nor(i)
68 IF(tagfr(nor)==0)THEN
69 tagfr(nor)=1
70 END IF
71 END DO
72C
73C NADD(1:NADMSR+1), KADD <=> liste sky line des noeuds secnd concerns / tous les sommets frontires
74C------
75C
76 DO n=1,nsn
77 DO j=1,4
78 nor=islide(j,n)
79 IF(nor/=0)THEN
80 IF(tagfr(nor)==1)THEN
81 nadd(nor)=nadd(nor)+1
82 END IF
83 END IF
84 END DO
85 END DO
86C
87 DO n=1,nsnr
88 DO j=1,4
89 nor=islide_fi(nin)%P(j,n)
90 IF(nor/=0)THEN
91 assert(nor > 0)
92 assert(nor <= nadmsr)
93 IF(tagfr(nor)==1)THEN
94 nadd(nor)=nadd(nor)+1
95 END IF
96 END IF
97 END DO
98 END DO
99C
100C--------------------------------------------------------
101 DO n=1,nadmsr
102 nadd(n+1)=nadd(n)+nadd(n+1)
103 END DO
104C
105 DO n=nadmsr,1,-1
106 nadd(n+1)=nadd(n)
107 END DO
108 nadd(1) = 0
109C--------------------------------------------------------
110 DO n=1,nsn
111 DO j=1,4
112 nor=islide(j,n)
113 IF(nor/=0)THEN
114 IF(tagfr(nor)==1)THEN
115 nadd(nor)=nadd(nor)+1
116 kadd(nadd(nor))=n
117 END IF
118 END IF
119 END DO
120 END DO
121C
122 DO n=1,nsnr
123 DO j=1,4
124 nor=islide_fi(nin)%P(j,n)
125 IF(nor/=0)THEN
126 IF(tagfr(nor)==1)THEN
127 nadd(nor)=nadd(nor)+1
128 kadd(nadd(nor))=nsn+n
129 END IF
130 END IF
131 END DO
132 END DO
133C
134C------
135 DO n=nadmsr,1,-1
136 nadd(n+1)=nadd(n)
137 END DO
138 nadd(1) = 0
139C
140 RETURN
tri7box::islide_fi
type(int_pointer2), dimension(:), allocatable islide_fi
Definition tri7box.F:547

◆ i25prep_nindex()

subroutine i25prep_nindex ( integer nin,
integer ni25,
integer nsn,
integer nsnr,
integer, dimension(*) itab,
integer, dimension(*) nsv,
integer, dimension(ninter25,nspmd+1) iad_frnor,
integer, dimension(*) fr_nor,
integer, dimension(*) nadd,
integer, dimension(*) kadd,
integer, dimension(nspmd) sizbufs,
integer nsendtot )

Definition at line 716 of file i25slid.F.

720C-----------------------------------------------
721C M o d u l e s
722C-----------------------------------------------
723 USE intbufdef_mod
724 USE message_mod
725 USE tri7box
726C-----------------------------------------------
727C I m p l i c i t T y p e s
728C-----------------------------------------------
729#include "implicit_f.inc"
730C-----------------------------------------------
731C G l o b a l P a r a m e t e r s
732C-----------------------------------------------
733#include "com01_c.inc"
734#include "task_c.inc"
735#include "comlock.inc"
736C-----------------------------------------------
737C D u m m y A r g u m e n t s
738C-----------------------------------------------
739 INTEGER NIN, NI25, NSN, NSNR,
740 . SIZBUFS(NSPMD),NSENDTOT
741 INTEGER ITAB(*)
742 INTEGER IAD_FRNOR(NINTER25,NSPMD+1),FR_NOR(*),
743 . NADD(*), KADD(*), IRTLM(4,NSN), NSV(*)
744C-----------------------------------------------
745C C o m m o n B l o c k s
746C-----------------------------------------------
747#include "com04_c.inc"
748C-----------------------------------------------
749C L o c a l V a r i a b l e s
750C-----------------------------------------------
751 INTEGER I, J, K, N, NOR, NOD,
752 . LOC_PROC, P, IADLEN, NS, IDEB
753 INTEGER LR, LI, RSHIFT, ISHIFT
754C INTEGER, DIMENSION(:), ALLOCATABLE :: TAGSLD
755 INTEGER :: TAGSLD(NSN+NSNR)
756C--------------------------------------------------------
757C ALLOCATE(TAGSLD(NSN+NSNR))
758C
759 nsendtot=0
760C
761 loc_proc = ispmd+1
762 tagsld(1:nsn+nsnr)=0
763
764 DO p=1,nspmd
765 sizbufs(p)=0
766 IF(p/=loc_proc)THEN
767 IF(iad_frnor(ni25,p+1)-iad_frnor(ni25,p)>0) THEN
768 DO j=iad_frnor(ni25,p),iad_frnor(ni25,p+1)-1
769 nor = fr_nor(j)
770C
771C NADD(1:NADMSR+1), KADD <=> liste sky line des noeuds secnd concerns / tous les sommets frontires
772 DO n=nadd(nor)+1, nadd(nor+1)
773 i=kadd(n)
774 IF(tagsld(i) /= p)THEN
775 sizbufs(p)=sizbufs(p)+1
776 END IF
777 tagsld(i) = p
778 END DO
779 END DO
780 END IF
781 END IF
782 nsendtot=nsendtot+sizbufs(p)
783 END DO
784C DEALLOCATE(TAGSLD)
785C------
786 RETURN
message_mod
Definition message_mod.F:1249

◆ i25prep_send()

subroutine i25prep_send ( integer nin,
integer ni25,
integer nsn,
integer nsnr,
integer ityp,
integer ifq,
integer inacti,
integer igap,
integer intth,
integer ilev,
integer, dimension(*) itab,
integer, dimension(ninter25,nspmd+1) iad_frnor,
integer, dimension(*) fr_nor,
integer lens,
integer, dimension(*) nadd,
integer, dimension(*) kadd,
integer, dimension(*) kinet,
integer, dimension(*) nodnx_sms,
x,
v,
ms,
temp,
type(intbuf_struct_) intbuf_tab,
type(real_pointer), dimension(nspmd,ninter25) rbuf,
type(int_pointer), dimension(nspmd,ninter25) ibuf,
integer rsiz,
integer isiz,
integer, dimension(nspmd) sizbufs,
integer, dimension(4,*) fr_slide,
integer, dimension(*) index,
integer, dimension(numnod) main_proc,
integer intfric,
integer ivis2,
integer, dimension(*), intent(in) icodt,
integer, dimension(*), intent(in) iskew,
integer, intent(in) istif_msdt,
integer, intent(in) ifsub_carea,
dimension(numnod), intent(in) intarean )

Definition at line 950 of file i25slid.F.

960
961C-----------------------------------------------
962C M o d u l e s
963C-----------------------------------------------
964 USE intbufdef_mod
965 USE message_mod
966 USE tri7box
967C-----------------------------------------------
968C I m p l i c i t T y p e s
969C-----------------------------------------------
970#include "implicit_f.inc"
971C-----------------------------------------------
972C G l o b a l P a r a m e t e r s
973C-----------------------------------------------
974#include "com01_c.inc"
975#include "sms_c.inc"
976#include "task_c.inc"
977#include "comlock.inc"
978C-----------------------------------------------
979C D u m m y A r g u m e n t s
980C-----------------------------------------------
981 INTEGER NIN, NI25, NSN, NSNR, ITYP, IFQ, INACTI, IGAP, INTTH, ILEV,
982 . RSIZ, ISIZ, INTFRIC, IVIS2, SIZBUFS(NSPMD)
983 INTEGER ITAB(*), INDEX(*), FR_SLIDE(4,*),
984 . KINET(*), NODNX_SMS(*)
985 INTEGER IAD_FRNOR(NINTER25,NSPMD+1),FR_NOR(*), LENS,
986 . NADD(*), KADD(*), MAIN_PROC(NUMNOD)
987 INTEGER, INTENT(IN) :: ICODT(*),ISKEW(*)
988 my_real
989 . x(3,*), v(3,*), ms(*), temp(*)
990 TYPE(INTBUF_STRUCT_) :: INTBUF_TAB
991 TYPE(real_pointer), DIMENSION(NSPMD,NINTER25) :: RBUF
992 TYPE(int_pointer) , DIMENSION(NSPMD,NINTER25) :: IBUF
993 INTEGER , INTENT(IN) :: ISTIF_MSDT, IFSUB_CAREA
994 my_real , INTENT(IN) :: intarean(numnod)
995C-----------------------------------------------
996C C o m m o n B l o c k s
997C-----------------------------------------------
998#include "com04_c.inc"
999C-----------------------------------------------
1000C L o c a l V a r i a b l e s
1001C-----------------------------------------------
1002 INTEGER I, J, K, N, NOR, NOD,
1003 . LOC_PROC, P, IADLEN, NS, II, IDEB
1004 INTEGER NSEND, LR, LI, RSHIFT, ISHIFT
1005C--------------------------------------------------------
1006
1007C
1008 loc_proc = ispmd+1
1009
1010 ideb = 0
1011 DO p=1,nspmd
1012 IF(p/=loc_proc)THEN
1013 IF(iad_frnor(ni25,p+1)-iad_frnor(ni25,p)>0) THEN
1014C
1015 nsend = sizbufs(p)
1016C
1017C Pointeurs sur la zone vs cette interface et ce processeur
1018 lr = 0
1019 li = 0
1020C
1021 DO j=1,nsend
1022 i = index(ideb+j)
1023 IF(i <= nsn)THEN
1024 nod = intbuf_tab%NSV(i)
1025 rbuf(p,ni25)%p(lr+1) = x(1,nod)
1026 rbuf(p,ni25)%p(lr+2) = x(2,nod)
1027 rbuf(p,ni25)%p(lr+3) = x(3,nod)
1028 rbuf(p,ni25)%p(lr+4) = v(1,nod)
1029 rbuf(p,ni25)%p(lr+5) = v(2,nod)
1030 rbuf(p,ni25)%p(lr+6) = v(3,nod)
1031 rbuf(p,ni25)%p(lr+7) = ms(nod)
1032 rbuf(p,ni25)%p(lr+8) = intbuf_tab%STFNS(i)
1033 ibuf(p,ni25)%p(li+1) = intbuf_tab%NSV_ON_PMAIN(i)
1034c IF(MAIN_PROC(NOD) == LOC_PROC) THEN
1035c IBUF(P,NI25)%p(LI+1) = -ITAB(NOD)
1036c ! on peut metre ici directement le numero local
1037c ELSE
1038c IBUF(P,NI25)%p(LI+1) = -ITAB(NOD)
1039c ENDIF
1040 ibuf(p,ni25)%p(li+2) = itab(nod)
1041c if(itab(nod)==6992)print *,'prep_send nat',ispmd+1,p,li,main_proc(nod)
1042 ibuf(p,ni25)%p(li+3) = main_proc(nod)
1043 ibuf(p,ni25)%p(li+4) = kinet(nod)
1044 ELSE
1045 ii = i-nsn
1046 rbuf(p,ni25)%p(lr+1) = xfi(nin)%P(1,ii)
1047 rbuf(p,ni25)%p(lr+2) = xfi(nin)%P(2,ii)
1048 rbuf(p,ni25)%p(lr+3) = xfi(nin)%P(3,ii)
1049 rbuf(p,ni25)%p(lr+4) = vfi(nin)%P(1,ii)
1050 rbuf(p,ni25)%p(lr+5) = vfi(nin)%P(2,ii)
1051 rbuf(p,ni25)%p(lr+6) = vfi(nin)%P(3,ii)
1052 rbuf(p,ni25)%p(lr+7) = msfi(nin)%P(ii)
1053 rbuf(p,ni25)%p(lr+8) = stifi(nin)%P(ii)
1054C To test search in SPMD_I25_FRONT
1055 ibuf(p,ni25)%p(li+1) = nsvfi(nin)%P(ii)
1056 ibuf(p,ni25)%p(li+2) = itafi(nin)%P(ii)
1057c if(ITAFI(NIN)%P(II) ==6992)print *,'prep_send rem',ispmd+1,p,li,PMAINFI(NIN)%P(II)
1058 ibuf(p,ni25)%p(li+3) = pmainfi(nin)%P(ii)
1059 ibuf(p,ni25)%p(li+4) = kinfi(nin)%P(ii)
1060 END IF
1061 lr = lr + rsiz
1062 li = li + isiz
1063 END DO
1064C
1065C shift for real variables (prepare for next setting)
1066 rshift = 9
1067C
1068C shift for integer variables (prepare for next setting)
1069 ishift = 8
1070C
1071C specific cases ../..
1072
1073
1074 IF(.true.) THEN
1075 li = 0
1076#include "vectorize.inc"
1077 DO j = 1, nsend
1078 i = index(ideb+j)
1079 IF(i <= nsn) THEN
1080 nod = intbuf_tab%NSV(i)
1081 ibuf(p,ni25)%p(li+ishift) = icodt(nod)
1082 ibuf(p,ni25)%p(li+ishift+1)= iskew(nod)
1083 ELSE
1084 ii = i-nsn
1085 ibuf(p,ni25)%p(li+ishift) = icodt_fi(nin)%P(ii)
1086 ibuf(p,ni25)%p(li+ishift+1)= iskew_fi(nin)%P(ii)
1087 END IF
1088 li = li + isiz
1089 END DO
1090 ishift = ishift + 2
1091 ENDIF
1092
1093 IF(igap==1 .OR. igap==2)THEN
1094 lr = 0
1095 DO j=1,nsend
1096 i = index(ideb+j)
1097 IF(i <= nsn)THEN
1098 nod = intbuf_tab%NSV(i)
1099 rbuf(p,ni25)%p(lr+rshift)= intbuf_tab%GAP_S(i)
1100 ELSE
1101 ii = i-nsn
1102 rbuf(p,ni25)%p(lr+rshift)= gapfi(nin)%P(ii)
1103 END IF
1104 lr = lr + rsiz
1105 END DO
1106 rshift = rshift + 1
1107 ELSEIF(igap==3)THEN
1108 lr = 0
1109#include "vectorize.inc"
1110 DO j = 1, nsend
1111 i = index(ideb+j)
1112 IF(i <= nsn)THEN
1113 rbuf(p,ni25)%p(lr+rshift) = intbuf_tab%GAP_S(i)
1114 rbuf(p,ni25)%p(lr+rshift+1)= intbuf_tab%GAP_SL(i)
1115 ELSE
1116 ii = i-nsn
1117 rbuf(p,ni25)%p(lr+rshift) = gapfi(nin)%P(ii)
1118 rbuf(p,ni25)%p(lr+rshift+1)= gap_lfi(nin)%P(ii)
1119 END IF
1120 lr = lr + rsiz
1121 END DO
1122 rshift = rshift + 2
1123 ENDIF
1124C
1125C thermic
1126 IF(intth>0)THEN
1127 lr = 0
1128 li = 0
1129#include "vectorize.inc"
1130 DO j = 1, nsend
1131 i = index(ideb+j)
1132 IF(i <= nsn)THEN
1133 nod = intbuf_tab%NSV(i)
1134 rbuf(p,ni25)%p(lr+rshift) = temp(nod)
1135 rbuf(p,ni25)%p(lr+rshift+1)= intbuf_tab%AREAS(i)
1136 ibuf(p,ni25)%p(li+ishift) = intbuf_tab%IELES(i)
1137 ELSE
1138 ii = i-nsn
1139 rbuf(p,ni25)%p(lr+rshift) = tempfi(nin)%P(ii)
1140 rbuf(p,ni25)%p(lr+rshift+1)= areasfi(nin)%P(ii)
1141 ibuf(p,ni25)%p(li+ishift) = matsfi(nin)%P(ii)
1142 END IF
1143 lr = lr + rsiz
1144 li = li + isiz
1145 END DO
1146 rshift = rshift + 2
1147 ishift = ishift + 1
1148 ENDIF
1149C Adhesion
1150 IF(ivis2==-1)THEN
1151 lr = 0
1152 li = 0
1153#include "vectorize.inc"
1154 DO j = 1, nsend
1155 i = index(ideb+j)
1156 IF(i <= nsn)THEN
1157 nod = intbuf_tab%NSV(i)
1158 IF(intth==0) rbuf(p,ni25)%p(lr+rshift)= intbuf_tab%AREAS(i)
1159 ibuf(p,ni25)%p(li+ishift)=intbuf_tab%IF_ADH(i)
1160 ELSE
1161 ii = i-nsn
1162 IF(intth==0) rbuf(p,ni25)%p(lr+rshift)= areasfi(nin)%P(ii)
1163 ibuf(p,ni25)%p(li+ishift)= if_adhfi(nin)%P(ii)
1164 END IF
1165 IF(intth==0) lr = lr + rsiz
1166 li = li + isiz
1167 END DO
1168 IF(intth==0) rshift = rshift + 1
1169 ishift = ishift + 1
1170 ENDIF
1171
1172C Friction
1173 IF(intfric>0)THEN
1174 li = 0
1175#include "vectorize.inc"
1176 DO j = 1, nsend
1177 i = index(ideb+j)
1178 IF(i <= nsn)THEN
1179 ibuf(p,ni25)%p(li+ishift) = intbuf_tab%IPARTFRICS(i)
1180 ELSE
1181 ii = i-nsn
1182 ibuf(p,ni25)%p(li+ishift) = ipartfricsfi(nin)%P(ii)
1183 END IF
1184 li = li + isiz
1185 END DO
1186 ishift = ishift + 1
1187 ENDIF
1188
1189 IF(istif_msdt > 0) THEN
1190 lr = 0
1191#include "vectorize.inc"
1192 DO j = 1, nsend
1193 i = index(ideb+j)
1194 IF(i <= nsn)THEN
1195 rbuf(p,ni25)%p(lr+rshift)= intbuf_tab%STIFMSDT_S(i)
1196 ELSE
1197 ii = i-nsn
1198 rbuf(p,ni25)%p(lr+rshift)= stif_msdt_fi(nin)%P(ii)
1199 END IF
1200 lr = lr + rsiz
1201 END DO
1202 rshift = rshift + 1
1203 ENDIF
1204
1205 IF(ifsub_carea > 0) THEN
1206 lr = 0
1207#include "vectorize.inc"
1208 DO j = 1, nsend
1209 i = index(ideb+j)
1210 IF(i <= nsn)THEN
1211 nod = intbuf_tab%NSV(i)
1212 rbuf(p,ni25)%p(lr+rshift)= intarean(nod)
1213 ELSE
1214 ii = i-nsn
1215 rbuf(p,ni25)%p(lr+rshift)= intareanfi(nin)%P(ii)
1216 END IF
1217 lr = lr + rsiz
1218 END DO
1219 rshift = rshift + 1
1220 ENDIF
1221
1222C
1223C -- IDTMINS==2
1224 IF(idtmins==2)THEN
1225 li = 0
1226#include "vectorize.inc"
1227 DO j = 1, nsend
1228 i = index(ideb+j)
1229 IF(i <= nsn)THEN
1230 nod = intbuf_tab%NSV(i)
1231 ibuf(p,ni25)%p(li+ishift) = nodnx_sms(nod)
1232 IF(p/=main_proc(nod)) THEN
1233 ibuf(p,ni25)%p(li+ishift+1)= ibuf(p,ni25)%p(li+1)
1234 ELSE
1235 ibuf(p,ni25)%p(li+ishift+1)= nod
1236 ENDIF
1237 ELSE
1238 ii = i-nsn
1239 ibuf(p,ni25)%p(li+ishift) = nodnxfi(nin)%P(ii)
1240 ibuf(p,ni25)%p(li+ishift+1)= nodamsfi(nin)%P(ii)
1241 END IF
1242 li = li + isiz
1243 END DO
1244 ishift = ishift + 2
1245
1246C -- IDTMINS_INT /= 0
1247 ELSEIF(idtmins_int/=0)THEN
1248 li = 0
1249#include "vectorize.inc"
1250 DO j = 1, nsend
1251 i = index(ideb+j)
1252 IF(i <= nsn)THEN
1253 nod = intbuf_tab%NSV(i)
1254 IF(p/=main_proc(nod)) THEN
1255 ibuf(p,ni25)%p(li+ishift)= ibuf(p,ni25)%p(li+1)
1256 ELSE
1257 ibuf(p,ni25)%p(li+ishift)= nod
1258 ENDIF
1259 ELSE
1260 ii = i-nsn
1261 ibuf(p,ni25)%p(li+ishift) = nodnxfi(nin)%P(ii)
1262 END IF
1263 li = li + isiz
1264 END DO
1265 ishift = ishift + 1
1266 ENDIF
1267C
1268 IF(ityp==25)THEN
1269 lr = 0
1270#include "vectorize.inc"
1271 DO j = 1, nsend
1272 i = index(ideb+j)
1273 IF(i <= nsn)THEN
1274 rbuf(p,ni25)%p(lr+rshift) =intbuf_tab%TIME_S(2*(i-1)+1)
1275 rbuf(p,ni25)%p(lr+rshift+1) =intbuf_tab%TIME_S(2*(i-1)+2)
1276 rbuf(p,ni25)%p(lr+rshift+2) =intbuf_tab%SECND_FR(6*(i-1)+4)
1277 rbuf(p,ni25)%p(lr+rshift+3) =intbuf_tab%SECND_FR(6*(i-1)+5)
1278 rbuf(p,ni25)%p(lr+rshift+4) =intbuf_tab%SECND_FR(6*(i-1)+6)
1279 rbuf(p,ni25)%p(lr+rshift+5) =intbuf_tab%PENE_OLD(5*(i-1)+2)
1280 rbuf(p,ni25)%p(lr+rshift+6) =intbuf_tab%STIF_OLD(2*(i-1)+2)
1281 rbuf(p,ni25)%p(lr+rshift+7) =intbuf_tab%PENE_OLD(5*(i-1)+3)
1282 rbuf(p,ni25)%p(lr+rshift+8) =intbuf_tab%PENE_OLD(5*(i-1)+4)
1283 rbuf(p,ni25)%p(lr+rshift+9) =intbuf_tab%PENE_OLD(5*(i-1)+5)
1284 ELSE
1285 ii = i-nsn
1286 rbuf(p,ni25)%p(lr+rshift) =time_sfi(nin)%P(2*(ii-1)+1)
1287 rbuf(p,ni25)%p(lr+rshift+1) =time_sfi(nin)%P(2*(ii-1)+2)
1288 rbuf(p,ni25)%p(lr+rshift+2) =secnd_frfi(nin)%P(4,ii)
1289 rbuf(p,ni25)%p(lr+rshift+3) =secnd_frfi(nin)%P(5,ii)
1290 rbuf(p,ni25)%p(lr+rshift+4) =secnd_frfi(nin)%P(6,ii)
1291 rbuf(p,ni25)%p(lr+rshift+5) =pene_oldfi(nin)%P(2,ii)
1292 rbuf(p,ni25)%p(lr+rshift+6) =stif_oldfi(nin)%P(2,ii)
1293 rbuf(p,ni25)%p(lr+rshift+7) =pene_oldfi(nin)%P(3,ii)
1294 rbuf(p,ni25)%p(lr+rshift+8) =pene_oldfi(nin)%P(4,ii)
1295 rbuf(p,ni25)%p(lr+rshift+9) =pene_oldfi(nin)%P(5,ii)
1296 END IF
1297 lr = lr + rsiz
1298 END DO
1299 rshift = rshift + 10
1300
1301 li = 0
1302#include "vectorize.inc"
1303 DO j = 1, nsend
1304 i = index(ideb+j)
1305 IF(i <= nsn)THEN
1306 nod = intbuf_tab%NSV(i)
1307 ibuf(p,ni25)%p(li+ishift) =intbuf_tab%IRTLM(4*(i-1)+1)
1308 ibuf(p,ni25)%p(li+ishift+1)=intbuf_tab%IRTLM(4*(i-1)+2)
1309 ibuf(p,ni25)%p(li+ishift+2)=intbuf_tab%IRTLM(4*(i-1)+3)
1310 ibuf(p,ni25)%p(li+ishift+3)=intbuf_tab%IRTLM(4*(i-1)+4)
1311 ibuf(p,ni25)%p(li+ishift+4)=intbuf_tab%ICONT_I(i)
1312 ELSE
1313 ii = i-nsn
1314 ibuf(p,ni25)%p(li+ishift) =irtlm_fi(nin)%P(1,ii)
1315 ibuf(p,ni25)%p(li+ishift+1)=irtlm_fi(nin)%P(2,ii)
1316 ibuf(p,ni25)%p(li+ishift+2)=irtlm_fi(nin)%P(3,ii)
1317 ibuf(p,ni25)%p(li+ishift+3)=irtlm_fi(nin)%P(4,ii)
1318 ibuf(p,ni25)%p(li+ishift+4)=icont_i_fi(nin)%P(ii)
1319 END IF
1320 li = li + isiz
1321 END DO
1322 ishift = ishift + 5
1323
1324 IF (ilev==2) THEN
1325C Voir avec
1326 li = 0
1327C include "vectorize.inc"
1328 DO j = 1, nsend
1329 i = index(ideb+j)
1330 IF(i <= nsn)THEN
1331c IBUF(P,NI25)%p(LI+ISHIFT)=NBINFLFI(NIN)%P(I)
1332 ELSE
1333 ibuf(p,ni25)%p(li+ishift) = 0
1334 END IF
1335 li = li + isiz
1336 END DO
1337 ishift = ishift + 1
1338 END IF
1339
1340 li = 0
1341!#include "vectorize.inc"
1342 DO j = 1, nsend
1343 i = index(ideb+j)
1344C
1345c if(i<=nsn)then
1346c if(itab(intbuf_tab%nsv(i))==6992)print *,'fr_slide nat',ispmd+1,p,FR_SLIDE(1:4,IDEB+J)
1347c else
1348c if(itafi(nin)%p(i-nsn)==6992)print *,'fr_slide rem',ispmd+1,p,FR_SLIDE(1:4,IDEB+J)
1349c end if
1350 ibuf(p,ni25)%p(li+ishift) =fr_slide(1,ideb+j)
1351 ibuf(p,ni25)%p(li+ishift+1)=fr_slide(2,ideb+j)
1352 ibuf(p,ni25)%p(li+ishift+2)=fr_slide(3,ideb+j)
1353 ibuf(p,ni25)%p(li+ishift+3)=fr_slide(4,ideb+j)
1354 li = li + isiz
1355 END DO
1356 ishift = ishift + 4
1357
1358 ENDIF ! (ITYP==25)
1359C
1360 ideb = ideb+nsend
1361C
1362 END IF ! IF(IAD_FRNOR(NI25,P+1)-IAD_FRNOR(NI25,P)>0) THEN
1363 END IF ! IF(P/=LOC_PROC)THEN
1364 END DO ! DO P=1,NSPMD
1365
1366 RETURN
tri7box::stif_oldfi
type(real_pointer2), dimension(:), allocatable stif_oldfi
Definition tri7box.F:545
tri7box::secnd_frfi
type(real_pointer2), dimension(:), allocatable secnd_frfi
Definition tri7box.F:543
tri7box::stif_msdt_fi
type(real_pointer), dimension(:), allocatable stif_msdt_fi
Definition tri7box.F:552
tri7box::iskew_fi
type(int_pointer), dimension(:), allocatable iskew_fi
Definition tri7box.F:550
tri7box::vfi
type(real_pointer2), dimension(:), allocatable vfi
Definition tri7box.F:459
tri7box::matsfi
type(int_pointer), dimension(:), allocatable matsfi
Definition tri7box.F:440
tri7box::tempfi
type(real_pointer), dimension(:), allocatable tempfi
Definition tri7box.F:449
tri7box::stifi
type(real_pointer), dimension(:), allocatable stifi
Definition tri7box.F:449
tri7box::gap_lfi
type(real_pointer), dimension(:), allocatable gap_lfi
Definition tri7box.F:449
tri7box::nodamsfi
type(int_pointer), dimension(:), allocatable nodamsfi
Definition tri7box.F:440
tri7box::pmainfi
type(int_pointer), dimension(:), allocatable pmainfi
Definition tri7box.F:435
tri7box::gapfi
type(real_pointer), dimension(:), allocatable gapfi
Definition tri7box.F:449
tri7box::nodnxfi
type(int_pointer), dimension(:), allocatable nodnxfi
Definition tri7box.F:440
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431
tri7box::intareanfi
type(real_pointer), dimension(:), allocatable intareanfi
Definition tri7box.F:554
tri7box::areasfi
type(real_pointer), dimension(:), allocatable areasfi
Definition tri7box.F:449
tri7box::icodt_fi
type(int_pointer), dimension(:), allocatable icodt_fi
Definition tri7box.F:551
tri7box::msfi
type(real_pointer), dimension(:), allocatable msfi
Definition tri7box.F:449
tri7box::ipartfricsfi
type(int_pointer), dimension(:), allocatable ipartfricsfi
Definition tri7box.F:440
tri7box::xfi
type(real_pointer2), dimension(:), allocatable xfi
Definition tri7box.F:459
tri7box::kinfi
type(int_pointer), dimension(:), allocatable kinfi
Definition tri7box.F:440
tri7box::pene_oldfi
type(real_pointer2), dimension(:), allocatable pene_oldfi
Definition tri7box.F:544
tri7box::icont_i_fi
type(int_pointer), dimension(:), allocatable icont_i_fi
Definition tri7box.F:532
tri7box::if_adhfi
type(int_pointer), dimension(:), allocatable if_adhfi
Definition tri7box.F:440

◆ i25prep_sizbufs()

subroutine i25prep_sizbufs ( integer nin,
integer ni25,
integer nsn,
integer nsnr,
integer ityp,
integer ifq,
integer inacti,
integer igap,
integer intth,
integer ilev,
integer, dimension(*) itab,
integer, dimension(*) nsv,
integer, dimension(ninter25,nspmd+1) iad_frnor,
integer, dimension(*) fr_nor,
integer, dimension(*) nadd,
integer, dimension(*) kadd,
integer rsiz,
integer isiz,
integer, dimension(nspmd) sizbufs,
integer, dimension(4,*) fr_slide,
integer, dimension(*) index,
integer intfric,
integer ivis2,
integer, intent(inout) istif_msdt,
integer, intent(inout) ifsub_carea )

Definition at line 797 of file i25slid.F.

803C-----------------------------------------------
804C M o d u l e s
805C-----------------------------------------------
806 USE intbufdef_mod
807 USE message_mod
808 USE tri7box
809C-----------------------------------------------
810C I m p l i c i t T y p e s
811C-----------------------------------------------
812#include "implicit_f.inc"
813C-----------------------------------------------
814C G l o b a l P a r a m e t e r s
815C-----------------------------------------------
816#include "com01_c.inc"
817#include "sms_c.inc"
818#include "task_c.inc"
819#include "comlock.inc"
820C-----------------------------------------------
821C D u m m y A r g u m e n t s
822C-----------------------------------------------
823 INTEGER NIN, NI25, NSN, NSNR, ITYP, IFQ, INACTI, IGAP, INTTH, ILEV,
824 . RSIZ, ISIZ, INTFRIC, IVIS2, SIZBUFS(NSPMD)
825 INTEGER ITAB(*), INDEX(*), FR_SLIDE(4,*)
826 INTEGER IAD_FRNOR(NINTER25,NSPMD+1),FR_NOR(*),
827 . NADD(*), KADD(*), IRTLM(4,NSN), NSV(*)
828 INTEGER , INTENT(INOUT) :: ISTIF_MSDT, IFSUB_CAREA
829C-----------------------------------------------
830C C o m m o n B l o c k s
831C-----------------------------------------------
832#include "com04_c.inc"
833C-----------------------------------------------
834C L o c a l V a r i a b l e s
835C-----------------------------------------------
836 INTEGER I, J, K, N, NOR, NOD,
837 . LOC_PROC, P, IADLEN, NS, IDEB
838 INTEGER LR, LI, RSHIFT, ISHIFT, TAGSLD(NSN+NSNR), ILOC(NSN+NSNR)
839C--------------------------------------------------------
840C
841C computation of real and integer sending buffers sizes
842c general case
843 rsiz = 9
844 isiz = 8
845 IF(.true.) THEN
846! ICODT and ISKEW
847 isiz = isiz + 2
848 ENDIF
849C
850C specific cases ../..
851 IF(igap==1 .OR. igap==2)THEN
852 rsiz = rsiz + 1
853 ELSEIF(igap==3)THEN
854 rsiz = rsiz + 2
855 ENDIF
856C
857C thermic
858 IF(intth > 0 ) THEN
859 rsiz = rsiz + 2
860 isiz = isiz + 1
861 ENDIF
862c adhesion
863 IF(ivis2==-1) THEN
864 IF(intth==0) rsiz = rsiz + 1
865 isiz = isiz + 1
866 ENDIF
867C Friction
868 IF(intfric > 0 ) THEN
869 isiz = isiz + 1
870 ENDIF
871C---Stiffness based on mass and time step
872 IF(istif_msdt > 0) rsiz = rsiz + 1
873C---CAREA output
874 IF(ifsub_carea > 0) rsiz = rsiz + 1
875C
876C -- IDTMINS==2
877 IF(idtmins == 2)THEN
878 isiz = isiz + 2
879C -- IDTMINS_INT /= 0
880 ELSEIF(idtmins_int/=0)THEN
881 isiz = isiz + 1
882 END IF
883C
884C INT24
885C IF(ITYP==24)THEN
886C RSIZ = RSIZ + 8
887C ISIZ = ISIZ + 3
888C-----for NBINFLG
889C IF (ILEV==2) ISIZ = ISIZ + 1
890C ENDIF
891C
892C INT25
893 IF(ityp==25)THEN
894 rsiz = rsiz + 10
895 isiz = isiz + 5
896C-----for NBINFLG
897 IF (ilev==2) isiz = isiz + 1
898C-----for FR_SLIDE
899 isiz = isiz + 4
900 ENDIF
901C------
902 loc_proc = ispmd+1
903 ideb=0
904 DO p=1,nspmd
905 sizbufs(p)=0
906 IF(p/=loc_proc)THEN
907 IF(iad_frnor(ni25,p+1)-iad_frnor(ni25,p)>0) THEN
908 tagsld(1:nsn+nsnr)=0
909 iloc(1:nsn+nsnr)=0
910 DO j=iad_frnor(ni25,p),iad_frnor(ni25,p+1)-1
911 nor = fr_nor(j)
912C
913C NADD(1:NADMSR+1), KADD <=> liste sky line des noeuds secnd concerns / tous les sommets frontires
914 DO n=nadd(nor)+1, nadd(nor+1)
915 i=kadd(n)
916 IF(tagsld(i)==0)THEN
917 sizbufs(p)=sizbufs(p)+1
918 index(ideb+sizbufs(p))=i
919 iloc(i)=ideb+sizbufs(p)
920 END IF
921 tagsld(i)=tagsld(i)+1
922C
923c if(i<=nsn)then
924c if(itab(nsv(i))==31935)print *,'index nat',ispmd+1,p,iloc(i)
925c else
926c if(itafi(nin)%p(i-nsn)==31935)print *,'index rem',ispmd+1,p,iloc(i)
927c end if
928C
929C entree dans IAD_FRNOR(NI25,P:P+1)
930 fr_slide(tagsld(i),iloc(i))=j-iad_frnor(ni25,p) + 1
931 END DO
932 END DO
933 ideb=ideb+sizbufs(p)
934 END IF
935 END IF
936 END DO
937C------
938 RETURN

◆ i25prep_slid_1()

subroutine i25prep_slid_1 ( integer jlt,
integer, dimension(*) cand_n,
integer, dimension(*) cand_e,
integer nin,
integer nsn,
integer nsnr,
integer inacti,
integer, dimension(*) mseglo,
integer, dimension(4,nsn) irtlm,
time_s,
integer, dimension(*) itab,
integer, dimension(4,*) farm,
penm,
integer, dimension(4,*) irect,
integer nadmsr,
integer, dimension(4,*) admsr,
lbm,
lcm,
integer, dimension(4,*) islide,
integer, dimension(*) nsv )

Definition at line 149 of file i25slid.F.

155C-----------------------------------------------
156C M o d u l e s
157C-----------------------------------------------
158 USE tri7box
159C-----------------------------------------------
160C I m p l i c i t T y p e s
161C-----------------------------------------------
162#include "implicit_f.inc"
163C-----------------------------------------------
164C G l o b a l P a r a m e t e r s
165C-----------------------------------------------
166#include "comlock.inc"
167C-----------------------------------------------
168C D u m m y A r g u m e n t s
169C-----------------------------------------------
170 INTEGER JLT, NIN, NSN, NSNR, INACTI, NADMSR,
171 . CAND_N(*),CAND_E(*),ITAB(*),IRECT(4,*), ADMSR(4,*)
172 INTEGER MSEGLO(*), IRTLM(4,NSN) ,FARM(4,*), ISLIDE(4,*), NSV(*)
173 my_real
174 . time_s(2,*),
175 . penm(4,*), lbm(4,*), lcm(4,*)
176C-----------------------------------------------
177C L o c a l V a r i a b l e s
178C-----------------------------------------------
179 INTEGER I, J, K, L, N, I1, I2, I3, I4,
180 . FAR1, FAR2, FAR3, FAR4, FARI, MGLOB,
181 . J1, J2, J3, J4, NOR,
182 . LOC_PROC, IADLEN, NS, IT, JT, ITRIA(2,4), NSLIDE, ITAG(4)
183 DATA itria/1,2,2,3,3,4,4,1/
184C
185C--------------------------------------------------------
186 DO j=1,jlt
187C
188 n = cand_n(j)
189 l = cand_e(j)
190C
191 IF(n <= nsn)THEN
192C
193C pas de glisst !
194 IF(irtlm(2,n) > 0) cycle
195C
196 IF(irect(3,l)/=irect(4,l))THEN
197
198 itag(1:4)=0
199
200 it=-irtlm(2,n)/5
201 IF(farm(it,j)==2)THEN
202C
203C quitte le contact
204 DO jt=1,4
205 IF(farm(jt,j)==2)THEN ! Hors cone vs normales cote no JT & (FAR/=0 .OR. BBB <= ZERO)
206 itag(itria(1,jt))=1
207 itag(itria(2,jt))=1
208 END IF
209 END DO
210
211 nslide=0
212 DO k=1,4
213 nslide=nslide+1
214 IF(itag(k)/=0) islide(nslide,n)=admsr(k,l)
215 END DO
216
217 ELSEIF(penm(it,j)==zero)THEN
218
219 i1=abs(admsr(1,l))
220 i2=abs(admsr(2,l))
221 i3=abs(admsr(3,l))
222 i4=abs(admsr(4,l))
223
224 islide(1,n)=i1
225 islide(2,n)=i2
226 islide(3,n)=i3
227 islide(4,n)=i4
228
229 ELSE
230C
231C still in contact (TIME_S = non zero value)
232 time_s(1,n)=penm(it,j)
233 END IF
234C
235 ELSE
236
237 i1=abs(admsr(1,l))
238 i2=abs(admsr(2,l))
239 i3=abs(admsr(3,l))
240 i4=i3
241
242 IF(farm(1,j)==2 .OR. farm(2,j)==2 .OR. farm(3,j)==2)THEN
243 IF( farm(1,j) == 2 )THEN
244C leave side 12
245 islide(1,n)=i1
246 islide(2,n)=i2
247 END IF
248C
249C
250 IF( farm(2,j) == 2 )THEN
251C
252C leave side 23
253 islide(2,n)=i2
254 islide(3,n)=i3
255 END IF
256C
257 IF( farm(3,j) == 2 )THEN
258C
259C leave side 31
260 islide(3,n)=i3
261 islide(1,n)=i1
262 END IF
263
264 ELSEIF(penm(1,j)==zero)THEN
265
266 i1=abs(admsr(1,l))
267 i2=abs(admsr(2,l))
268 i3=abs(admsr(3,l))
269 i4=i3
270
271 islide(1,n)=i1
272 islide(2,n)=i2
273 islide(3,n)=i3
274
275 ELSE
276C
277C Still in contact (TIME_S = non zero value)
278 time_s(1,n)=penm(1,j)
279 END IF
280C
281 END IF
282 ELSE
283 n = n - nsn
284C No sliding!
285 IF(irtlm_fi(nin)%P(2,n) > 0) cycle
286C
287 IF(irect(3,l)/=irect(4,l))THEN
288
289 it=-irtlm_fi(nin)%P(2,n)/5
290
291 itag(1:4)=0
292
293 IF(farm(it,j)==2)THEN
294C
295C leave contact
296 DO jt=1,4
297 IF(farm(jt,j)==2)THEN
298 itag(itria(1,jt))=1
299 itag(itria(2,jt))=1
300 END IF
301 END DO
302
303 nslide=0
304 DO k=1,4
305 nslide=nslide+1
306 IF(itag(k)/=0) islide_fi(nin)%P(nslide,n)=admsr(k,l)
307 END DO
308
309 ELSEIF(penm(it,j)==zero)THEN
310
311 i1=abs(admsr(1,l))
312 i2=abs(admsr(2,l))
313 i3=abs(admsr(3,l))
314 i4=abs(admsr(4,l))
315
316 islide_fi(nin)%P(1,n)=i1
317 islide_fi(nin)%P(2,n)=i2
318 islide_fi(nin)%P(3,n)=i3
319 islide_fi(nin)%P(4,n)=i4
320
321 ELSE
322 time_sfi(nin)%P(2*(n-1)+1)=penm(it,j)
323 END IF
324C
325 ELSE
326
327 IF(farm(1,j)==2 .OR. farm(2,j)==2 .OR. farm(3,j)==2)THEN
328
329 i1=abs(admsr(1,l))
330 i2=abs(admsr(2,l))
331 i3=abs(admsr(3,l))
332 i4=i3
333
334 IF( farm(1,j) == 2 )THEN
335C
336C leave side 12
337 islide_fi(nin)%P(1,n)=i1
338 islide_fi(nin)%P(2,n)=i2
339 END IF
340C
341 IF( farm(2,j) == 2 )THEN
342C
343C leave side 23
344 islide_fi(nin)%P(2,n)=i2
345 islide_fi(nin)%P(3,n)=i3
346 END IF
347C
348 IF( farm(3,j) == 2 )THEN
349C
350C leave side 31
351 islide_fi(nin)%P(3,n)=i3
352 islide_fi(nin)%P(1,n)=i1
353 END IF
354
355 ELSEIF(penm(1,j)==zero)THEN
356
357 i1=abs(admsr(1,l))
358 i2=abs(admsr(2,l))
359 i3=abs(admsr(3,l))
360 i4=i3
361
362 islide_fi(nin)%P(1,n)=i1
363 islide_fi(nin)%P(2,n)=i2
364 islide_fi(nin)%P(3,n)=i3
365
366 ELSE
367C
368C Contact not left (TIME_S = non zero value)
369 time_sfi(nin)%P(2*(n-1)+1)=penm(1,j)
370 END IF
371C
372 END IF
373 END IF
374 END DO
375C
376 RETURN

◆ i25prep_slid_2()

subroutine i25prep_slid_2 ( integer, dimension(*) cand_n,
integer, dimension(*) cand_e,
integer nin,
integer ni25,
integer nsn,
integer nsnr,
integer nrtm,
integer sizopt,
integer k_stok,
integer, dimension(*) mseglo,
integer, dimension(*) msegtyp,
integer i_stok_opt,
integer, dimension(*) itab,
integer, dimension(4,*) irect,
integer nadmsr,
integer, dimension(4,*) admsr,
integer, dimension(4,*) islide,
integer, dimension(*) nsv,
integer, dimension(*) knor2msr,
integer, dimension(*) nor2msr,
integer, dimension(4,*) irtlm,
stfm,
integer flagremn,
integer, dimension(*) kremnor,
integer, dimension(*) remnor )

Definition at line 385 of file i25slid.F.

391C-----------------------------------------------
392C M o d u l e s
393C-----------------------------------------------
394 USE tri7box
395C-----------------------------------------------
396C I m p l i c i t T y p e s
397C-----------------------------------------------
398#include "implicit_f.inc"
399C-----------------------------------------------
400C G l o b a l P a r a m e t e r s
401C-----------------------------------------------
402#include "comlock.inc"
403C-----------------------------------------------
404C D u m m y A r g u m e n t s
405C-----------------------------------------------
406 INTEGER NIN, NI25, NSN, NSNR, NADMSR, NRTM, I_MEM, SIZOPT, K_STOK,
407 . I_STOK_OPT, FLAGREMN
408 INTEGER NSV(*), CAND_N(*),CAND_E(*),ITAB(*),IRECT(4,*), MSEGLO(*),
409 . MSEGTYP(*), ADMSR(4,*), ISLIDE(4,*),
410 . KNOR2MSR(*), NOR2MSR(*), IRTLM(4,*),
411 . KREMNOR(*), REMNOR(*)
412 my_real
413 . stfm(*)
414C-----------------------------------------------
415C L o c a l V a r i a b l e s
416C-----------------------------------------------
417 INTEGER I, J, K, L, N, NL, NOR, ISH, NOR1, NOR2, M,
418 . ITAGM(NRTM)
419 INTEGER, DIMENSION(:), ALLOCATABLE :: PROV_E, PROV_N, TAGMSR
420C--------------------------------------------------------
421 k_stok = 0
422 itagm(1:nrtm)=0
423
424 ALLOCATE(prov_e(sizopt))
425 ALLOCATE(prov_n(sizopt))
426
427 IF(flagremn == 2)THEN
428 ALLOCATE(tagmsr(nrtm))
429 tagmsr(1:nrtm) = 0
430c
431 DO n=1,nsn
432 nor1 = kremnor(n)+1
433 nor2 = kremnor(n+1)
434 DO m=nor1,nor2
435 tagmsr(remnor(m)) = 1
436 ENDDO
437C
438 DO j=1,4
439 nor=islide(j,n)
440 IF(nor/=0)THEN
441 DO nl=knor2msr(nor)+1,knor2msr(nor+1)
442 l = nor2msr(nl)
443C
444C In some specific case, the segment and its symmetric one may share one vertex (common normal)
445C => make sure not to slide from one to the other.
446
447
448C | /
449C Shell (free edge) | /
450C | |
451C | /|
452C | / |
453C | / |
454C -------------------- |
455C |
456C .. Part of Bricks (corner) ..
457C |
458C |
459
460 ish = iabs(msegtyp(l))
461 IF(ish/=0)THEN
462 IF(ish > nrtm) ish=ish-nrtm
463 IF(mseglo(ish)==irtlm(1,n)) cycle
464 END IF
465
466 IF(stfm(l)> zero.AND.mseglo(l)/=irtlm(1,n).AND.
467 . itagm(l) /= n.AND.tagmsr(l)==0)THEN
468 IF(nsv(n)/=irect(1,l).AND.nsv(n)/=irect(2,l).AND.
469 . nsv(n)/=irect(3,l).AND.nsv(n)/=irect(4,l))THEN
470 itagm(l)=n
471 k_stok = k_stok + 1
472 IF(k_stok <= sizopt) THEN
473 prov_n(k_stok)=n
474 prov_e(k_stok)=l
475 ENDIF
476 END IF
477 END IF
478 END DO
479 END IF
480 END DO
481c
482 DO m=nor1,nor2
483 tagmsr(remnor(m)) = 0
484 ENDDO
485
486 END DO
487 ELSE !FLAGREMN
488 DO n=1,nsn
489 DO j=1,4
490 nor=islide(j,n)
491 IF(nor/=0)THEN
492 DO nl=knor2msr(nor)+1,knor2msr(nor+1)
493 l = nor2msr(nl)
494C
495C In some specific case, the segment and its symmetric one may share one vertex (common normal)
496C => make sure not to slide from one to the other.
497
498
499C | /
500C Shell (free edge) | /
501C | |
502C | /|
503C | / |
504C | / |
505C -------------------- |
506C |
507C .. Part of Bricks (corner) ..
508C |
509C |
510
511 ish = iabs(msegtyp(l))
512 IF(ish/=0)THEN
513 IF(ish > nrtm) ish=ish-nrtm
514 IF(mseglo(ish)==irtlm(1,n)) cycle
515 END IF
516
517 IF(stfm(l)> zero.AND.mseglo(l)/=irtlm(1,n).AND.
518 . itagm(l) /= n)THEN
519 IF(nsv(n)/=irect(1,l).AND.nsv(n)/=irect(2,l).AND.
520 . nsv(n)/=irect(3,l).AND.nsv(n)/=irect(4,l))THEN
521 itagm(l)=n
522 k_stok = k_stok + 1
523 IF(k_stok <= sizopt) THEN
524 prov_n(k_stok)=n
525 prov_e(k_stok)=l
526 ENDIF
527 END IF
528 END IF
529 END DO
530 END IF
531 END DO
532 END DO
533 ENDIF
534C-----
535 IF(flagremn == 2)THEN
536 DO n=1,nsnr
537 nor1 = kremnor_fi(nin)%P(n)+1
538 nor2 = kremnor_fi(nin)%P(n+1)
539 DO m=nor1,nor2
540 tagmsr(remnor_fi(nin)%P(m)) = 1
541 ENDDO
542 DO j=1,4
543 nor=islide_fi(nin)%P(j,n)
544 IF(nor/=0)THEN
545 DO nl=knor2msr(nor)+1,knor2msr(nor+1)
546 l = nor2msr(nl)
547
548 ish = iabs(msegtyp(l))
549 IF(ish/=0)THEN
550 IF(ish > nrtm) ish=ish-nrtm
551 IF(mseglo(ish)==irtlm_fi(nin)%P(1,n)) cycle
552 END IF
553
554 IF(stfm(l)> zero.AND.mseglo(l)/=irtlm_fi(nin)%P(1,n).AND.
555 . itagm(l) /= n+nsn.AND.tagmsr(l)==0)THEN
556 itagm(l)=n+nsn
557 k_stok = k_stok + 1
558 IF(k_stok <= sizopt) THEN
559 prov_n(k_stok)=n + nsn
560 prov_e(k_stok)=l
561 ENDIF
562 END IF
563 END DO
564 END IF
565 END DO
566c
567 DO m=nor1,nor2
568 tagmsr(remnor_fi(nin)%P(m)) = 0
569 ENDDO
570 END DO
571 ELSE !FLAGREMN
572 DO n=1,nsnr
573 DO j=1,4
574 nor=islide_fi(nin)%P(j,n)
575 IF(nor/=0)THEN
576 DO nl=knor2msr(nor)+1,knor2msr(nor+1)
577 l = nor2msr(nl)
578
579 ish = iabs(msegtyp(l))
580 IF(ish/=0)THEN
581 IF(ish > nrtm) ish=ish-nrtm
582 IF(mseglo(ish)==irtlm_fi(nin)%P(1,n)) cycle
583 END IF
584
585 IF(stfm(l)> zero.AND.mseglo(l)/=irtlm_fi(nin)%P(1,n).AND.
586 . itagm(l) /= n+nsn)THEN
587 itagm(l)=n+nsn
588 k_stok = k_stok + 1
589 IF(k_stok <= sizopt) THEN
590 prov_n(k_stok)=n + nsn
591 prov_e(k_stok)=l
592 ENDIF
593 END IF
594 END DO
595 END IF
596 END DO
597 END DO
598
599 ENDIF
600C-----
601 IF(i_stok_opt+k_stok>sizopt) THEN
602 DEALLOCATE(prov_e,prov_n)
603 RETURN
604 ENDIF
605C-----
606
607 cand_n(i_stok_opt+1:i_stok_opt+k_stok) = prov_n(1:k_stok)
608 cand_e(i_stok_opt+1:i_stok_opt+k_stok) = prov_e(1:k_stok)
609 i_stok_opt = i_stok_opt + k_stok
610
611 DEALLOCATE(prov_e,prov_n)
612 IF(flagremn == 2) DEALLOCATE(tagmsr)
613
614 RETURN
tri7box::kremnor_fi
type(int_pointer), dimension(:), allocatable kremnor_fi
Definition tri7box.F:549
tri7box::remnor_fi
type(int_pointer), dimension(:), allocatable remnor_fi
Definition tri7box.F:548
nl
character *2 function nl()
Definition message.F:2354