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

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