Télécharger nuachp.eso

Retour à la liste

Numérotation des lignes :

  1. C NUACHP SOURCE CHAT 05/01/13 02:02:43 5004
  2. SUBROUTINE NUACHP(ICHP)
  3. *
  4. * sous routine de l'operateur nuage pour creer un objet
  5. * nuage à partir d'un champ par point.
  6. *
  7. IMPLICIT INTEGER(I-N)
  8. IMPLICIT REAL*8(A-H,O-Z)
  9. *
  10. -INC CCOPTIO
  11. -INC SMELEME
  12. -INC SMNUAGE
  13. -INC SMLMOTS
  14. -INC SMCHPOI
  15. *
  16. *
  17. *
  18. IRETOU = 0
  19. *
  20. *------------------------ Lecture du CHPOINT ---------------------
  21. *
  22. MCHPOI = ICHP
  23. SEGACT MCHPOI
  24. NSOUPO = IPCHP(/1)
  25. *
  26. *-------- Boucle créant un LISTMOT contenant les noms des variables ---
  27. *-------- contenues dans le CHPOINT. Ces noms n'apparaissent qu'une ---
  28. *-------- seule fois --------------------------------------------------
  29. *
  30. IF (NSOUPO .EQ. 0) THEN
  31. NVAR = 0
  32. NBCOUP = 0
  33. SEGINI MNUAGE
  34. SEGDES MNUAGE
  35. ENDIF
  36. *
  37. DO 10 I=1,NSOUPO
  38. MSOUPO = IPCHP(I)
  39. SEGACT MSOUPO
  40. IF(I.EQ.1) THEN
  41. JGN = 4
  42. JGM = 20
  43. SEGINI MLMOTS
  44. NC = NOCOMP(/2)
  45. IF(NC.GT.20) THEN
  46. JGM = NC + 10
  47. SEGADJ MLMOTS
  48. ENDIF
  49. DO 20 J=1,NC
  50. MOTS(J) = NOCOMP(J)
  51. 20 CONTINUE
  52. NBMO = NC
  53. ELSE
  54. NC = NOCOMP(/2)
  55. DO 30 J = 1,NC
  56. NEXIS = 0
  57. DO 40 K = 1,NBMO
  58. IF(NOCOMP(J).EQ.MOTS(K)) THEN
  59. NEXIS = 1
  60. ENDIF
  61. 40 CONTINUE
  62. IF(NEXIS.EQ.0) THEN
  63. NBMO = NBMO + 1
  64. IF (NBMO.GT.MOTS(/2)) THEN
  65. JGM = JGM + 10
  66. SEGADJ MLMOTS
  67. ENDIF
  68. MOTS(NBMO) = NOCOMP(J)
  69. ENDIF
  70. 30 CONTINUE
  71. ENDIF
  72. SEGDES MSOUPO
  73. 10 CONTINUE
  74. *
  75. *------------------ on redefinit la taille du LISTMOT ----------------
  76. *
  77. JGM = NBMO
  78. SEGADJ MLMOTS
  79. *
  80. *--------------Calcul du nombre total de points-------------------------
  81. *
  82. NBPOI = 0
  83. DO 50 I=1,NSOUPO
  84. MSOUPO = IPCHP(I)
  85. SEGACT MSOUPO
  86. MELEME = IGEOC
  87. SEGACT MELEME
  88. NBPOI = NBPOI + NUM(/2)
  89. SEGDES MELEME
  90. SEGDES MSOUPO
  91. 50 CONTINUE
  92. *
  93. *
  94. *
  95. *---------------Initialisation de l'objet nuage-------------------------
  96. *
  97. NVAR = NBMO
  98. SEGINI MNUAGE
  99. DO 60 I = 1,NVAR
  100. NUANOM(I) = MOTS(I)
  101. 60 CONTINUE
  102. NBCOUP = NBPOI
  103. DO 70 I = 1,NVAR
  104. NUATYP(I) = 'FLOTTANT'
  105. 70 CONTINUE
  106.  
  107. SEGSUP MLMOTS
  108. *
  109. *
  110. *-------------------Création des n-uplets du nuage---------------
  111. *
  112. *---------A chaque n-uplet correspond une liste de réels---------
  113. *---------comportant les composantes contenues dans le-----------
  114. *---------champ par point----------------------------------------
  115. *
  116. *---------Boucle sur les composantes du nuage--------------------
  117. *
  118. DO 90 I = 1,NVAR
  119. SEGINI NUAVFL
  120. NUAPOI(I) = NUAVFL
  121. IND = 1
  122. *
  123. *---------Boucle sur les sous-maillages--------------------------
  124. *
  125. DO 100 J = 1,NSOUPO
  126. MSOUPO = IPCHP(J)
  127. SEGACT MSOUPO
  128. MELEME = MSOUPO.IGEOC
  129. SEGACT MELEME
  130. MPOVAL = IPOVAL
  131. SEGACT MPOVAL
  132. N = VPOCHA(/1)
  133. NC = VPOCHA(/2)
  134. *
  135. *---------Boucle sur les points du sous-maillage intégrant-------
  136. *---------une boucle sur les différentes composantes du----------
  137. *---------point. Remplissage du tableau de valeurs--------------
  138. *
  139. DO 110 L = 1,N
  140. DO 120 K = 1,NC
  141. IF (NUANOM(I) .EQ. NOCOMP(K)) THEN
  142. NUAFLO(IND) = VPOCHA(L,K)
  143. ENDIF
  144. 120 CONTINUE
  145. IND = IND + 1
  146. 110 CONTINUE
  147.  
  148. SEGDES MPOVAL
  149. SEGDES MELEME
  150. SEGDES MSOUPO
  151.  
  152. 100 CONTINUE
  153. SEGDES NUAVFL
  154.  
  155. 90 CONTINUE
  156.  
  157. SEGDES MCHPOI
  158. SEGDES MNUAGE
  159. *
  160. *---------------------Ecriture du nuage---------------------------
  161. *
  162. CALL ECROBJ('NUAGE ', MNUAGE)
  163. RETURN
  164. *
  165. END
  166.  
  167.  

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