Télécharger varipo.eso

Retour à la liste

Numérotation des lignes :

  1. C VARIPO SOURCE FANDEUR 16/09/21 21:15:17 9098
  2.  
  3. SUBROUTINE VARIPO(IPOI1,IPOI2,MOT2,IPOI3)
  4.  
  5. C-----------------------------------------------------------------------
  6. C CHPOINT VARIABLE
  7. C-----------------------------------------------------------------------
  8. C ENTREES:
  9. C IPOI1=POINTEUR SUR UN CHPOINT
  10. C IPOI2=POINTEUR SUR UN EVOLUTIO
  11. C MOT2 =NOM DE COMPOSANTE A DONNER AU RESULTAT
  12. C SORTIE:
  13. C IPOI3=POINTEUR SUR LE CHPOINT RESULTAT
  14. C-----------------------------------------------------------------------
  15. IMPLICIT INTEGER(I-N)
  16. IMPLICIT REAL*8(A-H,O-Z)
  17.  
  18. -INC CCOPTIO
  19.  
  20. -INC SMCOORD
  21. -INC SMCHPOI
  22. -INC SMEVOLL
  23. -INC SMLREEL
  24. -INC SMELEME
  25.  
  26. CHARACTER*(*) MOT2
  27. CHARACTER*4 MOTREF,MOTABS,MOTORD
  28.  
  29. SEGMENT mwrk
  30. INTEGER ipoi(NBPTS)
  31. REAL*8 xpoi(NBPTS)
  32. ENDSEGMENT
  33.  
  34. IPOI3 = 0
  35. C
  36. C ON RECUPERE L'OBJET EVOLUTION
  37. C
  38. MEVOLL = IPOI2
  39. SEGACT,MEVOLL
  40. KEVOLL = mevoll.IEVOLL(1)
  41. SEGDES,MEVOLL
  42. SEGACT,KEVOLL
  43. IF (kevoll.TYPX .NE. 'LISTREEL' .OR.
  44. & kevoll.TYPY .NE. 'LISTREEL') THEN
  45. SEGDES,KEVOLL
  46. MOTERR(1:8) = 'LISTREEL'
  47. CALL ERREUR(37)
  48. RETURN
  49. ENDIF
  50. MLREE1 = kevoll.IPROGX
  51. MLREE2 = kevoll.IPROGY
  52. MOTABS = kevoll.NOMEVX(1:4)
  53. IF (MOT2.NE.' ') THEN
  54. MOTORD = MOT2
  55. ELSE
  56. MOTORD = kevoll.NOMEVY(1:4)
  57. ENDIF
  58. SEGDES,KEVOLL
  59. * Petites verifications sur le contenu de l'evolution
  60. SEGACT,MLREE1,MLREE2
  61. NBPOIX = MLREE1.PROG(/1)
  62. NBPOIY = MLREE2.PROG(/1)
  63. IF (NBPOIX.NE.NBPOIY) THEN
  64. CALL ERREUR(577)
  65. GOTO 999
  66. ENDIF
  67. JORDO = 0
  68. CALL VARIFV(MLREE1.PROG,NBPOIX, JORDO)
  69. IF (JORDO.EQ.0) THEN
  70. CALL ERREUR(872)
  71. GOTO 999
  72. ENDIF
  73. C
  74. C ON RECUPERE LE CHPOINT
  75. C
  76. MCHPO1 = IPOI1
  77. SEGACT,MCHPO1
  78. C
  79. C Quelques verifications sur le CHPOINT d'entree
  80. NSOUP1 = MCHPO1.IPCHP(/1)
  81. C CHPOINT "VIDE" -> ERREUR
  82. IF (NSOUP1.LE.0) THEN
  83. MOTERR(1:8) = 'CHPOINT '
  84. INTERR(1) = IPOI1
  85. CALL ERREUR(356)
  86. GOTO 998
  87. ENDIF
  88. C On active le CHPOINT d'entree (son entete) :
  89. C On regarde si on a une seule composante pour tout le champ.
  90. IBVAL = 0
  91. DO 10 IA = 1, NSOUP1
  92. MSOUP1 = MCHPO1.IPCHP(IA)
  93. SEGACT,MSOUP1
  94. NC1 = MSOUP1.NOCOMP(/2)
  95. IF (NC1.EQ.1) THEN
  96. IBVAL = IBVAL + 1
  97. IF (IBVAL.EQ.1) MOTREF = MSOUP1.NOCOMP(1)
  98. ENDIF
  99. 10 CONTINUE
  100. C Si le champ a plus d'une composante, on va rechercher celle qui
  101. C correspond a l'abscisse de l'evolution.
  102. IF (IBVAL.NE.NSOUP1) MOTREF = MOTABS
  103. C
  104. C "Petit" segment de travail :
  105. NBPTS = XCOOR(/1) / (IDIM+1)
  106. SEGINI,mwrk
  107. C
  108. C BOUCLE SUR LES SOUS-ZONES DU CHPOINT
  109. C
  110. NBPOI3 = 0
  111. C
  112. DO 100 IA = 1, NSOUP1
  113. C
  114. MSOUP1 = MCHPO1.IPCHP(IA)
  115. NC1 = MSOUP1.NOCOMP(/2)
  116. IF (NC1.LE.0) GOTO 100
  117. IBVAL = 0
  118. CALL PLACE(MSOUP1.NOCOMP(1),NC1,IBVAL,MOTREF)
  119. IF (IBVAL.LE.0) GOTO 100
  120.  
  121. MELEME = MSOUP1.IGEOC
  122. MPOVAL = MSOUP1.IPOVAL
  123. SEGACT,MELEME,MPOVAL
  124. NBNN = meleme.NUM(/1)
  125. NBELEM = meleme.NUM(/2)
  126. N = mpoval.VPOCHA(/1)
  127. NC = mpoval.VPOCHA(/2)
  128. C
  129. C Verification sur LES DIMENSIONS DU CHPOINT :
  130. C Ne devrait pas arriver sauf si le chpoint n'est pas bien cree par on
  131. C ne sait quel operateur ou operation ou autre bizarrerie...
  132. IF (N.NE.NBELEM .OR. NBNN.NE.1 .OR. NC1.NE.NC) THEN
  133. SEGDES,MELEME,MPOVAL
  134. MOTERR(1:8) = 'VARIPO'
  135. CALL ERREUR(178)
  136. CALL ERREUR(5)
  137. GOTO 997
  138. ENDIF
  139.  
  140. DO 110 IC = 1, N
  141. XTT1 = mpoval.VPOCHA(IC,IBVAL)
  142. CALL VARIFO(MLREE1.PROG,MLREE2.PROG,NBPOIX,JORDO,XTT1,
  143. & YTT1)
  144. NBPOI3 = NBPOI3 + 1
  145. C* Ici on ne verifie pas que le point n'a pas deja ete rencontre.
  146. mwrk.ipoi(NBPOI3) = meleme.NUM(1,IC)
  147. mwrk.xpoi(NBPOI3) = YTT1
  148. 110 CONTINUE
  149.  
  150. SEGDES,MELEME,MPOVAL
  151.  
  152. 100 CONTINUE
  153. C
  154. C ERREUR SI LA COMPOSANTE RECHERCHEE N'EST PAS DANS MCHPOI
  155. IF (NBPOI3.EQ.0) THEN
  156. MOTERR(1:4) = MOTABS
  157. CALL ERREUR(181)
  158. GOTO 997
  159. ENDIF
  160. C
  161. C ON REMPLIT LE CHPOINT DE SORTIE
  162. C
  163. NSOUPO = 1
  164. NAT = MCHPO1.JATTRI(/1)
  165. SEGINI,MCHPOI
  166. mchpoi.MTYPOI = 'SCALAIRE'
  167. mchpoi.MOCHDE = 'CHPOINT cree par VARIPO'
  168. DO 200 IA = 1, NAT
  169. mchpoi.JATTRI(IA) = MCHPO1.JATTRI(IA)
  170. 200 CONTINUE
  171. mchpoi.IFOPOI = MCHPO1.IFOPOI
  172. NC = 1
  173. SEGINI,MSOUPO
  174. mchpoi.IPCHP(1) = MSOUPO
  175. msoupo.NOCOMP(1)= MOTORD
  176. NBNN = 1
  177. NBELEM = NBPOI3
  178. NBSOUS = 0
  179. NBREF = 0
  180. SEGINI,MELEME
  181. meleme.ITYPEL = 1
  182. N = NBPOI3
  183. NC = 1
  184. SEGINI,MPOVAL
  185. DO 210 IC = 1, NBPOI3
  186. meleme.NUM(1,IC) = mwrk.ipoi(IC)
  187. mpoval.VPOCHA(IC,1) = mwrk.xpoi(IC)
  188. 210 CONTINUE
  189. CALL CRECH1(meleme,1)
  190. SEGDES,MELEME,MPOVAL
  191. msoupo.IGEOC = MELEME
  192. msoupo.IPOVAL = MPOVAL
  193. SEGDES,MSOUPO,MCHPOI
  194. IPOI3 = MCHPOI
  195. C
  196. C On ferme tous les segments restants (et on detruit les inutiles).
  197. 997 CONTINUE
  198. SEGSUP,mwrk
  199. DO 9970 IA = 1, NSOUP1
  200. MSOUP1 = MCHPO1.IPCHP(IA)
  201. SEGDES,MSOUP1
  202. 9970 CONTINUE
  203. 998 CONTINUE
  204. SEGDES,MCHPO1
  205. 999 CONTINUE
  206. SEGDES,MLREE1,MLREE2
  207.  
  208. RETURN
  209. END
  210.  
  211.  
  212.  

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