Télécharger soucha.eso

Retour à la liste

Numérotation des lignes :

  1. C SOUCHA SOURCE GOUNAND 14/01/29 21:15:16 7923
  2. ************************************************************************
  3. * NOM : soucha.eso
  4. * DESCRIPTION : Extraction d'une sous-chaîne
  5. ************************************************************************
  6. * HISTORIQUE : 13/03/2012 : JCARDO : création de la subroutine
  7. * HISTORIQUE :
  8. * HISTORIQUE :
  9. ************************************************************************
  10. * Prière de PRENDRE LE TEMPS DE COMPLÉTER LES COMMENTAIRES
  11. * en cas de modification de ce sous-programme afin de faciliter
  12. * la maintenance !
  13. ************************************************************************
  14. * APPELÉ PAR : extrai.eso
  15. ************************************************************************
  16. * ENTRÉES :: CSTR = chaîne dont on veut extraire une sous-chaîne
  17. * LSTR = longueur de CSTR
  18. * CTYP = mode d'extraction ('ENTIER' ou 'LISTENTI')
  19. * SORTIES :: aucune
  20. ************************************************************************
  21. * SYNTAXE (GIBIANE) :
  22. *
  23. * MOT2 = EXTR MOT1 | ENTI1 (ENTI2) |
  24. * | LENTI1 |
  25. *
  26. ************************************************************************
  27. SUBROUTINE SOUCHA(CSTR,LSTR,CTYP)
  28. IMPLICIT INTEGER(I-N)
  29. IMPLICIT REAL*8(A-H,O-Z)
  30.  
  31.  
  32. -INC PPARAM
  33. -INC CCOPTIO
  34. -INC SMLENTI
  35.  
  36. CHARACTER*8 CTYP
  37. CHARACTER*512 CSTR,CSTR2
  38.  
  39.  
  40. * =====================================
  41. * EXTRACTION À PARTIR DE 1 OU 2 ENTIERS
  42. * =====================================
  43.  
  44. IF (CTYP.EQ.'ENTIER') THEN
  45.  
  46. * Lecture de la position du premier caractère à extraire
  47. CALL LIRENT(IPOS1,1,IRETOU)
  48. IF (IPOS1.LT.1.OR.IPOS1.GT.LSTR) THEN
  49. CALL ERREUR(21)
  50. WRITE (IOIMP,9001) 'le nombre ENTI1',1,LSTR
  51. RETURN
  52. ENDIF
  53.  
  54. * Lecture de la position du dernier caractère à extraire
  55. IPOS2=LSTR
  56. CALL LIRENT(IPOS2,0,IRETOU)
  57. IF (IPOS2.LT.IPOS1.OR.IPOS2.GT.LSTR) THEN
  58. CALL ERREUR(21)
  59. WRITE (IOIMP,9001) 'le nombre ENTI2',IPOS1,LSTR
  60. RETURN
  61. ENDIF
  62.  
  63. * Extraction et renvoi de la sous-chaîne
  64. CALL ECRCHA(CSTR(IPOS1:IPOS2))
  65. RETURN
  66.  
  67.  
  68.  
  69.  
  70. * =================================
  71. * EXTRACTION À PARTIR D'UN LISTENTI
  72. * =================================
  73.  
  74. ELSEIF (CTYP.EQ.'LISTENTI') THEN
  75.  
  76. * Lecture de l'objet LISTENTI
  77. CALL LIROBJ('LISTENTI',MLENTI,1,IRETOU)
  78. SEGACT MLENTI
  79.  
  80. * Construction de la sous-chaîne
  81. NCAR=LECT(/1)
  82. IF (NCAR.EQ.0) THEN
  83. CALL ERREUR(21)
  84. WRITE (IOIMP,*) '(le LISTENTI ne contient aucun élément)'
  85. RETURN
  86. ENDIF
  87.  
  88. CSTR2=' '
  89. DO IA=1,NCAR
  90. IB=LECT(IA)
  91. IF (IB.LT.1.OR.IB.GT.LSTR) THEN
  92. CALL ERREUR(21)
  93. WRITE (IOIMP,9001) 'chaque nombre du LISTENTI',1,LSTR
  94. RETURN
  95. ENDIF
  96.  
  97. CSTR2(IA:IA)=CSTR(IB:IB)
  98. ENDDO
  99.  
  100. * Renvoi de la sous-chaîne
  101. SEGDES MLENTI
  102. CALL ECRCHA(CSTR2(1:NCAR))
  103. RETURN
  104.  
  105. ENDIF
  106.  
  107.  
  108.  
  109.  
  110.  
  111. * ERREUR 39 : On ne veut pas d'objet de type %m1:8
  112. MOTERR(1:8)=CTYP
  113. CALL ERREUR(39)
  114. RETURN
  115.  
  116.  
  117. * Format du message d'erreur en cas de données incompatibles
  118. 9001 FORMAT('('A,' doit être compris entre ',I2,' et ',I2,')')
  119.  
  120. END
  121.  
  122.  
  123.  
  124.  

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