Télécharger anno.eso

Retour à la liste

Numérotation des lignes :

  1. C ANNO SOURCE JC220346 19/12/31 21:15:01 10442
  2. C***********************************************************************
  3. C NOM : ANNO
  4. C DESCRIPTION : Cree des objets de type ANNOTATI
  5. C***********************************************************************
  6. SUBROUTINE ANNO
  7.  
  8. IMPLICIT INTEGER(I-N)
  9. IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11.  
  12. -INC PPARAM
  13. -INC CCOPTIO
  14. -INC CCGEOME
  15. -INC SMANNOT
  16. -INC SMCOORD
  17.  
  18. CHARACTER*4 CHA4
  19. CHARACTER*8 CHA8
  20. CHARACTER*70 CH70,TXT
  21. LOGICAL BOOL
  22.  
  23. PARAMETER (NCLE=2)
  24. CHARACTER*4 MCLE(NCLE)
  25. DATA MCLE/'CATE','ETIQ'/
  26.  
  27. PARAMETER (NPOS=9)
  28. CHARACTER*4 MPOS(NPOS)
  29. DATA MPOS/'SO','S','SE','O','C','E','NO','N','NE'/
  30.  
  31.  
  32. C BRANCHEMENT VERS LE SOUS-TYPE DEMANDE
  33. CHA4 = ' '
  34. CALL LIRCHA(CHA4,0,ICLE)
  35. IF (ICLE.GT.0) CALL PLACE(MCLE,NCLE,ICLE,CHA4)
  36. IF (ICLE.EQ.0) THEN
  37. MOTERR(1:4) = CHA4
  38. MOTERR(5:40) = 'CATE ETIQ'
  39. CALL ERREUR(1052)
  40. ENDIF
  41. GOTO (100,200),ICLE
  42.  
  43.  
  44.  
  45. C **************************************************************
  46. C CREATION D'UNE ENTREE DE LEGENDE DE TYPE "CATEGORIE"
  47. C **************************************************************
  48.  
  49. 100 CONTINUE
  50. KTXTD = 0
  51. KCLRD = 0
  52.  
  53. * on veut obligatoirement lire un texte quelconque et une couleur,
  54. * dans n'importe quel ordre
  55. 101 CONTINUE
  56. CALL LIRCHA(CH70,1,LCHA)
  57. IF (IERR.NE.0) RETURN
  58.  
  59. IF (LCHA.LE.4) THEN
  60. CALL PLACE(NCOUL,NBCOUL,ICOUL1,CH70(1:LCHA))
  61. IF (ICOUL1.NE.0) THEN
  62. * CHOIX ARBITRAIRE
  63. * si on trouve deux mots correspondant a des couleurs,
  64. * c'est le premier qui est pris comme texte de la categorie
  65. IF (KCLRD.EQ.1) THEN
  66. TXT = NCOUL(ICOUL)
  67. KTXTD = 1
  68. ELSE
  69. ICOUL = ICOUL1
  70. KCLRD = 1
  71. ENDIF
  72. ENDIF
  73. ELSE
  74. IF (KTXTD.EQ.1) THEN
  75. MOTERR(1:4) = CH70(1:4)
  76. CALL ERREUR(1055)
  77. RETURN
  78. ELSE
  79. TXT = CH70(1:LCHA)
  80. KTXTD = 1
  81. ENDIF
  82. ENDIF
  83.  
  84. IF (KTXTD.EQ.0.OR.KCLRD.EQ.0) GOTO 101
  85.  
  86. SEGINI,MCATE1
  87. MCATE1.ICLRC = ICOUL - 1
  88. MCATE1.TXCAT = TXT
  89.  
  90. ICLAS1 = 1
  91. ISEGT1 = MCATE1
  92. GOTO 9000
  93.  
  94.  
  95. C **************************************************************
  96. C CREATION D'UNE ETIQUETTE
  97. C **************************************************************
  98.  
  99. 200 CONTINUE
  100.  
  101. IPOS=9
  102. ICOUL=IDCOUL
  103. DIS=0.D0
  104. BOOL=.TRUE.
  105. INUM=0
  106.  
  107. ILOOP=0
  108. KPOSD=0
  109. KCLRD=0
  110. KTXTD=0
  111.  
  112. * les seuls arguments obligatoires sont un POINT et un MOT
  113. * on peut lire en option un MOT pour la couleur et un autre MOT
  114. * pour la position
  115. * on peut aussi lire en option un FLOTTANT et un LOGIQUE
  116. * tous ces objets peuvent etre specifies DANS N'IMPORTE QUEL ORDRE
  117. 201 CONTINUE
  118. ILOOP=ILOOP+1
  119.  
  120. CALL QUETYP(CHA8,0,IRET)
  121. IF (IRET.EQ.0) GOTO 299
  122.  
  123. IF (CHA8.EQ.'MOT') THEN
  124. CALL LIRCHA(CH70,1,LCHA)
  125. IF (IERR.NE.0) RETURN
  126. IF (LCHA.LE.4) THEN
  127. CALL PLACE(MPOS,NPOS,IPOS1,CH70(1:LCHA))
  128. IF (IPOS1.NE.0) THEN
  129. IPOS2 = IPOS1
  130. KPOSD = ILOOP
  131. GOTO 201
  132. ENDIF
  133. CALL PLACE(NCOUL,NBCOUL,ICOUL1,CH70(1:4))
  134. IF (ICOUL1.NE.0) THEN
  135. ICOUL2 = ICOUL1
  136. KCLRD = ILOOP
  137. GOTO 201
  138. ENDIF
  139. ENDIF
  140. TXT = CH70(1:LCHA)
  141. KTXTD = ILOOP
  142. ELSEIF (CHA8.EQ.'FLOTTANT') THEN
  143. CALL LIRREE(DIS,1,IRET)
  144. IF (IERR.NE.0) RETURN
  145. ELSEIF (CHA8.EQ.'POINT') THEN
  146. CALL LIROBJ('POINT',INUM,1,IRET)
  147. IF (IERR.NE.0) RETURN
  148. ELSEIF (CHA8.EQ.'LOGIQUE') THEN
  149. CALL LIRLOG(BOOL,1,IRET)
  150. IF (IERR.NE.0) RETURN
  151. ENDIF
  152.  
  153. GOTO 201
  154.  
  155. 299 CONTINUE
  156.  
  157. IF (INUM.EQ.0) THEN
  158. MOTERR(1:8) = 'POINT'
  159. CALL ERREUR(37)
  160. RETURN
  161. ENDIF
  162.  
  163. IF (KTXTD.GT.0) THEN
  164. IF (KPOSD.GT.0) IPOS=IPOS2
  165. IF (KCLRD.GT.0) ICOUL=ICOUL2 - 1
  166.  
  167. * si le texte n'est pas defini mais que la position ou la couleur
  168. * l'est, c'est parce que l'utilisateur voulait peut-etre afficher
  169. * un mot tel que 'ROUG', 'VERT', 'SE', 'C'...
  170. ELSE
  171. IF (KPOSD.GT.0.OR.KCLRD.GT.0) THEN
  172. * CHOIX ARBITRAIRE
  173. * on utilise le mot (definissant la couleur ou la position)
  174. * apparaissant en premier dans l'instruction pour definir
  175. * le texte (la couleur/position reprend alors sa valeur
  176. * par defaut)
  177. IF (KPOSD.LT.KCLRD) THEN
  178. TXT = MPOS(IPOS2)
  179. ICOUL = ICOUL2 - 1
  180. ELSE
  181. TXT = NCOUL(ICOUL2)
  182. IPOS = IPOS2
  183. ENDIF
  184. ELSE
  185. MOTERR(1:8) = 'MOT'
  186. CALL ERREUR(37)
  187. RETURN
  188. ENDIF
  189. ENDIF
  190.  
  191. SEGINI,METIQ1
  192. METIQ1.INUPT = INUM
  193. METIQ1.ICLRE = ICOUL
  194. METIQ1.KPOSI = IPOS
  195. METIQ1.DEPOR = DIS
  196. METIQ1.BLIEN = BOOL
  197. METIQ1.TXETI = TXT
  198.  
  199. ICLAS1 = 2
  200. ISEGT1 = METIQ1
  201. GOTO 9000
  202.  
  203.  
  204. C **************************************************************
  205. C CREATION DE L'OBJET ANNOTATION
  206. C **************************************************************
  207.  
  208. 9000 CONTINUE
  209.  
  210. NBANNO = 1
  211. SEGINI,MANNO1
  212. MANNO1.ICLAS(1) = ICLAS1
  213. MANNO1.ISEGT(1) = ISEGT1
  214.  
  215. CALL ECROBJ('ANNOTATI',MANNO1)
  216.  
  217.  
  218. END
  219.  
  220.  
  221.  
  222.  

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