Télécharger la plaquette Cast3M


fr en

Télécharger sauf.eso

Retour à la liste

Numérotation des lignes : 

sauf

  1. C SAUF      SOURCE    JC220346  14/12/09    21:15:11     8315
  2.       SUBROUTINE SAUF
  3. C
  4. C
  5. C     CET OPERATEUR ENLEVE AU SEGMENT LECT1(RESP. MLREE1) LES ELEMENTS
  6. C     DU SEGMENT LECT2(RESP. MLREE2) ET LES MET DANS MLENTI(RESP.MLREEL)
  7. C
  8.       IMPLICIT INTEGER(I-N)
  9.       IMPLICIT REAL*8(A-H,O-Z)
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC SMLENTI
  14. -INC SMLREEL
  15. -INC SMLMOTS
  16.  
  17.       PARAMETER (NCLE = 1)
  18.       CHARACTER*4 LICLE(NCLE)
  19.       DATA LICLE / 'NOCA' /
  20.  
  21.       CHARACTER*4  CAR1,CAR2
  22.       CHARACTER*26 MINUSC,MAJUSC
  23.       DATA MINUSC / 'abcdefghijklmnopqrstuvwxyz' /
  24.       DATA MAJUSC / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
  25.  
  26. *      MOT-CLE NOCA
  27.        INOCA = 0
  28.   500  CONTINUE
  29.          CALL LIRMOT(LICLE,NCLE,IMOT,0)
  30.          IF (IERR.NE.0) RETURN
  31.          IF (IMOT.EQ.1) THEN
  32.             INOCA = 1
  33.             GOTO 500
  34.          ENDIF
  35.  
  36. *      PRECISION POUR TEST SUR LISTREEL
  37.        CALL LIRREE(RCRIT,0,ICRIT)
  38.        IF (IERR.NE.0) RETURN
  39.        IF (ICRIT.NE.0) RCRIT=ABS(RCRIT)
  40.  
  41.  
  42. C
  43. C  **** OPERATION SUR MLENTI
  44. C
  45.       CALL LIROBJ('LISTENTI',MLENT1,0,IRETOU)
  46.       IF(IRETOU.EQ.0) GO TO 10
  47.       SEGACT MLENT1
  48.       N1=MLENT1.LECT(/1)
  49.  
  50.       CALL LIROBJ('LISTENTI',MLENT2,1,IRETOU)
  51.       IF(IERR.NE.0) RETURN
  52.  
  53.       JG=N1
  54.       SEGINI MLENTI
  55.       IF(N1.EQ.0) GO TO 4901
  56.  
  57.       SEGACT MLENT2
  58.       N2=MLENT2.LECT(/1)
  59.  
  60.       JG=0
  61.       DO 1 I=1,N1
  62.       IF(N2.EQ.0) GO TO 3
  63.       DO 2 J=1,N2
  64.       IF(MLENT1.LECT(I).EQ.MLENT2.LECT(J)) GO TO 1
  65.  2    CONTINUE
  66.  3    CONTINUE
  67.       JG=JG+1
  68.       LECT(JG)=MLENT1.LECT(I)
  69.  1    CONTINUE
  70.       SEGADJ MLENTI
  71.       SEGDES MLENT2
  72.  
  73.  4901 CONTINUE
  74.       SEGDES MLENT1
  75.       CALL ECROBJ('LISTENTI',MLENTI)
  76.       SEGDES MLENTI
  77.       GO TO 5000
  78. C
  79. C  **** OPERATION SUR DES MLREEL
  80. C
  81.  10   CONTINUE
  82.  
  83.       CALL LIROBJ('LISTREEL',MLREE1,0,IRETOU)
  84.       IF(IRETOU.EQ.0) GO TO 100
  85.       SEGACT MLREE1
  86.       N1=MLREE1.PROG(/1)
  87.  
  88.       CALL LIROBJ('LISTREEL',MLREE2,1,IRETOU)
  89.       IF(IERR.NE.0)RETURN
  90.  
  91.       JG=N1
  92.       SEGINI MLREEL
  93.       IF(N1.EQ.0) GO TO 4902
  94.  
  95.       SEGACT MLREE2
  96.       N2=MLREE2.PROG(/1)
  97.  
  98.       JG=0
  99.       IF (ICRIT.EQ.0) THEN
  100.           DO 11 I=1,N1
  101.           IF(N2.EQ.0) GO TO 13
  102.           DO 12 J=1,N2
  103.           IF(MLREE1.PROG(I).EQ.MLREE2.PROG(J)) GO TO 11
  104.  12       CONTINUE
  105.  13       CONTINUE
  106.           JG=JG+1
  107.           PROG(JG)=MLREE1.PROG(I)
  108.  11       CONTINUE
  109.       ELSE
  110.           DO 14 I=1,N1
  111.           IF(N2.EQ.0) GO TO 16
  112.           DO 15 J=1,N2
  113.           IF (ABS(MLREE1.PROG(I)-MLREE2.PROG(J)).LT.RCRIT) GO TO 14
  114.  15       CONTINUE
  115.  16       CONTINUE
  116.           JG=JG+1
  117.           PROG(JG)=MLREE1.PROG(I)
  118.  14       CONTINUE
  119.       ENDIF
  120.       SEGADJ MLREEL
  121.       SEGDES MLREE2
  122.  
  123.  4902 CONTINUE
  124.       SEGDES MLREE1
  125.       CALL ECROBJ('LISTREEL',MLREEL)
  126.       SEGDES MLREEL
  127.       GO TO 5000
  128. C
  129. C  **** OPERATION SUR DES MLMOTS
  130. C
  131.  100  CONTINUE
  132.  
  133.       CALL LIROBJ('LISTMOTS',MLMOT1,0,IRETOU)
  134.       IF(IRETOU.EQ.0) GO TO 20
  135.       SEGACT MLMOT1
  136.       N1=MLMOT1.MOTS(/2)
  137.  
  138.       CALL LIROBJ('LISTMOTS',MLMOT2,1,IRETOU)
  139.       IF(IERR.NE.0)RETURN
  140.  
  141.       JGN=4
  142.       JGM=N1
  143.       SEGINI MLMOTS
  144.       IF (N1.EQ.0) GO TO 4903
  145.  
  146.       SEGACT MLMOT2
  147.       N2=MLMOT2.MOTS(/2)
  148.  
  149.       JGM=0
  150.       IF (INOCA.EQ.1) THEN
  151.           JGN1=MLMOT1.MOTS(/1)
  152.           JGN2=MLMOT2.MOTS(/1)
  153.  
  154.           DO 111 I=1,N1
  155.           IF(N2.EQ.0) GO TO 113
  156. *         Passage en majuscules pour MLMOT1
  157.           CAR1=MLMOT1.MOTS(I)
  158.           DO K=1,JGN1
  159.             ICAR = INDEX(MINUSC,CAR1(K:K))
  160.             IF (ICAR.NE.0) CAR1(K:K) = MAJUSC(ICAR:ICAR)
  161.           ENDDO
  162.           DO 112 J=1,N2
  163. *         Passage en majuscules pour MLMOT2
  164.           CAR2=MLMOT2.MOTS(J)
  165.           DO K=1,JGN2
  166.             ICAR = INDEX(MINUSC,CAR2(K:K))
  167.             IF (ICAR.NE.0) CAR2(K:K) = MAJUSC(ICAR:ICAR)
  168.           ENDDO
  169.           IF(CAR1.EQ.CAR2) GO TO 111
  170.  112      CONTINUE
  171.  113      CONTINUE
  172.           JGM=JGM+1
  173.           MOTS(JGM)=MLMOT1.MOTS(I)
  174.  111      CONTINUE
  175.       ELSE
  176.           DO 114 I=1,N1
  177.           IF(N2.EQ.0) GO TO 116
  178.           DO 115 J=1,N2
  179.           IF(MLMOT1.MOTS(I).EQ.MLMOT2.MOTS(J)) GO TO 114
  180.  115      CONTINUE
  181.  116      CONTINUE
  182.           JGM=JGM+1
  183.           MOTS(JGM)=MLMOT1.MOTS(I)
  184.  114      CONTINUE
  185.       ENDIF
  186.  
  187.       SEGADJ MLMOTS
  188.       SEGDES MLMOT2
  189.  
  190.  4903 CONTINUE
  191.       SEGDES MLMOT1
  192.       CALL ECROBJ('LISTMOTS',MLMOTS)
  193.       SEGDES MLMOTS
  194.  
  195.  5000 CONTINUE
  196.       RETURN
  197. C
  198. C    PAS D OPERANDE CORRECTE TROUVE
  199. C
  200.  20   CALL QUETYP(MOTERR(1:8),0,IRETOU)
  201.       IF(IRETOU.NE.0) THEN
  202.          CALL ERREUR (39)
  203.       ELSE
  204.          CALL ERREUR(533)
  205.       ENDIF
  206.       RETURN
  207.       END
  208.  
  209.  
  210.  

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