Télécharger chaspg.eso

Retour à la liste

chaspg
C CHASPG    SOURCE    OF166741  24/10/03    21:15:06     12022          
      SUBROUTINE CHASPG(IPMODL,IPOI1,IPOI2,IRET,IPLAC)
C---------------------------------------------------------------------
C
C     ENTREES:
C
C       IPMODL     Pointeur sur un MMODEL de type NAVIER_STOKES
C       IPOI1      Pointeur sur un MCHAML
C       IPLAC      Indique le type de support demandé :
C               1  scalaire aux NOEUDS
C               2  scalaire au  CENTRE DE GRAVITE
C               3  scalaire aux points d'integration de la RAIDEUR
C               4  scalaire aux points d'integration de la MASSE
C               5  scalaire aux points de CONTRAINTES
C               6  (utilisé dans le cas de la thermique)
C               7  SPG : FACE
C               8  SPG : CENTREP1
C               9  SPG : MSOMMET
C       TYPPROJ    Mot designant le type transformation autre-->sommet
C                  INTERP pour interpolation
C                  PROJEC pour projection
C
C     SORTIE:
C
C       IPOI2      Pointeur sur un MCHAML
C       IRET      =0 Si tout est ok
C                    Sinon contient le numero d'erreur
C
C     A.BLEYER le 22/01/2004
C
C---------------------------------------------------------------------
      IMPLICIT REAL*8(A-H,O-Z)
 
-INC PPARAM
-INC CCOPTIO
-INC SMMODEL
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
 
      PARAMETER (NSPG = 9)
      CHARACTER*8 LSPG(NSPG)
C
      SEGMENT SWORK
        REAL*8 VAL1(NBN1),VAL2(NBN2),VALN(NBN2)
        REAL*8 SHP1(6,NBN1),SHP2(6,NBN2),XE(3,NBNN)
      ENDSEGMENT
C
C     NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
C     N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
C
      SEGMENT  INFO
        INTEGER INFELL(JG)
      ENDSEGMENT
 
      POINTEUR INFO1.INFO
C
      IRET=0
 
      LSPG(1)='NOEUD'
      LSPG(2)='GRAVITE'
      LSPG(3)='RIGIDITE'
      LSPG(4)='MASSE'
      LSPG(5)='STRESSES'
      LSPG(6)='THERMIQU'
      LSPG(7)='FACE'
      LSPG(8)='P1CENTRE'
      LSPG(9)='MSOMMET'
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      CALL LEKMOD(MMODEL,IDOMA,INEFMD)
      NSOUS1=KMODEL(/1)
C
C     ACTIVATION DES MCHELM
C
      MCHEL1 =IPOI1
      NSOUS=MCHEL1.ICHAML(/1)
      IF(NSOUS.GT.NSOUS1)THEN
        IRET=553
        RETURN
      ENDIF
      N1=NSOUS
      L1=MCHEL1.TITCHE(/1)
      N3=MCHEL1.INFCHE(/2)
      IF (N3.NE.6) then
        write(ioimp,*) 'CHASPG : infche(/2) = N3 != 6'
        call erreur(5)
      endif
      NINF=N3
      SEGINI MCHELM
      TITCHE=MCHEL1.TITCHE
      IFOCHE=IFOUR
      IPOI2=MCHELM
C
C  ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
C
C      NTEL=0
C      KK1=0
      SEGACT,MCOORD
      DO 100 ISOUS=1,NSOUS
C
        CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
        DO 191 IP=1,NINF
          INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP)
 191    CONTINUE
        MINTE1=MCHEL1.INFCHE(ISOUS,4)
        IPLAC1=MCHEL1.INFCHE(ISOUS,6)
 
        IMODEL=KMODEL(ISOUS)
        MELE=NEFMOD
 
        IF (IPLAC1.EQ.IPLAC) THEN
          IPOI2=IPOI1
          RETURN
 
        ELSEIF (IPLAC1.EQ.1.AND.IPLAC1.NE.IPLAC) THEN
          IF (IPLAC.EQ.2) THEN
            CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
          ELSEIF(IPLAC.EQ.8) THEN
            IF (MELE.GE.223.AND.MELE.LE.236) THEN
              CALL LEKTAB(IDOMA,'MACRO1',IPT1)
            ELSE
              CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
            ENDIF
            CALL LEKTAB(IDOMA,'ELTP1NC',IPT2)
C            KK1=1
          ELSEIF(IPLAC.EQ.9) THEN
            IF (MELE.GE.223.AND.MELE.LE.236) THEN
              CALL LEKTAB(IDOMA,'MACRO1',IPT1)
            ELSE
              CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
            ENDIF
          ENDIF
 
       ELSEIF (IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN
          IF (MELE.GE.223.AND.MELE.LE.236) THEN
            CALL LEKTAB(IDOMA,'MACRO1',IPT1)
          ELSE
            CALL LEKTAB(IDOMA,'MAILLAGE',IPT1)
          ENDIF
 
       ELSEIF (IPLAC1.NE.1.AND.IPLAC.NE.1) THEN
          write(ioimp,*) 'IPLAC1,IPLAC=',IPLAC1,IPLAC
        WRITE(6,*)'Le SPG origine',LSPG(IPLAC1),'n''est pas compatible'
        WRITE(6,*)'avec ',LSPG(IPLAC)
        WRITE(6,*)'Seul le SPG SOMMET cible est authorisé !!!'
          MOTERR(1:8)='CHASPG  '
          IRET=1127
          RETURN
       ENDIF
 
        CALL ACTOBJ('MAILLAGE',IPT1,1)
        IF(IERR .NE. 0)RETURN
 
        IF(NSOUS.NE.1) THEN
          MELEME=IPT1.LISOUS(ISOUS)
        ELSE
          MELEME=IPT1
        ENDIF
 
        IMACHE(ISOUS)=MELEME
C
C       MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
C
        info=0
        if(infmod(/1).lt.2+iplac) then
        CALL ELQUOI(MELE,0,IPLAC,IPTR2,IMODEL)
        IF ( IERR .NE. 0) GOTO 665
        INFO=IPTR2
           MELGEO=INFELL(14)
           MINTE=INFELL(11)
         ELSE
          MINTE=infmod(2+iplac)
          MELGEO=INFELE(14)
         ENDIF
 
        INFCHE(ISOUS,4)=MINTE
        IF(IPLAC.EQ.1)INFCHE(ISOUS,4)=0
        INFCHE(ISOUS,6)=IPLAC
C
C     ON RECUPERE LE NOMBRE D ELEMENTS
C
        NBNN  =NUM(/1)
        NEL   =NUM(/2)
C        WRITE(6,*)'NBNN=',NBNN,'NEL=',NEL
C
C     ON RECUPERE LE NOMBRE DE POINTS SUPPORT
C     NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
C
        INFO1=0
        IF(MINTE1.EQ.0)THEN
        if(infmod(/1).lt.2+iplac1) then
          CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
          INFO1=IPTR2
          MINTE1=INFO1.INFELL(11)
          ELSE
          minte1=infmod(2+iplac1)
          endif
        ENDIF
        NBN1=MINTE1.SHPTOT(/2)
 
        NBN2=SHPTOT(/2)
        IF(IPLAC.EQ.2) NBN2=1
 
C        WRITE(6,*)'NBN1=',NBN1,'NBN2=',NBN2
        SEGINI SWORK
C
C       CREATION DU MCHAML
C
        MCHAM1=MCHEL1.ICHAML(ISOUS)
        N2=MCHAM1.NOMCHE(/2)
        SEGINI MCHAML
        ICHAML(ISOUS)=MCHAML
C
C       BOUCLE SUR LES COMPOSANTES
C
        DO 180 ICOMP=1,N2
C
          NOMCHE(ICOMP)=MCHAM1.NOMCHE(ICOMP)
          TYPCHE(ICOMP)=MCHAM1.TYPCHE(ICOMP)
C
          MELVA1=MCHAM1.IELVAL(ICOMP)
C
C  RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
C
            N1PTE1=MELVA1.VELCHE(/1)
            N1EL1 =MELVA1.VELCHE(/2)
 
            N1PTEL=NBN2
            N1EL  =NEL
C
            N2PTEL=0
            N2EL=0
 
          SEGINI MELVAL
          IELVAL(ICOMP)=MELVAL
C
C  TRAITEMENT IMMEDIAT SI CHAMP ORIGINEL CONSTANT
C
          IF(N1PTE1.EQ.1) THEN
             DO 4120 IEL=1,N1EL
                XFLO=MELVA1.VELCHE(1,IEL)
                DO 41201 INO=1,NBN2
                   VELCHE(INO,IEL)=XFLO
41201           CONTINUE
 4120        CONTINUE
C
          ELSE
           DO 3120 IEL=1,NEL
             DO 3121 IGAU=1,NBN1
               VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
3121         CONTINUE
C
C  LE CHAMELEM 1 EST AUX NOEUDS ET ON VEUT CHANGER DE SPG
C
          IF(IPLAC1.EQ.1) THEN
             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
             CALL QUEDIM(MELGEO,KERRE)
             CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,
     >                    SWORK,1,KERRE)
              IF(KERRE.NE.0) THEN
                IRET=KERRE
                SEGSUP SWORK,MCHAML,MELVAL
                GO TO 665
              ENDIF
C
              DO 3122 IGAU=1,NBN2
                VELCHE(IGAU,IEL)=VAL2(IGAU)
3122          CONTINUE
C
C  PASSAGE D'UN SPG QUELCONQUE VERS UN CHAMELEM AUX NOEUDS
C
          ELSEIF(IPLAC1.NE.1.AND.IPLAC.EQ.1) THEN
             CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
             CALL QUEDIM(MELGEO,KERRE)
             CALL K1K2(MELE,MINTE,MINTE1,NBN2,NBN1,NBNN,
     >                    SWORK,2,KERRE)
              IF(KERRE.NE.0) THEN
                IRET=KERRE
                SEGSUP SWORK,MCHAML,MELVAL
                GO TO 665
              ENDIF
C
              DO 3123 IGAU=1,NBN2
                VELCHE(IGAU,IEL)=VAL2(IGAU)
3123          CONTINUE
          ENDIF
3120    CONTINUE
C          NTEL=NTEL+NEL
          ENDIF
 180    CONTINUE
        SEGSUP SWORK
C
      IF (INFO .NE.0) SEGSUP INFO
      IF (INFO1.NE.0) SEGSUP INFO1
 
 100  CONTINUE
      SEGDES,MCOORD
 
 665  CONTINUE
C      CONTINUE
      RETURN
      END
 
 
 
 

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