Sources Esope | Cast3M

sorcha
C SORCHA    SOURCE    BP208322  15/11/05    21:15:03     8700
C
************************************************************************
* NOM         : sorcha.eso
* DESCRIPTION : Sortie de chaines de caracteres au format texte
*               (pour cast3m, Matlab, python, etc ... par exemple)
************************************************************************
* HISTORIQUE :  2015/11/04 : BP : version initiale
* HISTORIQUE :
************************************************************************
* Prière de PRENDRE LE TEMPS DE COMPLETER LES COMMENTAIRES
* en cas de modification de ce sous-programme afin de faciliter
* la maintenance !
************************************************************************
* APPELE PAR : operateur SORTir (prsort.eso)
************************************************************************
* ENTREES :: aucune
* SORTIES :: aucune (sur fichier uniquement)
************************************************************************
* SYNTAXE (GIBIANE) :
*
*    SORT 'CHAI' CHA1 ;
*
*    avec CHA1 = chaine de caracteres
*
************************************************************************
 
      SUBROUTINE SORCHA
 
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
 
 
-INC PPARAM
-INC CCOPTIO
-INC SMTEXTE
-INC CCNOYAU
 
*     Chaine de caracteres a ecrire
      PARAMETER (LMAX=512)
      CHARACTER*(LMAX) MESS,ICARB
*     ChaInes de caracteres generiques
      CHARACTER*4 CHA4
      CHARACTER*8 CHA8
 
      LOGICAL ZOPEN,ZEXIS
 
      EXTERNAL LONG
 
 
 
*     +---------------------------------------------------------------+
*     |                                                               |
*     |         VERIFICATION EXISTENCE DU FICHIER DE SORTIE           |
*     |                                                               |
*     +---------------------------------------------------------------+
 
 
*     Eventuelle erreur 705 si absence de fichier de sortie
      INQUIRE(UNIT=IOPER,OPENED=ZOPEN)
      IF (.NOT.ZOPEN) THEN
          CALL ERREUR(-212)
          WRITE(IOIMP,*) '(via OPTI "SORT")'
          MOTERR(1:8)='CHAI    '
          CALL ERREUR(705)
          RETURN
      ENDIF
 
 
 
*     +---------------------------------------------------------------+
*     |                                                               |
*     |           L E C T U R E   D E S   A R G U M E N T S           |
*     |                                                               |
*     +---------------------------------------------------------------+
 
*     Initialisation :
      MESS=' '
      NCHA=0
      ILON=0
 
*.... Boucle ....
  1   CONTINUE
 
*     Lecture
      CALL QUETYP(CHA8,0,IRETOU)
      IF (IRETOU.EQ.0)   GOTO 100
 
*     On a lu qqchose ...
      NCHA = NCHA + 1
 
* --- Cas d'un ENTIER ------------------------------------------------
      IF(CHA8.EQ.'ENTIER  ') THEN
 
        CALL LIRENT(IPO,0,IRETOU)
        IF(IRETOU.EQ.0) THEN
           CALL ERREUR(5)
           RETURN
        ENDIF
        IF(ILON+13.GT.LMAX) GO TO 1000
        IF(ABS(IPO).LT.10000) THEN
          WRITE(MESS(ILON+1:ILON+7),FMT='(I5)') IPO
          ILON=ILON+8
        ELSE
          WRITE(MESS(ILON+1:ILON+11),FMT='(I9)') IPO
          ILON=ILON+12
        ENDIF
 
* --- Cas d'un FLOTTANT ----------------------------------------------
      ELSEIF( CHA8.EQ.'FLOTTANT') THEN
 
        CALL LIRREE(XPO,0,IRETOU)
        IF(IRETOU.EQ.0) THEN
           CALL ERREUR(5)
           RETURN
        ENDIF
        IF(ILON +17.GT.LMAX) GO TO 1000
        WRITE(MESS(ILON+1:ILON+15),FMT='(1PG12.5)')XPO
        ILON=ILON+16
 
* --- Cas d'un MOT ou d'une PROCEDUR ---------------------------------
      ELSEIF ((CHA8.EQ.'MOT     ').OR.(CHA8.EQ.'PROCEDUR')) THEN
        CALL LIRCHA(ICARB,0,IRETOU)
        IF(IRETOU.EQ.0) THEN
           CALL ERREUR(5)
           RETURN
        ENDIF
        IFI=MIN(IRETOU,LMAX)
        IF(ILON+IFI.GT.LMAX) GO TO 1000
        MESS(ILON+1:ILON+IFI)=ICARB(1:IFI)
        ILON=ILON+IFI
 
* --- Cas d'un TEXTE -------------------------------------------------
      ELSEIF( CHA8.EQ.'TEXTE   ') THEN
        CALL LIROBJ('TEXTE   ',IPO,0,IRETOU)
        IF(IRETOU.EQ.0) THEN
           CALL ERREUR(5)
           RETURN
        ENDIF
        MTEXTE = IPO
        SEGACT MTEXTE
        IF(ILON+NCART.GT.LMAX) GO TO 1000
        MESS(ILON+1:ILON+NCART)=MTEXT(1:NCART)
        ILON=ILON+NCART
        SEGDES MTEXTE
 
* --- Autres Cas => ERREUR --------------------------------------------
      ELSE
*         ERREUR : On ne veut pas d'objet de type %m1:8
          MOTERR(1:8)=CHA8
          CALL ERREUR(39)
          RETURN
      ENDIF
 
      GO TO 1
*.... Fin de la boucle ....
 
 
 
 
*     +---------------------------------------------------------------+
*     |                                                               |
*     |        E C R I T U R E   D A N S   L E   F I C H I E R        |
*     |                                                               |
*     +---------------------------------------------------------------+
 
 100  CONTINUE
 
c     On n'a rien lu !
      IF (NCHA.EQ.0) THEN
          WRITE(IOIMP,*) 'ATTENTION : il n''y a rien à sortir'
          CALL ERREUR(21)
      ENDIF
 
c     On ecrit
      WRITE(IOPER,110) MESS (1:ILON)
 110  FORMAT(A)
      RETURN
 
 
 
*     +---------------------------------------------------------------+
*     |                                                               |
*     |                         E R R E U R                           |
*     |                                                               |
*     +---------------------------------------------------------------+
 
 
 
c     Erreur on depasse 512 caracteres
1000  CONTINUE
      CALL ERREUR(274)
      RETURN
      END