C CHASUP    SOURCE    FANDEUR   13/02/07    21:15:06     7694           
      SUBROUTINE CHASUP(IPMODL,IPOI1,IPOI2,IRET,IPLAC)
C---------------------------------------------------------------------

C     ENTREES:
C
C       IPMODL     Pointeur sur un MMODEL
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
C      AM  14/6/07  SI IPLAC EST NEGATIF, ON RECUPERE UN CHAMP QUI
C                   NE CONTIENT PAS LES COMPOSANTES COMPLEXES (NON SCALAIRES)
C                   QU'ON A N'A PAS PU CHANGER
C                   SINON, ON SORT EN ERREUR
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     I.MONNIER le 31.05.90
C
C---------------------------------------------------------------------
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC CCOPTIO
-INC SMMODEL
-INC SMCHAML
-INC SMELEME
-INC SMINTE
-INC SMCOORD
      CHARACTER*8 CHARIN,CHARTY
C
      SEGMENT SWORK
        REAL*8 VAL1(NBPGA1),VAL2(NBPGAU),VALN(NBNN)
        REAL*8 SHP(6,NBNN) ,XE(3,NBNN)
      ENDSEGMENT
C
      SEGMENT SWORK2
        INTEGER LETAB(N22)
      ENDSEGMENT
*
*     NBPGA1,NBPGAU DESIGNENT LES TAILLES MAX DES CHAMPS CH1 ET CH2
*     N1PTE1,N1PTEL DESIGNENT LES TAILLES EFFECTIVES DE CES CHAMPS
*
      SEGMENT  INFO
        INTEGER INFELL(JG)
      ENDSEGMENT
C
      IRET=0
C
C     ACTIVATION DU MODELE
C
      MMODEL=IPMODL
      SEGACT MMODEL
      NSOUS1=KMODEL(/1)
C
C     ACTIVATION DES MCHELM
C
      MCHEL1 =IPOI1
      SEGACT MCHEL1
      NSOUS=MCHEL1.ICHAML(/1)
      IF(NSOUS.GT.NSOUS1)THEN
*  on va essayer de reduir le champ
      call reduaf(mchel1,mmodel,mchel10,0,ire,kerre)
**     if (ire.ne.1) then
**       call erreur(kerre)
**       IRET=553
**       SEGDES MMODEL,MCHEL1
**       RETURN
**     endif
       if (ire.eq.1)  mchel1=mchel10
       SEGACT MCHEL1,mmodel
       NSOUS=MCHEL1.ICHAML(/1)
      ENDIF
      N1=NSOUS
      L1=MCHEL1.TITCHE(/1)
      N3=MCHEL1.INFCHE(/2)
      NINF=N3
      IF (N3.LT.6) N3=6
      SEGINI MCHELM
      TITCHE=MCHEL1.TITCHE
      IFOCHE=IFOUR
      IPOI2=MCHELM
      iresu=0
C
C  ON BOUCLE SUR LES SOUS-ZONES DU MCHAML
C
      DO 100 ISOUS=1,NSOUS
*
        IMACHE(ISOUS)=MCHEL1.IMACHE(ISOUS)
        CONCHE(ISOUS)=MCHEL1.CONCHE(ISOUS)
        DO 191 IP=1,NINF
          INFCHE(ISOUS,IP)=MCHEL1.INFCHE(ISOUS,IP)
 191    CONTINUE
C
C       MISE EN CONCORDANCE DES POINTEURS DE MAILLAGE
C
        MELEME=IMACHE(ISOUS)
        INS=0
        DO 151 IO=1,NSOUS1
          IMODEL=KMODEL(IO)
          SEGACT IMODEL
        CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY')
        IPMAIL=IMAMOD
C
C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
        IF(IDARC.NE.0)THEN
           CALL LEKMOD(MMODEL,IPTABL,INEFMD)
           CHARIN = 'MAILLAGE'
           CALL LEKTAB(IPTABL,CHARIN, IOBRE)
           IF (IERR.NE.0) RETURN
           IPT1 = IOBRE
           IPMAIL= IOBRE
           segact ipt1
           IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
           SEGACT IPT1
           IPMAIL= IPT1.LISOUS(ISOUS)
           SEGDES IPT1
           ENDIF
        ENDIF
          IF (IPMAIL.EQ.MELEME) INS=INS+1
 151    CONTINUE
        DO 150 IO=1,NSOUS1
          IMODEL=KMODEL(IO)
          SEGACT IMODEL
        CALL PLACE(FORMOD,FORMOD(/2),IDARC,'DARCY')
        IPMAIL=IMAMOD
C
C      CAS DE LA FORMULATION DARCY ON VA EXTRAIRE LE MAILLAGE SOMMET
        IF(IDARC.NE.0)THEN
           CALL LEKMOD(MMODEL,IPTABL,INEFMD)
           CHARIN = 'MAILLAGE'
           CALL LEKTAB(IPTABL,CHARIN, IOBRE)
           IF (IERR.NE.0) RETURN
           IPT1 = IOBRE
           IPMAIL= IOBRE
           SEGACT IPT1
           IF(N1.GT.1.and.ipt1.lisous(/1).ge.n1)THEN
           IPMAIL= IPT1.LISOUS(ISOUS)
           SEGDES IPT1
           ENDIF
        ENDIF
          IF (IPMAIL.EQ.MELEME.AND.(INS.GE.1.OR.
     >      CONCHE(ISOUS).EQ.CONMOD)) GOTO 160
          SEGDES IMODEL
 150    CONTINUE
*
        IRET=472
        SEGDES,MCHEL1,MMODEL
        SEGSUP MCHELM
        RETURN
*
 160    MELE=NEFMOD

**       write(6,*) 'mele ',mele
*  on saute si element sans les supports
        if(mele.eq.22) go to 100
        if(mele.eq.107) go to 100
        if(mele.eq.165) go to 100
        if(mele.eq.261) go to 100

*        write(6,*) 'chasup MCHEL1.INFCHE(ISOUS,4)',
*     $       MCHEL1.INFCHE(ISOUS,4)
*        write(6,*) ' chzsup MCHEL1.INFCHE(ISOUS,6) ninf ',
*     $ MCHEL1.INFCHE(ISOUS,6),ninf
*
*      DANS LE CAS DES COQUES INTEGREES ON SORT EN ERREUR
*
        IF (NINF.LT.4.OR.MCHEL1.INFCHE(ISOUS,4).EQ.0) THEN
           MINTE1=0
           IPLACA=0
        ELSE
           MINTE1=MCHEL1.INFCHE(ISOUS,4)
           IPLACA=MCHEL1.INFCHE(ISOUS,6)
        ENDIF
*        write(6,*) 'chasup minte1 ninf', ninf,minte1
C
        if (formod(1).eq.'LIAISON') then
          IPLAC1 = 1
        else
          IPLAC1 = ABS(IPLAC)
C le modele contient t il de la thermique ?
C s'il y a de la thermique le segment d'integration est particulier
          IF ( FORMOD(1) .EQ. 'THERMIQUE' ) THEN
            nmat = matmod(/2)
            icov = 0
C*          CALL PLACE(matmod,nmat,icov,'CONVECTION')
            CALL PLACE(matmod,nmat,iray,'RAYONNEMENT')
            IF (icov+iray.EQ.0) THEN
              IF ( IPLAC1 .NE. 1 ) IPLAC1 = 6
            ENDIF
          ENDIF
        endif
C
        IF(IPLAC1.EQ.6)THEN
          CALL TSHAPE(MELE,'GAUSS',IPMINT)
          IF ( IERR .NE. 0) GOTO 665
          MINTE=IPMINT
          MELGEO=NUMGEO(MELE)
        ELSE
          if(2+iplac1.gt.infmod(/1))then
             CALL ELQUOI(MELE,0,IPLAC1,IPTR2,IMODEL)
                  IF ( IERR .NE. 0) GOTO 665
             INFO=IPTR2
            MINTE=INFELL(11)
            MELGEO=INFELL(14)
             SEGSUP,INFO
          else                
            minte=infmod(2+iplac1)
            MELGEO=INFELE(14)
          endif
*          write(6,*) ' apres zelquoi minte' , minte
        ENDIF
        INFCHE(ISOUS,4)=MINTE
        IF(IPLAC1.EQ.1)INFCHE(ISOUS,4)=0
        INFCHE(ISOUS,6)=IPLAC1
C
C     ON RECUPERE LE NOMBRE D ELEMENTS
C
        SEGACT MELEME
        NBNN  =NUM(/1)
        NBELEM=NUM(/2)
C
C     ON RECUPERE LE NOMBRE DE POINTS SUPPORT
C     NBPGA1 POUR L'ANCIEN CHAMP ET NBPGAU POUR LE NOUVEAU
C
        IF(MINTE1.NE.0)THEN
          SEGACT MINTE1
          NBPGA1 = MINTE1.SHPTOT(/3)
        ELSE
          NBPGA1=NBNN
        ENDIF
        if (minte.eq.0) then
           call erreur(5)
           return
        endif
        SEGACT MINTE
        NBPGAU = SHPTOT(/3)
        nbpga1=max(nbpga1,nbpgau)
*         write(6,*) ' nbpgau,nbpga1',nbpgau,nbpga1
C
        NEL   =NBELEM
        SEGINI SWORK
C
C       PREPARATION POUR CREATION DU MCHAML
C
        MCHAM1=MCHEL1.ICHAML(ISOUS)
        SEGACT MCHAM1
C
        N22 = MCHAM1.NOMCHE(/2)
*       
*     SI IPLAC < 0, ON CHERCHE LE NOMBRE DE COMPOSANTES A CONSERVER 
*
        SEGINI SWORK2
*
        IF(IPLAC.GE.0) THEN
          N2 = N22
          DO ICOMP=1,N22
             LETAB(ICOMP) = ICOMP
          ENDDO
*
        ELSE 
*
*         BOUCLE SUR LES COMPOSANTES
*
          JECO = 0
          DO 170 ICOMP=1,N22
C
            CHARTY=MCHAM1.TYPCHE(ICOMP)
            MELVA1=MCHAM1.IELVAL(ICOMP)
            SEGACT MELVA1
            LETAB(ICOMP) = 0
*
            IF(CHARTY(1:6).EQ.'REAL*8') THEN
              JECO = JECO + 1
              LETAB(ICOMP) = JECO
            ENDIF
*
*            cas de variables complexes 
*
            IF(CHARTY(1:8).EQ.'POINTEUR') THEN
              N2PTE1=MELVA1.IELCHE(/1)
*
* ... Comme on ne sait pas extrapoler ou interpoler de variables
*     composées, on n'en accepte qu'une par élément ...

              IF(N2PTE1.EQ.1) THEN
                JECO = JECO + 1
                LETAB(ICOMP) = JECO
              ENDIF
            ENDIF
          SEGDES MELVA1
 170    CONTINUE
        N2 = JECO
*
        ENDIF
*
*    CREATION DU MCHAML 
*
        SEGINI MCHAML
        iresu=iresu+1
        ICHAML(iresu)=MCHAML
C
C       BOUCLE SUR LES COMPOSANTES EN ENTREE
C
        DO 180 ICOMP=1,N22
C         
          JCOMP = LETAB(ICOMP)
          IF(JCOMP.EQ.0) GO TO 180

          NOMCHE(JCOMP)=MCHAM1.NOMCHE(ICOMP)
          TYPCHE(JCOMP)=MCHAM1.TYPCHE(ICOMP)
C
          MELVA1=MCHAM1.IELVAL(ICOMP)
*         write (6,*) ' dans chasup melva1 ',melva1
          SEGACT MELVA1
*
*  RECHERCHE DES TAILLES DU NOUVEAU CHAMELEM - dans le cas scalaire
*
          IF(TYPCHE(JCOMP)(1:6).EQ.'REAL*8') THEN
            N1PTE1=MELVA1.VELCHE(/1)
            IF (N1PTE1.EQ.1) THEN
              N1PTEL=1
            ELSE
              N1PTEL=NBPGAU
            ENDIF
            N1EL  =MELVA1.VELCHE(/2)
*
*  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
*
            IF(N1EL.NE.NEL.AND.N1EL.NE.1.AND.NEL.NE.1) THEN
              SEGDES MELVA1,MELEME,IMODEL,MCHAM1
              SEGSUP SWORK,SWORK2,MCHAML
              IRET=146
              MOTERR(1:8)='CHASUP  '
              GO TO 665
            ENDIF
*
            N1PAUX=N1PTE1
C
C-----------------------------------------------------------------------
C                     PETIT TEST POUR LE COQ4
C       SI LE NOMBRE DE POINTS DE GAUSS VAUT 5 , ON NE PREND QUE
C       LES 4 PREMIERS , LE 5-EME SERVANT UNIQUEMENT AU CISAILLEMENT
C
            IF (MELE.EQ.49.AND.N1PAUX.EQ.5) N1PAUX=4
C-----------------------------------------------------------------------
C
          ELSE
             N1PTEL=0
             N1EL=0
          ENDIF
*
*     ... Et dans le cas de variables complexes ...
*
          IF(TYPCHE(JCOMP)(1:8).EQ.'POINTEUR') THEN
            N2PTE1=MELVA1.IELCHE(/1)
            IF (N2PTE1.EQ.1) THEN
              N2PTEL=1
            ELSE
              N2PTEL=NBPGAU
            ENDIF
            N2EL  =MELVA1.IELCHE(/2)
*
* ... Comme on ne sait pas extrapoler ou interpoler de variables
*     composées, on n'en accepte qu'une par élément ...

*           IF(N2PTEL.NE.1) THEN
*             SEGDES MELVA1,MELEME,IMODEL,MCHAM1
*             SEGSUP SWORK,SWORK2,MCHAML
*             IRET=755
*             GO TO 665
*           ENDIF
*
*  PETIT TEST DE COMPATIBILITE DES NOMBRES D'ELEMENTS
*
            IF(N2EL.NE.NEL.AND.N2EL.NE.1.AND.NEL.NE.1) THEN
              SEGDES MELVA1,MELEME,IMODEL,MCHAM1
              SEGSUP SWORK,SWORK2,MCHAML
              IRET=146
              MOTERR(1:8)='CHASUP  '
              GO TO 665
            ENDIF

          ELSE
            N2PTEL=0
            N2EL=0
          ENDIF
          SEGINI MELVAL
          IELVAL(JCOMP)=MELVAL
*
*  TRAITEMENT IMMEDIAT SI CHAMP CONSTANT
*
*         if(iplac1.eq.4) write(6,*)' n2ptel n1ptel',n2ptel,n1ptelq
         IF(n2ptel.ne.0) then
          IF(N2PTEL.EQ.1) THEN
            DO 4119 IEL=1,N2EL
              IELCHE(1,IEL)=MELVA1.IELCHE(1,IEL)
 4119       CONTINUE
C*        ELSE IF (N2PTEL.NE.1) THEN
          ELSE
            IF (MINTE.NE.MINTE1. AND. IPLAC1.NE.IPLACA) THEN
              SEGDES MELVA1,MELEME,IMODEL,MCHAM1
              SEGSUP SWORK,SWORK2,MCHAML
              IRET=755
              GO TO 665
            ENDIF
            DO 4109 IGAU=1,N2PTEL
            DO 4109 IEL=1,N2EL
              IELCHE(IGAU,IEL)=MELVA1.IELCHE(IGAU,IEL)
 4109       CONTINUE
          ENDIF
         else
          IF(N1PTE1.EQ.1) THEN
            DO 4120 IEL=1,N1EL
            VELCHE(1,IEL)=MELVA1.VELCHE(1,IEL)
 4120       CONTINUE
*
          ELSE
*
*          write (6,*) ' chasup ',swork,melva1,NBPGA1,NBPGAU,NBNN,
*    >      nel,n1pte1
*          write (6,*) melva1.velche(/1),melva1.velche(/2)

           DO 3120 IEL=1,NEL
           IF(IEL.GT.1.AND.N1EL.EQ.1) GO TO 3130
             DO 3121 IGAU=1,N1PTE1
             VAL1(IGAU)=MELVA1.VELCHE(IGAU,IEL)
3121         CONTINUE
C
C      LE CHAMELEM N'EST PAS AUX NOEUDS
C
           IF(MINTE1.NE.0)THEN
C
C           MEME SUPPORT( attention test sur iplaca et iplac1 pour DKT)
C
*            write(6,*) ' meme support?',minte,minte1,iplac1,iplaca
            IF(MINTE.EQ.MINTE1. OR. IPLAC1.eq.IPLACA) THEN
              DO 3124 IGAU=1,N1PTE1
              VELCHE(IGAU,IEL)=VAL1(IGAU)
3124          CONTINUE
C
C           SUPPORTS DIFFERENTS
C
            ELSE
C
C   COQUE INTEGREE OU PAS ?
C
               IF(INFMOD(/1).NE.0)THEN
                   NPINT=INFMOD(1)
               ELSE
                  NPINT=0
               ENDIF
               IF (NPINT.NE.0.AND.NPINT.NE.1)THEN
                  IRET = 19
                  SEGDES MELVA1,MELEME,IMODEL,MCHAM1
                  SEGSUP SWORK,SWORK2,MCHAML,MELVAL
                  GO TO 665
               ENDIF
C
              CALL DOXE(XCOOR,IDIM,NBNN,NUM,IEL,XE)
              CALL QUEDIM(MELGEO,KERRE)
              CALL CH1CH2(MELE,MINTE,MINTE1,N1PTEL,N1PAUX,NBNN,
     >                    SWORK,KERRE)
              IF(KERRE.NE.0) THEN
                IRET=KERRE
                SEGDES MELVA1,MELEME,IMODEL,MCHAM1
                SEGSUP SWORK,SWORK2,MCHAML,MELVAL
                GO TO 665
              ENDIF
*
              DO 3122 IGAU=1,N1PTEL
              VELCHE(IGAU,IEL)=VAL2(IGAU)
3122          CONTINUE
            ENDIF
          ELSE
           NBNI=NBNN
           IF( MELGEO.EQ.12.OR.MELGEO.EQ.13) NBNI=NBNN/2
             DO 3123 IGAU=1,N1PTEL
                VALG=0.D0
                DO 3125 INO=1,NBNI
                 VALG=VALG+SHPTOT(1,INO,IGAU)*VAL1(INO)
3125            CONTINUE
              VELCHE(IGAU,IEL)=VALG
3123         CONTINUE
            ENDIF
3120        CONTINUE
3130        CONTINUE
*
          ENDIF
         endif
          SEGDES MELVAL,MELVA1
 180    CONTINUE
        SEGSUP SWORK,SWORK2
        SEGDES MCHAML,MCHAM1,IMODEL,MELEME
*
      IF (MINTE.NE.0) SEGDES MINTE
      IF (MINTE1.NE.0) SEGDES MINTE1
 100  CONTINUE
      if (iresu.ne.nsous) then
        n1=iresu
        segadj mchelm
      endif
 665  CONTINUE
      SEGDES MCHELM,MCHEL1
      SEGDES MMODEL
 666  CONTINUE
      RETURN
      END