Télécharger evcomp.eso

Retour à la liste

Numérotation des lignes :

  1. C EVCOMP SOURCE BP208322 15/05/12 21:15:04 8530
  2. SUBROUTINE EVCOMP(ICOUL)
  3. C=======================================================================
  4. C OPTION COMP DE L'OPERATEUR EVOL
  5. C
  6. C POUR RENTRER UN OBJET DE TYPE EVOLUTION DE SOUS TYPE COMPLEXE
  7. C SYNTAXE :
  8. C
  9. c EVOL = EVOL (COUL) 'COMP' | ('REIM') | ...
  10. c | ('MOPH') |
  11. C
  12. c ... ('LEGE' TITOR1 TITOR2) ...
  13. C
  14. c ... NOMX PRGX (NOMOR1) PRGY1 (NOMOR2) PRGY2 ;
  15. C
  16. C COUL : COULEUR DE LA COURBE (FACULTATIVE)
  17. C
  18. C PRGX : LISTE DE REELS (ABSCISSES)
  19. C
  20. C PRGY1 : LISTE DE REELS (PARTIE REELLE OU MODULE)
  21. C
  22. C PRGY2 : LISTE DE REELS (PARTIE IMAGINAIRE OU PHASE)
  23. C
  24. C CREATION : 04/12/87, F. ROULLIER
  25. C MODIFS : 2015-05-07 BP, ajout du titre de la LEGEnde
  26. C
  27. C======================================================================
  28. IMPLICIT INTEGER(I-N)
  29. -INC CCOPTIO
  30. -INC SMEVOLL
  31. -INC SMLREEL
  32. C
  33. CHARACTER *72 TI,MTIT1
  34. CHARACTER*12 MOTITR
  35. CHARACTER*8 ITBLAN
  36. CHARACTER*4 MOTCMP(2,2),MOTOPT(2)
  37. CHARACTER*4 MOTIT1(1)
  38. DATA MOTCMP/'MODU','PHAS','PREE','PIMA'/
  39. DATA MOTOPT/'MOPH','REIM'/
  40. DATA MOTIT1/'LEGE'/
  41. LOPT=2
  42.  
  43. C LECTURE OPTIONNELLE DU TYPE (MOPH ou REIM)
  44. CALL LIRMOT (MOTOPT,LOPT,IOPT,0)
  45. IF (IOPT.EQ.0) IOPT=2
  46. N=2
  47.  
  48. C CREATION DE L'EVOLUTION MERE
  49. SEGINI MEVOLL
  50. IPVO=MEVOLL
  51. TI(1:72)=TITREE
  52. IEVTEX=TI
  53. ITYEVO='COMPLEXE'
  54.  
  55. C CREATION DES 2 SOUS-EVOLUTIONS
  56. SEGINI KEVOL1,KEVOL2
  57. IEVOLL(1)=KEVOL1
  58. IEVOLL(2)=KEVOL2
  59. KEVOL1.NUMEVX=ICOUL
  60. KEVOL2.NUMEVX=ICOUL
  61. KEVOL1.TYPX='LISTREEL'
  62. KEVOL1.TYPY='LISTREEL'
  63. KEVOL2.TYPX='LISTREEL'
  64. KEVOL2.TYPY='LISTREEL'
  65.  
  66. C LECTURE OPTIONNELLE DES TITRES DES SOUS EVOLUTIONS DE LA COURBE (LEGE) :
  67. c KEVOL1.KEVTEX=TI
  68. c KEVOL2.KEVTEX=TI
  69. ITIT1=0
  70. CALL LIRMOT(MOTIT1,1,ITIT1,0)
  71. IF(ITIT1.EQ.1) THEN
  72. MTIT1=' '
  73. CALL LIRCHA(MTIT1,1,IRETOU)
  74. KEVOL1.KEVTEX=MTIT1
  75. MTIT1=' '
  76. CALL LIRCHA(MTIT1,1,IRETOU)
  77. KEVOL2.KEVTEX=MTIT1
  78. IF(IERR.NE.0) RETURN
  79. ELSE
  80. IF(IOPT.EQ.1) THEN
  81. KEVOL1.KEVTEX='Amp'
  82. KEVOL2.KEVTEX='\j'
  83. ELSE
  84. KEVOL1.KEVTEX='Re'
  85. KEVOL2.KEVTEX='Im'
  86. ENDIF
  87. ENDIF
  88.  
  89. C LECTURE DES TITRES ET LISTREELS DE L'ABSCISSE + 2 ORDONNEES
  90. c boucle sur les 3 objets dans cet ordre
  91. DO 110 K=1,2
  92. DO 20 J=1,K
  93.  
  94. C *** TITRE DES ABSCISSES / ORDONNEES SOUS FORME DE CHAINE DE CARACTERES
  95. MOTITR=' '
  96. CALL LIRCHA(MOTITR,0,IRETOU)
  97. IF(IRETOU.EQ.0) GOTO 12
  98. IF (K.EQ.1) THEN
  99. KEVOL1.NOMEVX=MOTITR
  100. KEVOL2.NOMEVX=MOTITR
  101. ELSE
  102. IF(J.EQ.1) KEVOL1.NOMEVY=MOTITR
  103. IF(J.EQ.2) KEVOL2.NOMEVY=MOTITR
  104. ENDIF
  105.  
  106. C *** LECTURE DE LISTREEL
  107. 12 CONTINUE
  108. CALL LIROBJ('LISTREEL',IMOT,1,IRET)
  109. IF(IERR.NE.0) RETURN
  110. IF (K.EQ.1) THEN
  111. C ABSCISSES DES 2 COURBES
  112. KEVOL1.IPROGX=IMOT
  113. KEVOL2.IPROGX=IMOT
  114. MLREEL=IMOT
  115. SEGACT MLREEL
  116. LX = MLREEL.PROG(/1)
  117. SEGDES MLREEL
  118. ELSE
  119. IF (J.EQ.1) THEN
  120. C ORDONNEES DE LA PREMIERE COURBE
  121. KEVOL1.IPROGY=IMOT
  122. KEVOL1.NUMEVY=MOTCMP(1,IOPT)
  123. MLREEL=IMOT
  124. SEGACT MLREEL
  125. LY1 = MLREEL.PROG(/1)
  126. SEGDES MLREEL
  127. ELSE
  128. C ORDONNEES DE LA DEUXIEME COURBE
  129. KEVOL2.IPROGY=IMOT
  130. KEVOL2.NUMEVY=MOTCMP(2,IOPT)
  131. MLREEL=IMOT
  132. SEGACT MLREEL
  133. LY2 = MLREEL.PROG(/1)
  134. SEGDES MLREEL
  135. ENDIF
  136. ENDIF
  137.  
  138. 20 CONTINUE
  139. 110 CONTINUE
  140. SEGDES KEVOL1,KEVOL2
  141. C
  142. IF((LX.NE.LY1).OR.(LY1.NE.LY2)) THEN
  143. CALL ERREUR(263)
  144. C LES 3 PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
  145. RETURN
  146. ENDIF
  147. C
  148. SEGDES MEVOLL
  149. CALL ECROBJ('EVOLUTIO',IPVO)
  150.  
  151. RETURN
  152.  
  153. END
  154.  
  155.  
  156.  
  157.  

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