Télécharger quepo1.eso

Retour à la liste

quepo1
C QUEPO1    SOURCE    CB215821  20/11/25    13:38:07     10792          
      SUBROUTINE QUEPO1(ICHP1,IPSG,LMOT)
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-----------------------------------------------------------------------
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              Si IPSG = 0: pas de test sur le maiilage
C E/S LMOT   : En entrée (si LMOT > 0),
C                 noms des composantes à tester
C              En sortie (si LMOT <= 0),
C                 noms des composantes du CHPO
C-----------------------------------------------------------------------
C
C Langage : ESOPE + FORTRAN77
C
C Auteurs : A. BECCANTINI
C
C-----------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMCHPOI
-INC SMLMOTS
-INC SMLENTI
C
C**** Variables de COOPTIO
C
C      INTEGER IPLLB, IERPER, IERMAX, IERR, INTERR
C     &        ,IOTER,   IOLEC,  IOIMP,     IOCAR,  IOACQ
C     &        ,IOPER,   IOSGB,  IOGRA,     IOSAU,  IORES
C     &        ,IECHO,   IIMPI,  IOSPI
C     &        ,IDIM
C     &        ,MCOORD
C     &        ,IFOMOD, NIFOUR, IFOUR, NSDPGE, IONIVE
C     &        ,NGMAXY, IZROSF, ISOTYP, IOSCR,LTEXLU
C     &        ,NORINC,NORVAL,NORIND,NORVAD
C     &        ,NUCROU, IPSAUV
CC
      POINTEUR MLEORD.MLENTI, MLEPOI.MLENTI
C
      INTEGER ICHP1, IPSG, LMOT, NSOUPO, NBCOMP, JGN, JGM
     &      , IC, JG, NBCOM1, IC2, NBSOUS, N, NC, ICOLD, NGP
     &      , NLP, NLPOLD
 
      CHARACTER*(LOCOMP) MOT1
 
      LOGICAL LOGORD
C
C- Test si le CHPO est partitionné
C
      MCHPOI = ICHP1
      SEGACT MCHPOI
      NSOUPO = MCHPOI.IPCHP(/1)
      IF (NSOUPO.NE.1) THEN
         MOTERR='CHPOINT '
         CALL ERREUR(132)
         GOTO 9999
      ENDIF
C
C- Test/Récupération/Imposition du nom des composantes
C
      MSOUPO = MCHPOI.IPCHP(1)
      SEGDES MCHPOI
      SEGACT MSOUPO*MOD
      NBCOMP = MSOUPO.NOCOMP(/2)
      IF(LMOT .LE. 0)THEN
         LOGORD = .TRUE.
         JG = NBCOMP
         SEGINI MLEORD
C
C******** Recuperation
C
         JGN = LOCOMP
         JGM = NBCOMP
         SEGINI MLMOTS
         LMOT = MLMOTS
         DO IC = 1, NBCOMP, 1
            MLMOTS.MOTS(IC) = MSOUPO.NOCOMP(IC)
            MLEORD.LECT(IC) = IC
         ENDDO
      ELSE
C
C******** Test/imposition
C
         MLMOTS = LMOT
         SEGACT MLMOTS
         NBCOM1 = MLMOTS.MOTS(/2)
         IF (NBCOM1.NE.NBCOMP) THEN
            MOTERR(1:8)  = ' QUEPOI '
            MOTERR(9:16) = 'CHAMPOIN'
            INTERR(1)   = NBCOM1
            INTERR(2)   = NBCOMP
C
C********** Message d'erreur standard
C           699 2
C           routine %m1:8 : On voulait un %m9:16 à %i1 composantes au lieu de %i2 .
C
            CALL ERREUR(699)
            GOTO 9999
         ENDIF
         JG = NBCOMP
         LOGORD = .TRUE.
         SEGINI MLEORD
         DO IC = 1, NBCOMP, 1
C
C********** On cherche la position de chaque composante en MLMOTS
C
            MOT1 = MSOUPO.NOCOMP(IC)
            DO IC2 = 1, NBCOMP, 1
               IF(MLMOTS.MOTS(IC2) .EQ. MOT1) THEN
                  IF(IC2 .NE. IC) LOGORD= .FALSE.
                  MLEORD.LECT(IC2) = IC
                  GOTO 1
               ENDIF
            ENDDO
C
C********** On est la car on n'as pas de MOT1
            MOTERR=MOT1
            CALL ERREUR(197)
            GOTO 9999
C
 1          CONTINUE
         ENDDO
      ENDIF
C
C- Transforme le maillage en POI1 si maillage quelconque
C- Le maillage POI1 de pointeur IPT1 est actif au retour de CHANGE
C
      IPT1 = MSOUPO.IGEOC
      IF(IPSG .EQ. 0)THEN
         MELEME = IPT1
      ELSE
         MELEME = IPSG
      ENDIF
      SEGACT MELEME
      NBSOUS = MELEME.LISOUS(/1)
      IF ((NBSOUS.NE.0).OR.(ITYPEL.NE.1)) THEN
         CALL CHANGE(MELEME,1)
         IF (IERR.NE.0) GOTO 9999
      ENDIF
C
C- Si égalité des pointeurs et LOGORD -> OK, sinon
C
      IF (LOGORD .AND. (MELEME .EQ. IPT1)) THEN
         SEGDES MELEME
         SEGDES MLMOTS
         SEGSUP MLEORD
         SEGDES MSOUPO
         IF(MLEORD .GT. 0) SEGSUP MLEORD
         RETURN
      ELSE
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
         N  = MELEME.NUM(/2)
         NC = NBCOMP
         SEGINI MPOVA1
         MPOVAL = MSOUPO.IPOVAL
         SEGACT MPOVAL
C
C- Recherche si les points du MELEME de type POI1 sont dans le CHPO
C- et ordonnencement
C
         CALL KRIPAD(IPT1,MLEPOI)
C        SEGACT MLEPOI
         DO IC = 1, NC, 1
            ICOLD = MLEORD.LECT(IC)
            MSOUPO.NOCOMP(IC) = MLMOTS.MOTS(IC)
            DO NLP = 1, N, 1
               NGP = MELEME.NUM(1,NLP)
               NLPOLD = MLEPOI.LECT(NGP)
               IF(NLPOLD .EQ. 0)THEN
                  MOTERR(1:8)  = 'CHAMPOIN'
                  MOTERR(9:16) = 'MAILLAGE'
                  INTERR(1)    = 1
                  CALL ERREUR(698)
                  GOTO 9999
C
C**************** Message d'erreur standard
C                 698 2
C                 Incohérence entre les pointeurs géométriques des objets %m1:8 et %m9:16
C                 698 2
C                 pour la zone élémentaire numéro %i1.
C
               ELSE
                  MPOVA1.VPOCHA(NLP,IC)=MPOVAL.VPOCHA(NLPOLD,ICOLD)
               ENDIF
            ENDDO
         ENDDO
         SEGDES MPOVA1
         MSOUPO.IGEOC=MELEME
         MSOUPO.IPOVAL=MPOVA1
         SEGDES MSOUPO
         SEGSUP MLEORD
         SEGSUP MLEPOI
      ENDIF
 9999 CONTINUE
      RETURN
      END
 
 
 
 
 
 

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