Télécharger kcht.eso

Retour à la liste

kcht
C KCHT      SOURCE    GOUNAND   25/11/12    21:15:15     12399          
      SUBROUTINE KCHT
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C*************************************************************************
C     Operateur KCHT
C
C     OBJET    : Cree un CHAMPOINT TRIO c'est a dire sous-type
C                SOMMET CENTRE ou FACE
C
C     SYNTAXE  : CH1 = KCHT tabdom TYPC TYPG <VERIF> <COMP nc>
C                      <val1 > <CHP2> ;
C
C                           tabdom table domaine
C
C                           TYPC : SCAL   TYPG : SOMMET
C                                  VECT          CENTRE
C                                                FACE
C                           nc nom donne a ou aux composantes
C
C
C
C
C
C*************************************************************************
 
-INC PPARAM
-INC CCOPTIO
-INC SMCOORD
-INC SMCHPOI
-INC SMELEME
-INC SMLENTI
-INC SMLMOTS
 
      CHARACTER*8 TYPC,TYPG,LTYPC(3),LTYPG(8),MTYP,TYPE,TYPS
      CHARACTER*(LOCOMP) NCOS,NCOV(3),NCOSI,NCOVI(3)
 
      REAL*8 XVAL(3)
 
      DATA LTYPC/'SCAL    ','VECT    ','MATR    '/
      DATA LTYPG/'SOMMET  ','CENTRE  ','FACE    ','CENTREP0','CENTREP1',
     &'MSOMMET ','COMP    ','VERIF   '/
      DATA NCOSI/'SCAL'/
      DATA NCOVI/'UX  ','UY  ','UZ  '/
C***
 
      segact mcoord
      KVERIF=0
      MLENTI=0
      NCOS=NCOSI
      NCOV(1)=NCOVI(1)
      NCOV(2)=NCOVI(2)
      NCOV(3)=NCOVI(3)
 
      XVAL(1) = 0.D0
      XVAL(2) = 0.D0
      XVAL(3) = 0.D0
      MCHPOI = 0
 
      CALL LITDMD(MMODEL,MTABD,IRET)
      IF(IRET.EQ.0)RETURN
      IF(MTABD.EQ.0)CALL LEKMOD(MMODEL,MTABD,INEFMD)
C INEFMD=1 LINE  =2 MACRO  =3 QUADRATIQUE  =4 LINB
 
 
C     WRITE(*,*)' on cherche les MOT des sous-type du CHPOINT résultat'
C
C     SCAL    SOMMET
C     VECT    FACE
C             CENTRE
 
         CALL LIRMOT(LTYPC,3,IPC,1)
         IF(IPC.EQ.0)RETURN
         CALL LIRMOT(LTYPG,6,IPG,1)
         IF(IPG.EQ.0)RETURN
 
         IF(IPC.EQ.1)THEN
         NC=1
         ELSEIF(IPC.EQ.2)THEN
         NC=IDIM
         ELSEIF(IPC.EQ.3)THEN
         NC=IDIM*IDIM
         ENDIF
 
         CALL QUETYP(MTYP,0,IRET)
         IF(IRET.EQ.0)GO TO 90
         IF(MTYP.EQ.'MOT')THEN
         CALL LIRMOT(LTYPG(7),2,IPC,1)
         IF(IPC.EQ.0)THEN
C Il manque le mot-clé %m1:4
         MOTERR(1:4)='COMP'
         CALL ERREUR(396)
         MOTERR(1:4)='VERI'
         CALL ERREUR(396)
 
         RETURN
         ENDIF
 
         IF(IPC.EQ.1)THEN
         IF(NC.EQ.1)THEN
         CALL LIRCHA(NCOS,1,IRET)
         IF(IRET.EQ.0)RETURN
         ELSE
          CALL QUETYP(MTYP,0,IRET)
C         write(6,*)' MTYP,nc=',MTYP,nc
          IF(IRET.EQ.0)RETURN
          IF(MTYP.EQ.'LISTMOTS')THEN
                CALL LIROBJ('LISTMOTS',MLMOTS,1,IRET)
                IF(IRET.EQ.0)RETURN
                SEGACT MLMOTS
               DO 128 I=1,NC
C?             CALL LIRCHA(NCOV(I),1,IRET)
C?             IF(IRET.EQ.0)RETURN
               NCOV(I)=MOTS(I)
 128           CONTINUE
 
          ELSEIF(MTYP.EQ.'MOT')THEN
               DO 129 I=1,NC
              CALL LIRCHA(NCOV(I),1,IRET)
              IF(IRET.EQ.0)RETURN
 129           CONTINUE
          ELSE
          RETURN
          ENDIF
         ENDIF
         ELSEIF(IPC.EQ.2)THEN
         KVERIF=1
         ENDIF
 
         CALL QUETYP(MTYP,0,IRET)
         IF(IRET.EQ.0)GO TO 90
 
         ENDIF
 
         IF(IPG.GE.4.AND.IPG.NE.6)THEN
            IF(INEFMD.NE.2.AND.INEFMD.NE.3.AND.INEFMD.NE.4)THEN
C        Option %m1:8 incompatible avec les données
            MOTERR( 1: 8) = LTYPG(IPG)
            CALL ERREUR(803)
            RETURN
            ENDIF
        ENDIF
 
         TYPG=LTYPG(IPG)
         CALL LEKTAB(MTABD,TYPG,MELEME)
 
 
      NAT=2
      NSOUPO=1
      SEGACT MELEME
      N=NUM(/2)
      SEGINI MCHPOI,MSOUPO,MPOVAL
C     write(6,*)' KCHT on initialise MCHPOI n,nc=',n,nc
 
      MTYPOI=TYPG
      MOCHDE=TITREE
      JATTRI(1)=1
      IPCHP(1)=MSOUPO
      IFOPOI=IFOUR
      IF(NC.EQ.1)THEN
C     write(6,*)' On attribue le nom de composante :',ncos,' :'
      NOCOMP(1)=NCOS
      ELSE
      DO 127 I=1,NC
C     write(6,*)' On attribue le nom de composante :',ncov(i),' :'
      NOCOMP(I)=NCOV(I)
 127  CONTINUE
      ENDIF
      IGEOC=MELEME
      IPOVAL=MPOVAL
 
      IF(MTYP.EQ.'FLOTTANT'.OR.MTYP.EQ.'ENTIER  ')THEN
C On initialise le CHPOINT a une constante si c'est un SCAL
      IF(NC.NE.1)THEN
      WRITE(6,*)' CHPOINT SCAL Initialisation incompatible '
      CALL ERREUR(156)
C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n
C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu
      RETURN
      ENDIF
 
      CALL LIRREE(XVAL(1),1,IRET)
      CALL INITD(VPOCHA,N,XVAL(1))
 
      ELSEIF(MTYP.EQ.'POINT   ')THEN
      IF(NC.EQ.1)THEN
      WRITE(6,*)' CHPOINT VECT Initialisation incompatible '
      CALL ERREUR(156)
C Le chpoint donné est vide, ou bien son contenu est incompatible avec les n
C de composante imposés par le listmots et le mot-clé (donné ou sous-entendu
      RETURN
      ENDIF
         CALL LIROBJ('POINT   ',IP,1,IRET)
         XVAL(1)=XCOOR((IP-1)*(IDIM+1)    +1)
         XVAL(2)=XCOOR((IP-1)*(IDIM+1)    +2)
         IF(NC.EQ.3)XVAL(3)=XCOOR((IP-1)*(IDIM+1)    +3)
C On construit le CHPOINT résultat si celui-ci ne l'a pas déjà été ...
           CALL INITD(VPOCHA,N,XVAL(1))
           CALL INITD(VPOCHA(1,2),N,XVAL(2))
           IF(NC.EQ.3)CALL INITD(VPOCHA(1,3),N,XVAL(3))
           IF(NC.EQ.4.OR.NC.EQ.9)WRITE(6,*)' Cas non encore implemente'
 
      ELSEIF(MTYP.NE.'CHPOINT')THEN
      WRITE(6,*)' Type d objet incorrect pour l initialisation'
C Indice %m1:8 : Objet de type %m9:16 incorrect
      MOTERR(1:8)='        '
      MOTERR(9:16)=MTYP
      CALL ERREUR(787)
      RETURN
      ENDIF
 
 
C     write(6,*)' On cherche les champoints à charger ... '
      CALL KRIPAD(MELEME,MLENTI)
 10   CONTINUE
      CALL LIROBJ('CHPOINT ',MCHPO1,0,IRET)
      IF(IRET.EQ.0)GO TO 11
      CALL ACTOBJ('CHPOINT ',MCHPO1,1)
 
      NSOUP1=MCHPO1.IPCHP(/1)
 
      IKCOMP=0
      DO 1 L=1,NSOUP1
      MSOUP1=MCHPO1.IPCHP(1)
      NC1=MSOUP1.NOCOMP(/2)
      DO 2 M=1,NC1
      DO 3 K=1,NC
C     write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K)
 
      IF(MSOUP1.NOCOMP(M).EQ.NOCOMP(K))THEN
      IKCOMP=IKCOMP+1
      MELEME=MSOUP1.IGEOC
      MPOVA1=MSOUP1.IPOVAL
      NPT=NUM(/2)
      IKVAL=0
      DO 4 I=1,NPT
      I1=LECT(NUM(1,I))
      IF(I1.EQ.0)GO TO 4
      IKVAL=IKVAL+1
      VPOCHA(I1,K)=MPOVA1.VPOCHA(I,M)
 4    CONTINUE
      IF(IKVAL.EQ.0)THEN
      write(6,*)' Opérateur KCHT : aucun point pour la composante ',
     &NOCOMP(M)
C Le chpoint donné est vide, ou bien son contenu est incompatible avec les noms
Cde composante imposés par le listmots et le mot-clé (donné ou sous-entendu)
      CALL ERREUR(156)
      RETURN
      ENDIF
      IF(KVERIF.NE.0)THEN
      write(6,*)' Opérateur KCHT : la composante ',NOCOMP(M),
     &' a été initialisée'
      ENDIF
 
      ENDIF
 
 3    CONTINUE
 2    CONTINUE
 1    CONTINUE
      IF(IKCOMP.EQ.0)THEN
      write(6,*)' Opérateur KCHT : '
      write(6,*)' Aucune composante n''a été initialisée'
      write(6,*)' Liste des composantes : '
      DO 21 L=1,NSOUP1
      MSOUP1=MCHPO1.IPCHP(1)
      NC1=MSOUP1.NOCOMP(/2)
      DO 22 M=1,NC1
         DO 221 K=1,NC
            write(6,*)' ncomp1=',MSOUP1.NOCOMP(M),' ncomp=',NOCOMP(K)
 221     CONTINUE
 22   CONTINUE
 21   CONTINUE
C La composante %m1:4 n'existe pas pour le champ %m5:8
      MOTERR(1:4)=' '
      MOTERR(5:8)=' '
      CALL ERREUR(77)
 
      RETURN
      ENDIF
 
      GO TO 10
 
 11   CONTINUE
 
      IF(MLENTI.NE.0)SEGSUP MLENTI
      CALL ACTOBJ('CHPOINT ',MCHPOI,1)
      CALL ECROBJ('CHPOINT ',MCHPOI)
      RETURN
 
 90   CONTINUE
      WRITE(6,*)' Arret anormal dans KCHT '
C Tache impossible. Probablement données erronées
      CALL ERREUR(26)
 
      END
 
 

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