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. -INC CCOPTIO
  37. -INC CCREEL
  38. -INC SMEVOLL
  39. -INC SMLREEL
  40. POINTEUR KEVOL3.KEVOLL,MEVOL3.MEVOLL
  41. POINTEUR MLREE4.MLREEL,MLREE5.MLREEL
  42. C
  43. CHARACTER*12 MOTX,MOTY
  44. CHARACTER *72 TI,TI2,TI3
  45. C
  46. CALL LIRMOT(NCOUL,NBCOUL,ICOUL,0)
  47. IF(ICOUL.EQ.0) ICOUL=IDCOUL+1
  48. ICOUL=ICOUL-1
  49. C
  50. CALL LIROBJ('EVOLUTIO',IPEV1,1,IRET)
  51. CALL LIROBJ('EVOLUTIO',IPEV2,1,IRET)
  52. CALL LIROBJ('EVOLUTIO',IPEV3,1,IRET)
  53. C
  54. IF(IERR.NE.0) GOTO 100
  55. C
  56. C LES 3 OBJETS EVOLUTION DOIVENT ETRE DE MEME LONGUEUR
  57. C
  58. MEVOL1=IPEV1
  59. SEGACT MEVOL1
  60. KEVOL1=MEVOL1.IEVOLL(1)
  61. SEGACT KEVOL1
  62. MLREE1=KEVOL1.IPROGY
  63. SEGACT MLREE1
  64. L1=MLREE1.PROG(/1)
  65. C
  66. MEVOL2=IPEV2
  67. SEGACT MEVOL2
  68. KEVOL2=MEVOL2.IEVOLL(1)
  69. SEGACT KEVOL2
  70. TI2=KEVOL2.KEVTEX
  71. MOTX=KEVOL2.NOMEVY
  72. MLREE2=KEVOL2.IPROGY
  73. SEGACT MLREE2
  74. L2=MLREE2.PROG(/1)
  75. C
  76. MEVOL3=IPEV3
  77. SEGACT MEVOL3
  78. KEVOL3=MEVOL3.IEVOLL(1)
  79. SEGACT KEVOL3
  80. TI3=KEVOL3.KEVTEX
  81. MOTY=KEVOL3.NOMEVY
  82. MLREE3=KEVOL3.IPROGY
  83. SEGACT MLREE3
  84. L3=MLREE3.PROG(/1)
  85. C
  86. C
  87. IF((L1.EQ.L2).AND.(L1.EQ.L3))GOTO 10
  88. CALL ERREUR(337)
  89. GOTO 100
  90. C
  91. C CREATION DE L'OBJET CART DE TYPE EVOLUTIO
  92. C
  93. 10 CONTINUE
  94. N=1
  95. SEGINI MEVOLL
  96. IPMAP=MEVOLL
  97. TI(1:72)=TITREE
  98. IEVTEX=TI
  99. ITYEVO='REEL'
  100. SEGINI KEVOLL
  101. IEVOLL(1)=KEVOLL
  102. TYPX='LISTREEL'
  103. TYPY='LISTREEL'
  104. cbp KEVTEX=TI
  105. if (KEVOL2.KEVTEX .eq. KEVOL3.KEVTEX) then
  106. KEVTEX=KEVOL2.KEVTEX
  107. else
  108. KEVTEX='POINCARE MAP'
  109. endif
  110. C
  111. NOMEVX=MOTX
  112. NOMEVY=MOTY
  113. NUMEVX=ICOUL
  114. NUMEVY='REEL'
  115. C
  116. JG=L1
  117. SEGINI MLREE4
  118. IPROGX=MLREE4
  119. SEGINI MLREE5
  120. IPROGY=MLREE5
  121. cbp on dimensionne d'abord au maxi puis on ajustera
  122. JG=0
  123. C
  124. C L'EVENEMENT EST PRIS SUR LE PREMIER OBJET EVOLUTION CITE EN
  125. C ARGUMENT
  126. C
  127. DO 20 I=1,L1
  128.  
  129. FORC=MLREE1.PROG(I)
  130.  
  131. c IF(ABS(FORC).LE.1.E-10) GOTO 20
  132. IF(ABS(FORC).LE.XSPETI) GOTO 20
  133.  
  134. C IL Y A CHOC : ON TIENT L'EVENEMENT
  135. C LE DEUXIEME OBJET EVOL CONCERNE LE DEPLACEMENT D'UN POINT
  136. C LE TROISIEME OBJET EVOL CONCERNE LA VITESSE DU MEME POINT
  137. DEPL=MLREE2.PROG(I)
  138. VITE=MLREE3.PROG(I)
  139. C
  140. C DEPL ET VITE FORMENT UN POINT DE LA CARTE
  141. JG=JG+1
  142. MLREE4.PROG(JG)=DEPL
  143. MLREE5.PROG(JG)=VITE
  144. C
  145. 20 CONTINUE
  146. C
  147. C
  148. C AJUSTE ET DESACTIVE LES LISTREEL via JG
  149. C
  150. SEGADJ,MLREE4,MLREE5
  151. SEGDES,MLREE4,MLREE5
  152. SEGDES MLREE1,MLREE2,MLREE3
  153. C
  154. C
  155. C DESACTIVE LES MEVOL ET AUTRES KEVOL
  156. C
  157. SEGDES KEVOLL,KEVOL1,KEVOL2,KEVOL3
  158. SEGDES MEVOLL,MEVOL1,MEVOL2,MEVOL3
  159. C
  160. C
  161. CALL ECROBJ('EVOLUTIO',IPMAP)
  162. C
  163. 100 CONTINUE
  164. RETURN
  165. END
  166.  
  167.  
  168.  
  169.  
  170.  
  171.  
  172.  
  173.  
  174.  
  175.  
  176.  
  177.  

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