Télécharger mapp.eso

Retour à la liste

Numérotation des lignes :

  1. C MAPP SOURCE BP208322 16/11/18 21:19:04 9177
  2. SUBROUTINE MAPP
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C
  6. C=======================================================================
  7. C = =
  8. C = CONSTRUCTION D'UN OBJET DE TYPE EVOL CONTENANT LES POINTS D'UNE =
  9. C = SECTION DE POINCARE =
  10. C = =
  11. C = SYNTAXE : CART = MAPP (COUL) EVOLF EVOLD EVOLV =
  12. C = =
  13. C = SUR UN EVENEMENT SE PRODUISANT SUR EVOLF A L'ABSCISSE T, ON =
  14. C = EMPLIT CART AVEC L'ORDONNEE A L'ABSCISSE T DE EVOLD, EN ABSCISSE =
  15. C = ET L'ORDONNEE A L'ABSCISSE T DE EVOLV, EN ORDONNEE. =
  16. C = =
  17. C = L'EVENEMENT EST LE PASSAGE DE 0. A UNE VALEUR DE L'ORDONNEE DE =
  18. C = EVOLF =
  19. C = =
  20. C = =
  21. C = MEVOL1 : POINTEUR SUR MEVOLF (OBJET EVOLUTION) =
  22. C = MEVOL2 : POINTEUR SUR MEVOLD " " =
  23. C = MEVOL3 : POINTEUR SUR MEVOLV " " =
  24. C = KEVOL1 : POINTEUR SUR KEVOLF =
  25. C = KEVOL2 : POINTEUR SUR KEVOLD =
  26. C = KEVOL3 : POINTEUR SUR KEVOLV =
  27. C = MLREE1 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLF =
  28. C = MLREE2 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLD =
  29. C = MLREE3 : POINTEUR SUR LA LISTREEL ORDONNEE DE EVOLV =
  30. C = =
  31. C = CREATION : 25/03/87 =
  32. C = PROGRAMMATEUR : BEAUFILS =
  33. C=======================================================================
  34. C
  35. -INC CCGEOME
  36.  
  37. -INC PPARAM
  38. -INC CCOPTIO
  39. -INC CCREEL
  40. -INC SMEVOLL
  41. -INC SMLREEL
  42. POINTEUR KEVOL3.KEVOLL,MEVOL3.MEVOLL
  43. POINTEUR MLREE4.MLREEL,MLREE5.MLREEL
  44. C
  45. CHARACTER*12 MOTX,MOTY
  46. CHARACTER *72 TI,TI2,TI3
  47. C
  48. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  49. IF(ICOUL.EQ.0) ICOUL=IDCOUL+1
  50. ICOUL=ICOUL-1
  51. C
  52. CALL LIROBJ('EVOLUTIO',IPEV1,1,IRET)
  53. CALL LIROBJ('EVOLUTIO',IPEV2,1,IRET)
  54. CALL LIROBJ('EVOLUTIO',IPEV3,1,IRET)
  55. C
  56. IF(IERR.NE.0) GOTO 100
  57. C
  58. C LES 3 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR
  59. C
  60. MEVOL1=IPEV1
  61. SEGACT MEVOL1
  62. KEVOL1=MEVOL1.IEVOLL(1)
  63. SEGACT KEVOL1
  64. MLREE1=KEVOL1.IPROGY
  65. SEGACT MLREE1
  66. L1=MLREE1.PROG(/1)
  67. C
  68. MEVOL2=IPEV2
  69. SEGACT MEVOL2
  70. KEVOL2=MEVOL2.IEVOLL(1)
  71. SEGACT KEVOL2
  72. TI2=KEVOL2.KEVTEX
  73. MOTX=KEVOL2.NOMEVY
  74. MLREE2=KEVOL2.IPROGY
  75. SEGACT MLREE2
  76. L2=MLREE2.PROG(/1)
  77. C
  78. MEVOL3=IPEV3
  79. SEGACT MEVOL3
  80. KEVOL3=MEVOL3.IEVOLL(1)
  81. SEGACT KEVOL3
  82. TI3=KEVOL3.KEVTEX
  83. MOTY=KEVOL3.NOMEVY
  84. MLREE3=KEVOL3.IPROGY
  85. SEGACT MLREE3
  86. L3=MLREE3.PROG(/1)
  87. C
  88. C
  89. IF((L1.EQ.L2).AND.(L1.EQ.L3))GOTO 10
  90. CALL ERREUR(337)
  91. GOTO 100
  92. C
  93. C CREATION DE L'OBJET CART DE TYPE EVOLUTIO
  94. C
  95. 10 CONTINUE
  96. N=1
  97. SEGINI MEVOLL
  98. IPMAP=MEVOLL
  99. TI(1:72)=TITREE
  100. IEVTEX=TI
  101. ITYEVO='REEL'
  102. SEGINI KEVOLL
  103. IEVOLL(1)=KEVOLL
  104. TYPX='LISTREEL'
  105. TYPY='LISTREEL'
  106. cbp KEVTEX=TI
  107. if (KEVOL2.KEVTEX .eq. KEVOL3.KEVTEX) then
  108. KEVTEX=KEVOL2.KEVTEX
  109. else
  110. KEVTEX='POINCARE MAP'
  111. endif
  112. C
  113. NOMEVX=MOTX
  114. NOMEVY=MOTY
  115. NUMEVX=ICOUL
  116. NUMEVY='REEL'
  117. C
  118. JG=L1
  119. SEGINI MLREE4
  120. IPROGX=MLREE4
  121. SEGINI MLREE5
  122. IPROGY=MLREE5
  123. cbp on dimensionne d'abord au maxi puis on ajustera
  124. JG=0
  125. C
  126. C L'EVENEMENT EST PRIS SUR LE PREMIER OBJET EVOLUTION CITE EN
  127. C ARGUMENT
  128. C
  129. DO 20 I=1,L1
  130.  
  131. FORC=MLREE1.PROG(I)
  132.  
  133. c IF(ABS(FORC).LE.1.E-10) GOTO 20
  134. IF(ABS(FORC).LE.XSPETI) GOTO 20
  135.  
  136. C IL Y A CHOC : ON TIENT L'EVENEMENT
  137. C LE DEUXIEME OBJET EVOL CONCERNE LE DEPLACEMENT D'UN POINT
  138. C LE TROISIEME OBJET EVOL CONCERNE LA VITESSE DU MEME POINT
  139. DEPL=MLREE2.PROG(I)
  140. VITE=MLREE3.PROG(I)
  141. C
  142. C DEPL ET VITE FORMENT UN POINT DE LA CARTE
  143. JG=JG+1
  144. MLREE4.PROG(JG)=DEPL
  145. MLREE5.PROG(JG)=VITE
  146. C
  147. 20 CONTINUE
  148. C
  149. C
  150. C AJUSTE ET DESACTIVE LES LISTREEL via JG
  151. C
  152. SEGADJ,MLREE4,MLREE5
  153. SEGDES,MLREE4,MLREE5
  154. SEGDES MLREE1,MLREE2,MLREE3
  155. C
  156. C
  157. C DESACTIVE LES MEVOL ET AUTRES KEVOL
  158. C
  159. SEGDES KEVOLL,KEVOL1,KEVOL2,KEVOL3
  160. SEGDES MEVOLL,MEVOL1,MEVOL2,MEVOL3
  161. C
  162. C
  163. CALL ECROBJ('EVOLUTIO',IPMAP)
  164. C
  165. 100 CONTINUE
  166. RETURN
  167. END
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  
  178.  
  179.  

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