Télécharger la plaquette Cast3M


fr en

Télécharger unique.eso

Retour à la liste

Numérotation des lignes : 

unique

  1. C UNIQUE    SOURCE    SP204843  26/07/30    21:15:10     12612          
  2.  
  3. C=======================================================================
  4. C=======================================================================
  5.       SUBROUTINE UNIQUE
  6.  
  7.       IMPLICIT INTEGER(I-N)
  8.       IMPLICIT REAL*8 (A-H,O-Z)
  9.  
  10.  
  11. -INC PPARAM
  12. -INC CCOPTIO
  13. -INC CCREEL
  14.  
  15.       SEGMENT MPILO
  16.         INTEGER ITYOBJ(INOBJ)
  17.         INTEGER IPEOBJ(INOBJ)
  18.         INTEGER IPSOBJ(INOBJ)
  19.       ENDSEGMENT
  20.  
  21.       PARAMETER (NCLE = 2, NTYP = 5)
  22.  
  23.       CHARACTER*4 LICLE(NCLE)
  24.       CHARACTER*8 LITYP(NTYP)
  25.  
  26.       CHARACTER*8 TYPI
  27.  
  28.       DATA LICLE / 'NOCA','ORDO'/
  29.       DATA LITYP / 'LISTENTI','LISTREEL','LISTMOTS','MAILLAGE',
  30.      &             'LISTOBJE' /
  31.  
  32. C- Lecture des mots-cles et autres options
  33.       INOCA = 0
  34.       INOCA = 0
  35.       iordre=0
  36.  10   CONTINUE
  37.         CALL LIRMOT(LICLE,NCLE,IRETOU,0)
  38.         IF (IERR.NE.0) RETURN
  39.         IF (IRETOU.EQ.1) inoca=1
  40.         IF (IRETOU.EQ.2) iordre=1
  41.         INOCA = IRETOU
  42.  
  43.  11   CONTINUE
  44.       CALL LIRREE(FLOT1,0,ICRIT)
  45.       IF (IERR.NE.0) RETURN
  46.       IF (ICRIT.NE.0) THEN
  47.         RCRIT = FLOT1
  48.       ELSE
  49.         RCRIT = 10.D0 * XZPREC
  50.       ENDIF
  51.       RCRIT = ABS(RCRIT)
  52.  
  53. C- Lecture des objets a analyser
  54.       INOBJ = 50
  55.       SEGINI,MPILO
  56.       NBOBJ = 0
  57.  20   CONTINUE
  58.         TYPI = '        '
  59.         CALL QUETYP(TYPI,0,IRETOU)
  60.         IF (IERR.NE.0) GOTO 900
  61.         IF (IRETOU.EQ.0) GOTO 21
  62.         CALL PLACE(LITYP,NTYP,IPLAC,TYPI)
  63.         IF (IPLAC.EQ.0) THEN
  64. C         ERREUR => "On ne veut pas d'objet de type %m1:8"
  65.           MOTERR(1:8) = TYPI
  66.           CALL ERREUR(39)
  67.           GOTO 900
  68.         ENDIF
  69.         CALL LIROBJ(TYPI,IPOBJ,1,IRETOU)
  70.         IF (IERR.NE.0) GOTO 900
  71.         IF (NBOBJ.GE.INOBJ) THEN
  72.           INOBJ = INOBJ + 50
  73.           SEGADJ,MPILO
  74.         ENDIF
  75.         NBOBJ = NBOBJ + 1
  76.         ITYOBJ(NBOBJ) = IPLAC
  77.         IPEOBJ(NBOBJ) = IPOBJ
  78.         IPSOBJ(NBOBJ) = IPOBJ
  79.       GOTO 20
  80.  21   CONTINUE
  81.       IF (NBOBJ.EQ.0) THEN
  82.         CALL ERREUR(533)
  83.         GOTO 900
  84.       ENDIF
  85.  
  86. C- Analyse des objets avec appel aux subroutines dediees
  87.       DO I = 1, NBOBJ
  88.         IPLAC = ITYOBJ(I)
  89.         IPOBJ = IPSOBJ(I)
  90.         IF (IPLAC.EQ.1) THEN
  91.           CALL ELIMIN2(IPOBJ)
  92.         ELSE IF (IPLAC.EQ.2) THEN
  93.           CALL ELIMIN3(IPOBJ,ICRIT,RCRIT)
  94.         ELSE IF (IPLAC.EQ.3) THEN
  95.           CALL ELIMIN4(IPOBJ,INOCA)
  96.         ELSE IF (IPLAC.EQ.4) THEN
  97.           CALL UNIQMA(IPOBJ,NBDIF,iordre)
  98.         ELSE IF (IPLAC.EQ.5) THEN
  99.           CALL ELIMIN5(IPOBJ,ICRIT,RCRIT)
  100.         ELSE
  101.           CALL ERREUR(5)
  102.         ENDIF
  103.         IPSOBJ(I) = IPOBJ
  104.       ENDDO
  105.  
  106. C- Ecriture des objets resultats sans doublon
  107.       DO I = NBOBJ, 1, -1
  108.         TYPI  = LITYP(ITYOBJ(I))
  109.         IPOBJ = IPSOBJ(I)
  110.         CALL ECROBJ(TYPI,IPOBJ)
  111.       ENDDO
  112.  
  113.  900  CONTINUE
  114.       SEGSUP,MPILO
  115.  
  116.       RETURN
  117.       END
  118.  
  119.  
  120.  
  121.  
  122.  

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