Télécharger meland.eso

Retour à la liste

Numérotation des lignes :

  1. C MELAND SOURCE CHAT 05/01/13 01:41:54 5004
  2. SUBROUTINE MELAND(GPMELS,
  3. $ MAICOM,
  4. $ IMPR,IRET)
  5. IMPLICIT INTEGER(I-N)
  6. IMPLICIT REAL*8 (A-H,O-Z)
  7. C***********************************************************************
  8. C NOM : MELAND
  9. C DESCRIPTION : Renvoie le maillage de points (POI1) MAICOM des
  10. C points appartenant à tous les maillages de gpmels.
  11. C
  12. C LANGAGE : ESOPE
  13. C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/TTMF)
  14. C mél : gounand@semt2.smts.cea.fr
  15. C***********************************************************************
  16. C APPELES : -
  17. C APPELE PAR : MELCOM
  18. C***********************************************************************
  19. C ENTREES : GPMELS
  20. C SORTIES : MAICOM
  21. C CODE RETOUR (IRET) : = 0 si tout s'est bien passé
  22. C***********************************************************************
  23. C VERSION : v1, 12/05/99, version initiale
  24. C HISTORIQUE : v1, 12/05/99, création
  25. C HISTORIQUE :
  26. C HISTORIQUE :
  27. C***********************************************************************
  28. C Prière de PRENDRE LE TEMPS de compléter les commentaires
  29. C en cas de modification de ce sous-programme afin de faciliter
  30. C la maintenance !
  31. C***********************************************************************
  32. -INC CCOPTIO
  33. -INC SMCOORD
  34. -INC SMELEME
  35. POINTEUR MELCOU.MELEME
  36. POINTEUR SOUMEL.MELEME
  37. INTEGER NBELEM,NBNN,NBREF,NBSOUS
  38. POINTEUR MAICOM.MELEME
  39. -INC SMLENTI
  40. INTEGER JG
  41. POINTEUR IWORK.MLENTI
  42. *
  43. * Includes persos
  44. *
  45. SEGMENT MELS
  46. POINTEUR LISMEL(NBMEL).MELEME
  47. ENDSEGMENT
  48. POINTEUR GPMELS.MELS
  49. *
  50. INTEGER IMPR,IRET
  51. *
  52. LOGICAL LSAME
  53. INTEGER BEGI,LAST,ILAST,IPREC,LDG,ILDG,NUMNO
  54. INTEGER IELEM,IPOEL,ISOUS,IMEL
  55. INTEGER NELEM,NPOEL,NSOUS,NMEL
  56. *
  57. * Executable statements
  58. *
  59. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans meland.eso'
  60. SEGACT GPMELS
  61. NMEL=GPMELS.LISMEL(/1)
  62. IF (NMEL.LE.0) THEN
  63. WRITE(IOIMP,*) 'Nombre de MELEMEs négatif ou nul'
  64. GOTO 9999
  65. ENDIF
  66. * On cherche le cas évident :
  67. * - Maillage tous identiques de POI1
  68. MELCOU=GPMELS.LISMEL(1)
  69. SEGACT MELCOU
  70. LSAME=.FALSE.
  71. IF (MELCOU.ITYPEL.EQ.1) THEN
  72. LSAME=.TRUE.
  73. DO 1 IMEL=2,NMEL
  74. IF (GPMELS.LISMEL(IMEL).NE.MELCOU) THEN
  75. LSAME=.FALSE.
  76. ENDIF
  77. 1 CONTINUE
  78. ENDIF
  79. SEGDES MELCOU
  80. IF (LSAME) THEN
  81. SEGINI,MAICOM=MELCOU
  82. SEGDES MAICOM
  83. ELSE
  84. * - On construit la liste chaînée avec le premier maillage
  85. JG=XCOOR(/1)/(IDIM+1)
  86. SEGINI IWORK
  87. * degré, fin de la liste chaînée
  88. LDG=0
  89. BEGI=XCOOR(/1)/(IDIM+1)+1
  90. LAST=BEGI
  91. MELCOU=GPMELS.LISMEL(1)
  92. SEGACT MELCOU
  93. NSOUS=MELCOU.LISOUS(/1)
  94. DO 3 ISOUS=1,MAX(1,NSOUS)
  95. IF (NSOUS.EQ.0) THEN
  96. SOUMEL=MELCOU
  97. ELSE
  98. SOUMEL=MELCOU.LISOUS(ISOUS)
  99. SEGACT SOUMEL
  100. ENDIF
  101. NPOEL=SOUMEL.NUM(/1)
  102. NELEM=SOUMEL.NUM(/2)
  103. DO 32 IELEM=1,NELEM
  104. DO 322 IPOEL=1,NPOEL
  105. NUMNO=SOUMEL.NUM(IPOEL,IELEM)
  106. IF (IWORK.LECT(NUMNO).EQ.0) THEN
  107. LDG=LDG+1
  108. IWORK.LECT(NUMNO)=LAST
  109. LAST=NUMNO
  110. ENDIF
  111. 322 CONTINUE
  112. 32 CONTINUE
  113. IF (NSOUS.NE.0) THEN
  114. SEGDES SOUMEL
  115. ENDIF
  116. 3 CONTINUE
  117. SEGDES MELCOU
  118. * - On réduit la liste chaînée des points des autres maillages
  119. * qui ne sont pas déjà dedans
  120. *COMM write(ioimp,*) 'nmel=',nmel
  121. DO 5 IMEL=2,NMEL
  122. *COMM write(ioimp,*) 'last,ldg,imel',LAST,LDG,IMEL
  123. *COMM SEGPRT,IWORK
  124. * On attribue le signe - à tous les points de la liste chaînée
  125. NUMNO=LAST
  126. DO 52 ILDG=1,LDG
  127. IPREC=IWORK.LECT(NUMNO)
  128. IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO)
  129. NUMNO=IPREC
  130. 52 CONTINUE
  131. *COMM write(ioimp,*) 'négativation'
  132. *COMM SEGPRT,IWORK
  133. MELCOU=GPMELS.LISMEL(IMEL)
  134. * On attribue le signe + aux points de la liste chaînée
  135. * qui sont dans le IMEL ième maillage
  136. SEGACT MELCOU
  137. NSOUS=MELCOU.LISOUS(/1)
  138. DO 54 ISOUS=1,MAX(1,NSOUS)
  139. IF (NSOUS.EQ.0) THEN
  140. SOUMEL=MELCOU
  141. ELSE
  142. SOUMEL=MELCOU.LISOUS(ISOUS)
  143. SEGACT SOUMEL
  144. ENDIF
  145. NPOEL=SOUMEL.NUM(/1)
  146. NELEM=SOUMEL.NUM(/2)
  147. DO 542 IELEM=1,NELEM
  148. DO 5422 IPOEL=1,NPOEL
  149. NUMNO=SOUMEL.NUM(IPOEL,IELEM)
  150. IF (IWORK.LECT(NUMNO).LT.0) THEN
  151. IWORK.LECT(NUMNO)=-IWORK.LECT(NUMNO)
  152. ENDIF
  153. 5422 CONTINUE
  154. 542 CONTINUE
  155. IF (NSOUS.NE.0) THEN
  156. SEGDES SOUMEL
  157. ENDIF
  158. 54 CONTINUE
  159. SEGDES MELCOU
  160. *COMM write(ioimp,*) 'positivation'
  161. *COMM SEGPRT,IWORK
  162. * On nettoie la liste chaînée des points qui sont restés
  163. * avec le signe négatif
  164. *
  165. * D'abord, on cherche la fin de ce qui sera la nouvelle liste
  166. * If (LAST.EQ.BEGI), la liste résultat est vide
  167. IF (LAST.NE.BEGI) THEN
  168. NUMNO=LAST
  169. 56 CONTINUE
  170. IPREC=IWORK.LECT(NUMNO)
  171. IF (IPREC.LT.0) THEN
  172. LDG=LDG-1
  173. IWORK.LECT(NUMNO)=0
  174. NUMNO=-IPREC
  175. IF (NUMNO.NE.BEGI) THEN
  176. GOTO 56
  177. ENDIF
  178. ENDIF
  179. LAST=NUMNO
  180. ENDIF
  181. *COMM write(ioimp,*) 'Fin de la liste=',LAST
  182. * Une fois obtenue la fin de la liste résultat, on continue
  183. * If (LAST.EQ.BEGI), la liste résultat est vide
  184. IF (LAST.NE.BEGI) THEN
  185. ILAST=LAST
  186. NUMNO=LAST
  187. * IPREC est forcément positif sinon, LAST n'aurait pas la bonne valeur
  188. IPREC=IWORK.LECT(NUMNO)
  189. NUMNO=IPREC
  190. *COMM write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC
  191. IF (NUMNO.NE.BEGI) THEN
  192. 58 CONTINUE
  193. IPREC=IWORK.LECT(NUMNO)
  194. *COMM write(ioimp,*) 'ilast,numno,iprec',ILAST,NUMNO,IPREC
  195. IF (IPREC.LT.0) THEN
  196. LDG=LDG-1
  197. IWORK.LECT(NUMNO)=0
  198. NUMNO=-IPREC
  199. ELSE
  200. IWORK.LECT(ILAST)=NUMNO
  201. ILAST=NUMNO
  202. NUMNO=IPREC
  203. ENDIF
  204. IF (NUMNO.NE.BEGI) THEN
  205. GOTO 58
  206. ENDIF
  207. ENDIF
  208. IWORK.LECT(ILAST)=BEGI
  209. *COMM write(ioimp,*) 'nettoyage'
  210. *COMM SEGPRT,IWORK
  211. ENDIF
  212. 5 CONTINUE
  213. * Créer le maillage de points correspondant à la liste chaînée
  214. NBNN=1
  215. NBELEM=LDG
  216. NBSOUS=0
  217. NBREF=0
  218. SEGINI MAICOM
  219. MAICOM.ITYPEL=1
  220. NUMNO=LAST
  221. DO 7 ILDG=1,LDG
  222. IPREC=IWORK.LECT(NUMNO)
  223. MAICOM.NUM(1,ILDG)=NUMNO
  224. NUMNO=IPREC
  225. 7 CONTINUE
  226. SEGDES MAICOM
  227. SEGSUP IWORK
  228. ENDIF
  229. SEGDES GPMELS
  230. IF (IMPR.GT.2) THEN
  231. WRITE(IOIMP,*) 'On a créé MAICOM=',MAICOM
  232. IF (IMPR.GT.3) THEN
  233. SEGPRT,MAICOM
  234. ENDIF
  235. ENDIF
  236. *
  237. * Normal termination
  238. *
  239. IRET=0
  240. RETURN
  241. *
  242. * Format handling
  243. *
  244. *
  245. * Error handling
  246. *
  247. 9999 CONTINUE
  248. IRET=1
  249. WRITE(IOIMP,*) 'An error was detected in subroutine meland'
  250. RETURN
  251. *
  252. * End of subroutine MELAND
  253. *
  254. END
  255.  
  256.  
  257.  
  258.  
  259.  

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