Télécharger noepr2.eso

Retour à la liste

Numérotation des lignes :

  1. C NOEPR2 SOURCE PV 16/12/15 21:15:07 9264
  2. C****************************************************************************
  3. C****************************************************************************
  4. C*************NOEPERI ..NOEuds PERIpheriques*********************************
  5. C****************************************************************************
  6. C****************************************************************************
  7.  
  8. C NOEPERI part de PIVOT,lui associe l=1, associe l=l+1 a ses voisins directs,
  9. C repart des voisins directs pour associer un l a leur voisins....
  10. C LONG=max(l).
  11. C NRELONG(I)=l ,NOELON contient les noeuds tels que l=LONG.
  12. * noepr2 rend en prime la distance a la frontiere, sa taille et le
  13. * desequilibre des domaines
  14. * si nbtot n'est pas nul, noepr2 s'arrete des qu'il a trouve la
  15. * frontiere (il a remplis nbtot/2) pts. nrelong est alors remis a
  16. * zero
  17. * Octobre 2014: croissance simultanee de deux zones basees sur les pivots impairs ou pairs
  18. *
  19. SUBROUTINE NOEPR2(IADJ,JADJC,PIVOT,NRELONG,NOELON,isens,dimlon,
  20. > MASQ,NODES,IPOS,NBTOT,lfront,lfron,londim,fcout,lpiv,iccon)
  21. IMPLICIT INTEGER(I-N)
  22. IMPLICIT REAL*8 (A-H,O-Z)
  23.  
  24. integer iadj(1),jadjc(1)
  25. integer pivot(lpiv)
  26.  
  27. INTEGER LONG,DIMLON,Y,X,dimini,diminj
  28. integer nrelong(1),noelon(1)
  29.  
  30. integer ipos(1)
  31. logical masq(1)
  32. integer londim(*)
  33. INTEGER NODES
  34.  
  35. INTEGER diml1,DIML2,diml3,diml1i,diml2f,diml1f,diml2i
  36. LOGICAL bool1,bool2
  37.  
  38. MDOMN=-1
  39. do i=1,lpiv
  40. if (pivot(i).ne.0) then
  41. MDOMN=IPOS(PIVOT(i)+NODES)
  42. goto 1
  43. endif
  44. enddo
  45. 1 continue
  46. mode=1
  47. if (nbtot.eq.0) mode=2
  48. if (nbtot.eq.-1) mode=3
  49. if (nbtot .gt. nodes) call erreur(5)
  50. nodz=nodes
  51. if (nbtot.gt.0) nodz=nbtot
  52. DIMLON=0
  53. LONG=3
  54. * write (6,*) ' noepr2 lpiv pivot ',lpiv,(pivot(i),i=1,lpiv)
  55. nbz1=0
  56. nbz2=0
  57. * insertion pivot impair zone 1
  58. DIML1=0
  59. do 10 i=1,lpiv,2
  60. ** write (6,*) ' i pivot(i) ',i,pivot(i)
  61. if (pivot(i).le.0) goto 10
  62. if (ipos(pivot(i)+nodes).ne.mdomn) goto 10
  63. * if (i.eq.1) write (6,*) 'noepr2 mode i pivot nrelong',
  64. * > i,pivot(i),nrelong(pivot(i))
  65. if (nrelong(pivot(i)).ne.0) goto 10
  66. diml1=diml1+1
  67. noelon(diml1)=pivot(i)
  68. nrelong(pivot(i))=1
  69. nbz1=nbz1+1
  70. 10 continue
  71. * insertion pivot pair zone 2
  72. DIML2=nodz+1
  73. do 11 i=2,lpiv,2
  74. if (pivot(i).le.0) goto 11
  75. * write (6,*) 'noepr2 mode i pivot nrelong',
  76. * > i,pivot(i),nrelong(pivot(i))
  77. if (ipos(pivot(i)+nodes).ne.mdomn) goto 11
  78. if (nrelong(pivot(i)).ne.0) goto 11
  79. diml2=diml2-1
  80. noelon(diml2)=pivot(i)
  81. nrelong(pivot(i))=3
  82. nbz2=nbz2+1
  83. 11 continue
  84. if (diml1.eq.0.and.diml2.eq.nodz+1) call erreur(5)
  85. *
  86. * croissance des deux zones
  87. *
  88. icr1=1
  89. icr2=2
  90. bool1=.true.
  91. bool2=.true.
  92. diml1i=1
  93. diml2f=nodz
  94. icouch=0
  95. 20 continue
  96. ** evaluation frontiere
  97. if (bool1.and.(icr1*nbz1.le.icr2*nbz2.or..not.bool2)) then
  98. do 22 i=diml1i,diml1
  99. nz1=0
  100. nz2=0
  101. x=noelon(i)
  102. if (nrelong(x).eq.2) goto 22
  103. DO 29 J=IADJ(X),IADJ(X+1)-1
  104. Y=JADJC(J)
  105. ** if (mdomn.ne.ipos(y+nodes))goto 29
  106. if (nrelong(y).eq.1) nz1=nz1+1
  107. if (nrelong(y).eq.3) nz2=nz2+1
  108. 29 continue
  109. if (nz2.gt.nz1) then
  110. nbz1=nbz1-1
  111. nrelong(x)=2
  112. icr1=3
  113. icr2=4
  114. endif
  115. * write (6,*) 'frontiere 1 => 2',nz1,nz2
  116. 22 continue
  117. icouch=icouch+1
  118. bool1=.false.
  119. diml1f=diml1
  120. * write (6,*) ' diml1i diml1f ',diml1i,diml1f
  121. do 30 i=diml1i,diml1f
  122. x=noelon(i)
  123. if (nrelong(x).eq.2) goto 30
  124. DO 40 J=IADJ(X),IADJ(X+1)-1
  125. Y=JADJC(J)
  126. if (mdomn.ne.ipos(y+nodes))goto 40
  127. IF(NRELONG(Y).EQ.0) then
  128. * insertion zone 1
  129. diml1=diml1+1
  130. noelon(diml1)=y
  131. nrelong(y)=1
  132. nbz1=nbz1+1
  133. BOOL1=.true.
  134. * if (mode.ne.2) write (6,*) ' insertion dans 1 de ',diml1,y
  135. goto 40
  136. elseif (NRELONG(Y).eq.1) then
  137. * zone 1
  138. * if (mode.ne.2) write (6,*) ' deja en zone 1 ',y
  139. goto 40
  140. elseif (nrelong(y).eq.2) then
  141. * frontiere
  142. * if (mode.ne.2) write (6,*) ' deja en frontiere 1 ',y
  143. goto 40
  144. elseif (nrelong(y).eq.3) then
  145. * zone 2 <<> frontiere
  146. * if (mode.ne.2) write (6,*) ' passage 1 sur frontiere de ',y
  147. icr1=3
  148. icr2=4
  149. nrelong(y)=2
  150. nbz2=nbz2-1
  151. goto 40
  152. endif
  153. 40 continue
  154. 30 continue
  155. diml1i=diml1f+1
  156. endif
  157. if (bool2.and.(icr1*nbz2.le.icr2*nbz1.or..not.bool1)) then
  158. do 23 i=diml2f,diml2,-1
  159. nz1=0
  160. nz2=0
  161. x=noelon(i)
  162. if (nrelong(x).eq.2) goto 23
  163. DO 28 J=IADJ(X+1)-1,IADJ(X),-1
  164. Y=JADJC(J)
  165. ** if (mdomn.ne.ipos(y+nodes))goto 28
  166. if (nrelong(y).eq.1) nz1=nz1+1
  167. if (nrelong(y).eq.3) nz2=nz2+1
  168. 28 continue
  169. if (nz1.gt.nz2) then
  170. nbz2=nbz2-1
  171. nrelong(x)=2
  172. icr1=3
  173. icr2=4
  174. endif
  175. * write (6,*) 'frontiere 3 => 2',nz1,nz2
  176. 23 continue
  177. icouch=icouch+1
  178. bool2=.false.
  179. diml2i=diml2
  180. * write (6,*) ' diml2f diml2i ',diml2f,diml2i
  181. do 50 i=diml2f,diml2i,-1
  182. x=noelon(i)
  183. if (nrelong(x).eq.2) goto 50
  184. DO 60 J=IADJ(X+1)-1,IADJ(X),-1
  185. Y=JADJC(J)
  186. if (mdomn.ne.ipos(y+nodes))goto 60
  187. IF(NRELONG(Y).EQ.0) then
  188. * insertion zone 3
  189. diml2=diml2-1
  190. noelon(diml2)=y
  191. nrelong(y)=3
  192. nbz2=nbz2+1
  193. BOOL2=.true.
  194. * if (mode.ne.2) write (6,*) ' insertion dans 2 de ',diml2,y
  195. goto 60
  196. elseif (NRELONG(Y).eq.3) then
  197. * zone 3
  198. * if (mode.ne.2) write (6,*) ' deja en zone 2 ',y
  199. goto 60
  200. elseif (nrelong(y).eq.2) then
  201. * frontiere
  202. * if (mode.ne.2) write (6,*) ' deja en frontiere 2 ',y
  203. goto 60
  204. elseif (nrelong(y).eq.1) then
  205. * zone 1 ==> frontiere
  206. * if (mode.ne.2) write (6,*) ' passage 2 sur frontiere de ',y
  207. nrelong(y)=2
  208. nbz1=nbz1-1
  209. icr1=3
  210. icr2=4
  211. goto 60
  212. endif
  213. 60 continue
  214. 50 continue
  215. diml2f=diml2i-1
  216. endif
  217. if (bool1.or.bool2) goto 20
  218. nbtotn=diml1+nodz+1-diml2
  219. * dans le cas ou la zone n'est pas connexe on va completer par
  220. * la partie non connexe
  221. if (mode.ne.2.and.nbtot.gt.nbtotn) then
  222. * write (6,*) ' ajout autres composantes connexes ',diml1,diml2,
  223. * > nbtotn,nbtot,nodz
  224. * si pas trop de noeuds
  225. * on commence par examiner le voisinage de la frontiere car c'est moins cher
  226. **** if (mode.ne.3) goto 21
  227. diml1i=diml1
  228. do 200 i=1,nbtot
  229. x=noelon(i)
  230. if (x.eq.0) goto 200
  231. if (nrelong(x).ne.2) goto 200
  232. DO 210 J=IADJ(X),IADJ(X+1)-1
  233. Y=JADJC(J)
  234. if (mdomn.ne.ipos(y+nodes))goto 210
  235. IF(NRELONG(Y).EQ.0) then
  236. DIML1=DIML1+1
  237. NOELON(DIML1)=Y
  238. NRELONG(Y)=1
  239. nbtotn=nbtotn+1
  240. if (nbtot.le.nbtotn) goto 21
  241. endif
  242. 210 continue
  243. 200 continue
  244. if (diml1.eq.diml1i) goto 220
  245. * Si on a rajoute des noeuds, on fait aussi leurs voisinage
  246. 230 continue
  247. nodi=diml1i+1
  248. diml1i=diml1
  249. nodf=diml1
  250. do 240 i=nodi,nodf
  251. x=noelon(i)
  252. DO 250 J=IADJ(X),IADJ(X+1)-1
  253. Y=JADJC(J)
  254. if (mdomn.ne.ipos(y+nodes))goto 250
  255. IF(NRELONG(Y).EQ.0) then
  256. DIML1=DIML1+1
  257. NOELON(DIML1)=Y
  258. NRELONG(Y)=1
  259. nbtotn=nbtotn+1
  260. if (nbtot.le.nbtotn) goto 21
  261. endif
  262. 250 continue
  263. 240 continue
  264. if (diml1.ne.diml1i) goto 230
  265. 220 continue
  266. if (mode.ne.3) goto 21
  267.  
  268. * write (6,*) ' ajout 2autres composantes connexes ',diml1,diml2,
  269. * > nbtotn,nbtot,nodz
  270. 21 continue
  271. endif
  272. * Si on n'a toujours pas notre compte, on balaye tout
  273. if ((iccon.eq.1.and.mode.eq.2).or.
  274. > (mode.eq.1.and.nbtot.gt.nbtotn)) then
  275. do Y=1,NODES
  276. IF((NRELONG(Y).EQ.0).AND.(MDOMN.EQ.IPOS(Y+NODES))) THEN
  277. DIML1=DIML1+1
  278. NOELON(DIML1)=Y
  279. NRELONG(Y)=1
  280. nbtotn=nbtotn+1
  281. if (mode.eq.1.and.nbtot.le.nbtotn) goto 215
  282. ENDIF
  283. enddo
  284. 215 continue
  285. endif
  286. nbtot=nbtotn
  287. *
  288. * remise au carre des deux zones et de la frontiere
  289. *
  290. nbtot=diml1+nodz+1-diml2
  291. * write (6,*) ' nodes diml1 diml2 ',nodes,diml1,diml2,nbtot
  292. * classer a la fin par permutation dans zone 1 la frontiere
  293. diml1f=diml1
  294. do 100 i=1,diml1-1
  295. x=noelon(i)
  296. if (nrelong(x).eq.2) then
  297. do 105 j=diml1f,i+1,-1
  298. y=noelon(j)
  299. if (nrelong(y).eq.1) goto 106
  300. 105 continue
  301. goto 107
  302. 106 continue
  303. diml1f=j-1
  304. noelon(i)=y
  305. noelon(j)=x
  306. endif
  307. 100 continue
  308. 107 continue
  309. * classer au debut par permutation dans zone 2 la frontiere
  310. diml2i=diml2
  311. do 110 i=nodz,diml2+1,-1
  312. x=noelon(i)
  313. if (nrelong(x).eq.2) then
  314. do 115 j=diml2i,i-1
  315. y=noelon(j)
  316. if (nrelong(y).eq.3) goto 116
  317. 115 continue
  318. goto 117
  319. 116 continue
  320. diml2i=j+1
  321. noelon(i)=y
  322. noelon(j)=x
  323. endif
  324. 110 continue
  325. 117 continue
  326. * suprimer le trou entre les deux
  327. if (nodz.ne.nbtot) then
  328. do 120 i=diml2,nodz
  329. noelon(i-nodz+nbtot)=noelon(i)
  330. 120 continue
  331. endif
  332.  
  333. * decompte des longueurs
  334. n1bz1=0
  335. n1bz2=0
  336. nbfr=0
  337. do 130 i=1,nbtot
  338. x=noelon(i)
  339. if (nrelong(x).eq.1) n1bz1=n1bz1+1
  340. if (nrelong(x).eq.2) nbfr=nbfr+1
  341. if (nrelong(x).eq.3) n1bz2=n1bz2+1
  342. 130 continue
  343. ** if (nbfr.ne.nbfra) write (6,*) ' nbfr nbfra ',nbfr,nbfra
  344. * write (6,*) 'nbtot n1bz1 nbfr n1bz2',nbtot,n1bz1,nbfr,n1bz2
  345. *
  346. * finalisation des infos
  347. *
  348. londim(1)=n1bz1
  349. londim(2)=n1bz1+nbfr
  350. londim(3)=n1bz1+nbfr+n1bz2
  351. long=3
  352. dimlon=londim(3)
  353. ideseq=abs(n1bz1-n1bz2)
  354. xbtot=nbtot
  355. xbfr=nbfr
  356. xdeseq=ideseq
  357. ** fcout=(xbfr )**4 + (xdeseq )**3
  358.  
  359. fcout= 2*xbtot*xbfr+xbfr*xbfr*xbfr/3.0 + xdeseq**2 -icouch
  360. ** write (6,*) 'xbtot',nbtot,'xbfr',nbfr,'xdeseq',ideseq,'fcout',
  361. ** > fcout,'icouch',icouch
  362.  
  363. if (nbtot/(xdeseq+1).le.2)
  364. > fcout=fcout+xbtot*xbtot*xbtot*xbtot
  365. if (nbfr.eq.0.and.lpiv.ne.1.and.pivot(1).ne.0.and.
  366. > pivot(2).ne.0) then
  367. ** write (6,*) ' frontiere vide ',n1bz1,n1bz2,nbtot,mdomn
  368. if (mode.ne.2.and.n1bz1*n1bz2.ne.0) fcout=1
  369. endif
  370.  
  371. * write (6,*) ' noepr2 ',n1bz1,n1bz2,nbfr,nbtot,
  372. * > noelon(1),noelon(nbtot),fcout
  373. isens=2
  374. if (n1bz1.lt.n1bz2) isens=1
  375. * mise a zero eventuelle de nrelong
  376. if (mode.ne.2) then
  377. do i=1,dimlon
  378. x=noelon(i)
  379. if (x.ne.0) nrelong(x)=0
  380. enddo
  381. endif
  382. lfron = long
  383. lfront=2
  384. if (n1bz2.eq.0.or.n1bz1.eq.0) lfront=1
  385. if (mode.eq.1) nbtot=nodz
  386. return
  387. end
  388.  
  389.  
  390.  
  391.  
  392.  
  393.  
  394.  
  395.  
  396.  
  397.  
  398.  
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.  
  406.  
  407.  
  408.  
  409.  
  410.  
  411.  
  412.  
  413.  
  414.  

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