Télécharger evcomp.eso

Retour à la liste

Numérotation des lignes :

evcomp
  1. C EVCOMP SOURCE FANDEUR 22/04/14 21:15:02 11333
  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. IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31. -INC PPARAM
  32. -INC CCOPTIO
  33. -INC SMEVOLL
  34. -INC SMLREEL
  35.  
  36. CHARACTER*72 MTIT1
  37. CHARACTER*12 MOTITR
  38. CHARACTER*4 MOTCMP(2,2),MOTOPT(2)
  39. CHARACTER*4 MOTIT1(1)
  40. DATA MOTCMP/'MODU','PHAS','PREE','PIMA'/
  41. DATA MOTOPT/'MOPH','REIM'/
  42. DATA MOTIT1/'LEGE'/
  43. LOPT=2
  44.  
  45. C LECTURE OPTIONNELLE DU TYPE (MOPH ou REIM)
  46. CALL LIRMOT (MOTOPT,LOPT,IOPT,0)
  47. IF (IERR.NE.0) RETURN
  48. IF (IOPT.EQ.0) IOPT=2
  49.  
  50. C CREATION DE L'EVOLUTION MERE
  51. N=2
  52. SEGINI MEVOLL
  53. IPVO=MEVOLL
  54. IEVTEX(1:72)=TITREE(1:72)
  55. ITYEVO='COMPLEXE'
  56.  
  57. C CREATION DES 2 SOUS-EVOLUTIONS
  58. SEGINI KEVOL1,KEVOL2
  59. IEVOLL(1)=KEVOL1
  60. IEVOLL(2)=KEVOL2
  61.  
  62. KEVOL1.NUMEVX=ICOUL
  63. KEVOL1.NUMEVY=' '
  64. KEVOL1.TYPX='LISTREEL'
  65. KEVOL1.TYPY='LISTREEL'
  66. KEVOL1.NOMEVX=' '
  67. KEVOL1.NOMEVY=' '
  68. KEVOL1.KEVTEX=' '
  69.  
  70. KEVOL2.NUMEVX=ICOUL
  71. KEVOL2.NUMEVY=' '
  72. KEVOL2.TYPX='LISTREEL'
  73. KEVOL2.TYPY='LISTREEL'
  74. KEVOL2.NOMEVX=' '
  75. KEVOL2.NOMEVY=' '
  76. KEVOL2.KEVTEX=' '
  77.  
  78. C LECTURE OPTIONNELLE DES TITRES DES SOUS EVOLUTIONS DE LA COURBE (LEGE) :
  79. ITIT1=0
  80. CALL LIRMOT(MOTIT1,1,ITIT1,0)
  81. IF (IERR.NE.0) RETURN
  82. IF(ITIT1.EQ.1) THEN
  83. MTIT1=' '
  84. CALL LIRCHA(MTIT1,1,IRETOU)
  85. IF (IERR.NE.0) RETURN
  86. KEVOL1.KEVTEX=MTIT1
  87. MTIT1=' '
  88. CALL LIRCHA(MTIT1,1,IRETOU)
  89. IF (IERR.NE.0) RETURN
  90. KEVOL2.KEVTEX=MTIT1
  91. ELSE
  92. IF(IOPT.EQ.1) THEN
  93. KEVOL1.KEVTEX='Amp'
  94. KEVOL2.KEVTEX='\j'
  95. ELSE
  96. KEVOL1.KEVTEX='Re'
  97. KEVOL2.KEVTEX='Im'
  98. ENDIF
  99. ENDIF
  100.  
  101. C LECTURE DES TITRES ET LISTREELS DE L'ABSCISSE + 2 ORDONNEES
  102. c boucle sur les 3 objets dans cet ordre
  103. DO K=1,2
  104. DO J=1,K
  105.  
  106. C *** TITRE DES ABSCISSES / ORDONNEES SOUS FORME DE CHAINE DE CARACTERES
  107. MOTITR=' '
  108. CALL LIRCHA(MOTITR,0,IRETOU)
  109. IF (IERR.NE.0) RETURN
  110. IF (IRETOU.GT.0) THEN
  111. IF (K.EQ.1) THEN
  112. KEVOL1.NOMEVX=MOTITR
  113. KEVOL2.NOMEVX=MOTITR
  114. ELSE
  115. IF(J.EQ.1) KEVOL1.NOMEVY=MOTITR
  116. IF(J.EQ.2) KEVOL2.NOMEVY=MOTITR
  117. ENDIF
  118. ENDIF
  119.  
  120. C *** LECTURE DE LISTREEL
  121. CALL LIROBJ('LISTREEL',IMOT,1,IRET)
  122. IF (IERR.NE.0) RETURN
  123. IF (K.EQ.1) THEN
  124. C ABSCISSES DES 2 COURBES
  125. KEVOL1.IPROGX=IMOT
  126. KEVOL2.IPROGX=IMOT
  127. MLREEL=IMOT
  128. SEGACT MLREEL
  129. LX = MLREEL.PROG(/1)
  130. SEGDES MLREEL
  131. ELSE
  132. IF (J.EQ.1) THEN
  133. C ORDONNEES DE LA PREMIERE COURBE
  134. KEVOL1.IPROGY=IMOT
  135. KEVOL1.NUMEVY=MOTCMP(1,IOPT)
  136. MLREEL=IMOT
  137. SEGACT MLREEL
  138. LY1 = MLREEL.PROG(/1)
  139. SEGDES MLREEL
  140. ELSE
  141. C ORDONNEES DE LA DEUXIEME COURBE
  142. KEVOL2.IPROGY=IMOT
  143. KEVOL2.NUMEVY=MOTCMP(2,IOPT)
  144. MLREEL=IMOT
  145. SEGACT MLREEL
  146. LY2 = MLREEL.PROG(/1)
  147. SEGDES MLREEL
  148. ENDIF
  149. ENDIF
  150.  
  151. ENDDO
  152. ENDDO
  153.  
  154. SEGDES KEVOL1,KEVOL2
  155. SEGDES MEVOLL
  156.  
  157. IF((LX.NE.LY1).OR.(LY1.NE.LY2)) THEN
  158. CALL ERREUR(263)
  159. C LES 3 PROGRESSIONS DOIVENT ETRE DE MEME LONGUEUR
  160. RETURN
  161. ENDIF
  162.  
  163. CALL ECROBJ('EVOLUTIO',IPVO)
  164.  
  165. c RETURN
  166. END
  167.  
  168.  
  169.  

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