Télécharger la plaquette Cast3M


fr en

Télécharger lirnom.eso

Retour à la liste

Numérotation des lignes : 

lirnom

  1. C LIRNOM    SOURCE    CB215821  24/07/17    21:15:09     11961          
  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.  
  307.  

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