Télécharger crevlc.eso

Retour à la liste

Numérotation des lignes :

  1. C CREVLC SOURCE JC220346 16/04/25 21:15:02 8915
  2. SUBROUTINE CREVLC(ILREE1,ILCHP1,IMAIL1,ILMOT1,ILMOT2,TITR1,IEVOL1)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. ************************************************************************
  6. * NOM : CREVLC
  7. * DESCRIPTION : Cree un objet EVOLUTION a partir d'un LISTCHPO, un
  8. * MAILLAGE et un LISTMOTS pour les ordonnees et d'un
  9. * LISTREEL pour les abscisses
  10. ************************************************************************
  11. * APPELE PAR : evresu.eso ; evreco.eso
  12. ************************************************************************
  13. * ENTREES : ILREE1 = pointeur vers le LISTREEL des abscisses
  14. * ILCHP1 = pointeur vers le LISTCHPO des ordonnees
  15. * IMAIL1 = pointeur vers le MELEME de POI1
  16. * ILMOT1 = pointeur vers le LISTMOTS des composantes
  17. * (0 si non specifie)
  18. * ILMOT2 = pointeur vers le LISTMOTS des couleurs des courbes
  19. * TITR1 = titre de l'ensemble des courbes
  20. * SORTIES : IEVOL1 = pointeur vers l'objet EVOLUTIO
  21. ************************************************************************
  22. -INC CCOPTIO
  23. -INC SMEVOLL
  24. -INC SMELEME
  25. -INC SMLENTI
  26. -INC SMLREEL
  27. -INC SMLMOTS
  28. -INC SMLCHPO
  29. *
  30. POINTEUR LCOUL.MLENTI
  31. POINTEUR LCOMP.MLMOTS
  32. POINTEUR LNOMS.MLMOTS
  33. *
  34. CHARACTER*4 CHA4
  35. CHARACTER*8 CHA8
  36. CHARACTER*10 CH10
  37. CHARACTER*16 CH16
  38. CHARACTER*72 TITR1
  39. *
  40. *
  41. * ======================
  42. * LISTREEL DES ABSCISSES
  43. * ======================
  44. *
  45. MLREEL=ILREE1
  46. SEGACT,MLREEL
  47. NT=PROG(/1)
  48. *
  49. *
  50. * ======================
  51. * LISTCHPO DES ORDONNEES
  52. * ======================
  53. *
  54. MLCHPO=ILCHP1
  55. SEGACT,MLCHPO
  56. IF (ICHPOI(/1).NE.NT) THEN
  57. CALL ERREUR(212)
  58. RETURN
  59. ENDIF
  60. *
  61. *
  62. * =========
  63. * GEOMETRIE
  64. * =========
  65. *
  66. MELEME=IMAIL1
  67. SEGACT,MELEME
  68. IF (LISOUS(/1).NE.0.OR.ITYPEL.NE.1) CALL CHANGE(MELEME,1)
  69. SEGACT,MELEME
  70. NPO=NUM(/2)
  71. IF (NPO.EQ.0) THEN
  72. MOTERR(1:8)='MAILLAGE'
  73. CALL ERREUR(1027)
  74. RETURN
  75. ENDIF
  76. *
  77. *
  78. * ========================
  79. * LISTE DES NOMS DE POINTS
  80. * ========================
  81. *
  82. JGM=NPO
  83. JGN=16
  84. SEGINI,LNOMS
  85. DO I=1,NPO
  86. IPO1=NUM(1,I)
  87. CALL SKNAME(IPO1,CHA8,IRETOU,1)
  88. *
  89. * ON A TROUVE UN NOM DANS LA LISTE DES OBJETS NOMMES
  90. IF (IRETOU.NE.0) THEN
  91. LNOMS.MOTS(I)=CHA8
  92. *
  93. * SINON, CREATION D'UN NOM PAR DEFAUT
  94. ELSE
  95. WRITE(CH10,FMT='(I10)') IPO1
  96. CALL LIMCHA(CH10,I1,I2)
  97. WRITE(CH16,FMT='("POINT#",A)') CH10(I1:I2)
  98. LNOMS.MOTS(I)=CH16
  99. ENDIF
  100. ENDDO
  101. *
  102. *
  103. * =====================
  104. * LISTE DES COMPOSANTES
  105. * =====================
  106. *
  107. LCOMP=ILMOT1
  108. IF (LCOMP.NE.0) THEN
  109. SEGACT,LCOMP
  110. NCO=LCOMP.MOTS(/2)
  111. ELSE
  112. NCO=1
  113. ENDIF
  114. *
  115. *
  116. * ==================
  117. * LISTE DES COULEURS
  118. * ==================
  119. *
  120. LCOUL=ILMOT2
  121. SEGACT,LCOUL
  122. NCLR=LCOUL.LECT(/1)
  123. *
  124. * ON COMPLETE SI BESOIN LA LISTE DES COULEURS
  125. NEV=NCO*NPO
  126. IF (NEV.GT.NCLR) THEN
  127. JG=NEV
  128. SEGADJ,LCOUL
  129. DO K=NCLR+1,NEV
  130. LCOUL.LECT(K)=LCOUL.LECT(K-NCLR)
  131. ENDDO
  132. ENDIF
  133. *
  134. *
  135. * ====================
  136. * CREATION DES COURBES
  137. * ====================
  138. *
  139. N=NEV
  140. SEGINI,MEVOLL
  141. IEVOL1=MEVOLL
  142. ITYEVO='REEL'
  143. IEVTEX=TITR1
  144. DO INO=1,NPO
  145. SEGACT,MELEME
  146. IPO1=NUM(1,INO)
  147. *
  148. CALL EXTR24(ILCHP1,LCOMP,IPO1,ILREE2)
  149. MLREE2=ILREE2
  150. SEGACT,MLREE2
  151. IF (MLREE2.PROG(/1)/NCO.NE.NT) THEN
  152. MOTERR(1:8)='CREVLC'
  153. CALL ERREUR(1039)
  154. RETURN
  155. ENDIF
  156. *
  157. DO ICO=1,NCO
  158. *
  159. IF (NCO.EQ.1) THEN
  160. ILREEY=ILREE2
  161. ELSE
  162. JG=NT
  163. SEGINI,MLREE3
  164. ILREEY=MLREE3
  165. IT1=(ICO-1)*NT
  166. DO IT=1,NT
  167. MLREE3.PROG(IT)=MLREE2.PROG(IT1+IT)
  168. ENDDO
  169. ENDIF
  170. *
  171. IEV=(INO-1)*NCO+ICO
  172. SEGINI,KEVOLL
  173. IEVOLL(IEV)=KEVOLL
  174. TYPX='LISTREEL'
  175. TYPY='LISTREEL'
  176. IPROGX=ILREE1
  177. IPROGY=ILREEY
  178. NUMEVX=LCOUL.LECT(IEV)
  179. NUMEVY='REEL'
  180. NOMEVX='TEMPS'
  181. NOMEVY=' '
  182. IF (NCO.EQ.1) THEN
  183. KEVTEX=LNOMS.MOTS(INO)
  184. ELSE
  185. SEGACT,LCOMP
  186. CHA4=LCOMP.MOTS(ICO)
  187. CH16=LNOMS.MOTS(INO)
  188. CALL LENCHA(CH16,LN)
  189. WRITE(KEVTEX,FMT='(A," COMP. ",A4)') CH16(1:LN),CHA4
  190. SEGDES,MLREE3
  191. ENDIF
  192. *
  193. SEGDES,KEVOLL
  194. ENDDO
  195. *
  196. IF (NCO.EQ.1) THEN
  197. SEGDES,MLREE2
  198. ELSE
  199. SEGSUP,MLREE2
  200. ENDIF
  201. *
  202. ENDDO
  203. *
  204. SEGDES,MLREEL,MLCHPO,MEVOLL,LCOUL
  205. IF (LCOMP.GT.0) SEGDES,LCOMP
  206. SEGSUP,LNOMS
  207. *
  208. RETURN
  209. *
  210. END
  211. *
  212. *
  213.  

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