Télécharger sepa2.eso

Retour à la liste

Numérotation des lignes :

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

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