Télécharger la plaquette Cast3M


fr en

Télécharger chaine.eso

Retour à la liste

Numérotation des lignes : 

chaine

  1. C CHAINE    SOURCE    PV        22/11/03    21:15:01     11493          
  2.       SUBROUTINE CHAINE
  3. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  4. C
  5. C     CET OPERATEUR crée une chaîne de caractères
  6. C
  7. C     En présence du modificateur
  8. C       *N : justifie l'entrée à droite jusqu'à la colonne N
  9. C       /N : justifie l'entrée à gauche à partie de la colonne N
  10. C
  11. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  12. C
  13. C     Appelé par PILOT
  14. C
  15. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  16. C
  17. C     Remarques
  18. C
  19. C       ITOT : longueur de la chaîne élémentaire
  20. C
  21. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  22. C     Auteur : ?
  23. C
  24. C     Modifications :
  25. C       PM 17/01/2006
  26. C         - plus d'erreur si on impose une colonne d'écriture trop
  27. C           petite : on se contente de décaler vers la droite
  28. C         - ajout de commentaires
  29. C         - Ne tronque plus les chaînes en entrée de + de 72 caractères
  30. C           par passage de ITXTIN de 72 à LMAX caractères
  31. C         - ne conserve pas indûment le dernier alignement spécifié
  32. C           pour les entrées suivantes, ce qui corrige le bug survenant
  33. C           si on donne encore une entrée après une spécification d'alignement
  34. C           ex : 'CHAI' (bonjour*20 monde) ;
  35. C         - n'interprête plus les caractères * et / isolés comme des
  36. C           spécifications incomplètes de tabulation
  37. C
  38. C       CB215821 06/04/2020
  39. C         - Utilisation de LOCHAI dans PPARAM.INC.INC pour la longeur des
  40. C           chaines de caractere
  41. C
  42. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  43.       IMPLICIT INTEGER(I-N)
  44.  
  45. -INC PPARAM
  46. -INC CCOPTIO
  47. -INC CCNOYAU
  48. -INC SMTEXTE
  49.  
  50.       EXTERNAL         LONG
  51.       LOGICAL          LPO,LPO1,DEJALU
  52.       REAL*8           XPO,XPO1
  53.       CHARACTER*(LOCHAI) ITIT1,CMOT
  54.       CHARACTER*(LOCHAI) ITXTIN,ITXTI1
  55.       CHARACTER*(72)     MFMT
  56.       CHARACTER*(8)      CTYP,CTYP1,CTAB,CFMT
  57.       CHARACTER*(4)      IMO(4)
  58.       CHARACTER*(4)      CC
  59.       CHARACTER*(10)     DIGIT
  60.       logical entry
  61.       character*(*)      lachaine
  62.  
  63.       DATA             IMO/'*   ','/   ','<   ','>   '/
  64.       DATA             DIGIT/'1234567890'/
  65.  
  66.       entry = .false.
  67.       goto 314
  68.  
  69.       entry chain1(lachaine)
  70.       entry = .true.
  71.  314  continue
  72.       ITIT1 = ' '
  73.       ILON  = 0
  74.       ITOT  = 0
  75. *     Format par défaut
  76.       MFMT  = '(1PE12.5)'
  77.       IRETF = 9
  78.       DEJALU= .FALSE.
  79.  
  80. *     Boucle infinie sur tous les objets en entrée
  81.  1    CONTINUE
  82.  
  83. *     initialisation
  84.       IDECA = 0
  85.  
  86.  
  87. *     ===========================
  88. *     Lecture de l'objet en cours
  89. *     ===========================
  90.  
  91.       IF (.NOT.DEJALU) THEN
  92.           CALL QUETYP(CTYP,0,IRETOU)
  93.           IF (IRETOU.EQ.0) GOTO 10
  94.           IF (CTYP.EQ.'ENTIER') THEN
  95.               CALL LIRENT(IPO,1,IRETOU)
  96.               IF(IERR.NE.0) GOTO 1010
  97.           ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  98.               CALL LIRREE(XPO,1,IRETOU)
  99.               IF(IERR.NE.0) GOTO 1010
  100.           ELSEIF (CTYP.EQ.'LOGIQUE') THEN
  101.               CALL LIRLOG(LPO,1,IRETOU)
  102.               IF(IERR.NE.0) GOTO 1010
  103.           ELSEIF ((CTYP.EQ.'MOT').OR.(CTYP.EQ.'PROCEDUR')) THEN
  104.               CTYP='MOT'
  105.               CALL LIRCHA(ITXTIN,1,IRETOU)
  106.               IF(IERR.NE.0) GOTO 1010
  107. *             on lit la spécification éventuelle du format
  108.               IF(ITXTIN(1:7).EQ.'FORMAT ')THEN
  109.                   CALL LIRCHA(MFMT,1,IRETF)
  110.                   IF(IERR.NE.0) GOTO 1010
  111.                   GOTO 1
  112.               ENDIF
  113.           ENDIF
  114.  
  115.       ELSE
  116. *         on gère ce cas dans toute sa généralité, même si en pratique,
  117. *         on ne peut avoir qu'un MOT, valant '*' ou '/' ou '<' ou '>'
  118. *         (de longueur 1)
  119.           DEJALU=.FALSE.
  120.           CTYP  = CTYP1
  121.           IF     (CTYP.EQ.'ENTIER  ')THEN
  122.               IPO=IPO1
  123.           ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  124.               XPO=XPO1
  125.           ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  126.               LPO=LPO1
  127.           ELSEIF (CTYP.EQ.'MOT     ') THEN
  128.               ITXTIN=ITXTI1
  129.               IRETOU=IRETO1
  130. *             on lit la spécification éventuelle du format
  131.               IF(ITXTIN(1:7).EQ.'FORMAT ')THEN
  132.                   CALL LIRCHA(MFMT,1,IRETF)
  133.                   IF(IERR.NE.0) GOTO 1010
  134.                   GOTO 1
  135.               ENDIF
  136.           ENDIF
  137.       ENDIF
  138.  
  139.  
  140. *     Lecture d'un indicateur éventuel de tabulation ('*' ou '/' ou
  141. *     '<' ou '>')
  142.       CALL QUETYP(CTAB,0,IRETO)
  143.       IF (CTAB.EQ.'MOT') THEN
  144.           CALL LIRCHA(CMOT,1,LMOT)
  145.           IF (IERR.NE.0) RETURN
  146.  
  147.           CALL PLACE(IMO,4,IRET,CMOT(1:1))
  148.  
  149.           IF (IRET.NE.0) THEN
  150. *          => PRISE EN COMPTE DES INDICATEURS '<' ET '>' ECRITS
  151. *             "A LA VA-VITE" SANS QUOTES ET COLLES A L'ENTIER QUI SUIT
  152. *             EXEMPLE : CHAI 'TOTO'<12 ; QUE GIBIANE INTERPRETE COMME
  153. *                       LE MOT 'TOTO' SUIVI DU MOT '<12'
  154. *             REMARQUE : CELA NE CONCERNE PAS '/' ET '*' QUI SONT
  155. *                        CONSIDERES COMME DES SEPARATEURS NATIFS DE
  156. *                        GIBIANE
  157.               IF (LMOT.GE.2) THEN
  158.                   DO K=2,LMOT
  159.                       II = INDEX(DIGIT,CMOT(K:K))
  160.                       IF (II.EQ.0) GOTO 2
  161.                   ENDDO
  162.                   WRITE(CFMT,FMT='("(I",I1,")")') LMOT-1
  163.                   READ(CMOT(2:LMOT),FMT=CFMT) IPOS
  164.                   CALL ECRENT(IPOS)
  165.               ENDIF
  166.  
  167. *             y a-t-il un entier derrière ? (converti ci-dessus depuis
  168. *             un mot, ou bien lu en tant que tel)
  169.               CALL QUETYP(CTYP1,0,IRETO)
  170.               IF (CTYP1.EQ.'ENTIER') THEN
  171. *                 si oui, on a affaire à une spécification de tabulation
  172.                   CALL LIRENT(IPOS,1,IRETO)
  173.                   IF (IERR.NE.0) GOTO 1010
  174.                   IDECA = IRET
  175.                   GOTO 3
  176.               ENDIF
  177.  
  178. *             format de tabulation non reconnu
  179. *             => on traite le mot CMOT (qui debute par * ou / ou < ou >)
  180. *                comme un simple mot, sans signification particulière
  181. *                ...mais on l'a lu en avance (stocke dans ITXTI1)
  182.     2         CONTINUE
  183.               DEJALU=.TRUE.
  184.               CTYP1 = 'MOT     '
  185.               IPO1=IPO
  186.               XPO1=XPO
  187.               LPO1=LPO
  188.               ITXTI1(1:LMOT)=CMOT(1:LMOT)
  189.               IRETO1 = LMOT
  190.           ELSE
  191.               CALL REFUS
  192.           ENDIF
  193.       ENDIF
  194.  
  195.     3 CONTINUE
  196.  
  197.  
  198. *     =================================================================
  199. *     Construction de la chaîne de caractère élémentaire en fonction du
  200. *     type d'objet
  201. *     =================================================================
  202.  
  203.  
  204. *     1) calcul de la longueur du morceau de chaine a ajouter
  205. *        ----------------------------------------------------
  206.  
  207.       IF (CTYP.EQ.'ENTIER  ') THEN
  208.          IDEJ=0
  209.          IF(IPO.LT.0) IDEJ=1
  210.          IPO=ABS(IPO)
  211. *        nombre de chiffres à écrire, converti en chaîne
  212.          IF(IPO.EQ.0) THEN
  213.             idpl  = 1
  214.          ELSE
  215.             xnb   = log10 (real(ipo))
  216.             idpl  = (int(xnb)) + 1
  217.          ENDIF
  218. *        format d'écriture correspondant
  219.          IF (idpl.LT.10)   THEN
  220.             WRITE(cc,FMT='(I1)') idpl
  221.             CFMT  = '(I'//cc(1:1)//')'
  222.             IRETI = 4
  223.          ELSE
  224. *           ce cas n'est pas atteint lorsqu'un entier à plus de 10 chiffres est
  225. *           considéré comme un réel.
  226.             CFMT  = '(I10)'
  227.             IRETI = 5
  228.          ENDIF
  229.  
  230.          ITOT=IDEJ+IDPL
  231.  
  232. *        ajout du signe si négatif
  233.          IF (IDEJ.EQ.1) THEN
  234.             ITIT1(ILON+1:ILON+1)='-'
  235.             ILON=ILON+1
  236.          ENDIF
  237.  
  238.       ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  239. *        conversion en chaîne suivant le FORMAT
  240.          ITXTIN(1:LOCHAI)=' '
  241.          WRITE(ITXTIN,FMT=MFMT(1:IRETF),IOSTAT=ios1,ERR=1094) XPO
  242.          IF(ios1 .eq. 0)GOTO 1095
  243.  1094      CALL ERREUR(1094)
  244.            RETURN
  245.  1095    CONTINUE
  246.          ITOT=LONG(ITXTIN)
  247.  
  248.       ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  249.          ITOT=4
  250.  
  251.       ELSEIF (CTYP.EQ.'MOT     ') THEN
  252.          ITOT=IRETOU
  253.  
  254.       ELSE
  255. *       Données incompatibles
  256.         CALL ERREUR(21)
  257.         RETURN
  258.       ENDIF
  259.  
  260.  
  261. *     2) gestion du decalage et de l'alignement
  262. *        --------------------------------------
  263.  
  264. *     *N => on ecrit a gauche de la N-ieme colonne
  265.       IF     (IDECA.EQ.1) THEN
  266. c          IF (ILON+ITOT.GT.IPOS) IPOS=ILON+ITOT
  267.          ILON=IPOS-ITOT
  268.  
  269. *     /N => on ecrit a droite de la N-ieme colonne
  270.       ELSEIF (IDECA.EQ.2) THEN
  271. c          IF (IPOS.LE.ILON) IPOS=ILON+1
  272.          ILON=IPOS-1
  273.  
  274. *     -N => on ecrit a gauche de N colonnes plus loin
  275.       ELSEIF (IDECA.EQ.3) THEN
  276. c          IF(ILON+IPOS.LE.ILON) IPOS=ILON+ITOT
  277.          ILON=ILON+IPOS-ITOT
  278.  
  279. *     +N => on ecrit a droite de N colonnes plus loin
  280.       ELSEIF (IDECA.EQ.4) THEN
  281. c          IF(IPOS.LE.ILON) IPOS=ILON+1
  282.          ILON=ILON+IPOS-1
  283.  
  284.       ENDIF
  285.  
  286. *     erreur si chaîne totale trop grande
  287.       IF(ILON+ITOT.GT.LOCHAI) THEN
  288.         CALL ERREUR(1110)
  289.         RETURN
  290.       ENDIF
  291.  
  292.  
  293. *     3) mise a jour de la chaine
  294. *        ------------------------
  295.  
  296.       IF     (CTYP.EQ.'ENTIER  ')THEN
  297. *        write (6,*) ' format: ',ireti,cfmt(1:ireti)
  298.          WRITE(ITIT1(ILON+1:ILON+IDPL),FMT=CFMT(1:IRETI)) IPO
  299.          ILON=ILON+IDPL
  300.  
  301.       ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  302.          ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
  303.          ILON=ILON+ITOT
  304.  
  305.       ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  306.          IF (LPO) THEN
  307.             ITIT1(ILON+1:ILON+ITOT)='VRAI'
  308.          ELSE
  309.             ITIT1(ILON+1:ILON+ITOT)='FAUX'
  310.          ENDIF
  311.          ILON=ILON+ITOT
  312.  
  313.       ELSEIF (CTYP.EQ.'MOT     ') THEN
  314.          ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
  315.          ILON=ILON+ITOT
  316.       ENDIF
  317.  
  318.  
  319. *     Lecture de l'objet suivant
  320.       GOTO 1
  321.  
  322.  
  323.  
  324. *     ==========================================
  325. *     Fin de la subroutine : avec ou sans erreur
  326. *     ==========================================
  327.  
  328.  
  329. *     On a tout lu sans erreur
  330. *     On écrit la chaîne en sortie si elle n'est pas vide
  331.  10   CONTINUE
  332.       IF (ILON.EQ.0) THEN
  333.           ILON=1
  334.           ITIT1=' '
  335.       ENDIF
  336.  
  337. ***   IF(ILON.EQ.0) return
  338.       if (entry) then
  339.         lachaine=itit1(1:ilon)
  340.       else
  341.         CALL ECRCHA(ITIT1(1:ILON))
  342.       endif
  343.       RETURN
  344.  
  345.  
  346.  
  347. *     DECLENCHEMENT D'UNE ERREUR
  348. *     **************************
  349.  
  350.  1010 CONTINUE
  351.       CALL ERREUR(21)
  352.       RETURN
  353.       END
  354.  
  355.  
  356.  
  357.  

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