Télécharger lirnom.eso

Retour à la liste

Numérotation des lignes :

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

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