Télécharger sorcha.eso

Retour à la liste

Numérotation des lignes :

  1. C SORCHA SOURCE BP208322 15/11/05 21:15:03 8700
  2. C
  3. ************************************************************************
  4. * NOM : sorcha.eso
  5. * DESCRIPTION : Sortie de chaines de caracteres au format texte
  6. * (pour cast3m, Matlab, python, etc ... par exemple)
  7. ************************************************************************
  8. * HISTORIQUE : 2015/11/04 : BP : version initiale
  9. * HISTORIQUE :
  10. ************************************************************************
  11. * Prière de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
  12. * en cas de modification de ce sous-programme afin de faciliter
  13. * la maintenance !
  14. ************************************************************************
  15. * APPELE PAR : operateur SORTir (prsort.eso)
  16. ************************************************************************
  17. * ENTREES :: aucune
  18. * SORTIES :: aucune (sur fichier uniquement)
  19. ************************************************************************
  20. * SYNTAXE (GIBIANE) :
  21. *
  22. * SORT 'CHAI' CHA1 ;
  23. *
  24. * avec CHA1 = chaine de caracteres
  25. *
  26. ************************************************************************
  27.  
  28. SUBROUTINE SORCHA
  29.  
  30. IMPLICIT INTEGER(I-N)
  31. IMPLICIT REAL*8(A-H,O-Z)
  32.  
  33.  
  34. -INC PPARAM
  35. -INC CCOPTIO
  36. -INC SMTEXTE
  37. -INC CCNOYAU
  38.  
  39. * Chaine de caracteres a ecrire
  40. PARAMETER (LMAX=512)
  41. CHARACTER*(LMAX) MESS,ICARB
  42. * ChaInes de caracteres generiques
  43. CHARACTER*4 CHA4
  44. CHARACTER*8 CHA8
  45.  
  46. LOGICAL ZOPEN,ZEXIS
  47.  
  48. EXTERNAL LONG
  49.  
  50.  
  51.  
  52. * +---------------------------------------------------------------+
  53. * | |
  54. * | VERIFICATION EXISTENCE DU FICHIER DE SORTIE |
  55. * | |
  56. * +---------------------------------------------------------------+
  57.  
  58.  
  59. * Eventuelle erreur 705 si absence de fichier de sortie
  60. INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
  61. IF (.NOT.ZOPEN) THEN
  62. CALL ERREUR(-212)
  63. WRITE(IOIMP,*) '(via OPTI "SORT")'
  64. MOTERR(1:8)='CHAI '
  65. CALL ERREUR(705)
  66. RETURN
  67. ENDIF
  68.  
  69.  
  70.  
  71. * +---------------------------------------------------------------+
  72. * | |
  73. * | L E C T U R E D E S A R G U M E N T S |
  74. * | |
  75. * +---------------------------------------------------------------+
  76.  
  77. * Initialisation :
  78. MESS=' '
  79. NCHA=0
  80. ILON=0
  81.  
  82. *.... Boucle ....
  83. 1 CONTINUE
  84.  
  85. * Lecture
  86. CALL QUETYP(CHA8,0,IRETOU)
  87. IF (IRETOU.EQ.0) GOTO 100
  88.  
  89. * On a lu qqchose ...
  90. NCHA = NCHA + 1
  91.  
  92. * --- Cas d'un ENTIER ------------------------------------------------
  93. IF(CHA8.EQ.'ENTIER ') THEN
  94.  
  95. CALL LIRENT(IPO,0,IRETOU)
  96. IF(IRETOU.EQ.0) THEN
  97. CALL ERREUR(5)
  98. RETURN
  99. ENDIF
  100. IF(ILON+13.GT.LMAX) GO TO 1000
  101. IF(ABS(IPO).LT.10000) THEN
  102. WRITE(MESS(ILON+1:ILON+7),FMT='(I5)') IPO
  103. ILON=ILON+8
  104. ELSE
  105. WRITE(MESS(ILON+1:ILON+11),FMT='(I9)') IPO
  106. ILON=ILON+12
  107. ENDIF
  108.  
  109. * --- Cas d'un FLOTTANT ----------------------------------------------
  110. ELSEIF( CHA8.EQ.'FLOTTANT') THEN
  111.  
  112. CALL LIRREE(XPO,0,IRETOU)
  113. IF(IRETOU.EQ.0) THEN
  114. CALL ERREUR(5)
  115. RETURN
  116. ENDIF
  117. IF(ILON +17.GT.LMAX) GO TO 1000
  118. WRITE(MESS(ILON+1:ILON+15),FMT='(1PG12.5)')XPO
  119. ILON=ILON+16
  120.  
  121. * --- Cas d'un MOT ou d'une PROCEDUR ---------------------------------
  122. ELSEIF ((CHA8.EQ.'MOT ').OR.(CHA8.EQ.'PROCEDUR')) THEN
  123. CALL LIRCHA(ICARB,0,IRETOU)
  124. IF(IRETOU.EQ.0) THEN
  125. CALL ERREUR(5)
  126. RETURN
  127. ENDIF
  128. IFI=MIN(IRETOU,LMAX)
  129. IF(ILON+IFI.GT.LMAX) GO TO 1000
  130. MESS(ILON+1:ILON+IFI)=ICARB(1:IFI)
  131. ILON=ILON+IFI
  132.  
  133. * --- Cas d'un TEXTE -------------------------------------------------
  134. ELSEIF( CHA8.EQ.'TEXTE ') THEN
  135. CALL LIROBJ('TEXTE ',IPO,0,IRETOU)
  136. IF(IRETOU.EQ.0) THEN
  137. CALL ERREUR(5)
  138. RETURN
  139. ENDIF
  140. MTEXTE = IPO
  141. SEGACT MTEXTE
  142. IF(ILON+NCART.GT.LMAX) GO TO 1000
  143. MESS(ILON+1:ILON+NCART)=MTEXT(1:NCART)
  144. ILON=ILON+NCART
  145. SEGDES MTEXTE
  146.  
  147. * --- Autres Cas => ERREUR --------------------------------------------
  148. ELSE
  149. * ERREUR : On ne veut pas d'objet de type %m1:8
  150. MOTERR(1:8)=CHA8
  151. CALL ERREUR(39)
  152. RETURN
  153. ENDIF
  154.  
  155. GO TO 1
  156. *.... Fin de la boucle ....
  157.  
  158.  
  159.  
  160.  
  161. * +---------------------------------------------------------------+
  162. * | |
  163. * | E C R I T U R E D A N S L E F I C H I E R |
  164. * | |
  165. * +---------------------------------------------------------------+
  166.  
  167. 100 CONTINUE
  168.  
  169. c On n'a rien lu !
  170. IF (NCHA.EQ.0) THEN
  171. WRITE(IOIMP,*) 'ATTENTION : il n''y a rien à sortir'
  172. CALL ERREUR(21)
  173. ENDIF
  174.  
  175. c On ecrit
  176. WRITE(IOPER,110) MESS (1:ILON)
  177. 110 FORMAT(A)
  178. RETURN
  179.  
  180.  
  181.  
  182. * +---------------------------------------------------------------+
  183. * | |
  184. * | E R R E U R |
  185. * | |
  186. * +---------------------------------------------------------------+
  187.  
  188.  
  189.  
  190. c Erreur on depasse 512 caracteres
  191. 1000 CONTINUE
  192. CALL ERREUR(274)
  193. RETURN
  194. END
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  
  202.  

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