OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
ddtools.F File Reference
#include "implicit_f.inc"
#include "com04_c.inc"
#include "com01_c.inc"
#include "param_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine ini_ifront ()
subroutine realloc_ifront ()
subroutine plist_ifront (tab, n, cpt)
subroutine c_ifront (n, cpt)
integer function nlocal (n, p)
subroutine set_front8 (ipari, intercep, intbuf_tab, t8, nbt8, itab)
subroutine set_intercep (ipari, intercep, flag, intbuf_tab, itab, cep)
subroutine fill_intercep (ipari, intbuf_tab, intercep)
integer function intersurfl (n1, n2, n3, n4)
subroutine ini_iddconnect (nelem)
subroutine realloc_iddconnect (nelem)
subroutine c_iddconnect (n, cpt)
subroutine plist_iddconnect (adjncy, xadj, n)
subroutine plist_bfs (nelem, nconnx, colors, roots)

Function/Subroutine Documentation

◆ c_iddconnect()

subroutine c_iddconnect ( integer n,
integer cpt )

Definition at line 1206 of file ddtools.F.

1207C returns in CPT the number of connected nodes
1208C-----------------------------------------------
1209C M o d u l e s
1210C-----------------------------------------------
1211 USE front_mod
1212C-----------------------------------------------
1213C I m p l i c i t T y p e s
1214C-----------------------------------------------
1215#include "implicit_f.inc"
1216C-----------------------------------------------
1217C D u m m y A r g u m e n t s
1218C-----------------------------------------------
1219 INTEGER N,CPT
1220C-----------------------------------------------
1221C L o c a l V a r i a b l e s
1222C-----------------------------------------------
1223 INTEGER IAD
1224C-----------------------------------------------
1225C S o u r c e L i n e s
1226C-----------------------------------------------
1227 cpt=0
1228 iad=iddconnect%IENTRYDOM(1,n)
1229! if no connected node
1230! nothing to do as init has been done to -1
1231 IF(iad==-1)THEN
1232 cpt = 0
1233 RETURN
1234 ENDIF
1235
1236 IF(iddconnect%PDOM(2,iad)==0)THEN
1237! only one connected node
1238 cpt = cpt+1
1239 ELSE
1240! list of connected nodes for node N
1241 DO WHILE(iad/=0)
1242 cpt=cpt+1
1243 iad=iddconnect%PDOM(2,iad)
1244 ENDDO
1245 ENDIF
1246
1247 RETURN
front_mod
Definition front_mod.F:84
front_mod::iddconnect
type(my_connectdom) iddconnect
Definition front_mod.F:101

◆ c_ifront()

subroutine c_ifront ( integer n,
integer cpt )

Definition at line 204 of file ddtools.F.

205c returns in CPT the number of procs on which node N is sticked
206C-----------------------------------------------
207C M o d u l e s
208C-----------------------------------------------
209 USE front_mod
210C-----------------------------------------------
211C I m p l i c i t T y p e s
212C-----------------------------------------------
213#include "implicit_f.inc"
214C-----------------------------------------------
215C D u m m y A r g u m e n t s
216C-----------------------------------------------
217 INTEGER N,CPT
218C-----------------------------------------------
219C L o c a l V a r i a b l e s
220C-----------------------------------------------
221 INTEGER IAD
222C-----------------------------------------------
223C S o u r c e L i n e s
224C-----------------------------------------------
225 cpt=0
226 iad=ifront%IENTRY(n)
227c no proc set for this node
228c nothing to do as init has been done to -1
229 IF(iad==-1)THEN
230 cpt = 0
231 RETURN
232 ENDIF
233
234 IF(ifront%P(2,iad)==0)THEN
235c only one proc
236 cpt = cpt+1
237 ELSE
238c list of procs for node N
239 DO WHILE(iad/=0)
240 cpt=cpt+1
241 iad=ifront%P(2,iad)
242 ENDDO
243 ENDIF
244
245 RETURN
front_mod::ifront
type(my_front) ifront
Definition front_mod.F:93

◆ fill_intercep()

subroutine fill_intercep ( integer, dimension(npari,*) ipari,
type(intbuf_struct_), dimension(*) intbuf_tab,
type(intersurfp), dimension(3,ninter) intercep )

Definition at line 971 of file ddtools.F.

972C new routine called right after domdec1 to be used by interface sorting
973C-----------------------------------------------
974C M o d u l e s
975C-----------------------------------------------
976 USE message_mod
977 USE front_mod
978 USE intbufdef_mod
979C-----------------------------------------------
980C I m p l i c i t T y p e s
981C-----------------------------------------------
982#include "implicit_f.inc"
983C-----------------------------------------------
984C G l o b a l P a r a m e t e r s
985C-----------------------------------------------
986#include "param_c.inc"
987C-----------------------------------------------
988C C o m m o n B l o c k s
989C-----------------------------------------------
990#include "com04_c.inc"
991C-----------------------------------------------
992C D u m m y A r g u m e n t s
993C-----------------------------------------------
994 INTEGER IPARI(NPARI,*)
995 TYPE(INTERSURFP) :: INTERCEP(3,NINTER)
996 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
997C-----------------------------------------------
998C E x t e r n a l F u n c t i o n s
999C-----------------------------------------------
1000 INTEGER INTERSURFL
1001 EXTERNAL intersurfl
1002C-----------------------------------------------
1003C L o c a l V a r i a b l e s
1004C-----------------------------------------------
1005 INTEGER ITY,NRTM,N,N1,N2,N3,N4,NSN,
1006 . NRTS,N1L,N2L,N3L,N4L,NLINM,NLINS
1007 INTEGER NI,K,I,PROC
1008C--------------------------------------------------------------
1009 DO ni=1,ninter
1010
1011 !get generic values
1012 ity = ipari(7,ni)
1013
1014 IF (ity==7)THEN
1015
1016 nrtm = ipari(4,ni)
1017C Allocate CEP INTERFACE
1018 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
1019 ALLOCATE(intercep(1,ni)%P(nrtm))
1020 ENDIF
1021 intercep(1,ni)%P(1:nrtm)=0
1022
1023 DO k=1,nrtm
1024 n1=intbuf_tab(ni)%IRECTM(4*(k-1)+1)
1025 n2=intbuf_tab(ni)%IRECTM(4*(k-1)+2)
1026 n3=intbuf_tab(ni)%IRECTM(4*(k-1)+3)
1027 n4=intbuf_tab(ni)%IRECTM(4*(k-1)+4)
1028 !find first SPMD domain on which the 4 nodes of the surface are
1029 IF(n1>numnod.OR.n2>numnod.OR.
1030 . n3>numnod.OR.n4>numnod) THEN
1031 intercep(1,ni)%P(k) = 1
1032 ELSE
1033 proc = intersurfl(n1,n2,n3,n4)
1034 intercep(1,ni)%P(k) = proc
1035 ENDIF
1036 ENDDO
1037
1038 ENDIF
1039
1040 ENDDO !ENDDO 1,NINTER
1041
intersurfl
integer function intersurfl(n1, n2, n3, n4)
Definition ddtools.F:1054
message_mod
Definition message_mod.F:1249

◆ ini_iddconnect()

subroutine ini_iddconnect ( integer nelem)

Definition at line 1113 of file ddtools.F.

1114C-----------------------------------------------
1115C M o d u l e s
1116C-----------------------------------------------
1117 USE front_mod
1118C-----------------------------------------------
1119C I m p l i c i t T y p e s
1120C-----------------------------------------------
1121#include "implicit_f.inc"
1122C-----------------------------------------------
1123C D u m m y A r g u m e n t s
1124C-----------------------------------------------
1125 INTEGER NELEM
1126C-----------------------------------------------
1127C L o c a l V a r i a b l e s
1128C-----------------------------------------------
1129 INTEGER I
1130
1131 DO i=1,nelem
1132 iddconnect%IENTRYDOM(1,i) = -1
1133 iddconnect%IENTRYDOM(2,i) = 0
1134 ENDDO
1135
1136 DO i=1, siddconnect
1137 iddconnect%PDOM(1,i) = -1
1138 iddconnect%PDOM(2,i) = -1
1139 END DO
1140
1141 iddconnect_end = nelem
1142C
1143 RETURN
front_mod::iddconnect_end
integer iddconnect_end
Definition front_mod.F:102
front_mod::siddconnect
integer siddconnect
Definition front_mod.F:102

◆ ini_ifront()

subroutine ini_ifront

Definition at line 30 of file ddtools.F.

31C-----------------------------------------------
32C M o d u l e s
33C-----------------------------------------------
34 USE front_mod
35C-----------------------------------------------
36C I m p l i c i t T y p e s
37C-----------------------------------------------
38#include "implicit_f.inc"
39#include "com04_c.inc"
40C-----------------------------------------------
41C D u m m y A r g u m e n t s
42C-----------------------------------------------
43
44C-----------------------------------------------
45C L o c a l V a r i a b l e s
46C-----------------------------------------------
47 INTEGER I
48
49 DO i=1,numnod
50 ifront%IENTRY(i) = -1
51 ENDDO
52
53 DO i=1, sifront
54 ifront%P(1,i) = -1
55 ifront%P(2,i) = -1
56 END DO
57
58 ifront_end = numnod
59C
60 RETURN
front_mod::sifront
integer sifront
Definition front_mod.F:107
front_mod::ifront_end
integer ifront_end
Definition front_mod.F:107

◆ intersurfl()

integer function intersurfl ( integer n1,
integer n2,
integer n3,
integer n4 )

Definition at line 1053 of file ddtools.F.

1054C-----------------------------------------------
1055C M o d u l e s
1056C-----------------------------------------------
1057 USE front_mod
1058C-----------------------------------------------
1059C C o m m o n B l o c k s
1060C-----------------------------------------------
1061#include "implicit_f.inc"
1062C-----------------------------------------------
1063C D u m m y A r g u m e n t s
1064C-----------------------------------------------
1065 INTEGER N1,N2,N3,N4
1066C-----------------------------------------------
1067C L o c a l V a r i a b l e s
1068C-----------------------------------------------
1069 INTEGER IAD1,IAD2,IAD3,IAD4,
1070 . P1,P2,P3,P4,PMAX
1071 INTEGER TAB(4),NN
1072 LOGICAL SEARCH
1073C-----------------------------------------------
1074C S o u r c e L i n e s
1075C-----------------------------------------------
1076 intersurfl = -1
1077 search = .true.
1078
1079 iad1 = ifront%IENTRY(n1)
1080 iad2 = ifront%IENTRY(n2)
1081 iad3 = ifront%IENTRY(n3)
1082 iad4 = ifront%IENTRY(n4)
1083
1084 DO WHILE(search)
1085 p1 = ifront%P(1,iad1)
1086 p2 = ifront%P(1,iad2)
1087 p3 = ifront%P(1,iad3)
1088 p4 = ifront%P(1,iad4)
1089 IF(p1==p2.AND.p2==p3.AND.p3==p4)THEN
1090 intersurfl = p1
1091 search = .false.
1092 ELSE
1093 pmax = max(p1,p2,p3,p4)
1094 IF(p1<pmax) iad1 = ifront%P(2,iad1)
1095 IF(p2<pmax) iad2 = ifront%P(2,iad2)
1096 IF(p3<pmax) iad3 = ifront%P(2,iad3)
1097 IF(p4<pmax) iad4 = ifront%P(2,iad4)
1098 ENDIF
1099 ENDDO
1100! IF(INTERSURFL > 4) THEN
1101! WRITE(6,*) __FILE__,__LINE__,IAD1,IAD2,IAD3,IAD4
1102! ENDIF
1103
1104 RETURN
max
#define max(a, b)
Definition macros.h:21

◆ nlocal()

integer function nlocal ( integer n,
integer p )

Definition at line 348 of file ddtools.F.

349C returns 1 if node N is sticked on SPMD domain P, else returns 0
350C-----------------------------------------------
351C M o d u l e s
352C-----------------------------------------------
353 USE front_mod
354C-----------------------------------------------
355C C o m m o n B l o c k s
356C-----------------------------------------------
357#include "implicit_f.inc"
358C-----------------------------------------------
359C L o c a l V a r i a b l e s
360C-----------------------------------------------
361 INTEGER N,P,IAD
362 LOGICAL PSEARCH
363C-----------------------------------------------
364C S o u r c e L i n e s
365C-----------------------------------------------
366 psearch = .true.
367 iad = ifront%IENTRY(n)
368 nlocal = 0
369
370 ! no SPMD domain attributed for this node
371 IF(iad==-1)THEN
372 nlocal = 0
373 RETURN
374 ENDIF
375
376 !test if first proc is tested one (most frequent case)
377 IF(ifront%P(1,iad)==p)THEN
378 nlocal = 1
379 RETURN
380 ENDIF
381
382 iad = ifront%P(2,iad)
383 IF (iad==0)RETURN
384
385 DO WHILE(psearch)
386 IF(ifront%P(1,iad)==p) THEN
387 nlocal = 1
388 psearch = .false.
389 ENDIF
390 IF(ifront%P(1,iad)>p) psearch = .false.
391 IF(ifront%P(2,iad)==0) psearch = .false.
392 iad = ifront%P(2,iad)
393 ENDDO
394
395 RETURN
nlocal
integer function nlocal(n, p)
Definition ddtools.F:349

◆ plist_bfs()

subroutine plist_bfs ( integer nelem,
integer nconnx,
integer, dimension(nelem) colors,
integer, dimension(nelem) roots )

Definition at line 1309 of file ddtools.F.

1310C-----------------------------------------------
1311C MODULES
1312C-----------------------------------------------
1313 USE front_mod
1314C-----------------------------------------------
1315C I m p l i c i t T y p e s
1316C-----------------------------------------------
1317#include "implicit_f.inc"
1318C-----------------------------------------------
1319C D u m m y A r g u m e n t s
1320C-----------------------------------------------
1321 INTEGER NELEM, NCONNX,
1322 . COLORS(NELEM), ROOTS(NELEM)
1323C-----------------------------------------------
1324C L o c a l V a r i a b l e s
1325C-----------------------------------------------
1326 INTEGER NVISIT, N, I
1327 INTEGER, DIMENSION(:), ALLOCATABLE :: FILE_V
1328 INTEGER, DIMENSION(:), ALLOCATABLE :: XADJ
1329 INTEGER :: FILE_NEXT, ROOT, CURRENT, LEN
1330 INTEGER :: CPT,IAD
1331C-----------------------------------------------
1332
1333 ALLOCATE(file_v(nelem))
1334 ALLOCATE(xadj(nelem+1))
1335 xadj(1:nelem+1)=0
1336 xadj(1) = 1
1337 DO i=1,nelem
1338 CALL c_iddconnect(i,len)
1339 xadj(i+1) = xadj(i) + len
1340 ENDDO
1341
1342 DO n = 1, nelem
1343 colors(n)=0
1344 END DO
1345 nvisit=0
1346 root=1 ! first element of the graph == first vertex available
1347 nconnx=0
1348
1349 DO WHILE (nvisit < nelem) ! loop until all vertices are visited
1350 nconnx = nconnx+1
1351 DO WHILE ((root <= nelem) .AND. (colors(root) /= 0))
1352 root = root + 1
1353 END DO
1354 roots(nconnx)=root ! record roots for fatest treatments
1355 file_v(1)=root
1356 file_next=2 ! new file initialized with root
1357 colors(root)=nconnx ! root marked
1358 nvisit=nvisit+1
1359 DO WHILE (file_next > 1) ! test file not nill
1360 current = file_v(file_next-1)
1361 file_next = file_next-1
1362
1363 cpt=xadj(current)-1
1364 iad=iddconnect%IENTRYDOM(1,current)
1365
1366 DO n = xadj(current), xadj(current+1)-1
1367C I = ADJNCY(N)
1368 cpt = cpt+1
1369 i=iddconnect%PDOM(1,iad)
1370 iad=iddconnect%PDOM(2,iad)
1371C
1372
1373 IF(colors(i) == 0) THEN ! vertex not treated before
1374 file_v(file_next)=i
1375 file_next = file_next+1
1376 colors(i) = nconnx
1377 nvisit=nvisit+1
1378 END IF
1379 END DO
1380 END DO
1381 END DO
1382
1383 DEALLOCATE(file_v)
1384 RETURN
c_iddconnect
subroutine c_iddconnect(n, cpt)
Definition ddtools.F:1207

◆ plist_iddconnect()

subroutine plist_iddconnect ( integer, dimension(*) adjncy,
integer, dimension(*) xadj,
integer n )

Definition at line 1256 of file ddtools.F.

1257C returns in "ADJNCY" nodes connected to node N
1258C CPT is the number of nodes
1259C-----------------------------------------------
1260C M o d u l e s
1261C-----------------------------------------------
1262 USE front_mod
1263C-----------------------------------------------
1264C I m p l i c i t T y p e s
1265C-----------------------------------------------
1266#include "implicit_f.inc"
1267C-----------------------------------------------
1268C D u m m y A r g u m e n t s
1269C-----------------------------------------------
1270 INTEGER TAILLE
1271 INTEGER N,ADJNCY(*),XADJ(*)
1272C-----------------------------------------------
1273C L o c a l V a r i a b l e s
1274C-----------------------------------------------
1275 INTEGER CPT,IAD
1276C-----------------------------------------------
1277C S o u r c e L i n e s
1278C-----------------------------------------------
1279 cpt=xadj(n)-1
1280 iad=iddconnect%IENTRYDOM(1,n)
1281
1282! if no connected node
1283! nothing to do as init has been done to -1
1284
1285! only one connected node
1286 IF(iddconnect%PDOM(2,iad)==0)THEN
1287 cpt = cpt+1
1288 adjncy(cpt)=iddconnect%PDOM(1,iad)
1289 ELSE
1290! list of connected nodes for node N
1291 DO WHILE(iad/=0)
1292 cpt=cpt+1
1293 adjncy(cpt)=iddconnect%PDOM(1,iad)
1294 iad=iddconnect%PDOM(2,iad)
1295 ENDDO
1296 ENDIF
1297
1298 RETURN

◆ plist_ifront()

subroutine plist_ifront ( integer, dimension(nspmd) tab,
integer n,
integer cpt )

Definition at line 152 of file ddtools.F.

153C returns in "TAB" list of SPMD domains on which node N is sticked
154C CPT is the number of SPMD domains on which node N is sticked
155C-----------------------------------------------
156C M o d u l e s
157C-----------------------------------------------
158 USE front_mod
159C-----------------------------------------------
160C I m p l i c i t T y p e s
161C-----------------------------------------------
162#include "implicit_f.inc"
163#include "com01_c.inc"
164C-----------------------------------------------
165C D u m m y A r g u m e n t s
166C-----------------------------------------------
167 INTEGER N,CPT,TAB(NSPMD)
168C-----------------------------------------------
169C L o c a l V a r i a b l e s
170C-----------------------------------------------
171 INTEGER IAD
172C-----------------------------------------------
173C S o u r c e L i n e s
174C-----------------------------------------------
175 tab(1:nspmd) = -1
176 cpt=0
177 iad=ifront%IENTRY(n)
178 IF(iad==-1) RETURN
179c if no proc set for this node
180c nothing to do as init has been done to -1
181
182c only one proc
183 IF(ifront%P(2,iad)==0)THEN
184 cpt = cpt+1
185 tab(cpt)=ifront%P(1,iad)
186 ELSE
187c list of procs for node N
188 DO WHILE(iad/=0)
189 cpt=cpt+1
190 tab(cpt)=ifront%P(1,iad)
191 iad=ifront%P(2,iad)
192 ENDDO
193 ENDIF
194
195 RETURN

◆ realloc_iddconnect()

subroutine realloc_iddconnect ( integer nelem)

Definition at line 1155 of file ddtools.F.

1156C-----------------------------------------------
1157C M o d u l e s
1158C-----------------------------------------------
1159 USE message_mod
1160 USE front_mod
1161C-----------------------------------------------
1162C I m p l i c i t T y p e s
1163C-----------------------------------------------
1164#include "implicit_f.inc"
1165C-----------------------------------------------
1166C D u m m y A r g u m e n t s
1167C-----------------------------------------------
1168 INTEGER NELEM
1169C-----------------------------------------------
1170C L o c a l V a r i a b l e s
1171C-----------------------------------------------
1172 INTEGER,DIMENSION(:,:),ALLOCATABLE :: IDDCONNECT_SAVE
1173 INTEGER I, STAT
1174C-----------------------------------------------
1175C S o u r c e L i n e s
1176C-----------------------------------------------
1177 stat = 0
1178 ALLOCATE(iddconnect_save(2,siddconnect+nelem),stat=stat)
1179 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
1180 . msgtype=msgerror,
1181 . c1='IDDCONNECT_SAVE')
1182
1183! save IDDCONNECT in IFRONT_SAVEDOM
1184 DO i=1,siddconnect
1185 iddconnect_save(1,i) = iddconnect%PDOM(1,i)
1186 iddconnect_save(2,i) = iddconnect%PDOM(2,i)
1187 ENDDO
1188 DO i=siddconnect+1,siddconnect+nelem
1189 iddconnect_save(1,i) = -1
1190 iddconnect_save(2,i) = -1
1191 ENDDO
1192
1193 CALL move_alloc(iddconnect_save, iddconnect%PDOM)
1194 siddconnect = siddconnect+nelem
1195
1196 RETURN
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

◆ realloc_ifront()

subroutine realloc_ifront

Definition at line 72 of file ddtools.F.

73C-----------------------------------------------
74C M o d u l e s
75C-----------------------------------------------
76 USE message_mod
77 USE front_mod
78C-----------------------------------------------
79C I m p l i c i t T y p e s
80C-----------------------------------------------
81#include "implicit_f.inc"
82#include "com04_c.inc"
83C-----------------------------------------------
84C D u m m y A r g u m e n t s
85C-----------------------------------------------
86
87C-----------------------------------------------
88C L o c a l V a r i a b l e s
89C-----------------------------------------------
90 TYPE(my_front) :: IFRONT_SAVE
91 INTEGER I, STAT
92C-----------------------------------------------
93C S o u r c e L i n e s
94C-----------------------------------------------
95 ALLOCATE(ifront_save%P(2,sifront),stat=stat)
96 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
97 . msgtype=msgerror,
98 . c1='IFRONT_SAVE')
99
100c save IFRONT in IFRONT_SAVE
101 DO i=1,sifront
102 ifront_save%P(1,i) = ifront%P(1,i)
103 ifront_save%P(2,i) = ifront%P(2,i)
104 ENDDO
105
106c dealloc and realloc with bigger size (SIFRONT+NUMNOD)
107 DEALLOCATE(ifront%P)
108 ALLOCATE(ifront%P(2,sifront+numnod),stat=stat)
109 IF (stat /= 0) CALL ancmsg(msgid=268,anmode=aninfo,
110 . msgtype=msgerror,
111 . c1='IFRONT REALLOC')
112
113 DO i=1,sifront
114 ifront%P(1,i) = ifront_save%P(1,i)
115 ifront%P(2,i) = ifront_save%P(2,i)
116 ENDDO
117 DO i=sifront+1,sifront+numnod
118 ifront%P(1,i) = -1
119 ifront%P(2,i) = -1
120 ENDDO
121
122 DEALLOCATE(ifront_save%P)
123
124c set new size of SIFRONT
125 sifront = sifront+numnod
126
127 RETURN

◆ set_front8()

subroutine set_front8 ( integer, dimension(npari,*) ipari,
type(intersurfp), dimension(3,ninter) intercep,
type(intbuf_struct_), dimension(*) intbuf_tab,
type(int8_struct_), dimension(nspmd,nbt8) t8,
integer nbt8,
integer, dimension(*) itab )

Definition at line 405 of file ddtools.F.

406C-----------------------------------------------
407C M o d u l e s
408C-----------------------------------------------
409 USE front_mod
410 USE intbufdef_mod
411 USE int8_mod
412C-----------------------------------------------
413C I m p l i c i t T y p e s
414C-----------------------------------------------
415#include "implicit_f.inc"
416C-----------------------------------------------
417C G l o b a l P a r a m e t e r s
418C-----------------------------------------------
419#include "param_c.inc"
420C-----------------------------------------------
421C C o m m o n B l o c k s
422C-----------------------------------------------
423#include "com01_c.inc"
424#include "com04_c.inc"
425C-----------------------------------------------
426C D u m m y A r g u m e n t s
427C-----------------------------------------------
428 INTEGER IPARI(NPARI,*)
429 TYPE(INTERSURFP) :: INTERCEP(3,NINTER)
430 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
431 TYPE(INT8_STRUCT_) :: T8(NSPMD,NBT8)
432 INTEGER :: NBT8,ITAB(*)
433C-----------------------------------------------
434C L o c a l V a r i a b l e s
435C-----------------------------------------------
436 INTEGER NI,K,I,PROC,P,Q,NB
437 INTEGER N1,N2,N3,N4
438 INTEGER ITY,NMN,NRTM,NM_SHARED
439 INTEGER, DIMENSION(:,:), ALLOCATABLE :: TAG,INDEX_IN_COMM
440 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX_IN_FRONT
441 INTEGER :: S_FRONT8(NSPMD,NSPMD),IDX(NSPMD)
442 INTEGER :: LOCAL_ID,II,JJ,KK,NSN
443C--------------------------------------------------------------
444
445
446 nbt8 = 1
447 DO ni=1,ninter
448 !get generic values
449 ity = ipari(7,ni)
450 nmn = ipari(6,ni)
451 nrtm = ipari(4,ni)
452 nsn = ipari(5,ni)
453
454 local_id = 0
455 IF(ity == 8) THEN
456 ALLOCATE(index_in_front(nmn))
457 index_in_front(1:nmn) = 0
458 ALLOCATE(tag(nspmd,nmn))
459 ALLOCATE(index_in_comm(nspmd,nmn))
460 tag(1:nspmd,1:nmn) = 0
461 DO k=1,nrtm
462 n1 = intbuf_tab(ni)%IRECTM(4*(k-1)+1)
463 n2 = intbuf_tab(ni)%IRECTM(4*(k-1)+2)
464 n3 = intbuf_tab(ni)%IRECTM(4*(k-1)+3)
465 n4 = intbuf_tab(ni)%IRECTM(4*(k-1)+4)
466 proc = intercep(1,ni)%P(k)
467 tag(proc,n1) = 1
468 tag(proc,n2) = 1
469 tag(proc,n3) = 1
470 tag(proc,n4) = 1
471 ENDDO
472
473 ! Compute the number of main nodes shared between
474 ! each possible couple of proc (i,j) => S_FRONT8(i,j)
475 s_front8 = 0
476 DO p = 1,nspmd
477 DO q = p+1,nspmd
478 DO k = 1,nmn
479 IF(tag(p,k) == 1 .AND. tag(q,k) == 1) THEN
480 !The main is shared between procs P and Q
481 local_id = local_id + 1
482 s_front8(p,q) = s_front8(p,q) + 1
483 s_front8(q,p) = s_front8(q,p) + 1
484 ! the kth main node will have to be communucated
485 IF( index_in_front(k) == 0) THEN
486 index_in_front(k) = local_id
487 ENDIF
488 ENDIF
489 ENDDO
490 ENDDO
491 ENDDO
492 idx(1:nspmd) = 0
493 index_in_comm(1:nspmd,1:nmn) = 0
494 !INDEX_IN_COMM give an index to the communication structures
495 ! of each main node (or 0 if the main node is not shared)
496
497 DO k = 1,nmn
498 q = 0
499 DO p = 1,nspmd
500 q = q + tag(p,k)
501 ENDDO
502 IF(q > 1) THEN
503 DO p = 1,nspmd
504 IF(tag(p,k) /= 0) THEN
505 idx(p) = idx(p) + 1
506 index_in_comm(p,k)=idx(p)
507 ENDIF
508 ENDDO
509 ENDIF
510 ENDDO
511 ! symmetric allocation of arrays of size *nb main nodes in common*
512 ! between proc P and proc Q
513 DO p = 1,nspmd
514 DO q = p+1,nspmd
515 nm_shared = s_front8(p,q)
516 t8(p,nbt8)%BUFFER(q)%NBMAIN = 0! NM_SHARED
517 ALLOCATE(t8(p,nbt8)%BUFFER(q)%MAIN_ID(nm_shared))
518 ALLOCATE(t8(p,nbt8)%BUFFER(q)%MAIN_UID(nm_shared))
519 ALLOCATE(t8(p,nbt8)%BUFFER(q)%NBSECND(nm_shared))
520 t8(p,nbt8)%BUFFER(q)%NBSECND(1:nm_shared) = 0
521 t8(q,nbt8)%BUFFER(p)%NBMAIN = 0 !NM_SHARED
522 ALLOCATE(t8(q,nbt8)%BUFFER(p)%MAIN_ID(nm_shared))
523 ALLOCATE(t8(q,nbt8)%BUFFER(p)%MAIN_UID(nm_shared))
524 ALLOCATE(t8(q,nbt8)%BUFFER(p)%NBSECND(nm_shared))
525 t8(q,nbt8)%BUFFER(p)%NBSECND(1:nm_shared) = 0
526 ENDDO
527 ENDDO
528
529
530 !Compute the total number of main nodes to exchange per
531 ! proc P
532 DO p = 1,nspmd
533 k = idx(p)
534 t8(p,nbt8)%S_COMM = k
535 ALLOCATE(t8(p,nbt8)%SPMD_COMM_PATTERN(k))
536 DO q = 1,k
537 t8(p,nbt8)%SPMD_COMM_PATTERN(q)%NUMLOC = 0
538 t8(p,nbt8)%SPMD_COMM_PATTERN(q)%NBCOM = 0
539 ALLOCATE(t8(p,nbt8)%SPMD_COMM_PATTERN(q)%PROCLIST(nspmd))
540 t8(p,nbt8)%SPMD_COMM_PATTERN(q)%PROCLIST(1:nspmd) = 0
541 ALLOCATE(t8(p,nbt8)%SPMD_COMM_PATTERN(q)%BUF_INDEX(nspmd))
542 t8(p,nbt8)%SPMD_COMM_PATTERN(q)%BUF_INDEX(1:nspmd) = 0
543 ENDDO
544 ENDDO
545
546
547
548 ! Fill the part of the structure that depends only
549 ! on main nodes
550
551 ! To optimize the communication pattern in the engine,
552 ! The data dependencies are build in a symmetric fashion:
553 ! If procs P and Q share main K main nodes, then
554 ! T8(Q,NBT8)%BUFFER(P)%MAIN_UID(1:K) =
555 ! T8(P,NBT8)%BUFFER(Q)%MAIN_UID(1:K)
556 idx(1:nspmd) = 1
557 s_front8(1:nspmd,1:nspmd) = 0
558 DO p = 1,nspmd
559 DO k = 1,nmn
560 !If the node is has to be communicated by P
561 IF(index_in_comm(p,k) > 0) THEN
562 DO q = p+1,nspmd
563 IF(index_in_comm(q,k)/=0) THEN
564! Put the main node in the boundary of P with Q
565 local_id = index_in_comm(p,k)
566 nb = t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%NBCOM +1
567 t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%PROCLIST(nb) = q
568 ii = s_front8(p,q) + 1
569 t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%BUF_INDEX(nb) = ii
570 jj = t8(p,nbt8)%BUFFER(q)%NBMAIN+1
571 t8(p,nbt8)%BUFFER(q)%MAIN_ID(ii) = k
572 t8(p,nbt8)%BUFFER(q)%MAIN_UID(ii) =
573 . itab(intbuf_tab(ni)%MSR(k))
574
575 s_front8(p,q) = ii
576 t8(p,nbt8)%BUFFER(q)%NBMAIN = jj
577 t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%NBCOM=nb
578 t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%NUMLOC = k
579
580 ! SYMMETRIC : put the node in the boundary of Q with P
581 local_id = index_in_comm(q,k)
582 nb = t8(q,nbt8)%SPMD_COMM_PATTERN(local_id)%NBCOM +1
583 t8(q,nbt8)%SPMD_COMM_PATTERN(local_id)%PROCLIST(nb) = p
584 ii = s_front8(q,p) + 1
585 t8(q,nbt8)%SPMD_COMM_PATTERN(local_id)%BUF_INDEX(nb) = ii
586 jj = t8(q,nbt8)%BUFFER(p)%NBMAIN+1
587 t8(q,nbt8)%BUFFER(p)%MAIN_ID(ii) = k
588 t8(q,nbt8)%BUFFER(p)%MAIN_UID(ii) =
589 . itab(intbuf_tab(ni)%MSR(k))
590 s_front8(q,p) = ii
591 t8(q,nbt8)%BUFFER(p)%NBMAIN = jj
592 t8(q,nbt8)%SPMD_COMM_PATTERN(local_id)%NBCOM=nb
593 t8(q,nbt8)%SPMD_COMM_PATTERN(local_id)%NUMLOC = k
594 ENDIF
595 ENDDO
596 ENDIF
597 ENDDO
598 ENDDO ! NSPMD
599
600
601 DO p =1,nspmd
602 ! Count the number of actual secnds that have a main
603 ! shared between multiples procs
604 DO i = 1,nsn
605 IF(index_in_comm(p,intbuf_tab(ni)%ILOCS(i)) > 0) THEN
606 local_id = index_in_comm(p,intbuf_tab(ni)%ILOCS(i))
607 nb = t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%NBCOM
608 DO k =1,nb
609 ii = t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%BUF_INDEX(k)
610 q = t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%PROCLIST(k)
611 t8(p,nbt8)%BUFFER(q)%NBSECND(ii) =
612 . t8(p,nbt8)%BUFFER(q)%NBSECND(ii) + 1
613 t8(p,nbt8)%BUFFER(q)%NBSECND_TOT =
614 . t8(p,nbt8)%BUFFER(q)%NBSECND_TOT + 1
615 ENDDO
616 ENDIF
617 ENDDO !NSN
618 !DO Q = 1,NSPMD
619 ! IF(Q/=P) THEN
620 ! ! Total number of secnd node that have main nodes on processor
621 ! ! P shared with processor Q
622 ! II = T8(P,NBT8)%BUFFER(Q)%NBSECND_TOT
623 ! ALLOCATE(T8(P,NBT8)%BUFFER(Q)%SECND_ID(II))
624 ! ALLOCATE(T8(P,NBT8)%BUFFER(Q)%SECND_UID(II))
625 ! T8(P,NBT8)%BUFFER(Q)%SECND_ID(1:II) = 0
626 ! T8(P,NBT8)%BUFFER(Q)%SECND_UID(1:II) = 0
627 ! NB = T8(P,NBT8)%BUFFER(Q)%NBMAIN
628 ! IF(NB > 0) THEN
629 ! ! This array will keep pointers to secnd_id per main
630 ! ALLOCATE(T8(P,NBT8)%BUFFER(Q)%BUFI(NB))
631 ! T8(P,NBT8)%BUFFER(Q)%BUFI(1) = 1
632 ! DO I = 2,NB
633 ! T8(P,NBT8)%BUFFER(Q)%BUFI(I) =
634 . ! T8(P,NBT8)%BUFFER(Q)%BUFI(I-1) +
635 . ! T8(P,NBT8)%BUFFER(Q)%NBSECND(I-1)
636 ! ENDDO
637 ! ENDIF
638 ! ENDIF
639 !ENDDO !Q = 1,NSPMD
640 !DO I = 1,NSN
641 ! IF(INTBUF_TAB(NI)%ILOCS(I) > 0 ) THEN
642 ! ! If this secnd has a main shared by multiple proc
643 ! IF(INDEX_IN_COMM(P,INTBUF_TAB(NI)%ILOCS(I)) > 0) THEN
644 ! LOCAL_ID = INDEX_IN_COMM(P,INTBUF_TAB(NI)%ILOCS(I))
645 ! NB = T8(P,NBT8)%SPMD_COMM_PATTERN(LOCAL_ID)%NBCOM
646 ! DO K =1,NB
647 ! II = T8(P,NBT8)%SPMD_COMM_PATTERN(LOCAL_ID)%BUF_INDEX(K)
648 ! Q = T8(P,NBT8)%SPMD_COMM_PATTERN(LOCAL_ID)%PROCLIST(K)
649 ! jj = t8(p,nbt8)%BUFFER(q)%BUFI(ii)
650 ! T8(P,NBT8)%BUFFER(Q)%SECND_ID(JJ) = I
651 ! T8(P,NBT8)%BUFFER(Q)%SECND_UID(JJ)= ITAB(INTBUF_TAB(NI)%NSV(I))
652 ! T8(P,NBT8)%BUFFER(Q)%BUFI(II) = JJ + 1
653 ! ENDDO
654 ! ENDIF
655 ! ENDIF
656 !ENDDO !I=1,NSN
657 ENDDO
658
659! useful debug print
660! DO P = 1,NSPMD
661! WRITE(6,*) '============== Proc',P,'===',T8(P,NBT8)%S_COMM
662! DO LOCAL_ID=1,T8(P,NBT8)%S_COMM
663! nb = t8(p,nbt8)%SPMD_COMM_PATTERN(local_id)%NBCOM
664! WRITE(6,*) 'NLOC=',T8(P,NBT8)%SPMD_COMM_PATTERN(LOCAL_ID)%NUMLOC,'NB=',NB
665! DO K =1,NB
666! II = T8(P,NBT8)%SPMD_COMM_PATTERN(LOCAL_ID)%BUF_INDEX(K)
667! Q = T8(P,NBT8)%SPMD_COMM_PATTERN(LOCAL_ID)%PROCLIST(K)
668! WRITE(6,*) 'Q=',Q,T8(P,NBT8)%BUFFER(Q)%MAIN_UID(II)
669! ENDDO
670! ENDDO
671! ENDDO
672! DO P = 1,NSPMD
673! DO Q = 1,NSPMD
674! IF(P /= Q) THEN
675! DO II = 1,T8(P,NBT8)%BUFFER(Q)%NBMAIN
676! WRITE(6,*) "EXCH",p,q,ii,t8(p,nbt8)%BUFFER(q)%MAIN_UID(ii)
677! ENDDO
678! ENDIF
679! ENDDO
680! ENDDO
681! DO P = 1, NSPMD
682! DO K = 1,T8(P,NBT8)%S_COMM
683! WRITE(6,*) P,ITAB(
684! . INTBUF_TAB(NI)%MSR(T8(P,NBT8)%SPMD_COMM_PATTERN(K)%NUMLOC))
685! ENDDO
686! ENDDO
687
688
689
690 DEALLOCATE(tag)
691 DEALLOCATE(index_in_comm)
692 DEALLOCATE(index_in_front)
693 nbt8 = nbt8 + 1
694 ENDIF !ITY == 8
695 ENDDO
696
697
698

◆ set_intercep()

subroutine set_intercep ( integer, dimension(npari,*) ipari,
type(intersurfp), dimension(3,ninter) intercep,
integer flag,
type(intbuf_struct_), dimension(*) intbuf_tab,
integer, dimension(*) itab,
integer, dimension(*) cep )

Definition at line 711 of file ddtools.F.

712C-----------------------------------------------
713C M o d u l e s
714C-----------------------------------------------
715 USE message_mod
716 USE front_mod
717 USE intbufdef_mod
718C-----------------------------------------------
719C I m p l i c i t T y p e s
720C-----------------------------------------------
721#include "implicit_f.inc"
722C-----------------------------------------------
723C G l o b a l P a r a m e t e r s
724C-----------------------------------------------
725#include "param_c.inc"
726C-----------------------------------------------
727C C o m m o n B l o c k s
728C-----------------------------------------------
729#include "com04_c.inc"
730C-----------------------------------------------
731C D u m m y A r g u m e n t s
732C-----------------------------------------------
733 INTEGER IPARI(NPARI,*),FLAG,ITAB(*),CEP(*)
734 TYPE(INTERSURFP) :: INTERCEP(3,NINTER)
735 TYPE(INTBUF_STRUCT_) INTBUF_TAB(*)
736C-----------------------------------------------
737C E x t e r n a l F u n c t i o n s
738C-----------------------------------------------
739 INTEGER INTERSURFL
740 EXTERNAL intersurfl
741C-----------------------------------------------
742C L o c a l V a r i a b l e s
743C-----------------------------------------------
744 INTEGER ITY,NRTM,N,N1,N2,N3,N4,NSN,
745 . NRTS,N1L,N2L,N3L,N4L,NLINM,NLINS
746 INTEGER NI,K,I,PROC,IE
747C--------------------------------------------------------------
748 DO ni=1,ninter
749
750 !get generic values
751 ity = ipari(7,ni)
752
753 IF ((flag==0.AND.(ity==24.OR.(ity==25.AND.ipari(100,ni) == 0))).OR.
754 . (flag==1.AND.(ity==7.OR.ity==10.OR.
755 . ity==22.OR.ity==23)) )THEN
756
757 nrtm = ipari(4,ni)
758
759C Allocate CEP INTERFACE
760 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
761 ALLOCATE(intercep(1,ni)%P(nrtm))
762 IF(ity==25) ALLOCATE(intercep(2,ni)%P(nrtm))
763 ENDIF
764 intercep(1,ni)%P(1:nrtm)=0
765 IF(ity==25) THEN
766 IF (.NOT.(ASSOCIATED(intercep(2,ni)%P)))THEN
767 ALLOCATE(intercep(2,ni)%P(nrtm))
768 ENDIF
769 intercep(2,ni)%P(1:nrtm) = 0
770 ENDIF
771
772 DO k=1,nrtm
773 n1=intbuf_tab(ni)%IRECTM(4*(k-1)+1)
774 n2=intbuf_tab(ni)%IRECTM(4*(k-1)+2)
775 n3=intbuf_tab(ni)%IRECTM(4*(k-1)+3)
776 n4=intbuf_tab(ni)%IRECTM(4*(k-1)+4)
777 IF(n1>numnod.OR.n2>numnod.OR.
778 . n3>numnod.OR.n4>numnod) THEN
779 intercep(1,ni)%P(k) = 1
780 ELSE
781 !find first SPMD domain on which the 4 nodes of the surface are
782 proc = intersurfl(n1,n2,n3,n4)
783 intercep(1,ni)%P(k) = proc
784 ENDIF
785 ENDDO
786 ELSEIF (flag==0.AND.ity==25.AND.ipari(100,ni) > 0)THEN ! in case of solid erosion : split interface according to element proc
787 nrtm = ipari(4,ni)
788C Allocate CEP INTERFACE
789 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
790 ALLOCATE(intercep(1,ni)%P(nrtm))
791 ENDIF
792 intercep(1,ni)%P(1:nrtm)=0
793 DO k=1,nrtm
794 ie = intbuf_tab(ni)%IELEM_M(2*(k-1)+1)
795 IF(ie > 0) THEN
796 intercep(1,ni)%P(k) = cep(ie) + 1
797 ENDIF
798 ENDDO
799 ELSEIF(ity==24.AND.flag==1.AND.ipari(86,ni) > 0) THEN
800
801C Allocate CEP INTERFACE
802 nrts = ipari(3,ni)
803
804 IF (.NOT.(ASSOCIATED(intercep(3,ni)%P)))THEN
805 ALLOCATE(intercep(3,ni)%P(nrts))
806 ENDIF
807 intercep(3,ni)%P(1:nrts)=0
808
809 DO k=1,nrts
810 ! SECND SEGMENT AND ELEMENT HAVE TO ON THE SAME MPI DOMAIN (only solids/ if other CEP(OFF+IE))
811 ie = intbuf_tab(ni)%IELNRTS(k)
812 IF(ie > 0) THEN
813 proc = cep(ie)
814 intercep(3,ni)%P(k) = proc + 1
815 ENDIF
816 ENDDO
817
818 !ENDIF INTER TYPE 7, 10, 22, 23, 24, 25
819 ELSEIF (ity==8) THEN
820 nrtm = ipari(4,ni)
821
822C Allocate CEP INTERFACE
823 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
824 ALLOCATE(intercep(1,ni)%P(nrtm))
825 ENDIF
826 intercep(1,ni)%P(1:nrtm)=0
827
828 DO k=1,nrtm
829 n1=intbuf_tab(ni)%IRECTM(4*(k-1)+1)
830 n2=intbuf_tab(ni)%IRECTM(4*(k-1)+2)
831 n3=intbuf_tab(ni)%IRECTM(4*(k-1)+3)
832 n4=intbuf_tab(ni)%IRECTM(4*(k-1)+4)
833 n1=intbuf_tab(ni)%MSR(n1)
834 n2=intbuf_tab(ni)%MSR(n2)
835 n3=intbuf_tab(ni)%MSR(n3)
836 n4=intbuf_tab(ni)%MSR(n4)
837
838 !find first SPMD domain on which the 4 nodes of the surface are
839 proc = intersurfl(n1,n2,n3,n4)
840 intercep(1,ni)%P(k) = proc
841 ENDDO
842
843 ELSEIF (ity==11) THEN
844
845 nrts = ipari(3,ni)
846 nrtm = ipari(4,ni)
847
848C Allocate CEP INTERFACE
849 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
850 ALLOCATE(intercep(1,ni)%P(nrtm))
851 ENDIF
852 IF (.NOT.(ASSOCIATED(intercep(2,ni)%P)))THEN
853 ALLOCATE(intercep(2,ni)%P(nrts))
854 ENDIF
855 intercep(1,ni)%P(1:nrtm)=0
856 intercep(2,ni)%P(1:nrts)=0
857
858 DO k=1,nrtm
859 n1 = intbuf_tab(ni)%IRECTM(2*(k-1)+1)
860 n2 = intbuf_tab(ni)%IRECTM(2*(k-1)+2)
861 !find first SPMD domain on which the 2 nodes of the surface are
862 !use same generic routine with N1=N2 and N3=N4
863 proc = intersurfl(n1,n1,n2,n2)
864 intercep(1,ni)%P(k) = proc
865 ENDDO
866
867 DO k=1,nrts
868 n1 = intbuf_tab(ni)%IRECTS(2*(k-1)+1)
869 n2 = intbuf_tab(ni)%IRECTS(2*(k-1)+2)
870 !find first SPMD domain on which the 2 nodes of the surface are
871 !use same generic routine with N1=N2 and N3=N4
872 proc = intersurfl(n1,n1,n2,n2)
873 intercep(2,ni)%P(k) = proc
874 ENDDO
875
876 !ENDIF INTER TYPE 11
877 ELSEIF (ity==20) THEN
878
879 nrtm = ipari(4,ni)
880 nlins = ipari(51,ni)
881 nlinm = ipari(52,ni)
882
883C Allocate CEP INTERFACE
884 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
885 ALLOCATE(intercep(1,ni)%P(nrtm))
886 ENDIF
887 IF (.NOT.(ASSOCIATED(intercep(2,ni)%P)))THEN
888 ALLOCATE(intercep(2,ni)%P(nlinm))
889 ENDIF
890 IF (.NOT.(ASSOCIATED(intercep(3,ni)%P)))THEN
891 ALLOCATE(intercep(3,ni)%P(nlins))
892 ENDIF
893 intercep(1,ni)%P(1:nrtm) =0
894 intercep(2,ni)%P(1:nlinm)=0
895 intercep(3,ni)%P(1:nlins)=0
896
897 DO k=1,nrtm
898 n1l = intbuf_tab(ni)%IRECTM(4*(k-1)+1)
899 n2l = intbuf_tab(ni)%IRECTM(4*(k-1)+2)
900 n3l = intbuf_tab(ni)%IRECTM(4*(k-1)+3)
901 n4l = intbuf_tab(ni)%IRECTM(4*(k-1)+4)
902 n1 = intbuf_tab(ni)%NLG(n1l)
903 n2 = intbuf_tab(ni)%NLG(n2l)
904 n3 = intbuf_tab(ni)%NLG(n3l)
905 n4 = intbuf_tab(ni)%NLG(n4l)
906 !find first SPMD domain on which the 4 nodes of the surface are
907 proc = intersurfl(n1,n2,n3,n4)
908 intercep(1,ni)%P(k) = proc
909 ENDDO
910
911 DO k=1,nlinm
912 n1l = intbuf_tab(ni)%IXLINM(2*(k-1)+1)
913 n2l = intbuf_tab(ni)%IXLINM(2*(k-1)+2)
914 n1 = intbuf_tab(ni)%NLG(n1l)
915 n2 = intbuf_tab(ni)%NLG(n2l)
916 !find first SPMD domain on which the 2 nodes of the surface are
917 !use same generic routine with N1=N2 and N3=N4
918 proc = intersurfl(n1,n1,n2,n2)
919 intercep(2,ni)%P(k) = proc
920 ENDDO
921
922 DO k=1,nlins
923 n1l = intbuf_tab(ni)%IXLINS(2*(k-1)+1)
924 n2l = intbuf_tab(ni)%IXLINS(2*(k-1)+2)
925 n1 = intbuf_tab(ni)%NLG(n1l)
926 n2 = intbuf_tab(ni)%NLG(n2l)
927 !find first SPMD domain on which the 2 nodes of the surface are
928 !use same generic routine with N1=N2 and N3=N4
929 proc = intersurfl(n1,n1,n2,n2)
930 intercep(3,ni)%P(k) = proc
931 ENDDO
932
933 !ENDIF INTER TYPE 11
934 ELSEIF (ity==21) THEN
935
936 nrts = ipari(3,ni)
937
938C Allocate CEP INTERFACE
939 IF (.NOT.(ASSOCIATED(intercep(1,ni)%P)))THEN
940 ALLOCATE(intercep(1,ni)%P(nrts))
941 ENDIF
942 intercep(1,ni)%P(1:nrts) =0
943
944 DO k=1,nrts
945 n1 = intbuf_tab(ni)%IRECTS(4*(k-1)+1)
946 n2 = intbuf_tab(ni)%IRECTS(4*(k-1)+2)
947 n3 = intbuf_tab(ni)%IRECTS(4*(k-1)+3)
948 n4 = intbuf_tab(ni)%IRECTS(4*(k-1)+4)
949 !find first SPMD domain on which the 4 nodes of the surface are
950 proc = intersurfl(n1,n2,n3,n4)
951 intercep(1,ni)%P(k) = proc
952 ENDDO
953
954 ENDIF !ENDIF INTER TYPE 21
955
956
957 ENDDO !ENDDO 1,NINTER
958