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    PV090527  23/02/02    21:15:10     11577          
  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 = 4)
  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.  
  31. C- Lecture des mots-cles et autres options
  32.       INOCA = 0
  33.       INOCA = 0
  34.       iordre=0
  35.  10   CONTINUE
  36.         CALL LIRMOT(LICLE,NCLE,IRETOU,0)
  37.         IF (IERR.NE.0) RETURN
  38.         IF (IRETOU.EQ.1) inoca=1
  39.         IF (IRETOU.EQ.2) iordre=1
  40.         INOCA = IRETOU
  41.  
  42.  11   CONTINUE
  43.       CALL LIRREE(FLOT1,0,ICRIT)
  44.       IF (IERR.NE.0) RETURN
  45.       IF (ICRIT.NE.0) THEN
  46.         RCRIT = FLOT1
  47.       ELSE
  48.         RCRIT = 10.D0 * XZPREC
  49.       ENDIF
  50.       RCRIT = ABS(RCRIT)
  51.  
  52. C- Lecture des objets a analyser
  53.       INOBJ = 50
  54.       SEGINI,MPILO
  55.       NBOBJ = 0
  56.  20   CONTINUE
  57.         TYPI = '        '
  58.         CALL QUETYP(TYPI,0,IRETOU)
  59.         IF (IERR.NE.0) GOTO 900
  60.         IF (IRETOU.EQ.0) GOTO 21
  61.         CALL PLACE(LITYP,NTYP,IPLAC,TYPI)
  62.         IF (IPLAC.EQ.0) THEN
  63. C         ERREUR => "On ne veut pas d'objet de type %m1:8"
  64.           MOTERR(1:8) = TYPI
  65.           CALL ERREUR(39)
  66.           GOTO 900
  67.         ENDIF
  68.         CALL LIROBJ(TYPI,IPOBJ,1,IRETOU)
  69.         IF (IERR.NE.0) GOTO 900
  70.         IF (NBOBJ.GE.INOBJ) THEN
  71.           INOBJ = INOBJ + 50
  72.           SEGADJ,MPILO
  73.         ENDIF
  74.         NBOBJ = NBOBJ + 1
  75.         ITYOBJ(NBOBJ) = IPLAC
  76.         IPEOBJ(NBOBJ) = IPOBJ
  77.         IPSOBJ(NBOBJ) = IPOBJ
  78.       GOTO 20
  79.  21   CONTINUE
  80.       IF (NBOBJ.EQ.0) THEN
  81.         CALL ERREUR(533)
  82.         GOTO 900
  83.       ENDIF
  84.  
  85. C- Analyse des objets avec appel aux subroutines dediees
  86.       DO I = 1, NBOBJ
  87.         IPLAC = ITYOBJ(I)
  88.         IPOBJ = IPSOBJ(I)
  89.         IF (IPLAC.EQ.1) THEN
  90.           CALL ELIMIN2(IPOBJ)
  91.         ELSE IF (IPLAC.EQ.2) THEN
  92.           CALL ELIMIN3(IPOBJ,ICRIT,RCRIT)
  93.         ELSE IF (IPLAC.EQ.3) THEN
  94.           CALL ELIMIN4(IPOBJ,INOCA)
  95.         ELSE IF (IPLAC.EQ.4) THEN
  96.           CALL UNIQMA(IPOBJ,NBDIF,iordre)
  97.         ELSE
  98.           CALL ERREUR(5)
  99.         ENDIF
  100.         IPSOBJ(I) = IPOBJ
  101.       ENDDO
  102.  
  103. C- Ecriture des objets resultats sans doublon
  104.       DO I = NBOBJ, 1, -1
  105.         TYPI  = LITYP(ITYOBJ(I))
  106.         IPOBJ = IPSOBJ(I)
  107.         CALL ECROBJ(TYPI,IPOBJ)
  108.       ENDDO
  109.  
  110.  900  CONTINUE
  111.       SEGSUP,MPILO
  112.  
  113.       RETURN
  114.       END
  115.  
  116.  
  117.  
  118.  

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