Télécharger rlevb1.eso

Retour à la liste

Numérotation des lignes :

  1. C RLEVB1 SOURCE CHAT 05/01/13 03:01:51 5004
  2. SUBROUTINE RLEVB1(MELSOM,MELCEN,MLELSC,MLELSB,MLESBC,MLRDIS)
  3. C
  4. C
  5. C**** Variables de COOPTIO
  6. C
  7. C INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
  8. C & ,IOTER, IOLEC, IOIMP, IOCAR, IOACQ
  9. C & ,IOPER, IOSGB, IOGRA, IOSAU, IORES
  10. C & ,IECHO, IIMPI, IOSPI
  11. C & ,IDIM
  12. CC & ,MCOORD
  13. C & ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
  14. C & ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
  15. C & ,NORINC,NORVAL,NORIND,NORVAD
  16. C & ,NUCROU, IPSAUV
  17. C
  18. IMPLICIT INTEGER(I-N)
  19. INTEGER NCEN,I1,NMAXCE,ICEL,NMAXS,LAST,IPLSB1,IPLSB2
  20. & ,NGS,NLS,NSVOI,IPLSC1,IPLSC2,NGS1,ICEL1,NCVOI,NGC,NLC
  21. & ,I2,IPOS,NLS1,NTOTCV,NGS2,IPCOOR,I3,NCMIS
  22. REAL*8 XS,YS,ZS,DXC,DYC,DZC, DIST2, DIST21
  23. C
  24. -INC SMELEME
  25. INTEGER JG
  26. -INC SMLENTI
  27. -INC SMLREEL
  28. -INC CCOPTIO
  29. -INC SMCOORD
  30. C
  31. INTEGER NBL, NBTPOI
  32. SEGMENT MLELEM
  33. INTEGER INDEX(NBL+1)
  34. INTEGER LESPOI(NBTPOI)
  35. ENDSEGMENT
  36. POINTEUR MLELSC.MLELEM, MLELSB.MLELEM, MLESBC.MLELEM
  37. C
  38. POINTEUR MELSOM.MELEME, MELCEN.MELEME
  39. C
  40. POINTEUR MLESOM.MLENTI, MLECEN.MLENTI
  41. & ,MLECVO.MLENTI
  42. POINTEUR MLRDIS.MLREEL
  43. C
  44. C**** Le MELEME SOMMET
  45. C
  46. CALL KRIPAD(MELSOM,MLESOM)
  47. C
  48. C MLESOM: numerotation globale -> locale
  49. C
  50. C**** En KRIPAD
  51. C SEGACT MELSOM
  52. C SEGINI MLESOM
  53. C
  54. C**** Le MELEME CENTRE
  55. C
  56. CALL KRIPAD(MELCEN,MLECEN)
  57. C
  58. C MLECEN: numerotation globale -> locale
  59. C
  60. C**** En KRIPAD
  61. C SEGACT MELCEN
  62. C SEGINI MLECEN
  63. C
  64. NCEN=MELCEN.NUM(/2)
  65. C
  66. NMAXCE=0
  67. SEGACT MLELSC
  68. NBL=MLELSC.INDEX(/1)-1
  69. DO I1 = 1, NBL, 1
  70. ICEL=MLELSC.INDEX(I1+1)-MLELSC.INDEX(I1)-1
  71. NMAXCE=MAX(NMAXCE,ICEL)
  72. ENDDO
  73. C
  74. SEGACT MLELSB
  75. NMAXS=0
  76. NBL=MLELSB.INDEX(/1)-1
  77. DO I1 = 1, NBL, 1
  78. ICEL=MLELSB.INDEX(I1+1)-MLELSB.INDEX(I1)-1
  79. NMAXS=MAX(NMAXS,ICEL)
  80. ENDDO
  81. C
  82. C**** NBL de MLELSB = NBL de MLESBC
  83. C Surestimation des noeuds en MLESBC
  84. C
  85. NBTPOI=(NBL+1)*(NMAXCE*NMAXS)
  86. SEGINI MLESBC
  87. JG=NBTPOI
  88. SEGINI MLRDIS
  89. C
  90. C**** MLRDIS = dedans la structure MLESBC, distance (au carre)
  91. C premier noeud et ses voisins
  92. C
  93. C
  94. C**** MLECVO + LAST = liste chaînée des centres voisins
  95. C d'un sommet au bord
  96. JG=NCEN
  97. SEGINI MLECVO
  98. LAST=-1
  99. C
  100. C**** Soit NGS un sommet sur le bord.
  101. C Je dois créer la liste des centres voisins
  102. C des sommets voisins à NGS
  103. C Cette liste est ordonnée par rapport à la distance
  104. C centre-NGS
  105. C Cette liste ne doit pas contenir la liste des centres
  106. C voisins à NGS
  107. C
  108. C
  109. C NBTPOI = le vrai nombre de point de MLESBC
  110. NBTPOI=0
  111. C
  112. C**** IPLSB1 (IPLSB2) = position de NGS dans la structure MLELSB
  113. C IPOS = position de NGS dans la structure MLESBC
  114. C
  115. IPLSB2=1
  116. IPOS=1
  117. DO I1 = 1, NBL, 1
  118. C
  119. C******* Les sommets voisins de NGS
  120. C
  121. IPLSB1=IPLSB2
  122. IPLSB2=MLELSB.INDEX(I1+1)
  123. NSVOI=IPLSB2-IPLSB1-1
  124. C
  125. C******* Numero global et local du sommets NGS
  126. C
  127. NGS=MLELSB.LESPOI(IPLSB1)
  128. NLS=MLESOM.LECT(NGS)
  129. MLESBC.INDEX(I1)=IPOS
  130. MLESBC.LESPOI(IPOS)=NGS
  131. MLRDIS.PROG(IPOS)=0.0D0
  132. C
  133. C******* On remplie la liste chaînée avec les centres voisins de NGS
  134. C Ces centres ne doivent pas apparaitre dedans MLESBC
  135. C
  136. IPLSC1=MLELSC.INDEX(NLS)
  137. IPLSC2=MLELSC.INDEX(NLS+1)
  138. NGS1=MLELSC.LESPOI(IPLSC1)
  139. IF(NGS1 .NE. NGS)THEN
  140. C
  141. C********** Erreur de programmation
  142. C En effet, par construction, le position de NGS dans la
  143. C structure MLELSC est la meme que dans MELSOM
  144. C
  145. WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
  146. CALL ERREUR(5)
  147. GOTO 9999
  148. ENDIF
  149. NCVOI=IPLSC2-IPLSC1-1
  150. DO I2 = 1, NCVOI, 1
  151. NGC=MLELSC.LESPOI(IPLSC1+I2)
  152. NLC=MLECEN.LECT(NGC)
  153. IF((NLC.EQ.0).OR.(MLECVO.LECT(NLC).NE.0))THEN
  154. C
  155. C********** Erreur de programmation
  156. C
  157. WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
  158. CALL ERREUR(5)
  159. GOTO 9999
  160. ELSE
  161. MLECVO.LECT(NLC)=LAST
  162. LAST=NLC
  163. ENDIF
  164. ENDDO
  165. C
  166. C******* Les centre voisins de sommets voisins
  167. C
  168. NTOTCV=0
  169. C
  170. C******* Boucle sur les sommets voisins
  171. C
  172. DO I2 = 1, NSVOI, 1
  173. NGS1=MLELSB.LESPOI(IPLSB1+I2)
  174. NLS1=MLESOM.LECT(NGS1)
  175. IPLSC1=MLELSC.INDEX(NLS1)
  176. IPLSC2=MLELSC.INDEX(NLS1+1)
  177. NGS2=MLELSC.LESPOI(IPLSC1)
  178. IF(NGS1 .NE. NGS2)THEN
  179. WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
  180. CALL ERREUR(5)
  181. GOTO 9999
  182. ENDIF
  183. NCVOI=IPLSC2-IPLSC1-1
  184. DO I3 = 1, NCVOI, 1
  185. NGC=MLELSC.LESPOI(IPLSC1+I3)
  186. NLC=MLECEN.LECT(NGC)
  187. IF(NLC.EQ.0)THEN
  188. C
  189. C************* Erreur de programmation
  190. C
  191. WRITE(IOIMP,*) 'Subroutine rlevb1.eso'
  192. CALL ERREUR(5)
  193. GOTO 9999
  194. ELSEIF(MLECVO.LECT(NLC).EQ.0)THEN
  195. MLECVO.LECT(NLC)=LAST
  196. LAST=NLC
  197. NTOTCV=NTOTCV+1
  198. ENDIF
  199. ENDDO
  200. ENDDO
  201. C
  202. C******* La structure MLECVO + LAST contient NTOTCV centres voisins
  203. C des sommets sommets voisins à NGS + les centres de NGS
  204. C Il faut le mettre en ordre par raport à la distance
  205. C
  206. IPCOOR=(IDIM+1)*(NGS-1)+1
  207. XS=MCOORD.XCOOR(IPCOOR)
  208. YS=MCOORD.XCOOR(IPCOOR+1)
  209. IF(IDIM.EQ.3) ZS=MCOORD.XCOOR(IPCOOR+2)
  210. NCMIS=0
  211. DO I2 = 1, NTOTCV, 1
  212. NLC=LAST
  213. LAST=MLECVO.LECT(NLC)
  214. MLECVO.LECT(NLC)=0
  215. NGC=MELCEN.NUM(1,NLC)
  216. IPCOOR=(IDIM+1)*(NGC-1)+1
  217. DXC=MCOORD.XCOOR(IPCOOR)-XS
  218. DYC=MCOORD.XCOOR(IPCOOR+1)-YS
  219. DZC=0.0D0
  220. IF(IDIM.EQ.3) DZC=MCOORD.XCOOR(IPCOOR+2)-ZS
  221. DIST2=(DXC*DXC)+(DYC*DYC)+(DZC*DZC)
  222. C
  223. C********** Position avec la methode directe
  224. C
  225. ICEL=1
  226. 10 CONTINUE
  227. IF(ICEL .GT. NCMIS)THEN
  228. NCMIS=NCMIS+1
  229. MLESBC.LESPOI(IPOS+ICEL)=NGC
  230. MLRDIS.PROG(IPOS+ICEL)=DIST2
  231. ELSE
  232. DIST21=MLRDIS.PROG(IPOS+ICEL)
  233. IF(DIST21 .GT. DIST2)THEN
  234. NCMIS=NCMIS+1
  235. ICEL1=IPOS+NCMIS
  236. DO I3 = 0, NCMIS - ICEL - 1
  237. MLESBC.LESPOI(ICEL1-I3)=MLESBC.LESPOI(ICEL1-I3-1)
  238. MLRDIS.PROG(ICEL1-I3)=MLRDIS.PROG(ICEL1-I3-1)
  239. ENDDO
  240. MLESBC.LESPOI(IPOS+ICEL)=NGC
  241. MLRDIS.PROG(IPOS+ICEL)=DIST2
  242. ELSE
  243. ICEL=ICEL+1
  244. GOTO 10
  245. ENDIF
  246. ENDIF
  247. ENDDO
  248. IF(NCMIS .NE. NTOTCV)THEN
  249. CALL ERREUR(5)
  250. GOTO 9999
  251. ENDIF
  252. C
  253. C******* On nettoie MLECVO
  254. C
  255. 20 CONTINUE
  256. IF(LAST.GT.0)THEN
  257. NLC=LAST
  258. LAST=MLECVO.LECT(NLC)
  259. MLECVO.LECT(NLC)=0
  260. GOTO 20
  261. ELSEIF(LAST .NE. -1)THEN
  262. CALL ERREUR(5)
  263. GOTO 9999
  264. ENDIF
  265. C
  266. C******* Mise a jour de NBTPOI
  267. C
  268. NBTPOI=NBTPOI+NCMIS
  269. IPOS=IPOS+NCMIS+1
  270. ENDDO
  271. NBTPOI=NBTPOI+NBL
  272. MLESBC.INDEX(NBL+1)=IPOS
  273. C
  274. C**** MLESBC surdimensionné
  275. C
  276. SEGADJ MLESBC
  277. JG=NBTPOI
  278. SEGADJ MLRDIS
  279. C
  280. SEGDES MLESBC
  281. SEGDES MLELSC
  282. SEGSUP MLELSB
  283. C
  284. SEGDES MLESOM
  285. SEGSUP MLESOM
  286. SEGDES MELCEN
  287. SEGSUP MLECEN
  288. C
  289. SEGSUP MLECVO
  290. SEGDES MLRDIS
  291.  
  292. 9999 RETURN
  293. END
  294.  
  295.  
  296.  

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