Télécharger la plaquette Cast3M


fr en

Télécharger rempl5.eso

Retour à la liste

Numérotation des lignes : 

rempl5

  1. C REMPL5    SOURCE    JC220346  19/12/29    21:15:07     10441          
  2.       SUBROUTINE REMPL5
  3. ************************************************************************
  4. *
  5. *                             R E M P L 5
  6. *                             -----------
  7. *
  8. *     REMPLACER UN OU PLUSIEURS MOTIFS TROUVES DANS UNE CHAINE PAR
  9. *     DES CHAINES DE REMPLACEMENT
  10. *
  11. ************************************************************************
  12. *
  13.       IMPLICIT INTEGER(I-N)
  14. -INC CCASSIS
  15. -INC CCNOYAU
  16.  
  17. -INC PPARAM
  18. -INC CCOPTIO
  19. -INC SMLMOTS
  20. -INC SMTABLE
  21. *
  22.       CHARACTER*8 CTYP,CTYP2,CTYP3
  23.       CHARACTER*512 CHIN,AUX,AUX2
  24.       CHARACTER*1024 CHOUT
  25.  
  26.       EXTERNAL LONG
  27. *
  28. *     Lecture de la chaine dont on veut remplacer des portions
  29.       CALL LIRCHA(CHIN,1,LCHIN)
  30.       IF (IERR.NE.0) RETURN
  31.       CHOUT=CHIN
  32.       LCHOUT=LCHIN
  33.       LIN=LEN(CHIN)
  34.       LOUT=LEN(CHOUT)
  35. *
  36. *     Lecture du/des motifs a remplacer et des chaines de remplacement
  37.       CALL QUETYP(CTYP,0,IRETOU)
  38.       IF (IRETOU.EQ.0) THEN
  39.           CALL ERREUR(533)
  40.           RETURN
  41.       ENDIF
  42.  
  43.       IF (CTYP.EQ.'MOT') THEN
  44.           CALL LIRCHA(AUX,1,LAUX)
  45.           IF (IERR.NE.0) RETURN
  46.           CALL LIRCHA(AUX2,1,LAUX2)
  47.           IF (IERR.NE.0) RETURN
  48.           JGM=1
  49.           JGN=LAUX
  50.           SEGINI,MLMOT1
  51.           JGN=LAUX2
  52.           SEGINI,MLMOT2
  53.           MLMOT1.MOTS(1)=AUX
  54.           MLMOT2.MOTS(1)=AUX2
  55.           NMOTIF=1
  56.  
  57.       ELSEIF (CTYP.EQ.'LISTMOTS') THEN
  58.           CALL LIROBJ('LISTMOTS',IOB1,1,IRET)
  59.           IF (IERR.NE.0) RETURN
  60.           CALL LIROBJ('LISTMOTS',IOB2,1,IRET)
  61.           IF (IERR.NE.0) RETURN
  62.           MLMOT1=IOB1
  63.           MLMOT2=IOB2
  64.           SEGACT,MLMOT1,MLMOT2
  65.           NB1=MLMOT1.MOTS(/2)
  66.           NB2=MLMOT2.MOTS(/2)
  67.           IF (NB1.NE.NB2) THEN
  68.               CALL ERREUR(854)
  69.               RETURN
  70.           ENDIF
  71.           NMOTIF=NB1
  72.  
  73.       ELSEIF (CTYP.EQ.'TABLE') THEN
  74.           CALL LIROBJ('TABLE',IOB,1,IRET)
  75.           IF (IERR.NE.0) RETURN
  76.           MTAB1=IOB
  77.           SEGACT,MTAB1
  78.           NMOTIF=MTAB1.MLOTAB
  79.           NCAR1=0
  80.           NCAR2=0
  81.           IF (NBESC.NE.0) SEGACT,IPILOC
  82.           DO K=1,NMOTIF
  83.               CTYP2=MTAB1.MTABTI(K)
  84.               CTYP3=MTAB1.MTABTV(K)
  85.               IF (CTYP2.NE.'MOT'.OR.CTYP3.NE.'MOT') THEN
  86.                   CALL ERREUR(647)
  87.                   RETURN
  88.               ENDIF
  89.               IMO1=IPCHAR(MTAB1.MTABII(K))
  90.               IMO2=IPCHAR(MTAB1.MTABII(K)+1)
  91.               ILON=IMO2-IMO1
  92.               NCAR1=MAX(NCAR1,ILON)
  93.               IMO1=IPCHAR(MTAB1.MTABIV(K))
  94.               IMO2=IPCHAR(MTAB1.MTABIV(K)+1)
  95.               ILON=IMO2-IMO1
  96.               NCAR2=MAX(NCAR2,ILON)
  97.           ENDDO
  98.           JGM=NMOTIF
  99.           JGN=NCAR1
  100.           SEGINI,MLMOT1
  101.           JGN=NCAR2
  102.           SEGINI,MLMOT2
  103.           DO K=1,NMOTIF
  104.               IMO1=IPCHAR(MTAB1.MTABII(K))
  105.               IMO2=IPCHAR(MTAB1.MTABII(K)+1)
  106.               ILON=IMO2-IMO1
  107.               MLMOT1.MOTS(K)=ICHARA(IMO1:IMO1+ILON-1)
  108.               IMO1=IPCHAR(MTAB1.MTABIV(K))
  109.               IMO2=IPCHAR(MTAB1.MTABIV(K)+1)
  110.               ILON=IMO2-IMO1
  111.               MLMOT2.MOTS(K)=ICHARA(IMO1:IMO1+ILON-1)
  112.           ENDDO
  113.           SEGDES,MTAB1
  114.           IF (NBESC.NE.0) SEGDES,IPILOC
  115.       ENDIF
  116.  
  117. *     Remplacements des motifs les uns apres les autres
  118.       DO 10 K=1,NMOTIF
  119.           AUX=MLMOT1.MOTS(K)
  120.           AUX2=MLMOT2.MOTS(K)
  121.           LAUX=LONG(AUX)
  122.           LAUX2=LONG(AUX2)
  123.           LDEC=LAUX2-LAUX
  124.           IDEB=1
  125.  20       IPO=INDEX(CHOUT(IDEB:LOUT),AUX(1:LAUX))
  126.           IF (IPO.EQ.0) GOTO 10
  127.           IPO=IDEB-1+IPO
  128.           IF (LDEC.NE.0) THEN
  129.               CHOUT(IPO+LAUX2:LOUT)=CHOUT(IPO+LAUX:LOUT)
  130. C             Protection contre des remplacements trop volumineux
  131.               IF ((LCHOUT+LDEC).GT.LOUT) THEN
  132.                   CALL ERREUR(1111)
  133.                   RETURN
  134.               ENDIF
  135.               LCHOUT=LCHOUT+LDEC
  136.           ENDIF
  137.           CHOUT(IPO:IPO+LAUX2-1)=AUX2(1:LAUX2)
  138.           IDEB=IPO+LAUX2
  139.           IF (IDEB.GT.LCHOUT) GOTO 10
  140.           GOTO 20
  141.  10   CONTINUE
  142.  
  143.       IF (CTYP.EQ.'MOT'.OR.CTYP.EQ.'TABLE') SEGSUP,MLMOT1,MLMOT2
  144.       CALL ECRCHA(CHOUT(1:LIN))
  145.  
  146.       END
  147.  
  148.  
  149.  
  150.  
  151.  

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