Télécharger sepa2.eso

Retour à la liste

Numérotation des lignes :

sepa2
  1. C SEPA2 SOURCE PV090527 24/01/10 21:15:05 11818
  2. C****************************************************************************
  3. C****************************************************************************
  4. C***************SEPAR...trouve separation************************************
  5. C****************************************************************************
  6. C****************************************************************************
  7.  
  8. C SEPAR trouve la separation a partir du domaine defini par
  9. C MASQ=.TRUE. et du noeud appele PIVOT, renvoie DIMSEP,le nombre de
  10. C noeuds contenant dans la separation, MASQ=.FALSE. pour les noeuds
  11. C appartenant a la separation, renumerote celle-ci dans IADJ,
  12.  
  13. SUBROUTINE SEPA2(IADJ,JADJC,PIVOTA,MASQUE,DIMSEP,N,IPOS,
  14. & NODES,IPOSMAX,nrelong,noelon,noel2,
  15. > londim,nbthr,icco)
  16.  
  17. IMPLICIT INTEGER(I-N)
  18.  
  19. -INC PPARAM
  20. -INC CCOPTIO
  21. -INC CCREEL
  22. common/cnumop/fcout2c(64),fcoutc(64),iadjc,jadjcc,nrelongc,
  23. > noelonc,isensc(64),dimlonc(64),masqc,nodesc,iposc,nbtotc,
  24. > lfrontc(64),londimc,lpivc(64),ipointc,noel2c,
  25. > boolc(64),ldim2c(64),nbthrc,pivotc(50,64),npointc(64),
  26. > npoint2c(64),imaxc,lfronc(64),iccon,ncouch
  27. integer iths(64)
  28. external noepr2i,noepr2j
  29. integer dimlonc,boolc
  30. SEGMENT IADJ(0)
  31. SEGMENT JADJC(0)
  32. integer pivot(50),pivot2(50),pivota,pivots,pivotc,pivotb
  33. SEGMENT MASQUE
  34. LOGICAL MASQ(0)
  35. ENDSEGMENT
  36. SEGMENT IPOS(0)
  37. INTEGER NODES
  38. INTEGER BOOL
  39. INTEGER DIMSEP,N
  40. REAL*8 FCOUT,FCOUT2,fcout2c,fcoutc
  41. real*8 xran
  42. INTEGER LONG,LONG2,L,DIMLON
  43. C LONG2,LONG correspond au pseudo-diametre.
  44. C L determine les noeuds appartenant a la separation.
  45.  
  46. SEGMENT NRELONG(NODES)
  47. C NRELONG contient pour chaque noeud sa profondeur.
  48.  
  49. SEGMENT NOELON(NODES)
  50. SEGMENT NOEL2(NODES)
  51. SEGMENT LONDIM(NODES)
  52. C NOELON contient les noeuds de profondeur LONG.
  53. C DIMLON= dimension de NOELON.
  54.  
  55. C Initialisation des segments de travail.
  56. * write (6,*) ' entree dans sepa2 nbthr ',nbthr
  57. * noepr2 travaille differamment suivant que nbtot est nul ou pas
  58. * et aussi en fonction de iccon
  59.  
  60. FCOUT=0.D0
  61. FCOUT2=0.D0
  62. iccon=icco
  63. nbtot=0
  64. lpiv=1
  65. pivot(lpiv)=pivota
  66. MDOMN=IPOS(PIVOTA+NODES)
  67. CALL NOEPR2(IADJ(1),JADJC(1),PIVOT,NRELONG(1),NOELON(1),
  68. > isens,DIMLON,NODES,IPOS(1),NBTOT,lfront,lfron,
  69. > londim(1),fcout,lpiv,iccon,icouch)
  70. do j=1,dimlon
  71. noel2(j)=noelon(j)
  72. enddo
  73. * insertion d'un deuxieme pivot pour faire les partitions par la suite
  74. * on part du point extreme et on reprend le nouveau point extreme
  75. if (dimlon.ge.2) then
  76. lpiv=1
  77. pivot(lpiv)=noelon(dimlon)
  78. do ix=1,dimlon
  79. ii=noelon(ix)
  80. if(ii.ne.0) nrelong(ii)=0
  81. enddo
  82. nbtot=0
  83. CALL NOEPR2(IADJ(1),JADJC(1),PIVOT,NRELONG(1),NOELON(1),
  84. > isens,DIMLON,NODES,IPOS(1),NBTOT,lfront,lfron,
  85. > londim(1),fcout,lpiv,iccon,icouch)
  86. ncouch=icouch
  87. lpiv=2
  88. pivot(lpiv)=noelon(dimlon)
  89. endif
  90. if (dimlon.eq.0) return
  91.  
  92.  
  93.  
  94. * write (6,*) ' sepa2 apres noepr dimlon nbtot fcout ',dimlon,
  95. * > nbtot,fcout,pivot(lpiv)
  96. *
  97. do ix=1,dimlon
  98. ii=noelon(ix)
  99. if(ii.ne.0) nrelong(ii)=0
  100. enddo
  101. if (fcout.lt.2) goto 11
  102. if (dimlon.le.13) goto 11
  103. ldim2=londim(2)
  104. * recherche aleatoire
  105. * prevoir 2 cases pour les nouveaux pivots car 2 zones
  106. npoint=4
  107. do i=lpiv+1,npoint
  108. pivot(i)=0
  109. enddo
  110. lpiv=npoint
  111. bool=2
  112. ipoint=0
  113. imax=0
  114. 499 continue
  115. do 500 itent=1,igrand
  116. if (fcout.lt.2) goto 510
  117. if (bool.le.0 ) goto 510
  118. bool=bool-1
  119. ipoint=ipoint+1
  120. if (ipoint.gt.npoint) then
  121. imax=1
  122. ipoint=1
  123. endif
  124. npoint2=npoint
  125. nbthrl=min(nbthr,nbtot/16+1)
  126. ** nbthrl=1
  127. pivots=pivot(ipoint)
  128. iadjc=iadj
  129. jadjcc=jadjc
  130. nrelongc=nrelong
  131. noelonc=noelon
  132. masqc=masque
  133. nodesc=nodes
  134. iposc=ipos
  135. nbtotc=nbtot
  136. londimc=londim
  137. ipointc=ipoint
  138. noel2c=noel2
  139. nbthrc=nbthrl
  140. imaxc=imax
  141. do 521 ith=1,nbthrl
  142. isensc(ith)=isens
  143. dimlonc(ith)=dimlon
  144. lfrontc(ith)=lfront
  145. lfronc(ith)=lfron
  146. fcout2c(ith)=fcout2
  147. lpivc(ith)=lpiv
  148. boolc(ith)=bool
  149. fcoutc(ith)=fcout
  150. ldim2c(ith)=ldim2
  151. npointc(ith)=npoint
  152. npoint2c(ith)=npoint2
  153. do jj=1,lfron
  154. londim(jj+(ith-1)*nodes)=londim(jj)
  155. enddo
  156. do jj=1,npoint2
  157. pivotc(jj,ith)=pivot(jj)
  158. enddo
  159. if (ith.ne.nbthrl.and.dimlon.gt.64 ) then
  160. * write (6,*) ' appel threadid ',ith
  161. iths(ith)=1
  162. call threadid(ith,noepr2i)
  163. else
  164. call noepr2i(ith)
  165. iths(ith)=0
  166. endif
  167. 521 continue
  168. isig=2*mod(ipoint,2)-1
  169. do 522 ith=1,nbthrl
  170. if (iths(ith).eq.1) call threadif(ith)
  171. iths(ith)=0
  172. if (fcoutc(ith).lt.fcout) then
  173. if (fcoutc(ith).ne.fcout) bool=2
  174. isens=isensc(ith)
  175. fcout=fcoutc(ith)
  176. ldim2=ldim2c(ith)
  177. npoint=npointc(ith)
  178. npoint2=npoint2c(ith)
  179. pivot(ipoint)=pivotc(ipoint,ith)
  180. pivot(npoint2)=0
  181. endif
  182. 522 continue
  183. if (ierr.ne.0) return
  184. npoint=npoint2
  185. lpiv=npoint
  186. 500 continue
  187. 510 continue
  188. * write (6,*) ' nb pts maitres ',npoint
  189. * petit gradient local parallelise +
  190. * on garde la supression eventuelle
  191. if(dimlon.lt.64) goto 570
  192. ipoins=npoint
  193. do 560 itent=1,igrand
  194. if (isucc.eq.0) goto 570
  195. if (fcout.lt.2) goto 570
  196. do 550 ipoinu= npoint,1,-1
  197. ipoint=mod(ipoins+ipoinu-2,npoint)+1
  198. lpoint=pivot(ipoint)
  199. if (lpoint.le.0) goto 550
  200. iadh=iadj(lpoint+1)-1
  201. iadb=iadj(lpoint)
  202. * pour ne pas perdre trop de temps avec un super element
  203. iadb=max(iadb,iadh-256)
  204. do 580 kb=iadh,iadb,-nbthrl
  205. iadjc=iadj
  206. jadjcc=jadjc
  207. nrelongc=nrelong
  208. noelonc=noelon
  209. masqc=masque
  210. nodesc=nodes
  211. iposc=ipos
  212. nbtotc=nbtot
  213. londimc=londim
  214. ipointc=ipoint
  215. noel2c=noel2
  216. nbthrc=nbthrl
  217. imaxc=imax
  218. do 581 ith=nbthrl,1,-1
  219. kk=kb-ith+1
  220. if (kk.lt.iadj(lpoint)) goto 581
  221. if (kk.eq.iadj(lpoint+1)) then
  222. pivot(ipoint)=0
  223. else
  224. k=jadjc(kk)
  225. if (k.eq.0) goto 581
  226. if (IPOS(k+NODES).ne.mdomn) goto 581
  227. pivot(ipoint)=k
  228. endif
  229. isensc(ith)=isens
  230. dimlonc(ith)=dimlon
  231. lfrontc(ith)=lfront
  232. lfronc(ith)=lfron
  233. fcout2c(ith)=fcout2
  234. lpivc(ith)=lpiv
  235. boolc(ith)=bool
  236. fcoutc(ith)=fcout
  237. ldim2c(ith)=ldim2
  238. npointc(ith)=npoint
  239. npoint2c(ith)=npoint2
  240. do jj=1,lfron
  241. londim(jj+(ith-1)*nodes)=londim(jj)
  242. enddo
  243. do jj=1,npoint2
  244. pivotc(jj,ith)=pivot(jj)
  245. enddo
  246. if (ith.ne.1.and.dimlon.gt.64 ) then
  247. * write (6,*) ' appel threadid ',ith
  248. call threadid(ith,noepr2j)
  249. iths(ith)=1
  250. else
  251. call noepr2j(ith)
  252. iths(ith)=0
  253. endif
  254. pivot(ipoint)=lpoint
  255. 581 continue
  256. 583 continue
  257. do 582 ith=nbthrl,1,-1
  258. if (iths(ith).eq.1) then
  259. call threadif(ith)
  260. iths(ith)=0
  261. endif
  262. ** write(6,*) ' apres noepr2j ',fcout,fcoutc(ith)
  263. if (fcoutc(ith).lt.fcout) then
  264. ** write(6,*) 'amelioration gradient',fcout,
  265. ** > fcoutc(ith),pivotc(ipoint,ith)
  266. if (fcoutc(ith).ne.fcout) bool=2
  267. isens=isensc(ith)
  268. fcout=fcoutc(ith)
  269. ldim2=ldim2c(ith)
  270. npoint=npointc(ith)
  271. npoint2=npoint2c(ith)
  272. pivot(ipoint)=pivotc(ipoint,ith)
  273. pivot(npoint2)=0
  274. endif
  275. 582 continue
  276. if (ierr.ne.0) return
  277. npoint=npoint2
  278. lpiv=npoint
  279. if (isucc.eq.1) then
  280. ipoins=ipoint
  281. goto 560
  282. endif
  283. 580 continue
  284. 550 continue
  285. 560 continue
  286. 570 continue
  287.  
  288. 11 continue
  289. nbtot=0
  290. * write (6,*) ' sepa2 avant noepr2 final ',pivot(1),pivot(2)
  291. CALL NOEPR2(IADJ(1),JADJC(1),PIVOT,NRELONG(1),NOELON(1),
  292. > isens,DIMLON,NODES,IPOS(1),NBTOT,lfront,lfron,
  293. > londim(1),fcout,lpiv,iccon,icouch)
  294.  
  295. C PIVOT correspond au noeud pseudo-peripherique.
  296. C LONG2 correspond au pseudo-diametre.
  297. C
  298.  
  299. DIMSEP=0
  300. C MDOMN est le numéro de mon domaine
  301.  
  302. C pour l'instant,aucun noeud n'appartient a la separation.
  303.  
  304.  
  305. l=lfront
  306. C L correspond a la distance moyenne pour aller d'un bout a l'autre
  307. C du domaine.
  308.  
  309. C on arrete de separer si LONG < = 5 ou icouch < = 6
  310. C on masque alors tous les noeuds repondant a cette condition.
  311.  
  312. ** write (6,*) ' sepa2 icouch lfront nbtot ',icouch,lfront,nbtot
  313. IF(Lfront.le.1.OR.NBTOT.LE.16) THEN
  314. C insertion d'une seule zone
  315. IPOSV=IPOS(MDOMN+1)
  316. C IPOSV est son rang
  317. DO I=0,IPOSMAX
  318. IF (IPOS(I+1).GT.IPOSV) IPOS(I+1)=IPOS(I+1)+1
  319. ENDDO
  320. IPOSMAX=IPOSMAX+1
  321. if (iposmax.gt.nodes-1) then
  322. * write (6,*) ' iposmax > modes '
  323. iposmax=nodes-1
  324. endif
  325. IPOS(IPOSMAX+1-0)=IPOSV+1
  326. C IPOSV est son rang
  327. DO 40 IX=1,DIMLON
  328. I=NOELON(IX)
  329. IF(MDOMN.EQ.IPOS(I+NODES).AND.NRELONG(I).NE.0) THEN
  330. MASQ(I)=.FALSE.
  331. IPOS(I+NODES)=IPOSMAX
  332. DIMSEP=DIMSEP+1
  333. ENDIF
  334. 40 CONTINUE
  335. * do 41 i=1,nodes
  336. * IF(MDOMN.EQ.IPOS(I+NODES).AND.NRELONG(I).EQ.0) THEN
  337. * write (6,*) ' zone non connexe 1 ',mdomn,i
  338. * endif
  339. *41 continue
  340. * CALL CMG2(IADJ,JADJC,PIVOT,LONG,NRELONG,NOELON,
  341. * * DIMLON,MASQUE,NODES,IPOS,DIMSEP)
  342. GOTO 50
  343. ENDIF
  344.  
  345. C calcul des nouveaux indices de zones
  346. IPOSV=IPOS(MDOMN+1)
  347. C IPOSV est son rang
  348. DO I=0,IPOSMAX
  349. IF (IPOS(I+1).GT.IPOSV) IPOS(I+1)=IPOS(I+1)+3
  350. ENDDO
  351. IPOSMAX=IPOSMAX+3
  352. if (iposmax.gt.nodes-1) then
  353. * write (6,*) ' iposmax > modes '
  354. iposmax=nodes-1
  355. endif
  356. isens=1
  357. IPOS(IPOSMAX+1-2)=IPOSV+1
  358. IPOS(IPOSMAX+1-1)=IPOSV+1+isens
  359. IPOS(IPOSMAX+1-0)=IPOSV+4-isens
  360.  
  361. C On calcule la position de chaque noeud I.
  362. C si I a une profondeur L, I appartient a la separation.
  363.  
  364. iwr=1
  365. izcti1=igrand
  366. izcti2=igrand
  367. izcti3=igrand
  368. izcti4=igrand
  369. izcti5=igrand
  370. izcti6=igrand
  371. izcti7=igrand
  372. izcti8=igrand
  373. izcte1=igrand
  374. izcte2=igrand
  375. izcte3=igrand
  376. izcte4=igrand
  377. izcte5=igrand
  378. izcte6=igrand
  379. izcte7=igrand
  380. izcte8=igrand
  381. * dimseq=dimsep
  382. DO 20 IX=1,DIMLON
  383. I=NOELON(IX)
  384. * L'intérieur
  385. IF(MDOMN.EQ.IPOS(I+NODES).AND.(NRELONG(I).GT.0)) THEN
  386. IF((NRELONG(I).LT.L)) THEN
  387. * recherche de izcti
  388. do kk=iadj(i),iadj(i+1)-1
  389. k=jadjc(kk)
  390. if (k.ne.0) then
  391. if (nrelong(k).eq.0) then
  392. ipkn=ipos(ipos(k+nodes)+1)
  393. if (izcti1.eq.ipkn) then
  394. elseif (izcti1.gt.ipkn) then
  395. izcti8=izcti7
  396. izcti7=izcti6
  397. izcti6=izcti5
  398. izcti5=izcti4
  399. izcti4=izcti3
  400. izcti3=izcti2
  401. izcti2=izcti1
  402. izcti1=ipkn
  403. elseif (izcti2.eq.ipkn) then
  404. elseif (izcti2.gt.ipkn) then
  405. izcti8=izcti7
  406. izcti7=izcti6
  407. izcti6=izcti5
  408. izcti5=izcti4
  409. izcti4=izcti3
  410. izcti3=izcti2
  411. izcti2=ipkn
  412. ELSEIF (IZCTI3.EQ.IPkn) THEN
  413. elseif (izcti3.gt.ipkn) then
  414. izcti8=izcti7
  415. izcti7=izcti6
  416. izcti6=izcti5
  417. izcti5=izcti4
  418. izcti4=izcti3
  419. izcti3=ipkn
  420. elseif (izcti4.eq.ipkn) then
  421. elseif (izcti4.gt.ipkn) then
  422. izcti8=izcti7
  423. izcti7=izcti6
  424. izcti6=izcti5
  425. izcti5=izcti4
  426. izcti4=ipkn
  427. elseif (izcti5.eq.ipkn) then
  428. elseif (izcti5.gt.ipkn) then
  429. izcti8=izcti7
  430. izcti7=izcti6
  431. izcti6=izcti5
  432. izcti5=ipkn
  433. elseif (izcti6.eq.ipkn) then
  434. elseif (izcti6.gt.ipkn) then
  435. izcti8=izcti7
  436. izcti7=izcti6
  437. izcti6=ipkn
  438. elseif (izcti7.eq.ipkn) then
  439. elseif (izcti7.gt.ipkn) then
  440. izcti8=izcti7
  441. izcti7=ipkn
  442. elseif (izcti8.eq.ipkn) then
  443. elseif (izcti8.gt.ipkn) then
  444. izcti8=ipkn
  445. endif
  446. endif
  447. endif
  448. enddo
  449. IPOS(I+NODES)=IPOSMAX-1
  450. IPOS(I+2*NODES)=IPOS(I+2*NODES)+1
  451. * write (6,*) ' zone ',i,IPOS(I+NODES)
  452. if (icouch.le.4) masq(i)=.false.
  453. GOTO 20
  454. ENDIF
  455.  
  456. IF(NRELONG(I).EQ.L) THEN
  457. * pour que le noeud soit bien dans la separation, il faut qu'il soit
  458. * connecter a un noeud de profondeur plus élevée (prob des noeuds milieux)
  459. DO 100 J=1,IADJ(I+1)-IADJ(I)
  460. K=JADJC(IADJ(I)+J-1)
  461. C K:voisin de I
  462. * if (k.eq.0) write (6,*) ' k peut valoir 0 '
  463. IF(K.EQ.0) GOTO 100
  464. IF (NRELONG(K).EQ.0) GOTO 100
  465. IF(MDOMN.NE.IPOS(k+NODES).and.
  466. > ipos(k+nodes).lt.iposmax-2) then
  467. write (6,*) ' sepa2 mauvais domaine ',mdomn,
  468. > ipos(k+nodes),nrelong(k)
  469. GOTO 100
  470. endif
  471. IF(NRELONG(K).GT.L) GOTO 110
  472. 100 CONTINUE
  473. * recherche de izcti
  474. do kk=iadj(i),iadj(i+1)-1
  475. k=jadjc(kk)
  476. if (k.ne.0) then
  477. if (nrelong(k).eq.0) then
  478. ipkn=ipos(ipos(k+nodes)+1)
  479. if (izcti1.eq.ipkn) then
  480. elseif (izcti1.gt.ipkn) then
  481. izcti8=izcti7
  482. izcti7=izcti6
  483. izcti6=izcti5
  484. izcti5=izcti4
  485. izcti4=izcti3
  486. izcti3=izcti2
  487. izcti2=izcti1
  488. izcti1=ipkn
  489. elseif (izcti2.eq.ipkn) then
  490. elseif (izcti2.gt.ipkn) then
  491. izcti8=izcti7
  492. izcti7=izcti6
  493. izcti6=izcti5
  494. izcti5=izcti4
  495. izcti4=izcti3
  496. izcti3=izcti2
  497. izcti2=ipkn
  498. ELSEIF (IZCTI3.EQ.ipkn) THEN
  499. elseif (izcti3.gt.ipkn) then
  500. izcti8=izcti7
  501. izcti7=izcti6
  502. izcti6=izcti5
  503. izcti5=izcti4
  504. izcti4=izcti3
  505. izcti3=ipkn
  506. elseif (izcti4.eq.ipkn) then
  507. elseif (izcti4.gt.ipkn) then
  508. izcti8=izcti7
  509. izcti7=izcti6
  510. izcti6=izcti5
  511. izcti5=izcti4
  512. izcti4=ipkn
  513. elseif (izcti5.eq.ipkn) then
  514. elseif (izcti5.gt.ipkn) then
  515. izcti8=izcti7
  516. izcti7=izcti6
  517. izcti6=izcti5
  518. izcti5=ipkn
  519. elseif (izcti6.eq.ipkn) then
  520. elseif (izcti6.gt.ipkn) then
  521. izcti8=izcti7
  522. izcti7=izcti6
  523. izcti6=ipkn
  524. elseif (izcti7.eq.ipkn) then
  525. elseif (izcti7.gt.ipkn) then
  526. izcti8=izcti7
  527. izcti7=ipkn
  528. elseif (izcti8.eq.ipkn) then
  529. elseif (izcti8.gt.ipkn) then
  530. izcti8=ipkn
  531. endif
  532. endif
  533. endif
  534. enddo
  535. IPOS(I+NODES)=IPOSMAX-1
  536. IPOS(I+2*NODES)=IPOS(I+2*NODES)+1
  537. * write (6,*) ' zone ',i,IPOS(I+NODES)
  538. if (icouch.le.4) masq(i)=.false.
  539. GOTO 20
  540. ENDIF
  541. *
  542. * L'extérieur
  543. IF(NRELONG(I).GT.L) THEN
  544. * recherche de izcte
  545. do kk=iadj(i),iadj(i+1)-1
  546. k=jadjc(kk)
  547. if (k.ne.0) then
  548. if (nrelong(k).eq.0) then
  549. ipkn=ipos(ipos(k+nodes)+1)
  550. if (izcte1.eq.ipkn) then
  551. elseif (izcte1.gt.ipkn) then
  552. izcte8=izcte7
  553. izcte7=izcte6
  554. izcte6=izcte5
  555. izcte5=izcte4
  556. izcte4=izcte3
  557. izcte3=izcte2
  558. izcte2=izcte1
  559. izcte1=ipkn
  560. elseif (izcte2.eq.ipkn) then
  561. elseif (izcte2.gt.ipkn) then
  562. izcte8=izcte7
  563. izcte7=izcte6
  564. izcte6=izcte5
  565. izcte5=izcte4
  566. izcte4=izcte3
  567. izcte3=izcte2
  568. izcte2=ipkn
  569. elseif (izcte3.eq.ipkn) then
  570. elseif (izcte3.gt.ipkn) then
  571. izcte8=izcte7
  572. izcte7=izcte6
  573. izcte6=izcte5
  574. izcte5=izcte4
  575. izcte4=izcte3
  576. izcte3=ipkn
  577. elseif (izcte4.eq.ipkn) then
  578. elseif (izcte4.gt.ipkn) then
  579. izcte8=izcte7
  580. izcte7=izcte6
  581. izcte6=izcte5
  582. izcte5=izcte4
  583. izcte4=ipkn
  584. elseif (izcte5.eq.ipkn) then
  585. elseif (izcte5.gt.ipkn) then
  586. izcte8=izcte7
  587. izcte7=izcte6
  588. izcte6=izcte5
  589. izcte5=ipkn
  590. elseif (izcte6.eq.ipkn) then
  591. elseif (izcte6.gt.ipkn) then
  592. izcte8=izcte7
  593. izcte7=izcte6
  594. izcte6=ipkn
  595. elseif (izcte7.eq.ipkn) then
  596. elseif (izcte7.gt.ipkn) then
  597. izcte8=izcte7
  598. izcte7=ipkn
  599. elseif (izcte8.eq.ipkn) then
  600. elseif (izcte8.gt.ipkn) then
  601. izcte8=ipkn
  602. endif
  603. endif
  604. endif
  605. enddo
  606.  
  607. IPOS(I+NODES)=IPOSMAX
  608. IPOS(I+2*NODES)=IPOS(I+2*NODES)+1
  609. * write (6,*) ' zone ',i,IPOS(I+NODES)
  610. if (icouch.le.4) masq(i)=.false.
  611. GOTO 20
  612. ENDIF
  613. GOTO 21
  614. * la frontiere
  615. 110 CONTINUE
  616. * write (6,*) ' zone ',i,IPOS(I+NODES)
  617. MASQ(I)=.FALSE.
  618. IPOS(I+NODES)=IPOSMAX-2
  619. DIMSEP=DIMSEP+1
  620. GOTO 20
  621. ENDIF
  622. * mars
  623. 21 CONTINUE
  624.  
  625. 20 CONTINUE
  626. * do 23 i=1,nodes
  627. * IF(MDOMN.EQ.IPOS(I+NODES).AND.NRELONG(I).EQ.0) THEN
  628. * write (6,*) ' zone non connexe 2 ',mdomn,i
  629. * endif
  630. * 23 continue
  631.  
  632. * write (6,*) ' taille de frontière ',dimsep-dimseq
  633. * write (6,*) ' rang des zones ',izcti,izcte
  634. ipos1=max(IPOS(IPOSMAX+1-1),IPOS(IPOSMAX+1+0))
  635. ipos2=min(IPOS(IPOSMAX+1-1),IPOS(IPOSMAX+1+0))
  636. if (izcti1.gt.izcte1) then
  637. * write(6,*) 'sepa2 ordre 1 +'
  638. IPOS(IPOSMAX+1-1)=ipos1
  639. IPOS(IPOSMAX+1+0)=ipos2
  640. elseif (izcti1.lt.izcte1) then
  641. * write(6,*) 'sepa2 ordre 1 -'
  642. IPOS(IPOSMAX+1-1)=ipos2
  643. IPOS(IPOSMAX+1+0)=ipos1
  644. elseif (izcti2.gt.izcte2) then
  645. * write(6,*) 'sepa2 ordre 2 +'
  646. IPOS(IPOSMAX+1-1)=ipos1
  647. IPOS(IPOSMAX+1+0)=ipos2
  648. elseif (izcti2.lt.izcte2) then
  649. * write(6,*) 'sepa2 ordre 2 -'
  650. IPOS(IPOSMAX+1-1)=ipos2
  651. IPOS(IPOSMAX+1+0)=ipos1
  652. elseif (izcti3.gt.izcte3) then
  653. * write(6,*) 'sepa2 ordre 3 +'
  654. IPOS(IPOSMAX+1-1)=ipos1
  655. IPOS(IPOSMAX+1+0)=ipos2
  656. elseif (izcti3.lt.izcte3) then
  657. * write(6,*) 'sepa2 ordre 3 -'
  658. IPOS(IPOSMAX+1-1)=ipos2
  659. IPOS(IPOSMAX+1+0)=ipos1
  660. elseif (izcti4.gt.izcte4) then
  661. * write(6,*) 'sepa2 ordre 4 +'
  662. IPOS(IPOSMAX+1-1)=ipos1
  663. IPOS(IPOSMAX+1+0)=ipos2
  664. elseif (izcti4.lt.izcte4) then
  665. * write(6,*) 'sepa2 ordre 4 -'
  666. IPOS(IPOSMAX+1-1)=ipos2
  667. IPOS(IPOSMAX+1+0)=ipos1
  668. elseif (izcti5.gt.izcte5) then
  669. * write(6,*) 'sepa2 ordre 5 +'
  670. IPOS(IPOSMAX+1-1)=ipos1
  671. IPOS(IPOSMAX+1+0)=ipos2
  672. elseif (izcti5.lt.izcte5) then
  673. * write(6,*) 'sepa2 ordre 5 -'
  674. IPOS(IPOSMAX+1-1)=ipos2
  675. IPOS(IPOSMAX+1+0)=ipos1
  676. elseif (izcti6.gt.izcte6) then
  677. * write(6,*) 'sepa2 ordre 6 +'
  678. IPOS(IPOSMAX+1-1)=ipos1
  679. IPOS(IPOSMAX+1+0)=ipos2
  680. elseif (izcti6.lt.izcte6) then
  681. * write(6,*) 'sepa2 ordre 6 -'
  682. IPOS(IPOSMAX+1-1)=ipos2
  683. IPOS(IPOSMAX+1+0)=ipos1
  684. elseif (izcti7.gt.izcte7) then
  685. * write(6,*) 'sepa2 ordre 7 +'
  686. IPOS(IPOSMAX+1-1)=ipos1
  687. IPOS(IPOSMAX+1+0)=ipos2
  688. elseif (izcti7.lt.izcte7) then
  689. * write(6,*) 'sepa2 ordre 7 -'
  690. IPOS(IPOSMAX+1-1)=ipos2
  691. IPOS(IPOSMAX+1+0)=ipos1
  692. elseif (izcti8.gt.izcte8) then
  693. * write(6,*) 'sepa2 ordre 8 +'
  694. IPOS(IPOSMAX+1-1)=ipos1
  695. IPOS(IPOSMAX+1+0)=ipos2
  696. elseif (izcti8.le.izcte8) then
  697. * write(6,*) 'sepa2 ordre 8 -'
  698. IPOS(IPOSMAX+1-1)=ipos2
  699. IPOS(IPOSMAX+1+0)=ipos1
  700. else
  701. * write (6,*) ' ordonnancement impossible'
  702. * > izcti1,izcti2,izcti3,izcti4,izcti5,izcti6,
  703. * > izcte1,izcte2,izcte3,izcte4,izcte5,izcte6
  704. IPOS(IPOSMAX+1-1)=ipos1
  705. IPOS(IPOSMAX+1+0)=ipos2
  706. endif
  707.  
  708. 50 continue
  709. do ix=1,dimlon
  710. ii=noelon(ix)
  711. if(ii.ne.0) nrelong(ii)=0
  712. enddo
  713.  
  714. RETURN
  715. END
  716.  
  717.  
  718.  
  719.  
  720.  
  721.  
  722.  
  723.  
  724.  
  725.  
  726.  
  727.  
  728.  
  729.  
  730.  
  731.  
  732.  
  733.  
  734.  
  735.  
  736.  
  737.  
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  
  750.  
  751.  
  752.  
  753.  
  754.  
  755.  
  756.  
  757.  
  758.  
  759.  
  760.  
  761.  
  762.  
  763.  
  764.  
  765.  
  766.  
  767.  
  768.  
  769.  
  770.  
  771.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales