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    CB215821  20/08/07    21:15:01     10685          
  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)) XPO
  242.          ITOT=LONG(ITXTIN)
  243.  
  244.       ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  245.          ITOT=4
  246.  
  247.       ELSEIF (CTYP.EQ.'MOT     ') THEN
  248.          ITOT=IRETOU
  249.  
  250.       ELSE
  251. *       Données incompatibles
  252.         CALL ERREUR(21)
  253.         RETURN
  254.       ENDIF
  255.  
  256.  
  257. *     2) gestion du decalage et de l'alignement
  258. *        --------------------------------------
  259.  
  260. *     *N => on ecrit a gauche de la N-ieme colonne
  261.       IF     (IDECA.EQ.1) THEN
  262. c          IF (ILON+ITOT.GT.IPOS) IPOS=ILON+ITOT
  263.          ILON=IPOS-ITOT
  264.  
  265. *     /N => on ecrit a droite de la N-ieme colonne
  266.       ELSEIF (IDECA.EQ.2) THEN
  267. c          IF (IPOS.LE.ILON) IPOS=ILON+1
  268.          ILON=IPOS-1
  269.  
  270. *     -N => on ecrit a gauche de N colonnes plus loin
  271.       ELSEIF (IDECA.EQ.3) THEN
  272. c          IF(ILON+IPOS.LE.ILON) IPOS=ILON+ITOT
  273.          ILON=ILON+IPOS-ITOT
  274.  
  275. *     +N => on ecrit a droite de N colonnes plus loin
  276.       ELSEIF (IDECA.EQ.4) THEN
  277. c          IF(IPOS.LE.ILON) IPOS=ILON+1
  278.          ILON=ILON+IPOS-1
  279.  
  280.       ENDIF
  281.  
  282. *     erreur si chaîne totale trop grande
  283.       IF(ILON+ITOT.GT.LOCHAI) THEN
  284.         CALL ERREUR(1110)
  285.         RETURN
  286.       ENDIF
  287.  
  288.  
  289. *     3) mise a jour de la chaine
  290. *        ------------------------
  291.  
  292.       IF     (CTYP.EQ.'ENTIER  ')THEN
  293. *        write (6,*) ' format: ',ireti,cfmt(1:ireti)
  294.          WRITE(ITIT1(ILON+1:ILON+IDPL),FMT=CFMT(1:IRETI)) IPO
  295.          ILON=ILON+IDPL
  296.  
  297.       ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  298.          ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
  299.          ILON=ILON+ITOT
  300.  
  301.       ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  302.          IF (LPO) THEN
  303.             ITIT1(ILON+1:ILON+ITOT)='VRAI'
  304.          ELSE
  305.             ITIT1(ILON+1:ILON+ITOT)='FAUX'
  306.          ENDIF
  307.          ILON=ILON+ITOT
  308.  
  309.       ELSEIF (CTYP.EQ.'MOT     ') THEN
  310.          ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
  311.          ILON=ILON+ITOT
  312.       ENDIF
  313.  
  314.  
  315. *     Lecture de l'objet suivant
  316.       GOTO 1
  317.  
  318.  
  319.  
  320. *     ==========================================
  321. *     Fin de la subroutine : avec ou sans erreur
  322. *     ==========================================
  323.  
  324.  
  325. *     On a tout lu sans erreur
  326. *     On écrit la chaîne en sortie si elle n'est pas vide
  327.  10   CONTINUE
  328.       IF (ILON.EQ.0) THEN
  329.           ILON=1
  330.           ITIT1=' '
  331.       ENDIF
  332.  
  333. ***   IF(ILON.EQ.0) return
  334.       if (entry) then
  335.         lachaine=itit1(1:ilon)
  336.       else
  337.         CALL ECRCHA(ITIT1(1:ILON))
  338.       endif
  339.       RETURN
  340.  
  341.  
  342.  
  343. *     DECLENCHEMENT D'UNE ERREUR
  344. *     **************************
  345.  
  346.  1010 CONTINUE
  347. *     Erreur anormale.contactez votre support
  348.       CALL ERREUR(5)
  349.       END
  350.  
  351.  

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