Télécharger quepoi.eso

Retour à la liste

quepoi
C QUEPOI    SOURCE    CB215821  20/11/25    13:38:08     10792          
      SUBROUTINE QUEPOI(ICHP1,IPSG,INDIC,NBCOMP,NOMTOT)
C-----------------------------------------------------------------------
C On teste le champoint ICHP1 afin de vérifier :
C   1) qu'il est non partitionné
C   2) qu'il a le bon nombre de composantes et/ou les bonnes composantes
C   3) que son support géométrique est IPSG
C Si INDIC vaut 1 en entrée, on modifie, si besoin, l'ordonnencement
C des infos du CHPO afin d'imposer le SPG de pointeur IPSG. Si INDIC
C vaut 0, des supports différents générent INDIC=-4 mais on n'imprime
C pas de message d'erreur.
C-----------------------------------------------------------------------
C
C---------------------------
C Parametres Entree/Sortie :
C---------------------------
C
C E/  ICHP1  : Champoint à tester
C E/  IPSG   : Maillage de référence, en général de type POI1
C E/S INDIC  : En entrée,
C                  0 On ne fait que vérifier le support géométrique,
C                  1 On impose le pointeur du support géométrique.
C              En sortie,
C                 -4 si les spgs sont différents (points différents),
C                 -3 si le nom des composantes sont incorrects,
C                 -2 si le nombre de composantes est incorrect,
C                 -1 si le champoint est partitionné,
C                  0 si les spgs sont identiques,
C                  1 si les points sont identiques.
C E/S NBCOMP : En entrée,
C                 >0 si on teste le nombre de compoantes,
C                  0 si on veut recuperer les noms de composantes,
C                 -1 si on ne veut faire aucun test.
C              En sortie,
C                 nombre de composantes du CHPO.
C E/S NOMTOT : En entrée,
C                 noms des composantes à tester (si NBCOMP > 0),
C                 remplir NOMTOT(1)='    ' dans l'appelant sinon.
C              En sortie,
C                 noms des composantes du CHPO (si NBCOMP = 0),
C                 non rempli sinon.
C
C-----------------------------------------------------------------------
C ATTENTION: TOUJOURS initialiser NOMTOT(dim) dans le prg appelant
C                   (dim=1 si NBCOMP=0, dim=NBCOMP sinon)
C-----------------------------------------------------------------------
C
C Langage : ESOPE + FORTRAN77
C
C Auteurs : F.AURIOL 09/93
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
      CHARACTER*(*) NOMTOT(*)
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCHPOI
-INC SMCOORD
      SEGMENT IBEXIS
            INTEGER IEXIS(NBPTS)
      ENDSEGMENT
C
      ININI = INDIC
C
C- Test si le CHPO est partitionné
C
      MCHPOI = ICHP1
      SEGACT MCHPOI
      NSOUPO = IPCHP(/1)
      IF (NSOUPO.NE.1) THEN
         INDIC = -1
         MOTERR(1:8) = 'CHAMPOIN'
         CALL ERREUR(132)
         RETURN
      ENDIF
C
C- Test/Récupération du nom des composantes
C
      MSOUPO = IPCHP(1)
      SEGACT MSOUPO
      NBCOM1 = NBCOMP
      NBCOMP = NOCOMP(/2)
      IF (NBCOM1.GT.-1) THEN
         IF (NBCOM1.EQ.0) THEN
            DO 5 ICOMP=1,NBCOMP
               NOMTOT(ICOMP) = NOCOMP(ICOMP)
 5          CONTINUE
         ELSE
            IF (NBCOM1.NE.NBCOMP) THEN
               INDIC = -2
               MOTERR(1:8)  = ' QUEPOI '
               MOTERR(9:16) = 'CHAMPOIN'
               INTERR(1)   = NBCOM1
               INTERR(2)   = NBCOMP
               CALL ERREUR(699)
               RETURN
            ENDIF
            IF (NOMTOT(1).NE.'    ') THEN
               DO 10 ICOMP=1,NBCOMP
                  CALL PLACE(NOMTOT,NBCOMP,IPOS,NOCOMP(ICOMP))
                  IF (IPOS.EQ.0) THEN
                     INDIC = -3
                     MOTERR= NOCOMP(ICOMP)
                     CALL ERREUR(197)
                     RETURN
                  ENDIF
 10            CONTINUE
            ENDIF
         ENDIF
      ENDIF
C
C- Récupération des infos du MSOUPO utilisées
C
      IPT2   = IGEOC
      MPOVAL = IPOVAL
C
C- Transforme le maillage en POI1 si maillage quelconque
C- Le maillage POI1 de pointeur IPT1 est actif au retour de CHANGE
C
      MELEME = IPSG
      SEGACT MELEME
      IPT1   = MELEME
      NBSOUS = LISOUS(/1)
      IF ((NBSOUS.NE.0).OR.(ITYPEL.NE.1)) THEN
         CALL CHANGE(IPT1,1)
         IF (IERR.NE.0) RETURN
      ENDIF
C
C- Si égalité des pointeurs INDIC=0
C
      IF (IPT2.EQ.IPT1) THEN
         INDIC = 0
         RETURN
      ENDIF
C
C- Dans le cas d'un MELEME de POI1 création d'un CHPO de support
C- géométrique le POI1 en question.
C
      IF (ININI.EQ.1) THEN
         N  = IPT1.NUM(/2)
         NC = NBCOMP
         SEGINI MPOVA1
      ENDIF
C
C- Recherche si les points du MELEME de type POI1 sont dans le CHPO
C- et ordonnencement si INDIC=1
C
      NUMPT1 = IPT1.NUM(/2)
      SEGACT IPT2
      NUMPT2 = IPT2.NUM(/2)
      IF (NUMPT1.NE.NUMPT2) GOTO 110
      SEGINI IBEXIS
      DO 20 IEL=1,NBPTS
           IEXIS(IEL)=0
 20   CONTINUE
      DO 30 IEL=1,NUMPT1
           NOE = IPT1.NUM(1,IEL)
           IEXIS(NOE)=IEL
 30   CONTINUE
      IF (ININI.NE.1) THEN
            DO 15 IP=1,NUMPT2
               NOE=IPT2.NUM(1,IP)
               IF(IEXIS(NOE).EQ.0)GO TO 110
 15         CONTINUE
      ELSE
         SEGACT MPOVAL
            DO 60 IP=1,NUMPT2
               NOE=IPT2.NUM(1,IP)
               IEL=IEXIS(NOE)
               IF(IEL.EQ.0)GO TO 110
                  DO 50 NC1=1,NC
                     MPOVA1.VPOCHA(IEL,NC1) = VPOCHA(IP,NC1)
 50               CONTINUE
 60         CONTINUE
      ENDIF
      SEGSUP IBEXIS
C
C- Traitement si points identiques
C
      IF (ININI.EQ.1) THEN
         segact mpoval*mod
         DO 100 IEL=1,NUMPT1
            DO 90 NC1=1,NC
               VPOCHA(IEL,NC1) = MPOVA1.VPOCHA(IEL,NC1)
 90         CONTINUE
 100     CONTINUE
         SEGSUP MPOVA1
         SEGACT MSOUPO*MOD
         IGEOC = IPT1
      ENDIF
      INDIC = 1
      GOTO 120
C
C- Traitement si supports géométriques différents
C
 110  CONTINUE
      INDIC = -4
      IF (ININI.EQ.1) THEN
         SEGSUP MPOVA1
         MOTERR(1:8)  = 'CHPOINT '
         MOTERR(9:16) = 'MAILLAGE'
         INTERR(1)    = 1
         CALL ERREUR(698)
      ENDIF
C
C- Ménage
C
 120  CONTINUE
*
      RETURN
      END
 
 
 
 
 
 
 
 

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