Télécharger noepr2.eso

Retour à la liste

Numérotation des lignes :

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

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