OpenRadioss 2025.1.11
OpenRadioss project
Loading...
Searching...
No Matches
spmd_i25slide.F File Reference
#include "implicit_f.inc"
#include "spmd.inc"
#include "com01_c.inc"
#include "com04_c.inc"
#include "task_c.inc"
#include "spmd_c.inc"
#include "sms_c.inc"
#include "assert.inc"
#include "scr14_c.inc"
#include "scr16_c.inc"
#include "scr18_c.inc"
#include "parit_c.inc"

Go to the source code of this file.

Functions/Subroutines

subroutine spmd_i25_slide_exch (ibuf, rbuf, isiz, rsiz, nb, comm_int, comm_real, comm_siz, mode, nin, comm_pattern)
subroutine spmd_i25_slide_gat (nsn, nin, ni25, igap, nsnr, intth, ilev, intbuf_tab, fr_nor, iad_frnor, nb_slid, itab, h3d_data, intfric, flagremn, lremnormax, nrtm, ivis2, istif_msdt, ifsub_carea, nodadt_therm)
subroutine reallocate_fi1 (new_size, tmp, nin, intth, igap, ilev, intfric, flagremn, ivis2, istif_msdt, ifsub_carea)
subroutine deallocate_fi1_tmp (new_size, tmp, nin, intth, igap, ilev, intfric, flagremn, ivis2, istif_msdt, ifsub_carea)
subroutine reallocate_fi2 (nin, intth, nodfi, lskyfi, h3d_data, nodadt_therm)
subroutine check_fi ()

Function/Subroutine Documentation

◆ check_fi()

subroutine check_fi

Definition at line 1664 of file spmd_i25slide.F.

1665C use for debug only
1666C
1667C M o d u l e s
1668C-----------------------------------------------
1669 USE tri7box
1670 USE tri25tmp
1671 USE message_mod
1672C-----------------------------------------------
1673C I m p l i c i t T y p e s
1674C-----------------------------------------------
1675 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1676#include "implicit_f.inc"
1677C-----------------------------------------------
1678C C o m m o n B l o c k s
1679C-----------------------------------------------
1680#include "task_c.inc"
1681C-----------------------------------------------
1682C L o c a l V a r i a b l e s
1683C-----------------------------------------------
1684
1685 IF(ispmd == 1) THEN
1686 IF(abs(nsvfi(1)%P(2)) == 5864) THEN
1687 WRITE(6,*) __file__,__line__
1688 ENDIF
1689 ENDIF
1690
1691 RETURN
message_mod
Definition message_mod.F:1249
tri7box::nsvfi
type(int_pointer), dimension(:), allocatable nsvfi
Definition tri7box.F:431

◆ deallocate_fi1_tmp()

subroutine deallocate_fi1_tmp ( integer, intent(in) new_size,
type(i25_tmp_struct) tmp,
integer, intent(in) nin,
integer, intent(in) intth,
integer, intent(in) igap,
integer, intent(in) ilev,
integer, intent(in) intfric,
integer, intent(in) flagremn,
integer, intent(in) ivis2,
integer, intent(in) istif_msdt,
integer, intent(in) ifsub_carea )

Definition at line 1327 of file spmd_i25slide.F.

1329C-----------------------------------------------
1330C M o d u l e s
1331C-----------------------------------------------
1332 USE tri7box
1333 USE tri25tmp
1334 USE message_mod
1335C-----------------------------------------------
1336C I m p l i c i t T y p e s
1337C-----------------------------------------------
1338 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1339#include "implicit_f.inc"
1340C-----------------------------------------------
1341C C o m m o n B l o c k s
1342C-----------------------------------------------
1343#include "sms_c.inc"
1344C-----------------------------------------------
1345C D u m m y A r g u m e n t s
1346C-----------------------------------------------
1347 INTEGER, INTENT(IN) :: NEW_SIZE,NIN,INTTH,IGAP,ILEV,INTFRIC,FLAGREMN,IVIS2
1348 INTEGER, INTENT(IN) :: ISTIF_MSDT, IFSUB_CAREA
1349 TYPE(I25_TMP_STRUCT) TMP
1350C-----------------------------------------------
1351C L o c a l V a r i a b l e s
1352C-----------------------------------------------
1353
1354 IF(.NOT.ASSOCIATED(tmp%NSVFI%P))RETURN
1355 DEALLOCATE(tmp%NSNFI%P)
1356 DEALLOCATE(tmp%NSVFI%P)
1357 DEALLOCATE(tmp%XFI%P)
1358 DEALLOCATE(tmp%VFI%P)
1359 DEALLOCATE(tmp%MSFI%P)
1360 DEALLOCATE(tmp%STIFI%P)
1361 DEALLOCATE(tmp%ITAFI%P)
1362 DEALLOCATE(tmp%PMAINFI%P)
1363 DEALLOCATE(tmp%KINFI%P)
1364 IF(.true.) THEN
1365 DEALLOCATE(tmp%ICODT_FI%P)
1366 DEALLOCATE(tmp%ISKEW_FI%P)
1367 ENDIF
1368 IF(intth > 0 ) THEN
1369 DEALLOCATE(tmp%TEMPFI%P)
1370 DEALLOCATE(tmp%MATSFI%P)
1371 DEALLOCATE(tmp%AREASFI%P)
1372 ENDIF
1373 IF(ivis2==-1) THEN
1374 IF(intth==0) DEALLOCATE(tmp%AREASFI%P)
1375 DEALLOCATE(tmp%IF_ADHFI%P)
1376 ENDIF
1377 IF(intfric > 0 ) THEN
1378 DEALLOCATE(tmp%IPARTFRICSFI%P)
1379 ENDIF
1380 IF(istif_msdt > 0 ) THEN
1381 DEALLOCATE(tmp%STIF_MSDT_FI%P)
1382 ENDIF
1383 IF(ifsub_carea > 0 ) THEN
1384 DEALLOCATE(tmp%INTAREANFI%P)
1385 ENDIF
1386 IF(idtmins == 2) THEN
1387 DEALLOCATE(tmp%NODNXFI%P)
1388 DEALLOCATE(tmp%NODAMSFI%P)
1389 DEALLOCATE(tmp%PROCAMSFI%P)
1390 ELSEIF(idtmins_int /= 0) THEN
1391 DEALLOCATE(tmp%NODAMSFI%P)
1392 DEALLOCATE(tmp%PROCAMSFI%P)
1393 ENDIF
1394 IF(igap/=0) THEN
1395 DEALLOCATE(tmp%GAPFI%P)
1396 IF(igap==3) THEN
1397 DEALLOCATE(tmp%GAP_LFI%P)
1398 ENDIF
1399 ENDIF
1400 IF(ilev == 2 .AND. ASSOCIATED(tmp%NBINFLFI%P)) THEN
1401 DEALLOCATE(tmp%NBINFLFI%P)
1402 ENDIF
1403 DEALLOCATE(tmp%IRTLM_FI%P)
1404 DEALLOCATE(tmp%TIME_SFI%P)
1405 DEALLOCATE(tmp%SECND_FRFI%P)
1406
1407 DEALLOCATE(tmp%PENE_OLDFI%P)
1408
1409 DEALLOCATE(tmp%STIF_OLDFI%P)
1410
1411 DEALLOCATE(tmp%ICONT_I_FI%P)
1412 DEALLOCATE(tmp%ISLIDE_FI%P)
1413 IF(flagremn == 2) THEN
1414 IF(ASSOCIATED(tmp%REMNOR_FI%P)) DEALLOCATE(tmp%REMNOR_FI%P)
1415 IF(ASSOCIATED(tmp%KREMNOR_FI%P)) DEALLOCATE(tmp%KREMNOR_FI%P)
1416 ENDIF
1417C
1418
1419 RETURN

◆ reallocate_fi1()

subroutine reallocate_fi1 ( integer, intent(in) new_size,
type(i25_tmp_struct) tmp,
integer, intent(in) nin,
integer, intent(in) intth,
integer, intent(in) igap,
integer, intent(in) ilev,
integer, intent(in) intfric,
integer, intent(in) flagremn,
integer, intent(in) ivis2,
integer, intent(in) istif_msdt,
integer, intent(in) ifsub_carea )

Definition at line 1146 of file spmd_i25slide.F.

1148C-----------------------------------------------
1149C M o d u l e s
1150C-----------------------------------------------
1151 USE tri7box
1152 USE tri25tmp
1153 USE message_mod
1154C-----------------------------------------------
1155C I m p l i c i t T y p e s
1156C-----------------------------------------------
1157 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1158#include "implicit_f.inc"
1159#include "assert.inc"
1160C-----------------------------------------------
1161C C o m m o n B l o c k s
1162C-----------------------------------------------
1163#include "com01_c.inc"
1164#include "sms_c.inc"
1165C-----------------------------------------------
1166C D u m m y A r g u m e n t s
1167C-----------------------------------------------
1168 INTEGER, INTENT(IN) :: NEW_SIZE,NIN,INTTH,IGAP,ILEV,INTFRIC,FLAGREMN,
1169 . IVIS2
1170 INTEGER, INTENT(IN) :: ISTIF_MSDT, IFSUB_CAREA
1171 TYPE(I25_TMP_STRUCT) TMP
1172C-----------------------------------------------
1173C L o c a l V a r i a b l e s
1174C-----------------------------------------------
1175
1176 tmp%NSNFI%P=>nsnfi(nin)%P
1177 tmp%NSVFI%P=>nsvfi(nin)%P
1178 tmp%PMAINFI%P=>pmainfi(nin)%P
1179 tmp%XFI%P=>xfi(nin)%P
1180 tmp%VFI%P=>vfi(nin)%P
1181 tmp%MSFI%P=>msfi(nin)%P
1182 tmp%STIFI%P=>stifi(nin)%P
1183 tmp%ITAFI%P=>itafi(nin)%P
1184 tmp%KINFI%P=>kinfi(nin)%P
1185
1186
1187 IF(.true.) THEN
1188 tmp%ICODT_FI%P=>icodt_fi(nin)%P
1189 tmp%ISKEW_FI%P=>iskew_fi(nin)%P
1190 ENDIF
1191 IF(intth > 0 ) THEN
1192 tmp%TEMPFI%P=>tempfi(nin)%P
1193 tmp%MATSFI%P=>matsfi(nin)%P
1194 tmp%AREASFI%P=>areasfi(nin)%P
1195 ENDIF
1196 IF(ivis2==-1) THEN
1197 IF(intth==0) tmp%AREASFI%P=>areasfi(nin)%P
1198 tmp%IF_ADHFI%P=>if_adhfi(nin)%P
1199 ENDIF
1200 IF(intfric > 0 ) THEN
1201 tmp%IPARTFRICSFI%P=>ipartfricsfi(nin)%P
1202 ENDIF
1203 IF(istif_msdt > 0 ) THEN
1204 tmp%STIF_MSDT_FI%P=>stif_msdt_fi(nin)%P
1205 ENDIF
1206 IF(ifsub_carea > 0 ) THEN
1207 tmp%INTAREANFI%P=>intareanfi(nin)%P
1208 ENDIF
1209 IF(idtmins == 2) THEN
1210 tmp%NODNXFI%P=>nodnxfi(nin)%P
1211 tmp%NODAMSFI%P=>nodamsfi(nin)%P
1212 tmp%PROCAMSFI%P=>procamsfi(nin)%P
1213 ELSEIF(idtmins_int /= 0) THEN
1214 tmp%NODAMSFI%P=>nodamsfi(nin)%P
1215 tmp%PROCAMSFI%P=>procamsfi(nin)%P
1216 ENDIF
1217 IF(igap/=0) THEN
1218 tmp%GAPFI%P=>gapfi(nin)%P
1219 IF(igap==3) THEN
1220 tmp%GAP_LFI%P=>gap_lfi(nin)%P
1221 ENDIF
1222 ENDIF
1223
1224
1225 IF(ilev == 2) THEN
1226 tmp%NBINFLFI%P=>nbinflfi(nin)%P
1227 ENDIF
1228 tmp%IRTLM_FI%P=>irtlm_fi(nin)%P
1229 tmp%TIME_SFI%P=>time_sfi(nin)%P
1230 tmp%SECND_FRFI%P=>secnd_frfi(nin)%P
1231 tmp%PENE_OLDFI%P=>pene_oldfi(nin)%P
1232 tmp%STIF_OLDFI%P=>stif_oldfi(nin)%P
1233 tmp%ICONT_I_FI%P=>icont_i_fi(nin)%P
1234 tmp%ISLIDE_FI%P=>islide_fi(nin)%P
1235 IF(flagremn == 2) THEN
1236 tmp%REMNOR_FI%P=>remnor_fi(nin)%P
1237 tmp%KREMNOR_FI%P=>kremnor_fi(nin)%P
1238 ENDIF
1239C
1240
1241 assert(new_size >= 0)
1242
1243 nullify(nsnfi(nin)%P)
1244 nullify(nsvfi(nin)%P)
1245 nullify(xfi(nin)%P)
1246 nullify(vfi(nin)%P)
1247
1248C WRITE(6,*) "NEW SIZE:",NEW_SIZE
1249
1250 ALLOCATE(nsnfi(nin)%P(nspmd))
1251 ALLOCATE(nsvfi(nin)%P(new_size))
1252 ALLOCATE(msfi(nin)%P(new_size))
1253 ALLOCATE(stifi(nin)%P(new_size))
1254 ALLOCATE(itafi(nin)%P(new_size))
1255 ALLOCATE(pmainfi(nin)%P(new_size))
1256 ALLOCATE(kinfi(nin)%P(new_size))
1257 ALLOCATE(vfi(nin)%P(3,new_size))
1258 ALLOCATE(xfi(nin)%P(3,new_size))
1259 IF(.true.) THEN
1260 ALLOCATE(icodt_fi(nin)%P(new_size))
1261 ALLOCATE(iskew_fi(nin)%P(new_size))
1262 ENDIF
1263 IF(intth > 0 ) THEN
1264 ALLOCATE(tempfi(nin)%P(new_size))
1265 ALLOCATE(matsfi(nin)%P(new_size))
1266 ALLOCATE(areasfi(nin)%P(new_size))
1267 ENDIF
1268 IF(ivis2==-1) THEN
1269 IF(intth==0) ALLOCATE(areasfi(nin)%P(new_size))
1270 ALLOCATE(if_adhfi(nin)%P(new_size))
1271 ENDIF
1272 IF(intfric > 0 ) THEN
1273 ALLOCATE(ipartfricsfi(nin)%P(new_size))
1274 ENDIF
1275 IF(istif_msdt > 0 ) THEN
1276 ALLOCATE(stif_msdt_fi(nin)%P(new_size))
1277 ENDIF
1278 IF(ifsub_carea > 0 ) THEN
1279 ALLOCATE(intareanfi(nin)%P(new_size))
1280 ENDIF
1281 IF(idtmins == 2) THEN
1282 ALLOCATE(nodnxfi(nin)%P(new_size))
1283 ALLOCATE(nodamsfi(nin)%P(new_size))
1284 ALLOCATE(procamsfi(nin)%P(new_size))
1285 ELSEIF(idtmins_int /= 0) THEN
1286 ALLOCATE(nodamsfi(nin)%P(new_size))
1287 ALLOCATE(procamsfi(nin)%P(new_size))
1288 ENDIF
1289 IF(igap/=0) THEN
1290 ALLOCATE(gapfi(nin)%P(new_size))
1291 IF(igap==3) THEN
1292 ALLOCATE(gap_lfi(nin)%P(new_size))
1293 ENDIF
1294 ENDIF
1295 IF(ilev == 2 ) THEN
1296 ALLOCATE(nbinflfi(nin)%P(new_size))
1297 ENDIF
1298 ALLOCATE(irtlm_fi(nin)%P(4,new_size))
1299 ALLOCATE(time_sfi(nin)%P(2*new_size))
1300 ALLOCATE(secnd_frfi(nin)%P(6,new_size))
1301 secnd_frfi(nin)%P (1:6,1:new_size)=zero
1302 ALLOCATE(pene_oldfi(nin)%P(5,new_size))
1303 pene_oldfi(nin)%P(1:5,1:new_size)=zero
1304 ALLOCATE(stif_oldfi(nin)%P(2,new_size))
1305 stif_oldfi(nin)%P(1:2,1:new_size)=zero
1306 ALLOCATE(icont_i_fi(nin)%P(new_size))
1307 ALLOCATE(islide_fi(nin)%P(4,new_size))
1308 IF(flagremn == 2) THEN
1309 ALLOCATE(kremnor_fi(nin)%P(new_size+1))
1310 kremnor_fi(nin)%P(1:new_size+1) = 0
1311 ENDIF
1312C
1313C
1314
1315 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::time_sfi
type(real_pointer), dimension(:), allocatable time_sfi
Definition tri7box.F:542
tri7box::vfi
type(real_pointer2), dimension(:), allocatable vfi
Definition tri7box.F:459
tri7box::irtlm_fi
type(int_pointer2), dimension(:), allocatable irtlm_fi
Definition tri7box.F:533
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::kremnor_fi
type(int_pointer), dimension(:), allocatable kremnor_fi
Definition tri7box.F:549
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::remnor_fi
type(int_pointer), dimension(:), allocatable remnor_fi
Definition tri7box.F:548
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::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::nbinflfi
type(int_pointer), dimension(:), allocatable nbinflfi
Definition tri7box.F:440
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::procamsfi
type(int_pointer), dimension(:), allocatable procamsfi
Definition tri7box.F:440
tri7box::islide_fi
type(int_pointer2), dimension(:), allocatable islide_fi
Definition tri7box.F:547
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::nsnfi
type(int_pointer), dimension(:), allocatable nsnfi
Definition tri7box.F:440
tri7box::if_adhfi
type(int_pointer), dimension(:), allocatable if_adhfi
Definition tri7box.F:440
tri7box::itafi
type(int_pointer), dimension(:), allocatable itafi
Definition tri7box.F:440

◆ reallocate_fi2()

subroutine reallocate_fi2 ( integer, intent(in) nin,
integer, intent(in) intth,
integer, intent(in) nodfi,
integer, intent(in) lskyfi,
type(h3d_database) h3d_data,
integer, intent(in) nodadt_therm )

Definition at line 1436 of file spmd_i25slide.F.

1437C
1438C
1439C
1440C-----------------------------------------------
1441C M o d u l e s
1442C-----------------------------------------------
1443 USE tri7box
1444 USE message_mod
1445 USE h3d_mod
1446C-----------------------------------------------
1447C I m p l i c i t T y p e s
1448C-----------------------------------------------
1449 USE spmd_comm_world_mod, ONLY : spmd_comm_world
1450#include "implicit_f.inc"
1451C-----------------------------------------------
1452C C o m m o n B l o c k s
1453C-----------------------------------------------
1454#include "task_c.inc"
1455#include "scr14_c.inc"
1456#include "scr16_c.inc"
1457#include "scr18_c.inc"
1458#include "parit_c.inc"
1459C-----------------------------------------------
1460C D u m m y A r g u m e n t s
1461C-----------------------------------------------
1462 INTEGER, INTENT(IN) :: NIN, INTTH, NODFI, LSKYFI
1463 INTEGER, INTENT(IN) :: NODADT_THERM
1464 TYPE(H3D_DATABASE) :: H3D_DATA
1465C-----------------------------------------------
1466C L o c a l V a r i a b l e s
1467C-----------------------------------------------
1468 INTEGER I,J,IERROR1,IERROR2,IERROR3,IERROR4
1469
1470 ierror1 = 0
1471 ierror2 = 0
1472 ierror3 = 0
1473 ierror4 = 0
1474
1475 IF(intth == 0 ) THEN
1476C
1477C Allocation Parith/OFF
1478C
1479 IF(iparit==0) THEN
1480
1481 IF(ASSOCIATED(afi(nin)%P)) THEN
1482 DEALLOCATE(afi(nin)%P)
1483 NULLIFY(afi(nin)%P)
1484 ENDIF
1485 IF(ASSOCIATED(stnfi(nin)%P)) THEN
1486 DEALLOCATE(stnfi(nin)%P)
1487 NULLIFY(afi(nin)%P)
1488 ENDIF
1489
1490 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
1491 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
1492C Init a 0
1493 DO i = 1, nodfi*nthread
1494 afi(nin)%P(1,i) = zero
1495 afi(nin)%P(2,i) = zero
1496 afi(nin)%P(3,i) = zero
1497 stnfi(nin)%P(i) = zero
1498 ENDDO
1499C
1500 IF(kdtint/=0)THEN
1501 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
1502 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi*nthread),stat=ierror3)
1503C Init a 0
1504 DO i = 1, nodfi*nthread
1505 vscfi(nin)%P(i) = zero
1506 ENDDO
1507 ENDIF
1508 nlskyfi(nin) = nodfi
1509C
1510 ELSE
1511C
1512C Allocation Parith/ON
1513C
1514 IF(ASSOCIATED(fskyfi(nin)%P)) DEALLOCATE(fskyfi(nin)%P)
1515 IF(ASSOCIATED(iskyfi(nin)%P)) DEALLOCATE(iskyfi(nin)%P)
1516 nlskyfi(nin) = lskyfi
1517 IF(lskyfi>0) THEN
1518 ALLOCATE(iskyfi(nin)%P(lskyfi),stat=ierror1)
1519 IF(kdtint==0) THEN
1520 ALLOCATE(fskyfi(nin)%P(4,lskyfi),stat=ierror2)
1521 ELSE
1522 ALLOCATE(fskyfi(nin)%P(5,lskyfi),stat=ierror2)
1523 ENDIF
1524 ENDIF
1525 ENDIF
1526 ELSE
1527C
1528C Allocation Parith/OFF
1529C
1530 IF(iparit==0) THEN
1531 IF(ASSOCIATED(afi(nin)%P)) DEALLOCATE(afi(nin)%P)
1532 IF(ASSOCIATED(stnfi(nin)%P)) DEALLOCATE(stnfi(nin)%P)
1533 IF(ASSOCIATED(fthefi(nin)%P)) DEALLOCATE(fthefi(nin)%P)
1534 IF(nodfi>0)ALLOCATE(afi(nin)%P(3,nodfi*nthread),stat=ierror1)
1535 IF(nodfi>0)ALLOCATE(stnfi(nin)%P(nodfi*nthread),stat=ierror2)
1536 IF(nodfi>0)ALLOCATE(fthefi(nin)%P(nodfi*nthread),stat=ierror3)
1537C
1538 IF(nodadt_therm ==1) THEN
1539 IF(ASSOCIATED(condnfi(nin)%P)) DEALLOCATE(condnfi(nin)%P)
1540 IF(nodfi>0.AND.nodadt_therm ==1)ALLOCATE(condnfi(nin)%P(nodfi*nthread),stat=ierror4)
1541 ENDIF
1542C
1543
1544
1545C Init a 0
1546
1547 DO i = 1, nodfi*nthread
1548 afi(nin)%P(1,i) = zero
1549 afi(nin)%P(2,i) = zero
1550 afi(nin)%P(3,i) = zero
1551 stnfi(nin)%P(i) = zero
1552 fthefi(nin)%P(i) = zero
1553 ENDDO
1554 IF(nodadt_therm ==1) THEN
1555 DO i = 1, nodfi
1556 condnfi(nin)%P(i) = zero
1557 ENDDO
1558 ENDIF
1559C
1560 IF(kdtint/=0)THEN
1561 IF(ASSOCIATED(vscfi(nin)%P)) DEALLOCATE(vscfi(nin)%P)
1562 IF(nodfi>0)ALLOCATE(vscfi(nin)%P(nodfi),stat=ierror4)
1563C Init a 0
1564 DO i = 1, nodfi
1565 vscfi(nin)%P(i) = zero
1566 ENDDO
1567 ENDIF
1568C
1569 ELSE
1570C
1571C Allocation Parith/ON
1572C
1573 IF(ASSOCIATED(fskyfi(nin)%P)) DEALLOCATE(fskyfi(nin)%P)
1574 IF(ASSOCIATED(iskyfi(nin)%P)) DEALLOCATE(iskyfi(nin)%P)
1575 IF(ASSOCIATED(ftheskyfi(nin)%P)) DEALLOCATE(ftheskyfi(nin)%P)
1576 nlskyfi(nin) = lskyfi
1577 IF(lskyfi>0) THEN
1578 ALLOCATE(iskyfi(nin)%P(lskyfi),stat=ierror1)
1579 IF(kdtint==0) THEN
1580 ALLOCATE(fskyfi(nin)%P(4,lskyfi),stat=ierror2)
1581 ALLOCATE(ftheskyfi(nin)%P(lskyfi),stat=ierror3)
1582 ELSE
1583 ALLOCATE(fskyfi(nin)%P(5,lskyfi),stat=ierror2)
1584 ALLOCATE(ftheskyfi(nin)%P(lskyfi),stat=ierror3)
1585 ENDIF
1586
1587 ENDIF
1588C
1589 IF(nodadt_therm ==1) THEN
1590 IF(ASSOCIATED(condnskyfi(nin)%P)) DEALLOCATE(condnskyfi(nin)%P)
1591 IF(lskyfi>0) ALLOCATE(condnskyfi(nin)%P(lskyfi),stat=ierror4)
1592 ENDIF
1593C
1594
1595 ENDIF
1596 ENDIF
1597C
1598 IF(ierror1+ierror2+ierror3+ierror4/=0) THEN
1599 CALL ancmsg(msgid=20,anmode=aninfo)
1600 CALL arret(2)
1601 ENDIF
1602C
1603C allocations conditionnelles output pression/ friction energy
1604C
1605 IF(anim_v(12)+outp_v(12)+h3d_data%N_VECT_PCONT >0)THEN
1606 IF(ASSOCIATED(fnconti(nin)%P)) DEALLOCATE(fnconti(nin)%P)
1607 IF(ASSOCIATED(ftconti(nin)%P)) DEALLOCATE(ftconti(nin)%P)
1608 ALLOCATE(fnconti(nin)%P(3,nodfi),stat=ierror1)
1609 ALLOCATE(ftconti(nin)%P(3,nodfi),stat=ierror2)
1610 IF(ierror1+ierror2/=0) THEN
1611 CALL ancmsg(msgid=20,anmode=aninfo)
1612 CALL arret(2)
1613 ELSE
1614 DO j = 1, nodfi
1615 fnconti(nin)%P(1,j)=zero
1616 fnconti(nin)%P(2,j)=zero
1617 fnconti(nin)%P(3,j)=zero
1618 ftconti(nin)%P(1,j)=zero
1619 ftconti(nin)%P(2,j)=zero
1620 ftconti(nin)%P(3,j)=zero
1621 END DO
1622 END IF
1623 END IF
1624C
1625 IF(h3d_data%N_SCAL_CSE_FRICINT >0)THEN
1626 IF(h3d_data%N_CSE_FRIC_INTER (nin) >0)THEN
1627 IF(ASSOCIATED(efricfi(nin)%P)) DEALLOCATE(efricfi(nin)%P)
1628 ALLOCATE(efricfi(nin)%P(nodfi),stat=ierror1)
1629 IF(ierror1/=0) THEN
1630 CALL ancmsg(msgid=20,anmode=aninfo)
1631 CALL arret(2)
1632 ELSE
1633 DO j = 1, nodfi
1634 efricfi(nin)%P(j)=zero
1635 END DO
1636 END IF
1637 END IF
1638 ENDIF
1639C
1640 IF(h3d_data%N_SCAL_CSE_FRIC >0)THEN
1641 IF(ASSOCIATED(efricgfi(nin)%P)) DEALLOCATE(efricgfi(nin)%P)
1642 ALLOCATE(efricgfi(nin)%P(nodfi),stat=ierror1)
1643 IF(ierror1/=0) THEN
1644 CALL ancmsg(msgid=20,anmode=aninfo)
1645 CALL arret(2)
1646 ELSE
1647 DO j = 1, nodfi
1648 efricgfi(nin)%P(j)=zero
1649 END DO
1650 END IF
1651 END IF
1652
1653 RETURN
h3d_mod
Definition h3d_mod.F:308
tri7box::condnfi
type(real_pointer), dimension(:), allocatable condnfi
Definition tri7box.F:449
tri7box::ftheskyfi
type(real_pointer), dimension(:), allocatable ftheskyfi
Definition tri7box.F:449
tri7box::fnconti
type(real_pointer2), dimension(:), allocatable fnconti
Definition tri7box.F:510
tri7box::efricgfi
type(real_pointer), dimension(:), allocatable efricgfi
Definition tri7box.F:511
tri7box::condnskyfi
type(real_pointer), dimension(:), allocatable condnskyfi
Definition tri7box.F:449
tri7box::stnfi
type(real_pointer), dimension(:), allocatable stnfi
Definition tri7box.F:449
tri7box::afi
type(real_pointer2), dimension(:), allocatable afi
Definition tri7box.F:459
tri7box::fskyfi
type(real_pointer2), dimension(:), allocatable fskyfi
Definition tri7box.F:459
tri7box::iskyfi
type(int_pointer), dimension(:), allocatable iskyfi
Definition tri7box.F:480
tri7box::efricfi
type(real_pointer), dimension(:), allocatable efricfi
Definition tri7box.F:511
tri7box::vscfi
type(real_pointer), dimension(:), allocatable vscfi
Definition tri7box.F:449
tri7box::nlskyfi
integer, dimension(:), allocatable nlskyfi
Definition tri7box.F:512
tri7box::fthefi
type(real_pointer), dimension(:), allocatable fthefi
Definition tri7box.F:449
tri7box::ftconti
type(real_pointer2), dimension(:), allocatable ftconti
Definition tri7box.F:510
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

◆ spmd_i25_slide_exch()

subroutine spmd_i25_slide_exch ( type(int_pointer), dimension(nspmd,ninter25) ibuf,
type(real_pointer), dimension(nspmd,ninter25) rbuf,
integer, intent(in) isiz,
integer, intent(in) rsiz,
integer, dimension(nspmd,ninter25), intent(inout) nb,
type(mpi_comm_struct) comm_int,
type(mpi_comm_struct) comm_real,
type(mpi_comm_struct) comm_siz,
integer, intent(in) mode,
integer, intent(in) nin,
integer, dimension(nspmd,ninter25), intent(in) comm_pattern )

Definition at line 34 of file spmd_i25slide.F.

37C-----------------------------------------------
38C M o d u l e s
39C-----------------------------------------------
40 USE message_mod
41 USE mpi_commod
42 USE pointerdef
43C-----------------------------------------------
44C I m p l i c i t T y p e s
45C-----------------------------------------------
46 USE spmd_comm_world_mod, ONLY : spmd_comm_world
47#include "implicit_f.inc"
48C-----------------------------------------------
49C M e s s a g e P a s s i n g
50C-----------------------------------------------
51#include "spmd.inc"
52C-----------------------------------------------
53C C o m m o n B l o c k s
54C-----------------------------------------------
55#include "com01_c.inc"
56#include "com04_c.inc"
57#include "task_c.inc"
58C-----------------------------------------------
59C D u m m y A r g u m e n t s
60C-----------------------------------------------
61 INTEGER, INTENT(IN) :: MODE
62 ! MODE 0 => ISEND sizes
63 ! MODE 1 => ISEND buffer
64 ! MODE 2 => Receive the sizes
65 ! MODE 3 => Receive the messages
66 ! MODE 4 => Deallocate Recv buffer
67 ! MODE 5 => Deallocate Send buffer
68 INTEGER, INTENT(IN) :: NIN ! Interface number
69 INTEGER, INTENT(IN) :: RSIZ,ISIZ
70 ! Real and Integer buffer size
71 INTEGER, INTENT(INOUT) :: NB(NSPMD,NINTER25)
72 ! Number of secnds node to exchange (send or recv depending on MODE)
73 INTEGER, INTENT(IN) :: COMM_PATTERN(NSPMD,NINTER25)
74 ! COMM_PATTERN(P,NIN) == 1 => Proc ISPMD and P shares nodes in NIN interface
75
76
77 ! Communication structures
78 TYPE(MPI_COMM_STRUCT):: COMM_INT
79 TYPE(MPI_COMM_STRUCT):: COMM_REAL
80 TYPE(MPI_COMM_STRUCT):: COMM_SIZ
81
82 ! Buffers
83 TYPE(real_pointer), DIMENSION(NSPMD,NINTER25) :: RBUF
84 TYPE(int_pointer) , DIMENSION(NSPMD,NINTER25) :: IBUF
85 INTEGER MSGTYP
86C-----------------------------------------------
87C L o c a l V a r i a b l e s
88C-----------------------------------------------
89 INTEGER IERROR
90 INTEGER P,PP,LOC_PROC
91 INTEGER LENGTH
92 INTEGER MSGOFF1,MSGOFF2,MSGOFF3
93 INTEGER NBCOM
94 DATA msgoff1/2400/
95 DATA msgoff2/2500/
96 DATA msgoff3/2600/
97
98
99
100#ifdef MPI
101 INTEGER STATUS (MPI_STATUS_SIZE)
102
103 loc_proc = ispmd + 1
104
105 IF(mode == 0) THEN
106 !SEND sizes
107 DO p = 1, nspmd
108 IF(p /= loc_proc .AND. comm_pattern(p,nin) == 1) THEN
109 msgtyp = msgoff1
110 comm_siz%SIZ(p,nin) = 1
111 comm_siz%TAG(p,nin) = msgtyp
112 CALL mpi_isend(
113 1 nb(p,nin),1,mpi_integer,it_spmd(p),msgtyp,
114 2 spmd_comm_world,comm_siz%SEND_RQ(p,nin),ierror)
115 ELSE
116 comm_siz%SEND_RQ(p,nin) = mpi_request_null
117 ENDIF
118 ENDDO
119 ELSE IF(mode == 1) THEN
120 !SEND
121 DO p = 1, nspmd
122 IF(p /= loc_proc .AND. comm_pattern(p,nin) == 1) THEN
123 IF(nb(p,nin) > 0) THEN
124 length = nb(p,nin)*rsiz
125 msgtyp = msgoff2
126 comm_real%SIZ(p,nin) = length
127 comm_real%TAG(p,nin) = msgtyp
128
129 CALL mpi_isend(
130 1 rbuf(p,nin)%P(1),length,real,it_spmd(p),msgtyp,
131 2 spmd_comm_world,comm_real%SEND_RQ(p,nin),ierror)
132
133 msgtyp = msgoff3
134 length = nb(p,nin) * isiz
135 comm_int%SIZ(p,nin) = length
136 comm_int%TAG(p,nin) = msgtyp
137 CALL mpi_isend(
138 1 ibuf(p,nin)%P(1),length,mpi_integer,it_spmd(p),msgtyp,
139 2 spmd_comm_world,comm_int%SEND_RQ(p,nin),ierror)
140 ELSE
141 comm_int%SEND_RQ(p,nin) = mpi_request_null
142 comm_real%SEND_RQ(p,nin) = mpi_request_null
143 ENDIF
144 ENDIF
145 ENDDO
146 ELSEIF(mode==2) THEN
147 !RECV SIZES
148 DO p = 1, nspmd
149 IF( p/=loc_proc .AND. comm_pattern(p,nin) == 1) THEN
150 msgtyp = msgoff1
151 comm_real%SIZ(p,nin) = 1
152
153 CALL mpi_irecv(
154 1 nb(p,nin),1,mpi_integer,it_spmd(p),msgtyp,
155 2 spmd_comm_world,comm_siz%RECV_RQ(p,nin),ierror)
156 ELSE
157 comm_siz%RECV_RQ(p,nin) = mpi_request_null
158 ENDIF
159 ENDDO
160
161 ELSEIF(mode == 3) THEN
162 !WAIT
163 nbcom = 0
164 DO p = 1,nspmd
165 comm_real%SIZ(p,nin) = 0
166 comm_int%SIZ(p,nin) = 0
167 IF(p/= loc_proc .AND. comm_pattern(p,nin) == 1) nbcom = nbcom + 1
168 ENDDO
169
170 DO pp = 1,nbcom
171C IF(P/= LOC_PROC .AND. COMM_PATTERN(P,NIN) == 1) THEN
172C CALL MPI_WAIT(COMM_SIZ%RECV_RQ(P,NIN),STATUS,IERROR)
173 CALL mpi_waitany(nspmd,comm_siz%RECV_RQ(1:nspmd,nin),p,status,ierror)
174
175 IF(nb(p,nin) > 0) THEN
176 length = nb(p,nin)*rsiz
177 msgtyp = msgoff2
178 comm_real%SIZ(p,nin) = nb(p,nin)
179 ALLOCATE(rbuf(p,nin)%P(length))
180 rbuf(p,nin)%P(1:length) = 0
181
182 CALL mpi_recv(
183 1 rbuf(p,nin)%P(1),length,real,it_spmd(p),msgtyp,
184 2 spmd_comm_world,status,ierror)
185
186 length = nb(p,nin)*isiz
187 msgtyp = msgoff3
188 comm_int%SIZ(p,nin) = nb(p,nin)
189
190 ALLOCATE(ibuf(p,nin)%P(length))
191 ibuf(p,nin)%P(1:length) = 0
192
193 CALL mpi_recv(
194 1 ibuf(p,nin)%P(1),length,mpi_integer,it_spmd(p),msgtyp,
195 2 spmd_comm_world,status,ierror)
196 ENDIF
197C ENDIF
198 ENDDO
199
200 ELSEIF(mode == 4) THEN
201 !CLEAN
202 DO p = 1, nspmd
203 IF(nb(p,nin) > 0 .AND. comm_pattern(p,nin) == 1) THEN
204 DEALLOCATE(ibuf(p,nin)%P)
205 DEALLOCATE(rbuf(p,nin)%P)
206 ENDIF
207 ENDDO
208 ELSEIF(mode == 5) THEN
209 !CLEAN
210 DO p = 1, nspmd
211 IF(p /= loc_proc .AND. comm_pattern(p,nin) == 1) THEN
212 CALL mpi_wait(comm_siz%SEND_RQ(p,nin),status,ierror)
213 ENDIF
214 IF(nb(p,nin) > 0 .AND. comm_pattern(p,nin) == 1) THEN
215 CALL mpi_wait(comm_int%SEND_RQ(p,nin),status,ierror)
216 DEALLOCATE(ibuf(p,nin)%P)
217 CALL mpi_wait(comm_real%SEND_RQ(p,nin),status,ierror)
218 DEALLOCATE(rbuf(p,nin)%P)
219 ENDIF
220 ENDDO
221 ENDIF
222
223#endif
224 RETURN
mpi_recv
subroutine mpi_recv(buf, cnt, datatype, source, tag, comm, status, ierr)
Definition mpi.f:461
mpi_isend
subroutine mpi_isend(buf, cnt, datatype, dest, tag, comm, ireq, ierr)
Definition mpi.f:382
mpi_wait
subroutine mpi_wait(ireq, status, ierr)
Definition mpi.f:525
mpi_waitany
subroutine mpi_waitany(cnt, array_of_requests, index, status, ierr)
Definition mpi.f:549
mpi_irecv
subroutine mpi_irecv(buf, cnt, datatype, source, tag, comm, ireq, ierr)
Definition mpi.f:372
mpi_commod
Definition mpi_comm_mod.F:37

◆ spmd_i25_slide_gat()

subroutine spmd_i25_slide_gat ( integer, intent(in) nsn,
integer, intent(in) nin,
integer, intent(in) ni25,
integer, intent(in) igap,
integer, intent(inout) nsnr,
integer, intent(in) intth,
integer, intent(in) ilev,
type(intbuf_struct_) intbuf_tab,
integer, dimension(*) fr_nor,
integer, dimension(ninter25,nspmd+1) iad_frnor,
integer, dimension(nspmd), intent(in) nb_slid,
integer, dimension(*), intent(in) itab,
type(h3d_database) h3d_data,
integer, intent(in) intfric,
integer, intent(in) flagremn,
integer, intent(in) lremnormax,
integer, intent(in) nrtm,
integer, intent(in) ivis2,
integer, intent(in) istif_msdt,
integer, intent(in) ifsub_carea,
integer, intent(in) nodadt_therm )

Definition at line 247 of file spmd_i25slide.F.

252c
253c - Nodes in IREM are not necessarily from their PMAIN processor.
254c - IREM is reordered according to ITAB for each PMAIN
255c INDX_FOR_P(0) = positions in IREM of the sliding secnd nodes that
256c have 0 as PMAIN
257c
258c - IAUX( "position in new FI" ) = value
259c value = 0 => Secnd is sliding, but is a local node
260c IAUX_K("position in new FI") = position in INTBUF_TAB
261c value < 0 => -value is position in INDX_FOR_P (secnd is sliding)
262c value > 0 => value is position in old *FI structures
263c (TMP%ITAFI) (secnd is not sliding)
264c Remark "position in new FI" is the position in the new *FI structure considering
265c before the removal of nodes that are actually local (and will be put into
266c INTBUF_TAB).
267c
268c
269c - INDEX( "numbering on old FI" ) = numbering in new FI
270c - This is be used to renumber the remote part of CAND_N , CAND_OPT_N
271c
272c Remark If a secnd node known as an old remote slides
273c (present in XREM and old TMP%*FI structure), then the values in *FI structures
274c are replaced by the values coming from [XI]REM.
275c
276c Example using NSPMD = 4.
277c proc P3 received some incoming sliding nodes from P0 P1 & P2, and
278c store the secnds nodes that have P0 as PMAIN:
279c - The node with UID 500 is sliding from P1 to P3 and has P0 as PMAIN
280c This node is a new (was not included in the old *FI structures).
281c It will be store as the 1st remote nodes (ITAFI(nin)%P(5) = 500)
282c
283c - The node 1000 is sliding from P0 to P3, and has P0 as PMAIN.
284c This node was already remote on P3
285c (old position = I, new position = INDEX("old position = 1" ) = 5)
286c
287c
288c "Pmain" "ITAB"
289c IREM(3,:) IREM(2,:)
290c +----+----+
291c Sent 1| |....|
292c BY +----+----+
293c P 2| 0 |1000|<--------+
294c 0 +----+----+ |
295c 3| |....| |
296c +----+----+ |
297c 4| |....| |
298c +----+----+ |
299c 5| |....| |
300c ================= |
301c 6| |....| |
302c +----+----+ | INDX_FOR_P(0) : array of index into IREM of
303c 7| 0 | 500|<------+ | +----+ Secnds that have 0 as PMAIN
304c P +----+----+ +-----| 7 |1 (sorted by USER ID)
305c 1 8| 0 | 600|<----+ | +----+
306c +----+----+ +-------| 8 |2
307c 9| 0 | 700| | +----+
308c +----+----+ | | 9 |3
309c 10| |....| | +----+
310c ================= | | 13 |4
311c 11| |....| | +----+
312c +----+----+ +---| 2 |5<----------+ (New) ITAFI
313c 12| |....| +----+ | +----+
314c P +----+----+ | |500 | 1
315c 2 13| 0 | 800| | +----+
316c +----+----+ | |600 | 2
317c 14| |....| IAUX(5)=-5 +----+
318c +----+----+ | |700 | 3
319c | +----+ P0
320c | |800 | 4
321c (old) | +----+
322c TMP%ITAFI +-----------+-------- |1000| 5
323c +----+ INDEX(1)=5 | +----+
324c 1|1000| <-----------------+ |1001| 6
325c P0 +----+ =====================
326c 2|1001| | | 7
327c ================= +----+
328c 3| | IDEB_OLD | | 8
329c P2 +----+ +----+
330c 4| | | | 9
331c -----+ +----+
332c 5| | | | 10
333c -----+ +----+
334c ....
335c +----+
336c | | 19
337c +----+
338
339C-----------------------------------------------
340C M o d u l e s
341C-----------------------------------------------
342 USE ifront_mod
343 USE tri7box
344 USE tri25tmp
345 USE message_mod
346 USE intbufdef_mod
347 USE h3d_mod
348C-----------------------------------------------
349C I m p l i c i t T y p e s
350C-----------------------------------------------
351 USE spmd_comm_world_mod, ONLY : spmd_comm_world
352#include "implicit_f.inc"
353C-----------------------------------------------
354C C o m m o n B l o c k s
355C-----------------------------------------------
356#include "com01_c.inc"
357#include "com04_c.inc"
358#include "task_c.inc"
359#include "spmd_c.inc"
360#include "sms_c.inc"
361C-----------------------------------------------
362C D u m m y A r g u m e n t s
363C-----------------------------------------------
364 TYPE(INTBUF_STRUCT_) :: INTBUF_TAB
365 INTEGER, INTENT(IN) :: NIN, NI25, NSN, IGAP, INTTH,ILEV,INTFRIC,FLAGREMN,
366 . LREMNORMAX, NRTM, IVIS2,
367 . NB_SLID(NSPMD), ! NB of new sliding secnd nodes
368 . ITAB(*)
369 INTEGER, INTENT(INOUT) :: NSNR
370 INTEGER, INTENT(IN) :: NODADT_THERM
371 INTEGER, INTENT(IN) :: ISTIF_MSDT,IFSUB_CAREA
372 INTEGER IAD_FRNOR(NINTER25,NSPMD+1),FR_NOR(*)
373 TYPE(H3D_DATABASE) :: H3D_DATA
374C-----------------------------------------------
375C L o c a l V a r i a b l e s
376C-----------------------------------------------
377#ifdef MPI
378 INTEGER NSNR_OLD,NSNR_NEW,NODFI,NNP,LSKYFI,
379 . NOD, LOC_PROC, I, N, NN, P, IDEB, J, K,L,JJ, I_STOK, IX, II
380 INTEGER NSNR_TOT
381 INTEGER, DIMENSION(:), ALLOCATABLE :: INDEX ! renumbering cand_n
382 INTEGER NN2,RSHIFT,ISHIFT, IOLDNSNFI, ND, JDEB, Q
383 INTEGER, DIMENSION(:), ALLOCATABLE :: IAUX,IAUX_LOCAL,IAUX_REV,IAUX_K,IAUX_L
384 INTEGER IDEB_NEW ! shift for resulting *FI
385 INTEGER IDEB_OLD ! shift for old *FI
386 INTEGER IDEB_SLID ! shift for new sliding nodes
387 INTEGER PNEW,POLD,ID_OLD,ID_NEW
388 INTEGER SNEW,SOLD,PMAIN,NB_SLID_TOT
389 my_real,
390 . DIMENSION(:), ALLOCATABLE :: penefi_old, stiffi_old
391 INTEGER MARGIN,N_NEW_SECND,UID
392 TYPE(I25_TMP_STRUCT) :: TMP
393 TYPE(int_pointer) , DIMENSION(NSPMD) :: INDX_FOR_P,UID_FOR_P
394 INTEGER, ALLOCATABLE, DIMENSION(:) :: PERMUTATIONS, PROC_ORIG
395 INTEGER SINDEX(NSPMD), SIZE_PERM_MAX, PROC_FROM
396 INTEGER WORK(70000)
397 INTEGER PLOCAL, NBLOCAL, PM, KK, KM, KI, LL, SIZREMNORFI, SIZ, NE
398 INTEGER, DIMENSION(:), ALLOCATABLE :: REMNOR_FI_TMP
399C-----------------------------------------------
400C S o u r c e L i n e s
401C-----------------------------------------------
402 loc_proc = ispmd + 1
403 nodfi = 0
404 lskyfi= 0
405 nb_slid_tot = 0
406 nsnr_tot = 0
407C Reperage des candidats
408
409C
410C Allocation des tableaux de frontieres interfaces
411C
412 DO p = 1,nspmd
413 nodfi = nodfi + nsnfi(nin)%P(p) + nb_slid(p)
414 nb_slid_tot = nb_slid_tot + nb_slid(p)
415 nsnr_tot = nsnr_tot + nsnfi(nin)%P(p)
416 ENDDO
417 ALLOCATE(proc_orig(nb_slid_tot))
418 ideb = 0
419 DO p = 1,nspmd
420 proc_orig(ideb+1:ideb+nb_slid(p)) = p
421 ideb = ideb + nb_slid(p)
422 ENDDO
423
424
425 ALLOCATE(index(nsnr_tot))
426 index(1:nsnr_tot) = 0
427 CALL reallocate_fi1(nodfi,tmp,nin,intth,igap,ilev,intfric,flagremn,ivis2,istif_msdt,ifsub_carea)
428 nsnfi(nin)%P(1:nspmd) = tmp%NSNFI%P(1:nspmd)
429C
430C Compactage des candidats
431C
432 ideb = 0
433 ideb_new = 0
434 jdeb = 0
435 ideb_new = 0
436 ideb_old = 0
437 ideb_slid = 0
438
439!
440! sort XREM/IREM wrt to main processor
441! only new remote kept in xrem
442!
443!
444 DO p = 1,nspmd
445 ! overestimation
446 nullify(indx_for_p(p)%P)
447 nullify(uid_for_p(p)%P)
448 ALLOCATE(indx_for_p(p)%P(max(nb_slid_tot,1)))
449 ALLOCATE(uid_for_p(p)%P(max(1,nb_slid_tot)))
450 indx_for_p(p)%P(1:nb_slid_tot) = 0
451 uid_for_p(p)%P(1:nb_slid_tot) = 0
452 sindex(p) = 0
453 ENDDO
454
455!
456 DO i = 1,nb_slid_tot
457 uid = irem(2,i)
458 p = irem(3,i) ! PMAIN
459 sindex(p) = sindex(p) + 1
460! Array of pointer to XREM (per PMAIN)
461 indx_for_p(p)%P(sindex(p)) = i
462 uid_for_p(p)%P(sindex(p)) = uid
463 ENDDO
464
465 size_perm_max = 0
466 DO p = 1, nspmd
467 size_perm_max = max(size_perm_max,sindex(p))
468 ENDDO
469
470 ALLOCATE(permutations(2*size_perm_max))
471 IF(flagremn == 2 ) THEN
472 ALLOCATE(remnor_fi_tmp(nodfi*lremnormax))
473 ki = 0
474 ENDIF
475 DO p = 1, nspmd
476 ! Pour l'instant on garde l'iteration P = LOC_PROC
477 ! voir avec ce qu'il faut faire dans ce cas
478 nn = 0
479 nsnr_old = nsnfi(nin)%P(p)
480 nsnr_new = sindex(p) ! NSNR from XREM, we don't know yet if they are already known
481 nsnfi(nin)%P(p) = nsnr_new + nsnr_old
482
483 IF(nsnr_old + nsnr_new > 0) THEN
484
485 ! Tri INDX_FOR_P en fonction de UID on each proc
486 IF(nsnr_new > 0) THEN
487 CALL my_orders(0,work,uid_for_p(p)%P,permutations,nsnr_new,1)
488 DO i = 1,nsnr_new
489 permutations(i) = indx_for_p(p)%P(permutations(i))
490 ENDDO
491 DO i = 1,nsnr_new
492 indx_for_p(p)%P(i) = permutations(i)
493 ENDDO
494 ENDIF
495
496 ALLOCATE(iaux(nsnr_old+nsnr_new))
497 ALLOCATE(iaux_local(nsnr_old+nsnr_new))
498 ALLOCATE(iaux_rev(nsnr_old+nsnr_new))
499 ALLOCATE(iaux_k(nsnr_old+nsnr_new))
500 ALLOCATE(iaux_l(nsnr_old+nsnr_new))
501
502 pold=1
503 pnew=1
504
505 ! IAUX : array of index for the merge sort of *FI and *REM
506 i = 1
507 ix= 1
508 plocal = 1
509 nblocal = 0
510 DO WHILE(pold<= nsnr_old .OR. pnew <= nsnr_new)
511
512 ! DO I = 1, NSNR_OLD + NSNR_NEW
513 IF(pold > nsnr_old) THEN
514 id_old = 0
515 ELSE
516 id_old = tmp%ITAFI%P(ideb_old+pold)
517 ENDIF
518 IF(pnew > nsnr_new) THEN
519 !it happens if NSNR_NEW = 0 for eg
520 !In that case we use a dummy ID_NEW
521 !that will not bo chosen
522 id_new = id_old + 1
523 ELSE
524 id_new = irem(2,indx_for_p(p)%P(pnew))
525 ENDIF
526 IF((id_new > id_old .OR. pnew > nsnr_new).AND. pold <= nsnr_old) THEN
527 index(ideb_old+pold) = ix + ideb_new
528 ix = ix + 1
529 iaux(i) = pold
530 pold = pold + 1
531! IF(ID_OLD==27569) WRITE(6,*) ispmd+1,"NODE :",ID_OLD,"Is old",
532! . ideb_old+pold-1,index(ideb_old+pold-1)
533 ELSEIF ((id_new < id_old .OR. pold > nsnr_old) .AND. pnew <= nsnr_new) THEN
534
535 ! Search in NSV (NSV must be sorted wrt ITAB)
536 IF(nsn > 0)THEN
537 DO WHILE( itab(intbuf_tab%NSV(plocal)) < id_new .AND. plocal < nsn )
538 plocal = plocal + 1
539 ENDDO
540 IF(itab(intbuf_tab%NSV(plocal)) == id_new) THEN
541 ! if the node is local
542 nblocal = nblocal + 1
543 iaux_rev(nblocal) = i
544 iaux_local(nblocal) = plocal
545! IF(ID_NEW==27569) WRITE(6,*) ispmd+1,"NODE :",ID_NEW,"Is Local:", PLOCAL
546 ELSE
547! IF(ID_NEW==27569) WRITE(6,*) ispmd+1,"NODE :",ID_NEW,"is new"
548 ix = ix + 1
549 ENDIF
550 iaux(i) = -pnew
551 pnew = pnew + 1
552 ELSE
553 ! some processor may have 0 secnd nodes
554 ix = ix + 1
555 iaux(i) = -pnew
556 pnew = pnew + 1
557 END IF
558 ELSEIF (id_new == id_old .AND. pnew <= nsnr_new .AND. pold <= nsnr_old) THEN
559 ! In the case the secnd sliding from another processor
560 ! is known already on this processor, then we keep the new values
561 ! in IREM and XREM
562 nsnfi(nin)%P(p) = nsnfi(nin)%P(p) - 1
563 index(ideb_old+pold) = ix + ideb_new
564 ix = ix + 1
565 iaux(i) = -pnew
566 pnew = pnew + 1
567 pold = pold + 1
568! IF(ID_NEW==27569) WRITE(6,*) ispmd+1,"NODE :",ID_NEW,"Is already in frontier",
569! . ideb_old+pold-1,index(ideb_old+pold-1)
570 ENDIF
571 i = i + 1
572 ENDDO
573
574
575C ========================================================
576C If a secnd is already known, update local structure here
577C Or in ELSEIF(I == 0) THEN blocks below
578C ========================================================
579 DO j = 1,nblocal
580 i = iaux(iaux_rev(j))
581 l = indx_for_p(p)%P(-i)
582 k = iaux_local(j)
583 iaux_k(iaux_rev(j)) = k
584 iaux_l(iaux_rev(j)) = l
585 iaux(iaux_rev(j)) = 0 !flag to identify local nodes
586 ENDDO
587
588C ========================================================
589C If a secnd is already known, update local structure here
590C ========================================================
591
592
593
594 ! NN = Taille de XREM + Taille ancien FI - noeuds communs
595 nn = nsnfi(nin)%P(p)
596 nsnfi(nin)%P(p) = nn - nblocal
597
598C =============================================================
599 nblocal = 0
600 DO j=1,nn ! NN is the number of unique nodes that are in X
601 i = iaux(j)
602 k = ideb_new+j-nblocal
603 IF(i > 0 )THEN
604 ! IAUX > 0 => Pointer to secnds already in FI structure
605 l = ideb_old+i
606 xfi(nin)%P(1,k) = tmp%XFI%P(1,l)
607 xfi(nin)%P(2,k) = tmp%XFI%P(2,l)
608 xfi(nin)%P(3,k) = tmp%XFI%P(3,l)
609 vfi(nin)%P(1,k) = tmp%VFI%P(1,l)
610 vfi(nin)%P(2,k) = tmp%VFI%P(2,l)
611 vfi(nin)%P(3,k) = tmp%VFI%P(3,l)
612 msfi(nin)%P(k) = tmp%MSFI%P(l)
613 stifi(nin)%P(k) = tmp%STIFI%P(l)
614 nsvfi(nin)%P(k) = tmp%NSVFI%P(l)
615 itafi(nin)%P(k) = tmp%ITAFI%P(l)
616 pmainfi(nin)%P(k) = tmp%PMAINFI%P(l)
617 kinfi(nin)%P(k) = tmp%KINFI%P(l)
618 ELSEIF( i < 0 ) THEN
619 ! IAUX < 0 => Pointer to secnds new secnds in XREM
620 l = indx_for_p(p)%P(-i)
621 xfi(nin)%P(1,k) = xrem(1,l)
622 xfi(nin)%P(2,k) = xrem(2,l)
623 xfi(nin)%P(3,k) = xrem(3,l)
624 vfi(nin)%P(1,k) = xrem(4,l)
625 vfi(nin)%P(2,k) = xrem(5,l)
626 vfi(nin)%P(3,k) = xrem(6,l)
627 msfi(nin)%P(k) = xrem(7,l)
628 stifi(nin)%P(k) = xrem(8,l)
629 nsvfi(nin)%P(k) = irem(1,l)
630 itafi(nin)%P(k) = irem(2,l)
631 pmainfi(nin)%P(k) = irem(3,l)
632 kinfi(nin)%P(k) = irem(4,l)
633 ELSEIF(i == 0) THEN
634 ! IAUX=0 => Secnd is known locally (in NSV),
635 ! we do not put in the FI structures
636 nblocal = nblocal +1
637 ENDIF
638 END DO
639
640C
641C shift for real variables (prepare for next setting)
642 rshift = 9
643
644C shift for integer variables (prepare for next setting)
645 ishift = 8
646
647C symmetric plane
648 IF(.true. )THEN
649 nblocal = 0
650 DO j = 1, nn
651 i = iaux(j)
652 k = ideb_new+j -nblocal
653 IF (i > 0) THEN
654 l = ideb_old+i
655 icodt_fi(nin)%P(k) = tmp%ICODT_FI%P(l)
656 iskew_fi(nin)%P(k) = tmp%ISKEW_FI%P(l)
657 ELSEIF( i < 0 ) THEN
658 l = indx_for_p(p)%P(-i)
659 icodt_fi(nin)%P(k) = irem(ishift + 0,l)
660 iskew_fi(nin)%P(k) = irem(ishift + 1,l)
661 ELSEIF(i == 0) THEN
662 nblocal = nblocal+1
663 END IF
664 END DO
665 ishift = ishift + 2
666 ENDIF
667
668
669C
670C specific cases ../..
671 IF(igap==1 .OR. igap==2)THEN
672 nblocal = 0
673 DO j=1,nn
674 i = iaux(j)
675 k = ideb_new+j-nblocal
676 IF (i > 0) THEN
677 l = ideb_old+i
678 gapfi(nin)%P(k) = tmp%GAPFI%P(l)
679 ELSEIF( i < 0 ) THEN
680 l = indx_for_p(p)%P(-i)
681 gapfi(nin)%P(k) = xrem(rshift,l)
682 ELSEIF(i == 0) THEN
683 nblocal = nblocal+1
684 END IF
685 END DO
686 rshift = rshift + 1
687 ELSEIF(igap==3)THEN
688 nblocal = 0
689 DO j = 1, nn
690 i = iaux(j)
691 k = ideb_new+j - nblocal
692 IF (i > 0) THEN
693 l = ideb_old+i
694 gapfi(nin)%P(k) = tmp%GAPFI%P(l)
695 gap_lfi(nin)%P(k) = tmp%GAP_LFI%P(l)
696 ELSEIF( i < 0 ) THEN
697 l = indx_for_p(p)%P(-i)
698 gapfi(nin)%P(k) = xrem(rshift ,l)
699 gap_lfi(nin)%P(k) = xrem(rshift+1,l)
700 ELSEIF(i == 0) THEN
701 nblocal = nblocal+1
702 END IF
703 END DO
704 rshift = rshift + 2
705 ENDIF
706C
707
708C thermic
709 IF(intth>0)THEN
710 nblocal = 0
711 DO j = 1, nn
712 i = iaux(j)
713 k = ideb_new+j -nblocal
714 IF (i > 0) THEN
715 l = ideb_old+i
716 tempfi(nin)%P(k) = tmp%TEMPFI%P(l)
717 areasfi(nin)%P(k) = tmp%AREASFI%P(l)
718 matsfi(nin)%P(k) = tmp%MATSFI%P(l)
719 ELSEIF( i < 0 ) THEN
720 l = indx_for_p(p)%P(-i)
721 tempfi(nin)%P(k) = xrem(rshift ,l)
722 areasfi(nin)%P(k) = xrem(rshift+1,l)
723 matsfi(nin)%P(k) = irem(ishift, l)
724 ELSEIF(i == 0) THEN
725 nblocal = nblocal+1
726 END IF
727 END DO
728 rshift = rshift + 2
729 ishift = ishift + 1
730 ENDIF
731
732C Adhesion
733 IF(ivis2==-1)THEN
734 nblocal = 0
735 DO j = 1, nn
736 i = iaux(j)
737 k = ideb_new+j -nblocal
738 IF (i > 0) THEN
739 l = ideb_old+i
740 IF(intth==0) areasfi(nin)%P(k) = tmp%AREASFI%P(l)
741 if_adhfi(nin)%P(k) = tmp%IF_ADHFI%P(l)
742 ELSEIF( i < 0 ) THEN
743 l = indx_for_p(p)%P(-i)
744 IF(intth==0) areasfi(nin)%P(k) = xrem(rshift,l)
745 if_adhfi(nin)%P(k) = irem(ishift,l)
746 ELSEIF(i == 0) THEN
747 k = iaux_k(j)
748 l = iaux_l(j)
749 IF(intth==0) intbuf_tab%AREAS(k) = xrem(rshift,l)
750 intbuf_tab%IF_ADH(k) = irem(ishift,l)
751 nblocal = nblocal+1
752 END IF
753 END DO
754 IF(intth==0) rshift = rshift + 1
755 ishift = ishift + 1
756 ENDIF
757
758C Friction
759 IF(intfric > 0 ) THEN
760 nblocal = 0
761 DO j = 1, nn
762 i = iaux(j)
763 k = ideb_new+j -nblocal
764 IF (i > 0) THEN
765 l = ideb_old+i
766 ipartfricsfi(nin)%P(k) = tmp%IPARTFRICSFI%P(l)
767 ELSEIF( i < 0 ) THEN
768 l = indx_for_p(p)%P(-i)
769 ipartfricsfi(nin)%P(k) = irem(ishift, l)
770 ELSEIF(i == 0) THEN
771 nblocal = nblocal+1
772 END IF
773 END DO
774 ishift = ishift + 1
775 ENDIF
776C Stiffness based on masses and time step
777 IF(istif_msdt > 0) THEN
778 nblocal = 0
779 DO j = 1, nn
780 i = iaux(j)
781 k = ideb_new+j -nblocal
782 IF (i > 0) THEN
783 l = ideb_old+i
784 stif_msdt_fi(nin)%P(k) = tmp%STIF_MSDT_FI%P(l)
785 ELSEIF( i < 0 ) THEN
786 l = indx_for_p(p)%P(-i)
787 stif_msdt_fi(nin)%P(k) = xrem(rshift, l)
788 ELSEIF(i == 0) THEN
789 nblocal = nblocal+1
790 END IF
791 END DO
792 rshift = rshift + 1
793 ENDIF
794C
795C CAREA output in TH (case of NISUB)
796 IF(ifsub_carea > 0) THEN
797 nblocal = 0
798 DO j = 1, nn
799 i = iaux(j)
800 k = ideb_new+j -nblocal
801 IF (i > 0) THEN
802 l = ideb_old+i
803 intareanfi(nin)%P(k) = tmp%INTAREANFI%P(l)
804 ELSEIF( i < 0 ) THEN
805 l = indx_for_p(p)%P(-i)
806 intareanfi(nin)%P(k) = xrem(rshift, l)
807 ELSEIF(i == 0) THEN
808 nblocal = nblocal+1
809 END IF
810 END DO
811 rshift = rshift + 1
812 ENDIF
813C
814 IF(idtmins==2)THEN
815 nblocal = 0
816 DO j = 1, nn
817 i = iaux(j)
818 k = ideb_new+j-nblocal
819 IF (i > 0) THEN
820 l = ideb_old+i
821 nodnxfi(nin)%P(k) = tmp%NODNXFI%P(l)
822 nodamsfi(nin)%P(k) = tmp%NODAMSFI%P(l)
823 procamsfi(nin)%P(k) = tmp%PROCAMSFI%P(l)
824 ELSEIF( i < 0 ) THEN
825 l = indx_for_p(p)%P(-i)
826 nodnxfi(nin)%P(k) = irem(ishift , l)
827 nodamsfi(nin)%P(k) = irem(ishift+1, l)
828 procamsfi(nin)%P(k) =irem(3,l)
829 ELSEIF(i == 0) THEN
830 nblocal = nblocal+1
831 END IF
832 END DO
833 ishift = ishift + 2
834
835 ELSEIF(idtmins_int/=0)THEN
836 nblocal = 0
837 DO j = 1, nn
838 i = iaux(j)
839 k = ideb_new+j-nblocal
840 IF (i > 0) THEN
841 l = ideb_old+i
842 nodamsfi(nin)%P(k) = tmp%NODAMSFI%P(l)
843 procamsfi(nin)%P(k) = tmp%PROCAMSFI%P(l)
844 ELSEIF( i < 0 ) THEN
845 l = indx_for_p(p)%P(-i)
846 nodamsfi(nin)%P(k) = irem(ishift+1, l)
847 procamsfi(nin)%P(k) =irem(3,l)
848 ELSEIF(i == 0) THEN
849 nblocal = nblocal+1
850 END IF
851 END DO
852 ishift = ishift + 1
853 ENDIF
854
855C
856C IF(ITYP==25)THEN
857 nblocal = 0
858 DO j = 1, nn
859 i = iaux(j)
860 k = ideb_new+j-nblocal
861 IF (i > 0) THEN
862 l = ideb_old+i
863 time_sfi(nin)%P(2*(k-1)+1) = tmp%TIME_SFI%P(2*(l-1)+1)
864 time_sfi(nin)%P(2*(k-1)+2) = tmp%TIME_SFI%P(2*(l-1)+2)
865 secnd_frfi(nin)%P(4,k) = tmp%SECND_FRFI%P(4,l)
866 secnd_frfi(nin)%P(5,k) = tmp%SECND_FRFI%P(5,l)
867 secnd_frfi(nin)%P(6,k) = tmp%SECND_FRFI%P(6,l)
868 pene_oldfi(nin)%P(2,k)= tmp%PENE_OLDFI%P(2,l)
869 stif_oldfi(nin)%P(2,k)= tmp%STIF_OLDFI%P(2,l)
870 pene_oldfi(nin)%P(3,k)= tmp%PENE_OLDFI%P(3,l)
871 pene_oldfi(nin)%P(4,k)= tmp%PENE_OLDFI%P(4,l)
872 pene_oldfi(nin)%P(5,k)= tmp%PENE_OLDFI%P(5,l)
873 ELSEIF( i < 0 ) THEN
874 l = indx_for_p(p)%P(-i)
875 time_sfi(nin)%P(2*(k-1)+1) = xrem(rshift+0,l)
876 time_sfi(nin)%P(2*(k-1)+2) = xrem(rshift+1,l)
877 secnd_frfi(nin)%P(4,k) = xrem(rshift+2,l)
878 secnd_frfi(nin)%P(5,k) = xrem(rshift+3,l)
879 secnd_frfi(nin)%P(6,k) = xrem(rshift+4,l)
880 pene_oldfi(nin)%P(2,k) = xrem(rshift+5,l)
881 stif_oldfi(nin)%P(2,k) = xrem(rshift+6,l)
882 pene_oldfi(nin)%P(3,k) = xrem(rshift+7,l)
883 pene_oldfi(nin)%P(3,k) = xrem(rshift+8,l)
884 pene_oldfi(nin)%P(5,k) = xrem(rshift+9,l)
885 ELSEIF(i == 0) THEN
886 k = iaux_k(j)
887 l = iaux_l(j)
888 intbuf_tab%TIME_S(2*(k-1)+1) = xrem(rshift+0,l)
889 intbuf_tab%TIME_S(2*(k-1)+2) = xrem(rshift+1,l)
890 intbuf_tab%SECND_FR(6*(k-1)+4) = xrem(rshift+2,l)
891 intbuf_tab%SECND_FR(6*(k-1)+5) = xrem(rshift+3,l)
892 intbuf_tab%SECND_FR(6*(k-1)+6) = xrem(rshift+4,l)
893 intbuf_tab%PENE_OLD(5*(k-1)+2) = xrem(rshift+5,l)
894 intbuf_tab%STIF_OLD(2*(k-1)+2) = xrem(rshift+6,l)
895 intbuf_tab%PENE_OLD(5*(k-1)+3) = xrem(rshift+7,l)
896 intbuf_tab%PENE_OLD(5*(k-1)+4) = xrem(rshift+8,l)
897 intbuf_tab%PENE_OLD(5*(k-1)+5) = xrem(rshift+9,l)
898 nblocal = nblocal+1
899 END IF
900 END DO
901 rshift = rshift + 10
902
903 nblocal = 0
904 DO j = 1, nn
905 i = iaux(j)
906 k = ideb_new+j-nblocal
907 IF (i > 0) THEN
908 l = ideb_old+i
909 irtlm_fi(nin)%P(1,k) = tmp%IRTLM_FI%P(1,l)
910 irtlm_fi(nin)%P(2,k) = tmp%IRTLM_FI%P(2,l)
911 irtlm_fi(nin)%P(3,k) = tmp%IRTLM_FI%P(3,l)
912 irtlm_fi(nin)%P(4,k) = tmp%IRTLM_FI%P(4,l)
913 icont_i_fi(nin)%P(k) = tmp%ICONT_I_FI%P(l)
914 ELSEIF( i < 0 ) THEN
915 l = indx_for_p(p)%P(-i)
916 irtlm_fi(nin)%P(1,k) = irem(ishift+0,l)
917 irtlm_fi(nin)%P(2,k) = irem(ishift+1,l)
918 irtlm_fi(nin)%P(3,k) = irem(ishift+2,l)
919 irtlm_fi(nin)%P(4,k) = irem(ishift+3,l)
920 icont_i_fi(nin)%P(k) = irem(ishift+4,l)
921 ELSEIF(i == 0) THEN
922 k = iaux_k(j)
923 l = iaux_l(j)
924 intbuf_tab%IRTLM(4*(k-1)+1) = irem(ishift+0,l)
925 intbuf_tab%IRTLM(4*(k-1)+2) = irem(ishift+1,l)
926 intbuf_tab%IRTLM(4*(k-1)+3) = irem(ishift+2,l)
927 intbuf_tab%IRTLM(4*(k-1)+4) = irem(ishift+3,l)
928 intbuf_tab%ICONT_I(k) = irem(ishift+4,l)
929 nblocal = nblocal+1
930 END IF
931 END DO
932 ishift = ishift + 5
933
934 IF (ilev==2) THEN
935C NBINFLFI local ne semble pas toujours alloue
936 nblocal = 0
937 DO j = 1, nn
938 i = iaux(j)
939 k = ideb_new+j-nblocal
940 IF (i > 0) THEN
941 l = ideb_old+i
942! NBINFLFI(NIN)%P(K) = TMP%NBINFLFI%P(L)
943 ELSEIF( i < 0 ) THEN
944 l = indx_for_p(p)%P(-i)
945 nbinflfi(nin)%P(k) = irem(ishift ,l)
946 ELSEIF(i == 0) THEN
947 nblocal = nblocal+1
948 END IF
949 END DO
950 ishift = ishift + 1
951 END IF
952
953 nblocal = 0
954 DO j = 1, nn
955 i = iaux(j)
956 k = ideb_new+j-nblocal
957 IF (i > 0) THEN
958C old node
959 l = ideb_old+i
960 islide_fi(nin)%P(1,k) = tmp%ISLIDE_FI%P(1,l)
961 islide_fi(nin)%P(2,k) = tmp%ISLIDE_FI%P(2,l)
962 islide_fi(nin)%P(3,k) = tmp%ISLIDE_FI%P(3,l)
963 islide_fi(nin)%P(4,k) = tmp%ISLIDE_FI%P(4,l)
964 ELSEIF( i < 0 ) THEN
965C new remote node
966 l = indx_for_p(p)%P(-i)
967 proc_from = proc_orig(l)
968 DO jj = 1,4
969 IF( irem(ishift-1+jj,l) >0 ) THEN
970 islide_fi(nin)%P(jj,k) = fr_nor( irem(ishift-1+jj,l) + iad_frnor(ni25,proc_from) - 1)
971 ELSE
972 islide_fi(nin)%P(jj,k) = 0
973 ENDIF
974 ENDDO
975 ELSEIF(i == 0) THEN
976C new node, knonw locally
977 k = iaux_k(j)
978 l = iaux_l(j)
979 proc_from = proc_orig(l)
980 DO jj = 1,4
981 IF( irem(ishift-1+jj,l) >0 ) THEN
982 intbuf_tab%ISLIDE(4*(k-1)+jj) = fr_nor( irem(ishift-1+jj,l) + iad_frnor(ni25,proc_from) - 1)
983 ELSE
984 intbuf_tab%ISLIDE(4*(k-1)+jj) = 0
985 ENDIF
986 ENDDO
987 nblocal = nblocal+1
988 END IF
989 END DO
990 ishift = ishift + 4
991
992C ENDIF ! (ITYP==25)
993
994C REMOVE main SEGMENTS : no reception but reconstruction of the tab REMNOR_FI
995 IF(flagremn==2)THEN
996 nblocal = 0
997 DO j = 1, nn
998 i = iaux(j)
999 k = ideb_new+j-nblocal
1000 IF (i > 0) THEN
1001 l = ideb_old+i
1002 siz = tmp%KREMNOR_FI%P(l+1)- tmp%KREMNOR_FI%P(l)
1003 kremnor_fi(nin)%P(k)=kremnor_fi(nin)%P(k)+ siz
1004c KK = TMP%KREMNOR_FI%P(L)+1
1005 DO km=tmp%KREMNOR_FI%P(l)+1,tmp%KREMNOR_FI%P(l+1)
1006 ki = ki +1
1007 remnor_fi_tmp(ki) = tmp%REMNOR_FI%P(km)
1008 ENDDO
1009 ELSEIF( i < 0 ) THEN
1010 DO ne=1,nrtm
1011 kk = intbuf_tab%KREMNODE(2*(ne-1)+2) + 1
1012 ll = intbuf_tab%KREMNODE(2*(ne-1)+3)
1013 DO km=kk,ll
1014 IF(intbuf_tab%REMNODE(km) == -itafi(nin)%P(k) ) THEN
1015 kremnor_fi(nin)%P(k)=kremnor_fi(nin)%P(k)+1
1016 ki = ki+1
1017 remnor_fi_tmp(ki) = ne
1018 ENDIF
1019 ENDDO
1020 ENDDO
1021 ELSEIF(i == 0) THEN
1022 nblocal = nblocal+1
1023 END IF
1024
1025 END DO
1026C
1027 ENDIF
1028
1029
1030
1031! IDEB_NEW = IDEB_NEW + NN
1032 ideb_new = ideb_new + nsnfi(nin)%P(p)
1033
1034
1035 ideb_old = ideb_old + nsnr_old
1036 ideb_slid = ideb_slid + nb_slid(p)
1037 DEALLOCATE(iaux,iaux_local,iaux_rev,iaux_k,iaux_l)
1038
1039
1040 ENDIF !IF(NSNR_OLD/=0)
1041 ENDDO ! end do NSPMD
1042
1043c ===============================================================
1044c TESTS
1045c ==============================================================
1046! DO II = 1,NSPMD
1047! IF(II == LOC_PROC) THEN
1048! IF(NSNR /= IDEB_NEW) WRITE(6,*) __FILE__,"NSNR = ",NSNR," --> ", IDEB_NEW
1049! J = 1
1050! DO P = 1,NSPMD
1051! WRITE(6,*) ispmd+1, "P = ",P
1052! WRITE(6,*) "NSNFI = ",NSNFI(NIN)%P(P)
1053! DO I = 1,NSNFI(NIN)%P(P)
1054! WRITE(6,*) I,NSVFI(NIN)%P(J),ITAFI(NIN)%P(J), "on ",PMAINFI(NIN)%P(J)
1055! J = J + 1
1056! ENDDO
1057! ENDDO
1058! ENDIF
1059! CALL FLUSH(6)
1060! CALL MPI_BARRIER(SPMD_COMM_WORLD,IDEB)
1061! ENDDO
1062c ==============================================================
1063
1064 IF(flagremn == 2 ) THEN
1065 DO n=1,nodfi
1066 kremnor_fi(nin)%P(n+1) = kremnor_fi(nin)%P(n+1) + kremnor_fi(nin)%P(n)
1067 END DO
1068C
1069 DO n=nodfi,1,-1
1070 kremnor_fi(nin)%P(n+1)=kremnor_fi(nin)%P(n)
1071 END DO
1072 kremnor_fi(nin)%P(1)=0
1073
1074 sizremnorfi = kremnor_fi(nin)%P(nodfi+1)
1075 ALLOCATE(remnor_fi(nin)%P(sizremnorfi))
1076 IF(sizremnorfi > 0) THEN
1077 DO n=1,sizremnorfi
1078 remnor_fi(nin)%P(n) =remnor_fi_tmp(n)
1079 ENDDO
1080 ENDIF
1081 DEALLOCATE(remnor_fi_tmp)
1082 ENDIF
1083
1084
1085
1086C ===============================================================
1087 lskyfi = ideb_new*multimax
1088 nsnr = ideb_new
1089C ================================================================
1090
1091
1092
1093C
1094C Deallocation de XREM IREM
1095C
1096 IF(ALLOCATED(xrem)) DEALLOCATE(xrem)
1097 IF(ALLOCATED(irem)) DEALLOCATE(irem)
1098
1099C
1100C ALLOCATIONS FOR THE ASSEMBLY
1101C
1102 CALL reallocate_fi2(nin, intth, nodfi, lskyfi, h3d_data,nodadt_therm)
1103C
1104C ! DEALLOCATE old structures
1105C
1106 CALL deallocate_fi1_tmp(nodfi,tmp,nin,intth,igap,ilev,intfric,flagremn,ivis2,istif_msdt,ifsub_carea)
1107C
1108 DO i = 1, intbuf_tab%I_STOK(1)
1109 n = intbuf_tab%CAND_N(i)
1110 nn = n-nsn
1111 IF(nn>0)THEN
1112 intbuf_tab%CAND_N(i) = abs(index(nn))+nsn
1113 ENDIF
1114 ENDDO
1115C
1116 DO i = 1, intbuf_tab%I_STOK(2)
1117 n = intbuf_tab%CAND_OPT_N(i)
1118 nn = n-nsn
1119 IF(nn>0)THEN
1120 intbuf_tab%CAND_OPT_N(i) = abs(index(nn))+nsn
1121 ENDIF
1122 ENDDO
1123
1124 DO p=1,nspmd
1125 DEALLOCATE(indx_for_p(p)%P)
1126 DEALLOCATE(uid_for_p(p)%P)
1127 ENDDO
1128
1129 DEALLOCATE(permutations,proc_orig)
1130
1131C
1132#endif
1133 RETURN
my_real
#define my_real
Definition cppsort.cpp:32
max
#define max(a, b)
Definition macros.h:21
my_orders
void my_orders(int *mode, int *iwork, int *data, int *index, int *n, int *irecl)
Definition my_orders.c:82
ifront_mod
Definition ifront_mod.F:31
tri7box::irem
integer, dimension(:,:), allocatable irem
Definition tri7box.F:339
reallocate_fi2
subroutine reallocate_fi2(nin, intth, nodfi, lskyfi, h3d_data, nodadt_therm)
Definition spmd_i25slide.F:1437
reallocate_fi1
subroutine reallocate_fi1(new_size, tmp, nin, intth, igap, ilev, intfric, flagremn, ivis2, istif_msdt, ifsub_carea)
Definition spmd_i25slide.F:1148
deallocate_fi1_tmp
subroutine deallocate_fi1_tmp(new_size, tmp, nin, intth, igap, ilev, intfric, flagremn, ivis2, istif_msdt, ifsub_carea)
Definition spmd_i25slide.F:1329