Télécharger evmanu.eso

Retour à la liste

Numérotation des lignes :

  1. C EVMANU SOURCE CB215821 16/03/09 21:15:03 8849
  2. SUBROUTINE EVMANU(ICOUL)
  3. C=======================================================================
  4. C OPTION MANU DE L'OPERATEUR EVOL
  5. C
  6. C POUR RENTRER A LA MAIN UN OBJET DE TYPE EVOLUTION
  7. C (IL N Y AURA QU UNE SEULE EVOLUTION)
  8. C SYNTAXE :
  9. C
  10. C EV1= EVOL (COUL) MANU ('TYPE' MTYP) ('LEGE' MTIT1)
  11. C ('CHAINE CARAC') PRGX ('CHAINE CARAC') PRGY ;
  12. C
  13. C
  14. C COUL : COULEUR DE LA COURBE (FACULTATIVE)
  15. C MOTXI : OBJET DE TYPE MOT
  16. C PRGX : LISTE DE REELS (ABSCISSES)
  17. C MOTYI : OBJET DE TYPE MOT
  18. C PRGY : LISTE DE REELS (ORDONNEES)
  19. C
  20. C CREATION : 01/10/86, GUILBAUD
  21. C MODIFS : 2015-05-07 BP, ajout du titre de la LEGEnde
  22. C
  23. C======================================================================
  24. IMPLICIT INTEGER(I-N)
  25. -INC CCOPTIO
  26. -INC SMEVOLL
  27. -INC SMLREEL
  28. -INC SMLMOTS
  29. -INC SMLENTI
  30. C
  31. CHARACTER*72 TI,MTIT1
  32. CHARACTER*12 MOTITR
  33. CHARACTER*8 ITBLAN,TYPi
  34. CHARACTER*4 MTYP,LMOT(1)
  35. CHARACTER*4 MOTIT1(1)
  36. DIMENSION MOT(2)
  37. C
  38. DATA LMOT/'TYPE'/
  39. DATA MOTIT1/'LEGE'/
  40. C
  41. C CREATION DE LA SOUS-EVOLUTION
  42. SEGINI KEVOLL
  43. NOMEVX=' '
  44. NOMEVY=' '
  45. TYPX='LISTREEL'
  46. TYPY='LISTREEL'
  47. C
  48. C LECTURE OPTIONNELLE DU TYPE DE LA COURBE
  49. C (NUMEVY = MTYP = {REEL, MODU, PHAS, PREE, PIMA ...} ) :
  50. IPLAC=0
  51. IMOT=0
  52. CALL LIRMOT(LMOT,1,IPLAC,0)
  53. IF (IPLAC.EQ.1) THEN
  54. CALL LIRCHA(MTYP,1,IMOT)
  55. IF (IMOT.EQ.0) RETURN
  56. ENDIF
  57.  
  58. C LECTURE OPTIONNELLE DU TITRE DE LA SOUS EVOLUTION DE LA COURBE (LEGE) :
  59. MTIT1=' '
  60. ITIT1=0
  61. CALL LIRMOT(MOTIT1,1,ITIT1,0)
  62. IF(ITIT1.EQ.1) THEN
  63. CALL LIRCHA(MTIT1,1,IRETOU)
  64. IF(IERR.NE.0) RETURN
  65. ENDIF
  66. C
  67. C LECTURE DES TITRES ET LISTREELS DE L'ABSCISSE + ORDONNEE
  68. DO 20 J=1,2
  69.  
  70. C *** TITRE ABSCISSES / ORDONNEES SOUS FORME DE MOT
  71. MOTITR=' '
  72. CALL LIRCHA(MOTITR,0,IRETOU)
  73. IF(IRETOU.EQ.0) GOTO 12
  74. IF(J.EQ.1) NOMEVX=MOTITR
  75. IF(J.EQ.2) NOMEVY=MOTITR
  76.  
  77. C *** LECTURE DE LA LISTREEL (ou autre...)
  78. 12 CONTINUE
  79. CALL QUETYP (TYPi,1,IRETOU)
  80. IF (IRETOU .EQ. 0 .OR. (.NOT. ( Typi .EQ. 'LISTREEL'
  81. & .OR. Typi .EQ. 'LISTMOTS'
  82. & .OR. Typi .EQ. 'LISTENTI'))) THEN
  83. MOTERR(1 :8 ) = 'LISTREEL'
  84. MOTERR(9 :16) = 'LISTMOTS'
  85. MOTERR(17:24) = 'LISTENTI'
  86. CALL ERREUR(471)
  87. GOTO 1000
  88. ENDIF
  89.  
  90. CALL LIROBJ(Typi,MOT(J),0,IRET)
  91. IF( J.EQ.1) TYPX=Typi
  92. IF( J.EQ.2) TYPY=Typi
  93. 20 CONTINUE
  94. C
  95. IF (TYPX.EQ.'LISTREEL') THEN
  96. MLREEL=MOT(1)
  97. SEGACT MLREEL
  98. LX = PROG(/1)
  99. SEGDES MLREEL
  100. ELSEIF(TYPX.EQ.'LISTMOTS') THEN
  101. MLMOTS=MOT(1)
  102. SEGACT MLMOTS
  103. LX= MOTS(/2)
  104. SEGDES MLMOTS
  105. ELSEIF(TYPX.EQ.'LISTENTI') THEN
  106. MLENTI=MOT(1)
  107. SEGACT MLENTI
  108. LX=LECT(/1)
  109. SEGDES MLENTI
  110. ENDIF
  111.  
  112. IF (TYPY.EQ.'LISTREEL') THEN
  113. MLREEL=MOT(2)
  114. SEGACT MLREEL
  115. LY = PROG(/1)
  116. IF (IPLAC .EQ. 0) MTYP ='REEL'
  117. SEGDES MLREEL
  118. ELSEIF(TYPY.EQ.'LISTMOTS') THEN
  119. MLMOTS=MOT(2)
  120. SEGACT MLMOTS
  121. LY= MOTS(/2)
  122. IF (IPLAC .EQ. 0) MTYP ='MOTS'
  123. SEGDES MLMOTS
  124. ELSEIF(TYPY.EQ.'LISTENTI') THEN
  125. MLENTI=MOT(2)
  126. SEGACT MLENTI
  127. LY=LECT(/1)
  128. IF (IPLAC .EQ. 0) MTYP ='ENTI'
  129. SEGDES MLENTI
  130. ENDIF
  131.  
  132. IF(LX.NE.LY) THEN
  133. CALL ERREUR(263)
  134. C LES 2 PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
  135. GOTO 1000
  136. ENDIF
  137.  
  138. C CREATION DE L'EVOLUTION AVEC 1 SEULE SOUS EVOLUTION
  139. N=1
  140. SEGINI MEVOLL
  141. IPVO=MEVOLL
  142. TI(1:72)=TITREE
  143. IEVTEX=TI
  144. ITYEVO='REEL'
  145. c KEVTEX=TI
  146. IF(ITIT1.EQ.0) MTIT1=NOMEVY
  147. KEVTEX=MTIT1
  148. IEVOLL(1)=KEVOLL
  149. IPROGX=MOT(1)
  150. IPROGY=MOT(2)
  151. NUMEVX=ICOUL
  152. NUMEVY=MTYP
  153. SEGDES KEVOLL,MEVOLL
  154. CALL ECROBJ('EVOLUTIO',IPVO)
  155. RETURN
  156. 1000 CONTINUE
  157. SEGSUP KEVOLL
  158. RETURN
  159. END
  160.  
  161.  
  162.  
  163.  
  164.  
  165.  
  166.  

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