Télécharger evchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C EVCHPO SOURCE SERRE 17/06/26 21:15:05 9465
  2. SUBROUTINE EVCHPO(ICOUL)
  3. C======================================================================
  4. C OPTION CHPO DE L'OPERATEUR EVOL C
  5. C C
  6. C LA SYNTHAXE DE CETTE OPTION D'EVOL EST LA SUIVANTE : C
  7. C C
  8. C C
  9. C EV1 = EVOL (COUL) CHPO CHPT COMP LIGN; C
  10. C C
  11. C C
  12. C + COUL : COULEUR DE LA COURBE (FACULTATIVE) C
  13. C C
  14. C + CHPT : CHAMP-POINT C
  15. C C
  16. C + COMP : COMPOSANTE DU CHAMP POINT C
  17. C C
  18. C + LIGN : LIGNE DE NOEUDS. C
  19. C C
  20. C C
  21. C======================================================================
  22. IMPLICIT INTEGER(I-N)
  23. IMPLICIT REAL*8 (A-H,O-Z)
  24. -INC CCOPTIO
  25. -INC SMEVOLL
  26. -INC SMCHPOI
  27. -INC SMLREEL
  28. -INC SMELEME
  29. -INC SMCOORD
  30. -INC SMLMOTS
  31. -INC TMTRAV
  32. SEGMENT MVOL
  33. REAL*8 MMABS(JG)
  34. REAL*8 MMORD(JG)
  35. CHARACTER*8 NOMAB(JG)
  36. REAL*8 POSNO(JG)
  37. ENDSEGMENT
  38. SEGMENT TTRAV
  39. INTEGER ILIS(IDIMM)
  40. ENDSEGMENT
  41. CHARACTER*8 NOMQUA,NOM
  42. CHARACTER*4 CMOT
  43. CHARACTER*8 NCHPT,NMAIL
  44. CHARACTER*23 UMOT1
  45. CHARACTER*16 UMOT2
  46. CHARACTER*12 UMOT3
  47. CHARACTER*72 TITRE
  48. REAL*8 DEPA(400),PREC(3),TREPA(400),MYPOS(3),HEPOS(3)
  49. LOGICAL FIRST,SECOND,THIRD,NOMME
  50. DIMENSION ITABCH(3)
  51. CMOT=' '
  52. TITRE = 'CREE PAR EVOL CHPO'
  53. C LECTURE DES DIFFERENTES ENTREES
  54. C LECTURE DU CHAMP-POINT
  55. CALL LIROBJ ('CHPOINT',IBOPOI,1,IRETOC)
  56. IF (IRETOC.EQ.0) GOTO 111
  57. MCHPOI=IBOPOI
  58. C LECTURE DE LA COMPOSANTE
  59. CALL LIRCHA(CMOT,0,IRETOU)
  60. C LECTURE DE L'OBJET MAILLAGE
  61. CALL LIROBJ('MAILLAGE',IPOI,1,IRETOM)
  62. IF (IRETOM.EQ.0) GOTO 111
  63. MELEME = IPOI
  64. CALL LIGMAI(MELEME,TTRAV,1)
  65. IF(IERR.NE.0) RETURN
  66. SEGACT TTRAV
  67. NBNN=ILIS(/1)
  68. JG=NBNN
  69. SEGINI MVOL
  70. C APPEL A UNE ROUTINE DE PRESENTATION D'UN CHPOINT SOUS FORME RESUME
  71. CALL TRACHP(MCHPOI,MTRAV)
  72. SEGACT MTRAV
  73. SEGACT MCOORD
  74. ICC=0
  75. NCO=INCO(/2)
  76. *
  77. IF(IRETOU.EQ.0.AND.NCO.GT.1) THEN
  78. MOTERR(1:8)='MOT '
  79. CALL ERREUR(37)
  80. GO TO 111
  81. ENDIF
  82. *
  83. * SI LE CHAMP A UNE SEULE COMPOSANTE ET QU'ON N'A PAS LU
  84. * DE NOM DE COMPOSANTE , ON LA PREND
  85. *
  86. IF(NCO.EQ.1.AND.IRETOU.EQ.0) THEN
  87. CMOT=INCO(1)
  88. ICC=1
  89. ELSE
  90. DO 1 INC=1,NCO
  91. IF (INCO(INC).EQ.CMOT) THEN
  92. ICC=INC
  93. ENDIF
  94. 1 CONTINUE
  95. ENDIF
  96. * Pas besoin d'erreur, il suffit de mettre 0
  97. * IF (ICC.EQ.0) THEN
  98. * MOTERR(1:4)=CMOT
  99. * CALL ERREUR(181)
  100. * GOTO 111
  101. * ENDIF
  102. C BOUCLE SUR TOUS LES NOEUDS DU MAILLAGE
  103. IBAC=0
  104. IBOC=0
  105. ZMABS=0.D0
  106. DO 2 IY=1,3
  107. PREC(IY)=0.D0
  108. 2 CONTINUE
  109. DO 7 IBO=1,ILIS(/1)
  110. NN= ILIS(IBO)
  111. NCOO=0
  112. DO 3 J=1,IDIM
  113. NCOO=NCOO+1
  114. MYPOS(NCOO)=XCOOR((NN-1)*(IDIM+1)+NCOO)
  115. 3 CONTINUE
  116. TOTAL = 0.D0
  117. DO 4 IT=1,IDIM
  118. TOTAL = TOTAL + (MYPOS(IT)-PREC(IT))**2
  119. PREC(IT)=MYPOS(IT)
  120. 4 CONTINUE
  121. TOTAL = TOTAL**0.5D0
  122. ZMABS = ZMABS + TOTAL
  123. IF (IBAC.EQ.0) THEN
  124. ZMABS=0.D0
  125. ENDIF
  126. NOMME=.FALSE.
  127. CALL SKNAME(NN,NOMQUA,IRETOL,1)
  128. IF (IRETOL.EQ.1) THEN
  129. NOMME=.TRUE.
  130. NOM = NOMQUA
  131. ENDIF
  132. IF (ICC.EQ.0) THEN
  133. INDI0=1
  134. ELSE
  135. INDI0=1
  136. DO 6 KJ=1,IGEO(/1)
  137. NH=IGEO(KJ)
  138. IF(NH.EQ.NN) THEN
  139. IF (IBIN(ICC,KJ).EQ.0) THEN
  140. INDI0 = 1
  141. GOTO 6
  142. ENDIF
  143. IBAC=IBAC+1
  144. MMORD(IBAC)=BB(ICC,KJ)
  145. MMABS(IBAC)=ZMABS
  146. INDI0=0
  147. IF (NOMME) THEN
  148. IBOC=IBOC+1
  149. POSNO (IBOC)=ZMABS
  150. NOMAB (IBOC)=NOM
  151. ENDIF
  152. GOTO 7
  153. ENDIF
  154. 6 CONTINUE
  155. ENDIF
  156. IF (INDI0.EQ.1) THEN
  157. IBAC=IBAC+1
  158. MMORD(IBAC)=0.D0
  159. MMABS(IBAC)=ZMABS
  160. IF (NOMME) THEN
  161. IBOC=IBOC+1
  162. POSNO (IBOC)=ZMABS
  163. NOMAB (IBOC)=NOM
  164. ENDIF
  165. ENDIF
  166. 7 CONTINUE
  167. JG=IBAC
  168. SEGINI MLREEL,MLREE1
  169. DO 8 IT=1,IBAC
  170. PROG(IT)=MMABS(IT)
  171. MLREE1.PROG(IT)=MMORD(IT)
  172. 8 CONTINUE
  173. N=1
  174. M=IBOC
  175. IF(M.NE.0) N = 2
  176. SEGINI MEVOLL
  177. C
  178. C CREATION DU EVOL CONTENANT LES NOMS
  179. C
  180. IF(M.NE.0) THEN
  181. SEGINI KEVOLL
  182. *MMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMMM IIIIIII
  183. * DANS NOMAB ON A LES POINTS QUALIFIES IIIIIII
  184. * IBOC LE NOMBRE DE POINTS QUALIFIES IIII
  185. * DANS POSNO LA POSITION DES POINTS QUALIFIES IIII
  186. * MLREEL : ABSCISSE DES POINTS IIII
  187. * MLREE1 : ORDONNEE DES POINTS IIIIII
  188. JGN=8
  189. JGM=IBOC
  190. SEGINI MLMOTS
  191. JG=IBOC
  192. SEGINI MLREE2
  193. IPROGX=MLREE2
  194. IPROGY=MLMOTS
  195. TYPX='LISTREEL'
  196. TYPY='LISTMOTS'
  197. IEVOLL(2)=KEVOLL
  198. NUMEVY='MARQ'
  199. NUMEVX=ICOUL
  200. NOMEVX='ABS'
  201. NOMEVY=CMOT
  202. DO 9 I=1,IBOC
  203. MOTS(I)=NOMAB(I)
  204. MLREE2.PROG(I)=POSNO(I)
  205. 9 CONTINUE
  206. KEVTEX='POINTS NOMMES APPARTENANT A LA LIGNE'
  207. SEGDES MLREE2,MLMOTS,KEVOLL
  208. ENDIF
  209. SEGINI KEVOLL
  210. IEVOLL(1)= KEVOLL
  211. ITYEVO='REEL'
  212. TYPX='LISTREEL'
  213. TYPY='LISTREEL'
  214. IPROGX= MLREEL
  215. IPROGY= MLREE1
  216. IEVTEX=TITREE
  217. NOMEVX= 'ABS'
  218. NOMEVY= CMOT
  219. NUMEVX= ICOUL
  220. NUMEVY= 'REEL'
  221. KEVTEX=TITRE
  222. CALL SKNAME(IBOPOI,NCHPT,IRETO,0)
  223. IF (IRETO.NE.0) THEN
  224. CALL SKNAME(IPOI,NMAIL,IRETO,0)
  225. IF (IRETO.NE.0) THEN
  226. UMOT1= 'TRACE DE LA COMPOSANTE '
  227. UMOT2= ' DU CHAMP-POINT '
  228. UMOT3= ' LE LONG DE '
  229. TITRE=UMOT1//CMOT//UMOT2//NCHPT//UMOT3//NMAIL
  230. KEVTEX=TITRE
  231. ENDIF
  232. ENDIF
  233. SEGDES MEVOLL,KEVOLL
  234. SEGDES MLREEL,MLREE1
  235. CALL ECROBJ('EVOLUTIO',MEVOLL)
  236. SEGSUP MTRAV,TTRAV
  237. SEGSUP MVOL
  238. 111 RETURN
  239. END
  240.  
  241.  
  242.  
  243.  

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