Télécharger noepr2.eso

Retour à la liste

Numérotation des lignes :

  1. C NOEPR2 SOURCE PV 20/08/22 21:15:01 10699
  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=2
  91. icr2=3
  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. endif
  115. * write (6,*) 'frontiere 1 => 2',nz1,nz2
  116. 22 continue
  117. bool1=.false.
  118. diml1f=diml1
  119. * write (6,*) ' diml1i diml1f ',diml1i,diml1f
  120. do 30 i=diml1i,diml1f
  121. x=noelon(i)
  122. if (nrelong(x).eq.2) goto 30
  123. DO 40 J=IADJ(X),IADJ(X+1)-1
  124. Y=JADJC(J)
  125. if (mdomn.ne.ipos(y+nodes))goto 40
  126. IF(NRELONG(Y).EQ.0) then
  127. * insertion zone 1
  128. diml1=diml1+1
  129. if (.not.bool1) icouch=icouch+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. nrelong(y)=2
  148. nbz2=nbz2-1
  149. goto 40
  150. endif
  151. 40 continue
  152. 30 continue
  153. diml1i=diml1f+1
  154. endif
  155. if (bool2.and.(icr1*nbz2.le.icr2*nbz1.or..not.bool1)) then
  156. do 23 i=diml2f,diml2,-1
  157. nz1=0
  158. nz2=0
  159. x=noelon(i)
  160. if (nrelong(x).eq.2) goto 23
  161. DO 28 J=IADJ(X+1)-1,IADJ(X),-1
  162. Y=JADJC(J)
  163. ** if (mdomn.ne.ipos(y+nodes))goto 28
  164. if (nrelong(y).eq.1) nz1=nz1+1
  165. if (nrelong(y).eq.3) nz2=nz2+1
  166. 28 continue
  167. if (nz1.gt.nz2) then
  168. nbz2=nbz2-1
  169. nrelong(x)=2
  170. endif
  171. * write (6,*) 'frontiere 3 => 2',nz1,nz2
  172. 23 continue
  173. bool2=.false.
  174. diml2i=diml2
  175. * write (6,*) ' diml2f diml2i ',diml2f,diml2i
  176. do 50 i=diml2f,diml2i,-1
  177. x=noelon(i)
  178. if (nrelong(x).eq.2) goto 50
  179. DO 60 J=IADJ(X+1)-1,IADJ(X),-1
  180. Y=JADJC(J)
  181. if (mdomn.ne.ipos(y+nodes))goto 60
  182. IF(NRELONG(Y).EQ.0) then
  183. * insertion zone 3
  184. diml2=diml2-1
  185. if (.not.bool2) icouch=icouch+1
  186. noelon(diml2)=y
  187. nrelong(y)=3
  188. nbz2=nbz2+1
  189. BOOL2=.true.
  190. * if (mode.ne.2) write (6,*) ' insertion dans 2 de ',diml2,y
  191. goto 60
  192. elseif (NRELONG(Y).eq.3) then
  193. * zone 3
  194. * if (mode.ne.2) write (6,*) ' deja en zone 2 ',y
  195. goto 60
  196. elseif (nrelong(y).eq.2) then
  197. * frontiere
  198. * if (mode.ne.2) write (6,*) ' deja en frontiere 2 ',y
  199. goto 60
  200. elseif (nrelong(y).eq.1) then
  201. * zone 1 ==> frontiere
  202. * if (mode.ne.2) write (6,*) ' passage 2 sur frontiere de ',y
  203. nrelong(y)=2
  204. nbz1=nbz1-1
  205. goto 60
  206. endif
  207. 60 continue
  208. 50 continue
  209. diml2f=diml2i-1
  210. endif
  211. if (bool1.or.bool2) goto 20
  212. nbtotn=diml1+nodz+1-diml2
  213. * dans le cas ou la zone n'est pas connexe on va completer par
  214. * la partie non connexe
  215. if (mode.ne.2.and.nbtot.gt.nbtotn) then
  216. * write (6,*) ' ajout autres composantes connexes ',diml1,diml2,
  217. * > nbtotn,nbtot,nodz
  218. * si pas trop de noeuds
  219. * on commence par examiner le voisinage de la frontiere car c'est moins cher
  220. **** if (mode.ne.3) goto 21
  221. diml1i=diml1
  222. do 200 i=1,nbtot
  223. x=noelon(i)
  224. if (x.eq.0) goto 200
  225. if (nrelong(x).ne.2) goto 200
  226. DO 210 J=IADJ(X),IADJ(X+1)-1
  227. Y=JADJC(J)
  228. if (mdomn.ne.ipos(y+nodes))goto 210
  229. IF(NRELONG(Y).EQ.0) then
  230. DIML1=DIML1+1
  231. NOELON(DIML1)=Y
  232. NRELONG(Y)=1
  233. nbtotn=nbtotn+1
  234. if (nbtot.le.nbtotn) goto 21
  235. endif
  236. 210 continue
  237. 200 continue
  238. if (diml1.eq.diml1i) goto 220
  239. * Si on a rajoute des noeuds, on fait aussi leurs voisinage
  240. 230 continue
  241. nodi=diml1i+1
  242. diml1i=diml1
  243. nodf=diml1
  244. do 240 i=nodi,nodf
  245. x=noelon(i)
  246. DO 250 J=IADJ(X),IADJ(X+1)-1
  247. Y=JADJC(J)
  248. if (mdomn.ne.ipos(y+nodes))goto 250
  249. IF(NRELONG(Y).EQ.0) then
  250. DIML1=DIML1+1
  251. NOELON(DIML1)=Y
  252. NRELONG(Y)=1
  253. nbtotn=nbtotn+1
  254. if (nbtot.le.nbtotn) goto 21
  255. endif
  256. 250 continue
  257. 240 continue
  258. if (diml1.ne.diml1i) goto 230
  259. 220 continue
  260. if (mode.ne.3) goto 21
  261.  
  262. * write (6,*) ' ajout 2autres composantes connexes ',diml1,diml2,
  263. * > nbtotn,nbtot,nodz
  264. 21 continue
  265. endif
  266. * Si on n'a toujours pas notre compte, on balaye tout
  267. if ((iccon.eq.1.and.mode.eq.2).or.
  268. > (mode.eq.1.and.nbtot.gt.nbtotn)) then
  269. do Y=1,NODES
  270. IF((NRELONG(Y).EQ.0).AND.(MDOMN.EQ.IPOS(Y+NODES))) THEN
  271. DIML1=DIML1+1
  272. NOELON(DIML1)=Y
  273. NRELONG(Y)=1
  274. nbtotn=nbtotn+1
  275. if (mode.eq.1.and.nbtot.le.nbtotn) goto 215
  276. ENDIF
  277. enddo
  278. 215 continue
  279. endif
  280. nbtot=nbtotn
  281. *
  282. * remise au carre des deux zones et de la frontiere
  283. *
  284. nbtot=diml1+nodz+1-diml2
  285. * write (6,*) ' nodes diml1 diml2 ',nodes,diml1,diml2,nbtot
  286. * classer a la fin par permutation dans zone 1 la frontiere
  287. diml1f=diml1
  288. do 100 i=1,diml1-1
  289. x=noelon(i)
  290. if (nrelong(x).eq.2) then
  291. do 105 j=diml1f,i+1,-1
  292. y=noelon(j)
  293. if (nrelong(y).eq.1) goto 106
  294. 105 continue
  295. goto 107
  296. 106 continue
  297. diml1f=j-1
  298. noelon(i)=y
  299. noelon(j)=x
  300. endif
  301. 100 continue
  302. 107 continue
  303. * classer au debut par permutation dans zone 2 la frontiere
  304. diml2i=diml2
  305. do 110 i=nodz,diml2+1,-1
  306. x=noelon(i)
  307. if (nrelong(x).eq.2) then
  308. do 115 j=diml2i,i-1
  309. y=noelon(j)
  310. if (nrelong(y).eq.3) goto 116
  311. 115 continue
  312. goto 117
  313. 116 continue
  314. diml2i=j+1
  315. noelon(i)=y
  316. noelon(j)=x
  317. endif
  318. 110 continue
  319. 117 continue
  320. * suprimer le trou entre les deux
  321. if (nodz.ne.nbtot) then
  322. do 120 i=diml2,nodz
  323. noelon(i-nodz+nbtot)=noelon(i)
  324. 120 continue
  325. endif
  326.  
  327. * decompte des longueurs
  328. n1bz1=0
  329. n1bz2=0
  330. nbfr=0
  331. do 130 i=1,nbtot
  332. x=noelon(i)
  333. if (nrelong(x).eq.1) n1bz1=n1bz1+1
  334. if (nrelong(x).eq.2) nbfr=nbfr+1
  335. if (nrelong(x).eq.3) n1bz2=n1bz2+1
  336. 130 continue
  337. ** if (nbfr.ne.nbfra) write (6,*) ' nbfr nbfra ',nbfr,nbfra
  338. * write (6,*) 'nbtot n1bz1 nbfr n1bz2',nbtot,n1bz1,nbfr,n1bz2
  339. *
  340. * finalisation des infos
  341. *
  342. londim(1)=n1bz1
  343. londim(2)=n1bz1+nbfr
  344. londim(3)=n1bz1+nbfr+n1bz2
  345. long=3
  346. dimlon=londim(3)
  347. ideseq=abs(n1bz1-n1bz2)
  348. xbtot=nbtot
  349. xbfr=nbfr
  350. xdeseq=ideseq
  351. ** fcout=(xbfr )**4 + (xdeseq )**3
  352.  
  353. fcout= 2*xbtot*xbfr+xbfr*xbfr*xbfr/3.0 + xdeseq**2 -icouch**2
  354. ** write (6,*) 'xbtot',nbtot,'xbfr',nbfr,'xdeseq',ideseq,'fcout',
  355. ** > fcout,'icouch',icouch
  356.  
  357. if (nbtot/(xdeseq+1).le.2)
  358. > fcout=fcout+xbtot*xbtot*xbtot*xbtot
  359. if (nbfr.eq.0.and.lpiv.ne.1.and.pivot(1).ne.0.and.
  360. > pivot(2).ne.0) then
  361. ** write (6,*) ' frontiere vide ',n1bz1,n1bz2,nbtot,mdomn
  362. if (mode.ne.2.and.n1bz1*n1bz2.ne.0) fcout=1
  363. endif
  364.  
  365. * write (6,*) ' noepr2 ',n1bz1,n1bz2,nbfr,nbtot,
  366. * > noelon(1),noelon(nbtot),fcout
  367. isens=2
  368. if (n1bz1.lt.n1bz2) isens=1
  369. * mise a zero eventuelle de nrelong
  370. if (mode.ne.2) then
  371. do i=1,dimlon
  372. x=noelon(i)
  373. if (x.ne.0) nrelong(x)=0
  374. enddo
  375. endif
  376. lfron = long
  377. lfront=2
  378. if (n1bz2.eq.0.or.n1bz1.eq.0) lfront=1
  379. if (mode.eq.1) nbtot=nodz
  380. return
  381. end
  382.  
  383.  
  384.  
  385.  
  386.  
  387.  
  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.  

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