Sources Esope | Cast3M

kcham1
C KCHAM1    SOURCE    PV090527  25/01/07    14:42:46     12115          
      SUBROUTINE KCHAM1(IPMODL,IPCHPO,IPCHEL)
C____________________________________________________________________*
C                                                                    *
C     transformation de chpoint en mchaml                            *
C                                                                    *
C     entr{es:                                                       *
C     ________                                                       *
C                                                                    *
C     ipmodl       pointeur sur un mmodel                            *
C     ipchpo       pointeur sur le chpoint                           *
C                                                                    *
C     sorties:                                                       *
C     ________                                                       *
C                                                                    *
C     ipchel       pointeur sur le mchaml resultat                   *
C____________________________________________________________________*
C                                                                    *
      IMPLICIT REAL*8 (A-H,O-Z)
C
 
-INC PPARAM
-INC CCOPTIO
-INC CCGEOME
-INC SMCOORD
-INC SMCHAML
-INC SMCHPOI
-INC SMMODEL
-INC SMELEME
-INC SMLENTI
C
C
      SEGMENT INFO
         INTEGER INFELL(JG)
      ENDSEGMENT
C
C      PARAMETER (NSPG = 9)
      PARAMETER (NSPG = 5)
      CHARACTER*8 LSPG(NSPG)
      CHARACTER*(NCONCH)  CONM
      CHARACTER*8 SOUTYP,TYPSPG
C
C     l'ordre des SPG correspond à l'ordre du KPOIND
C      LSPG(1)='NOEUD'     -> SOMMET
C      LSPG(2)='GRAVITE'   -> CENTRE
C      LSPG(3)='RIGIDITE'
C      LSPG(4)='MASSE'
C      LSPG(5)='STRESSES'
C      LSPG(6)='THERMIQU'
C      LSPG(7)='FACE'      -> FACE
C      LSPG(8)='P1CENTRE'  -> CENTREP1
C      LSPG(9)='MSOMMET'   -> MSOMMET
      LSPG(1)='SOMMET'
      LSPG(2)='CENTRE'
      LSPG(3)='FACE'
      LSPG(4)='CENTREP1'
      LSPG(5)='MSOMMET'
C
C        le traitement d'harmoniques de fourier n'est pas implemente
C
C      IPMINT=0
      IPCHEL=0
C      NPINT = 0
C      IRRT=0
      CONM=' '
      TYPSPG=' '
C
C     activation de l'objet modele
C
      MMODEL = IPMODL
      CALL LEKMOD(MMODEL,IDOMA,INEFMD)
      IF(IERR.NE.0)GOTO 9999
      SEGACT,MMODEL
C     IDOMA correspond au pointeur de la table domaine
C
C     activation du chpoint
C
      MCHPOI=IPCHPO
      SEGACT,MCHPOI
      NSOUPO=IPCHP(/1)
C
C     Determination du type de support geometrique
C
      DO 20 I=1,NSOUPO
        MSOUPO=IPCHP(I)
        SEGACT MSOUPO
        MLMCHP=IGEOC
        SEGDES MSOUPO
        CALL KRIPAD(MLMCHP,MLENTI)
C
C     TYPSPG = SOMMET, FACE, CENTRE, CENTREP0, CENTREP1 ou MSOMMET
C
        DO 10 L=1,NSPG
          TYPSPG=LSPG(L)
          CALL LEKTAB(IDOMA,TYPSPG,MLMSPG)
          CALL KRIPAD(MLMSPG,MLENT1)
          IF(IERR.NE.0)GOTO 9999
          CALL VERPAD(MLENTI,MLMSPG,IRET1)
          CALL VERPAD(MLENT1,MLMCHP,IRET2)
          IF(IRET1.EQ.0.AND.IRET2.EQ.0) GOTO 21
10    CONTINUE
20    CONTINUE
 
      WRITE(6,*)'SPG du champoint non trouve : '
      WRITE(6,*)'CHPO peut-etre incompatible avec le modele?'
      GOTO 666
 
21    CONTINUE
 
      IPT3=MLMSPG
      INFSPG=L
      IF(L.GE.3) INFSPG=4+L
      IF(INFSPG.EQ.2) SEGACT,IPT3
C
C     recherche eventuelle des sous-domaine du maillage
C     associe a l'objet modele Navier-Stokes
C
      IMACR1=0
      DO 11 I=1,MAX(1,KMODEL(/1))
        IMODEL=KMODEL(I)
        SEGACT,IMODEL
        NELE=NEFMOD
        IF(NELE.GE.216.AND.NELE.LE.222) IMACR1=IMACR1+1
11    CONTINUE
 
 
 
      CALL LEKTAB(IDOMA,'MAILLAGE',MPERE)
      IF(INEFMD.EQ.2.AND.INFSPG.NE.2) THEN
        CALL LEKTAB(IDOMA,'MACRO1',MPERE)
      ENDIF
      IF(IMACR1.EQ.KMODEL(/1)) CALL LEKTAB(IDOMA,'MAILLAGE',MPERE)
C LINE ou LINB avec CENTREP1
      IF(INEFMD.EQ.1.OR.INEFMD.EQ.4) THEN
        IF(INFSPG.EQ.8) THEN
C        Option %m1:8 incompatible avec les données
          MOTERR( 1: 8) = TYPSPG
          CALL ERREUR(803)
          GOTO 666
        ENDIF
      ENDIF
C Face
      IF(INFSPG.EQ.7) THEN
C        Option %m1:8 incompatible avec les données
          MOTERR( 1: 8) = TYPSPG
          CALL ERREUR(803)
          GOTO 666
      ENDIF
      IF(INFSPG.EQ.8) THEN
        CALL LEKTAB(IDOMA,'ELTP1NC',IPT4)
        SEGACT,IPT4
      ENDIF
 
      MELEME=MPERE
      SEGACT MELEME
      N1=MAX(1,LISOUS(/1))
 
C
C     initialisation du segment descripteur du champ par element
C
      N3=6
      L1=LEN(MTYPOI)
      SOUTYP=MTYPOI
      SEGINI,MCHELM
      TITCHE=SOUTYP
      IFOCHE=IFOUR
C
C     remplissage des MCHAML
C
      ILM1=0
      DO 30 I=1,N1
        IF(N1.NE.1) THEN
          IPT1=LISOUS(I)
          SEGACT IPT1
        ELSE
          IPT1=MELEME
        ENDIF
        IMACHE(I)=IPT1
        CONCHE(I)=CONM
        INFCHE(I,6)=INFSPG
 
        IMODEL=KMODEL(I)
        SEGACT,IMODEL
        NELE=NEFMOD
        N2PTEL=0
        N2EL=0
C     TYPE SPG DU CHPO : SOMMET
        IF(INFSPG.EQ.1) THEN
          IMINT=0
          N1PTEL=IPT1.NUM(/1)
          N1EL=IPT1.NUM(/2)
C     TYPE SPG DU CHPO : CENTRE
        ELSEIF(INFSPG.EQ.2) THEN
          if(infmod(/1).lt.4) then
          CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
          INFO=IPTR
          IMINT=INFELL(11)
          segsup info
          else
           IMINT=infmod(INFSPG+2)
          endif
          N1PTEL=1
          N1EL=IPT1.NUM(/2)
C          IF(INFO.GT.0) SEGSUP INFO
C     TYPE SPG DU CHPO : CENTREP1
        ELSEIF(INFSPG.EQ.8) THEN
          CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
          INFO=IPTR
          IMINT=INFELL(11)
          N1PTEL=INFELL(8)
          N1EL=IPT1.NUM(/2)
          SEGSUP INFO
C     TYPE SPG DU CHPO : MSOMMET
        ELSEIF(INFSPG.EQ.9) THEN
          CALL ELQUOI(NELE,0,INFSPG,IPTR,IMODEL)
          INFO=IPTR
          IMINT=INFELL(11)
          N1PTEL=INFELL(8)
          N1EL=IPT1.NUM(/2)
          SEGSUP INFO
        ENDIF
 
        INFCHE(I,4)=IMINT
 
        DO 40 J=1,NSOUPO
          MSOUPO=IPCHP(J)
          SEGACT MSOUPO
          N2=NOCOMP(/2)
          IPT2=IGEOC
          SEGACT,IPT2
          CALL KRIPAD(IPT2,MLENT2)
          SEGACT,MLENT2
          MPOVAL=IPOVAL
          SEGACT,MPOVAL
          SEGINI,MCHAML
          ICHAML(I)=MCHAML
 
          DO 50 K=1,N2
            NOMCHE(K)=NOCOMP(K)
            TYPCHE(K)='REAL*8'
            SEGINI,MELVAL
            IELVAL(K)=MELVAL
            DO 70 K70=1,N1EL
              DO 80 K80=1,N1PTEL
                IF(INFSPG.EQ.1) THEN
                  II2=IPT1.NUM(K80,K70)
                ELSEIF(INFSPG.EQ.2) THEN
                  II2=IPT3.NUM(K80,(ILM1+K70))
                ELSEIF(INFSPG.EQ.8) THEN
                  II2=IPT4.NUM(K80,(ILM1+K70))
                ELSEIF(INFSPG.EQ.9) THEN
                  IF(INEFMD.EQ.1) II1=K80
                  IF(INEFMD.EQ.2) II1=(2*K80)-1
                  IF(INEFMD.EQ.3) II1=(2*K80)-1
                  IF(INEFMD.EQ.4) II1=K80
                  II2=IPT1.NUM(II1,K70)
                ENDIF
                VELCHE(K80,K70)=VPOCHA(MLENT2.LECT(II2),K)
80    CONTINUE
70    CONTINUE
            SEGDES,MELVAL
50    CONTINUE
        SEGDES,IPT2
        SEGDES,MLENT2
        SEGDES,MSOUPO
        SEGDES,MPOVAL
        SEGDES,MCHAML
40    CONTINUE
        ILM1=ILM1+IPT1.NUM(/2)
        IF(N1.NE.1) SEGDES,IPT1
        SEGDES,IMODEL
30    CONTINUE
 
      IPCHEL=MCHELM
      SEGDES,MCHELM
 
      SEGDES,MELEME
666   CONTINUE
      IF(INFSPG.EQ.2) SEGDES,IPT3
      IF(INFSPG.EQ.8) SEGDES,IPT4
      SEGDES,MCHPOI
      SEGDES,MMODEL
 
C
 9999 CONTINUE
      RETURN
      END