Télécharger chaine.eso

Retour à la liste

Numérotation des lignes :

  1. C CHAINE SOURCE JC220346 14/02/19 21:15:00 7941
  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. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  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. CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
  39. IMPLICIT INTEGER(I-N)
  40. -INC CCOPTIO
  41. -INC SMTEXTE
  42. * taille maximale d'une chaîne de caractères
  43. PARAMETER (LMAX=512)
  44.  
  45. EXTERNAL LONG
  46. LOGICAL LPO,LPO1,DEJALU
  47. REAL*8 XPO,XPO1
  48. CHARACTER*(LMAX) ITIT1
  49. CHARACTER*(LMAX) ITXTIN,ITXTI1
  50. CHARACTER*72 MFMT
  51. CHARACTER*(8) CTYP,CTYP1,CTAB,CFMT
  52. CHARACTER*4 IMO(2)
  53. CHARACTER*4 CC
  54.  
  55. DATA IMO/'* ','/ '/
  56.  
  57. ITIT1 = ' '
  58. ILON = 0
  59. * Format par défaut
  60. MFMT = '(1PE12.5)'
  61. IRETF = 9
  62. DEJALU= .FALSE.
  63.  
  64. * Boucle infinie sur tous les objets en entrée
  65. 1 CONTINUE
  66.  
  67. * initialisation
  68. IDECA = 0
  69.  
  70. * Lecture de l'objet en cours
  71. * ===========================
  72. IF (.NOT.DEJALU) THEN
  73. CALL QUETYP(CTYP,0,IRETOU)
  74. IF(IRETOU.EQ.0) GOTO 10
  75. IF (CTYP.EQ.'ENTIER ')THEN
  76. CALL LIRENT(IPO,1,IRETOU)
  77. IF(IERR.NE.0) GOTO 1010
  78. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  79. CALL LIRREE(XPO,1,IRETOU)
  80. IF(IERR.NE.0) GOTO 1010
  81. ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  82. CALL LIRLOG(LPO,1,IRETOU)
  83. IF(IERR.NE.0) GOTO 1010
  84. ELSEIF ((CTYP.EQ.'MOT ').OR.(CTYP.EQ.'PROCEDUR')) THEN
  85. CTYP='MOT'
  86. CALL LIRCHA(ITXTIN,1,IRETOU)
  87. IF(IERR.NE.0) GOTO 1010
  88. * on lit la spécification éventuelle du format
  89. IF(ITXTIN.EQ.'FORMAT')THEN
  90. CALL LIRCHA(MFMT,1,IRETF)
  91. IF(IERR.NE.0) GOTO 1010
  92. GOTO 1
  93. ENDIF
  94. ENDIF
  95. ELSE
  96. * on gère ce cas dans toute sa généralité, même si en pratique,
  97. * on ne peut avoir qu'un MOT, valant '*' ou '/' (de longueur 1)
  98. DEJALU=.FALSE.
  99. CTYP = CTYP1
  100. IF (CTYP.EQ.'ENTIER ')THEN
  101. IPO=IPO1
  102. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  103. XPO=XPO1
  104. ELSEIF (CTYP.EQ.'LOGIQUE ') THEN
  105. LPO=LPO1
  106. ELSEIF (CTYP.EQ.'MOT ') THEN
  107. ITXTIN=ITXTI1
  108. IRETOU=IRETO1
  109. * on lit la spécification éventuelle du format
  110. IF(ITXTIN.EQ.'FORMAT')THEN
  111. CALL LIRCHA(MFMT,1,IRETF)
  112. IF(IERR.NE.0) GOTO 1010
  113. GOTO 1
  114. ENDIF
  115. ENDIF
  116. ENDIF
  117.  
  118. * Lecture d'un indicateur éventuel de tabulation ('*' ou '/')
  119. CALL QUETYP(CTAB,0,IRETO)
  120. IF(CTAB.EQ.'MOT ') THEN
  121. CALL LIRMOT(IMO,2,IRET,0)
  122. IF(IRET.NE.0) THEN
  123. * y a-t-il un entier derrière ?
  124. CALL QUETYP(CTYP1,0,IRETO)
  125. IF(CTYP1.EQ.'ENTIER ') THEN
  126. * si oui, on a affaire à une spécification de tabulation
  127. CALL LIRENT(IPOS,0,IRETO)
  128. IF(IERR.NE.0) GOTO 1010
  129. IDECA = IRET
  130. ELSE
  131. * sinon on considère * ou / comme un simple caractère, sans
  132. * signification particulière
  133. * mais on a lu un mot en avance
  134. DEJALU=.TRUE.
  135. CTYP1 = 'MOT '
  136. ipo1=ipo
  137. xpo1=xpo
  138. lpo1=lpo
  139. ITXTI1 = IMO(IRET)
  140. IRETO1 = 1
  141. ENDIF
  142. ENDIF
  143. ENDIF
  144.  
  145. * Construction de la chaîne de caractère élémentaire en fonction du
  146. * type d'objet
  147. * =================================================================
  148.  
  149. IF(CTYP.EQ.'ENTIER ')THEN
  150. IDEJ=0
  151. IF(IPO.LT.0) IDEJ=1
  152. IPO=ABS(IPO)
  153. * nombre de chiffres à écrire, converti en chaîne
  154. IF(IPO.EQ.0) THEN
  155. idpl = 1
  156. ELSE
  157. xnb = log10 (real(ipo))
  158. idpl = (int(xnb)) + 1
  159. ENDIF
  160. * format d'écriture correspondant
  161. IF (idpl.LT.10) THEN
  162. WRITE(cc,FMT='(I1)') idpl
  163. CFMT = '(I'//cc(1:1)//')'
  164. IRETI = 4
  165. ELSE
  166. * ce cas n'est pas atteint lorsqu'un entier à plus de 10 chiffres est
  167. * considéré comme un réel.
  168. CFMT = '(I10)'
  169. IRETI = 5
  170. ENDIF
  171.  
  172. ITOT=IDEJ+IDPL
  173.  
  174. C a-t-on un cadrage a droite ou a gauche ?
  175. IF(IDECA.EQ.1) THEN
  176. * On écrit à droite d'une colonne spécifiée
  177. IF(ILON+ITOT.GT.IPOS) THEN
  178. * on décale la suite à droite si l'on manque de place.
  179. *PM GOTO 1000
  180. IPOS=ILON+ITOT
  181. ENDIF
  182. ILON=IPOS-ITOT
  183. ELSEIF(IDECA.EQ.2) THEN
  184. * On écrit à gauche d'une colonne spécifiée
  185. IF(IPOS.LE.ILON) THEN
  186. * on décale la suite à droite si l'on manque de place.
  187. *PM GOTO 1000
  188. IPOS=ILON+1
  189. ENDIF
  190. ILON=IPOS-1
  191. ENDIF
  192.  
  193. * erreur si chaîne totale trop grande
  194. IF(ILON+ITOT.GT.LMAX) GOTO 1000
  195.  
  196. * ajout du signe si négatif
  197. IF(IDEJ.EQ.1) THEN
  198. ITIT1(ILON+1:ILON+1)='-'
  199. ILON=ILON+1
  200. ENDIF
  201.  
  202. * sauvegarde (write interne)
  203. * write (6,*) ' format: ',ireti,cfmt(1:ireti)
  204. WRITE(ITIT1(ILON+1:ILON+IDPL),FMT=CFMT(1:IRETI)) IPO
  205. ILON=ILON+IDPL
  206.  
  207. GOTO 1
  208.  
  209. ELSEIF (CTYP.EQ.'FLOTTANT') THEN
  210. * conversion en chaîne suivant le format
  211. ITXTIN(1:LMAX)=' '
  212. WRITE(ITXTIN,FMT=MFMT(1:IRETF)) XPO
  213. ITOT=LONG(ITXTIN)
  214.  
  215. C a-t-on un cadrage a droite ou a gauche ?
  216. IF(IDECA.EQ.1) THEN
  217. * On écrit à droite d'une colonne spécifiée
  218. IF(ILON+ITOT.GT.IPOS) THEN
  219. * on décale la suite à droite si l'on manque de place.
  220. *PM GOTO 1000
  221. IPOS=ILON+ITOT
  222. ENDIF
  223. ILON=IPOS-ITOT
  224. ELSEIF(IDECA.EQ.2) THEN
  225. * On écrit à gauche d'une colonne spécifiée
  226. IF(IPOS.LE.ILON) THEN
  227. * on décale la suite à droite si l'on manque de place.
  228. *PM GOTO 1000
  229. IPOS=ILON+1
  230. ENDIF
  231. ILON=IPOS-1
  232. ENDIF
  233.  
  234. * erreur si chaîne totale trop grande
  235. IF(ILON+ITOT.GT.LMAX) GOTO 1000
  236.  
  237. * sauvegarde
  238. ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
  239. ILON=ILON+ITOT
  240. GOTO 1
  241.  
  242. ELSEIF(CTYP.EQ.'LOGIQUE ') THEN
  243. ITOT=IRETOU
  244.  
  245. C a-t-on un cadrage a droite ou a gauche ?
  246. IF(IDECA.EQ.1) THEN
  247. * On écrit à droite d'une colonne spécifiée
  248. IF(ILON+ITOT.GT.IPOS) THEN
  249. * on décale la suite à droite si l'on manque de place.
  250. *PM GOTO 1000
  251. IPOS=ILON+ITOT
  252. ENDIF
  253. ILON=IPOS-ITOT
  254. ELSEIF(IDECA.EQ.2) THEN
  255. * On écrit à gauche d'une colonne spécifiée
  256. IF(IPOS.LE.ILON) THEN
  257. * on décale la suite à droite si l'on manque de place.
  258. *PM GOTO 1000
  259. IPOS=ILON+1
  260. ENDIF
  261. ILON=IPOS-1
  262. ENDIF
  263.  
  264. * erreur si chaîne totale trop grande
  265. IF(ILON+ITOT.GT.LMAX) GOTO 1000
  266.  
  267. * sauvegarde
  268. IF (LPO) THEN
  269. ITIT1(ILON+1:ILON+ITOT)='VRAI'
  270. ELSE
  271. ITIT1(ILON+1:ILON+ITOT)='FAUX'
  272. ENDIF
  273. ILON=ILON+ITOT
  274. GOTO 1
  275.  
  276. ELSEIF(CTYP.EQ.'MOT ') THEN
  277. ITOT=IRETOU
  278.  
  279. C a-t-on un cadrage a droite ou a gauche ?
  280. IF(IDECA.EQ.1) THEN
  281. * On écrit à droite d'une colonne spécifiée
  282. IF(ILON+ITOT.GT.IPOS) THEN
  283. * on décale la suite à droite si l'on manque de place.
  284. *PM GOTO 1000
  285. IPOS=ILON+ITOT
  286. ENDIF
  287. ILON=IPOS-ITOT
  288. ELSEIF(IDECA.EQ.2) THEN
  289. * On écrit à gauche d'une colonne spécifiée
  290. IF(IPOS.LE.ILON) THEN
  291. * on décale la suite à droite si l'on manque de place.
  292. *PM GOTO 1000
  293. IPOS=ILON+1
  294. ENDIF
  295. ILON=IPOS-1
  296. ENDIF
  297.  
  298. * erreur si chaîne totale trop grande
  299. IF(ILON+ITOT.GT.LMAX) GOTO 1000
  300.  
  301. * sauvegarde
  302. ITIT1(ILON+1:ILON+ITOT)=ITXTIN(1:ITOT)
  303. ILON=ILON+ITOT
  304. GOTO 1
  305. ELSE
  306. GOTO 1020
  307. ENDIF
  308.  
  309. * Il y a eu une erreur
  310. 1000 CONTINUE
  311. * Un titre ou un texte ne peut avoir plus de 72 caractères
  312. *PM (ce qui est faux pour le texte => nouvelle erreur à écrire dans GIBI.ERREUR)
  313. CALL ERREUR(425)
  314. RETURN
  315.  
  316. 1010 CONTINUE
  317. * Erreur anormale.contactez votre support
  318. CALL ERREUR(5)
  319. RETURN
  320.  
  321. 1020 CONTINUE
  322. * Données incompatibles
  323. CALL ERREUR(21)
  324. RETURN
  325.  
  326.  
  327. * On a tout lu sans erreur
  328. * On écrit la chaîne en sortie si elle n'est pas vide
  329. 10 CONTINUE
  330. IF(ILON.EQ.0) GOTO 1000
  331. CALL ECRCHA(ITIT1(1:ILON))
  332. RETURN
  333.  
  334. END
  335.  
  336.  
  337.  
  338.  
  339.  
  340.  

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