Télécharger lirnom.eso

Retour à la liste

Numérotation des lignes :

  1. C LIRNOM SOURCE CHAT 11/05/27 21:15:24 6985
  2. C LIRNOM SOURCE CHAT 06/03/29 21:27:09 5360
  3. C
  4. C FOURNIT A LIRE UNE PHRASE ELEMENTAIRE MISE EN PILE SOUS FORME DECODEE
  5. C
  6. C DEFINITION DE LA PILE :
  7. C ITANOM( ILONG) CONTIENT LES ADRESSES DANS LA TABLE DES NOMS
  8. C DES NOMS A AFFECTER ET LEURS TYPES.
  9. C
  10. C SI ITINTE(I)=0 SIGNALE FIN DE PHRASE ELEMENTAIRE
  11. C SI ITINTE(I)=-1 SIGNALE FIN DE PHRASE COMPLETE
  12. C SI ITINTE(I)= AUTRE CHOSE DONNE LA POSITION DANS PILE DES NOMS
  13. C
  14. C AUTRES VARIABLES :
  15. C NBNOM = NOMBRE DE NOMS CONTENUS DANS ITANOM
  16. C SI NBNOM=0 LE NOM CONTENUE EST UN NOM
  17. C D'OBJET TEMPORAIRE SONT EXISTENCE EST
  18. C NON GARANTIE.
  19. C INILU =0 SIGNALE QU'IL FAUT INITIALISER LA
  20. C LECTURE PAR L'APPEL A INILIR
  21. C MBFONC = 0 ON SE TROUVE EN REPETITION D'UN BLOC
  22. C REPETER.
  23. C MBLSUP DIFFERENT DE 0 ON SE TROUVE POUR LA
  24. C PREMIERE FOIS DANS UN BLOC REPETER.
  25. SUBROUTINE LIRNOM
  26. IMPLICIT INTEGER(I-N)
  27. -INC CCREDLE
  28. -INC CCNOYAU
  29. -INC CCOPTIO
  30. -INC SMBLOC
  31. -INC CCASSIS
  32. LOGICAL IPEG
  33. sredle=iredle
  34. i100= -100
  35. * write(6,*) ' lirnom mdeobj', mdeobj
  36. IF (INILU.EQ.0) CALL INILIR
  37. IF (MBFONC.EQ.0) THEN
  38.  
  39. MBCOUR=MBCOUR+1
  40. MTXBLC=MTXBL
  41. C MTXBLL=MTXBLC(MBCOUR)
  42. C SEGACT MTXBLL
  43. C NBNOM=MTXBLB(/1)
  44. NBNOM=LMTXBM(MBCOUR+1)- LMTXBM(MBCOUR)
  45. C IPVINT=MTXBLA(/1)
  46. IPVINT=MTXBA(MBCOUR+1)-MTXBA(MBCOUR)
  47. IDEF= LMTXBM(MBCOUR)
  48. * write(6,*) ' lirnom mdeobj', mdeobj
  49. if( mbloc.eq.2120910 ) then
  50. * write(6,*)'mbcour nbnom ipvint idef ',mbcour,nbnom,ipvint,idef
  51. endif
  52. DO 103 I=1,NBNOM
  53. C ITANO1(I)=MTXBLB(I)
  54. C ITANOM(I)=MTXBLM(I)
  55. if(MTXBLB(I+IDEF).ge.0) then
  56. ITANO1(I)=MTXBLB(I+IDEF) + mdeobj - 1
  57. * if( itano1(i).eq.646) then
  58. * write(6,*) ' 646 MTXBLB(I+IDEF) mdeobj',MTXBLB(I+IDEF),mdeobj
  59. * endif
  60. else
  61. ITANO1(I)=MTXBLB(I+IDEF)/i100
  62. endif
  63. ITANOM(I)=MTXBLM(I+IDEF)
  64. 103 CONTINUE
  65. IDEF=MTXBA(MBCOUR)
  66. DO 104 I=1,IPVINT
  67. C ITINTE(I)=MTXBLA(I)
  68. if(mtxbla(i+idef).gt.0)then
  69. itinte(i)=MTXBLA(I+IDEF) + mdeobj - 1
  70. elseif( MTXBLA(I+IDEF).lt.-99) then
  71. ITINTE(I)=MTXBLA(I+IDEF)/I100
  72. * write(6,*) ' bizarrequa itinte ' , itinte(i)
  73. else
  74. ITINTE(I)=MTXBLA(I+IDEF)
  75. * write(6,*) ' bizarreter dans lirnom ' ,itinte(i)
  76. endif
  77. * if( mbloc.eq.2120910 ) then
  78. * write(6,*) ' i itinte(I) ',i ,itinte(i)
  79. * endif
  80. 104 CONTINUE
  81. C INTEMP=MTXTEM
  82. INTEMP=MTXTTM(MBCOUR)
  83. NOMLU=1
  84. ISTOP=0
  85. IINTPO=1
  86. C SEGDES MTXBLL
  87. IERR=0
  88. * write(6,*) 'lecture procedur '
  89. * write(6,*) ' itinte' , (itinte(iou),iou=1,ipvint)
  90. * write(6,*) 'inoob1',( inoob1(ITINTE(IOU)),IOU=1,IPVONT-1)
  91. * write(6,*)' itano1 itanom nbnom',itano1(1),itanom(1),nbnom
  92. RETURN
  93. ENDIF
  94. IPVIR=0
  95. * write(6,*) ' lirnom appel anasyn lmnnom', lmnnom
  96. CALL ANASYN(IPEG,IPVIR)
  97. NOMLU=1
  98. INTEMP=0
  99. NBNOM=0
  100. IINTPO=1
  101. if(ierr.ne.0) return
  102. IF (.NOT.IPEG) GO TO 20
  103. ILUL=0
  104. 1 IF (ILUL.EQ.0) CALL REDLEC(sredle)
  105. IF(IRE.EQ.0) THEN
  106. CALL ERREUR (282)
  107. RETURN
  108. ENDIF
  109. C IF(IRE.NE.3) CALL ERREUR(345)
  110. C IF(IERR.NE.0) RETURN
  111. ILUL=0
  112. IF (MOT(1:1).EQ.'=') GOTO 200
  113. IF (ITANO1(/1).GT.NBNOM) GOTO 2
  114. M=NBNOM+1
  115. SEGADJ ITABNO
  116. ITANOM(M)=' '
  117. ITANO1(M)=0
  118. 2 NBNOM=NBNOM+1
  119. IREF=NBNOM
  120. IAV=1
  121. CALL PRENOM(IPLAMO,IAV,sredle)
  122. * AFIN DE LIRE CORRECTEMENT L'INDICE D'UNE TABLE SI C'EST UNE CONSTANTE
  123. ITANO1(IREF)=IPLAMO
  124. C ON PEUT INDIQUER APRES LE TYPE DESIRE
  125. CALL REDLEC(sredle)
  126. ILUL=1
  127. IF (MOT(1:1).NE.'*') GOTO 4
  128. CALL REDLEC(sredle)
  129. IF (MOT(1:1).EQ.'=') THEN
  130. ITANOM(IREF)=' '
  131. ELSE
  132. ITANOM(IREF)=MOT(:8)
  133. ILUL=0
  134. ENDIF
  135. GOTO 1
  136. 4 CONTINUE
  137. ITANOM(IREF)=' '
  138. GO TO 1
  139. C ON CREE UN NOM D'OBJET TEMPORAIRE
  140. 20 CONTINUE
  141. INTEMP=1
  142. IF (ITANOM(/2).LT.1) THEN
  143. M=1
  144. SEGADJ ITABNO
  145. ENDIF
  146. ITANO1(1)=0
  147. ITANOM(1)=' '
  148. NBNOM=1
  149. MOT(1:8)='# '
  150. IF (IPTEM.LT.9) THEN
  151. WRITE (MOT(2:2),FMT='(I1)') IPTEM+1
  152. NCAR=2
  153. ELSE
  154. IF(IPTEM.EQ.99) CALL ERREUR(10)
  155. IF(IERR.NE.0) RETURN
  156. WRITE (MOT(2:3),FMT='(I2)') IPTEM+1
  157. NCAR=3
  158. ENDIF
  159. IRE=3
  160. IAV=1
  161. * write(6,*) ' appel de prenom avec nom temporaire'
  162. CALL PRENOM(IPLAMO,IAV,sredle)
  163. ITANO1(1)= IPLAMO
  164. IPTEM=IPTEM+1
  165. 200 CONTINUE
  166. IPVINT=0
  167. C
  168. C ON VA TRADUIRE LA PHRASE POUR REMPLIR LE TABLEAU INTERMEDIAIRE
  169. C
  170. IF (MBLSUP.NE.0) THEN
  171. MTXBLC=MTXBL
  172. SEGACT MTXBLC*MOD
  173. ENDIF
  174. 21 CONTINUE
  175. ** write(6,*) ' lirnom appel de redlec '
  176. CALL REDLEC(sredle)
  177. * write(6,*) ' lirnom sortie de redlec ire' , ire
  178. C IRE = 0 FIN DE PHRASE
  179. C METTRE ICI LE SAUVETAGE DE LA PRECOMPILATION DANS LE CAS D'UN BLOC
  180. C
  181. IF (IRE.EQ.0) THEN
  182. IF(ITINTE(/1).LE.IPVINT) THEN
  183. ITINTE(**)=0
  184. ENDIF
  185. IPVINT=IPVINT+1
  186. ITINTE(IPVINT)=0
  187. IF(IPVIR.EQ.1) ITINTE(IPVINT)=-(IPTEM + 1)
  188. C ON EFFACE LA LIGNE (A PARTIR DE = )
  189. I1=IEGAL
  190. I2=ICOUR-1
  191. DO 7778 II3=I1,I2
  192. TEXT(II3:II3)=' '
  193. 7778 CONTINUE
  194. IF (INTEMP.NE.0) THEN
  195. IF (ICOUR.LE.2) then
  196. RETURN
  197. endif
  198. if(nbesc.ne.0) segact ipiloc
  199. INCHA=INOOB1(ITANO1(1))
  200. IDEBCH=IPCHAR(INCHA)
  201. IFINCH= IPCHAR(INCHA+1)-1
  202. TEXT(ICOUR-2:ICOUR)= ICHARA(IDEBCH:IFINCH)
  203. if(nbesc.ne.0) segdes ipiloc
  204. ENDIF
  205. IF(MBLSUP.NE.0) THEN
  206. NINSTV=NINSTV+1
  207. IPVINQ=MTXBA(NINSTV)+IPVINT
  208. IPVINN=MTXBLA(/1)
  209. NINST=LMTXBM(/1)
  210. NBNOMM=MTXBLB(/1)
  211. NBNOML=LMTXBM(NINSTV)+NBNOM
  212. ISEG=0
  213. IF(NINSTV+2.GT.NINST) THEN
  214. NINST= NINST+ 1000
  215. ISEG=1
  216. ENDIF
  217. IF(IPVINQ.GT.IPVINN) THEN
  218. IPVINN=IPVINN+5000
  219. ISEG=1
  220. ENDIF
  221. IF(NBNOML.GT.NBNOMM) THEN
  222. NBNOMM = NBNOMM + 1000
  223. ISEG=1
  224. ENDIF
  225. IF(ISEG.EQ.1) SEGADJ MTXBLC
  226.  
  227. C SEGINI MTXBLL
  228. C MTXTEM=INTEMP
  229. MTXTTM(NINSTV)=INTEMP
  230. C NUINST=NBCART
  231. C NUINSV(NINSTV)=NBCART
  232. IDEF= LMTXBM(NINSTV)
  233. * write(6,*) ' nbnom ',nbnom
  234. DO 102 I=1,NBNOM
  235. C MTXBLM(I)=ITANOM(I)
  236. C MTXBLB(I)=ITANO1(I)
  237. MTXBLM(I+IDEF)=ITANOM(I)
  238. if(itano1(i). ge.mdeobj) then
  239. MTXBLB(I+IDEF)=ITANO1(I) - mdeobj + 1
  240. else
  241. MTXBLB(I+IDEF)=ITANO1(I) *I100
  242. endif
  243. 102 CONTINUE
  244. LMTXBM(NINSTV+1)=IDEF+NBNOM
  245. IDEF=MTXBA(NINSTV)
  246. DO 101 I=1,IPVINT
  247. C MTXBLA(I)=ITINTE(I)
  248. if( itinte(i).ge.mdeobj) then
  249. * write(6,*) ' ecriture normal itinte(i) ', itinte(i)
  250. MTXBLA(I+IDEF)=ITINTE(I) - mdeobj + 1
  251. elseif( itinte(i).gt.0) then
  252. * write(6,*) ' on passe bizarre dans lirnom ' ,itinte(I)
  253. MTXBLA(I+IDEF)=ITINTE(I)* I100
  254. else
  255. * write(6,*) ' bizarrebis dans lirnom itinte(i) ',itinte(i)
  256. MTXBLA(I+IDEF)=ITINTE(I)
  257. endif
  258. 101 CONTINUE
  259. * write(6,*)' enr proc mdeobj ',mdeobj
  260. * write(6,*) 'itinte',(itinte(iou),iou=1,ipvint)
  261. * WRITE(6,*)'INOOB1', (INOOB1(ITINTE(IOU)),IOU=1,IPVINT-1)
  262. * write(6,*)'itano1,itanom,nbnom',itano1(1),itanom(1),nbnom
  263. MTXBA(NINSTV+1)= IDEF+IPVINT
  264. C MTXBLC(**)=MTXBLL
  265. C SEGDES MTXBLL
  266. ENDIF
  267. RETURN
  268. ENDIF
  269. C IF(IDEBPR.EQ.1.OR.JARGMT.EQ.1) THEN
  270. C IF(IRE.NE.3.AND.IRE.NE.4) THEN
  271. C CALL ERREUR (6)
  272. C ENDIF
  273. C IRE=4
  274. C ENDIF
  275. IAV=0
  276. * write(6,*) ' lirnom appel de prenom 2 iav 0'
  277. CALL PRENOM(IPLAMO,IAV,sredle)
  278. * write(6,*) ' lirnom appel de prenom 2 iplamo' ,iplamo
  279. * write(6,*) ' inoob1 inoob2 ',inoob1(iplamo),inoob2(iplamo)
  280. IPLINT=ITINTE(/1)
  281. IF(IPVINT.GE.IPLINT) THEN
  282. ITINTE(**)=IPLAMO
  283. ELSE
  284. ITINTE(IPVINT+1)=IPLAMO
  285. ENDIF
  286. * if( iplamo.lt.mdeobj.and.iplamo.gt.0) then
  287. * write(6,*) ' bizarre ',ire,iplamo ,text(1:62)
  288. * endif
  289. IPVINT=IPVINT+1
  290. GO TO 21
  291. END
  292.  
  293.  
  294.  
  295.  
  296.  

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