C FLUMAS    SOURCE    BP208322  13/07/30    21:15:06     7809           

C=======================================================================
C=                            F L U M A S                              =
C=                            -----------                              =
C=                                                                     =
C=  Fonction :                                                         =
C=  ----------                                                         =
C=   Calcul des flux nodaux equivalents a une condition de FLUX IMPOSE =
C=   pour des elements de type MASSIF (1D, 2D, 3D)                     =
C=   Sous-programme appele par FLUX2 (flux2.eso)                       =
C=                                                                     =
C=  Parametres :  (E)=Entree (S)=Sortie                                =
C=  ------------                                                       =
C=   IPMODE   (E)   Pointeur sur le segment MMODEL                     =
C=   IPGEOM   (E)   Objet MAILLAGE support de IPCHPO                   =
C=   IPCHPO   (E)   Pointeur sur le CHPOINT (ou le MCHAML) de flux     =
C=                  imposes aux noeuds de la structure                 =
C=                  (champ variable ou constant)                       =
C=   NUMPOI   (E)   Vaut -1 si le flux impose est normal a la surface, =
C=                  sinon pointeur sur un POINT correspondant a la     =
C=                  direction du flux (par rapport au repere global)   =
C=   MOCOMP   (E)   Nom de la composante du champ de flux equivalents  =
C=   MLMOTX   (E)   Pointeur MLMOTS de la liste des composantes de     =
C=                  IPCHPO associees aux 3 directions x,y,z.           =
C=   IPFLUX   (S)   Pointeur sur le champ des flux nodaux equivalents  =
C=                                                                     =
C=  Variables locales :                                                =
C=  -------------------                                                =
C=   ITGEOM   Pointeur sur un MAILLAGE elementaire du MASSIF           =
C=   IPENVE   Pointeur sur l'enveloppe d'un maillage MASSIF            =
C=   IPGEOM   Pointeur sur un MAILLAGE elementaire du CHPOINT          =
C=   IPOGEO   Pointeur sur un MAILLAGE commun au CHPOINT et au MASSIF  =
C=                                                                     =
C=  Denis ROBERT, le 1er fevrier 1988.                                 =
C=======================================================================

      SUBROUTINE FLUMAS (IPMODE,IPGEOM,IPCHPO,NUMPOI,NOMCQ,MLMOTX,
     &                   IPFLUX)

      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC CCOPTIO
-INC CCHAMP
-INC CCREEL
-INC SMCHAML
-INC SMCHPOI
-INC SMMODEL
-INC SMELEME
-INC SMCOORD
-INC SMLMOTS

      CHARACTER*(*) NOMCQ

      PARAMETER (XUn=1.)

      DIMENSION IVAL(4)
      CHARACTER*4 IMOT1,IMOT2

C= Activation du MMODEL
      MMODEL=IPMODE
      SEGACT,MMODEL
      NSOU=KMODEL(/1)
C= Activation de MLMOTX si defini
      NINC = 0
      IF (MLMOTX.NE.0) THEN
        MLMOTS=MLMOTX
        SEGACT,MLMOTS
        NINC = MOTS(/2)
      ENDIF

C  BOUCLE SUR LES ZONES ELEMENTAIRES DU MODELE
C =============================================
      idimp1=IDIM+1
      IRRT=0

      DO ISOU=1,NSOU

        IPCHEL=0

        IMODEL=KMODEL(ISOU)
        SEGACT,IMODEL
        NEF=NEFMOD

* Determination de l'ENVELOPPE du MASSIF
        ITGEOM=IMAMOD
        CALL ECROBJ('MAILLAGE',ITGEOM)
        IF (IDIM.EQ.3) THEN
          CALL ENVELO
        ELSE IF (IDIM.EQ.2) THEN
          CALL PRCONT
        ELSE IF (IDIM.EQ.1) THEN
          CALL PREX1D
        ENDIF
        CALL LIROBJ('MAILLAGE',IPENVE,1,IRET)
        IF (IERR.NE.0) GOTO 9900

*  ON RECUPERE LES MAILLAGES ELEMENTAIRES DE L'ENVELOPPE
*  APPUYES STRICTEMENT SUR LE CHPOINT DE FLUX
        CALL ECROBJ('MAILLAGE',IPGEOM)
        CALL ECRCHA('STRI')
        CALL ECRCHA('APPU')
        CALL ECROBJ('MAILLAGE',IPENVE)
        CALL EXTREL(IRR,0,i)

*  Pas DE MAILLAGE COMMUN A CETTE PARTIE DE L'ENVELOPPE ET DU CHPOINT
        IF (IRR.EQ.1) THEN
          IRRT=IRRT+1
          GOTO 9900
        ENDIF

*  IL Y A DES MAILLAGES COMMUNS AU CHPOINT ET A L'ENVELOPPE
        CALL LIROBJ('MAILLAGE',IPOGEO,1,IRET)
        IF (IERR.NE.0) GOTO 9900
*  ON DESIRE CONNAITRE LES CARACTERISTIQUES DE CES MAILLAGES
        IPT3=IPOGEO
        SEGACT,IPT3
        NSOU3=IPT3.LISOUS(/1)
        IF (NSOU3.EQ.0) NBN2=IPT3.NUM(/1)

*  BOUCLE SUR LES ZONES DE CET OBJET GEOMETRIQUE
        DO IMAIL=1,MAX(1,NSOU3)
          IF (NSOU3.NE.0) THEN
            IPT2=IPT3.LISOUS(IMAIL)
            SEGACT,IPT2
            IPOGEO=IPT2
            NBN2=IPT2.NUM(/1)
            SEGDES,IPT2
          ENDIF
*    RECHERCHE DE LA FORMULATION DES (SUR)FACES POUR LES MASSIF
          CALL FLUX3(NEF,NBN2,NEFACE)
* IMPOSSIBLE D'UTILISER L'OPERATEUR FLUX POUR LES ELEMENTS DE TYPE NEF
          IF (NEFACE.EQ.0) THEN
            MOTERR(1:4)=NOMTP(NEF)
            CALL ERREUR(407)
            GOTO 9901
          ENDIF
*      RECUPERATION DES CARACTERISTIQUES D'INTEGRATION
          CALL TSHAPE(NEFACE,'GAUSS',IPINTE)
*       ECHEC DANS L'ACQUISITION DES CARACTERISTIQUES D'INTEGRATION
          IF (IERR.NE.0) GOTO 9901

*   ON GENERE UN CHAMELEM ELEMENTAIRE DE FLUX 
*   A PARTIR DU MAILLAGE ELEMENTAIRE DE POINTEUR IPOGEO
*   ET DU CHPOINT
          if (IPCHPO.gt.0) then
            CALL CHAME1(IPOGEO,0,IPCHPO,' ',ICHELF,6)
          else
*ou ET DU MCHAML
            ICHE = -1*IPCHPO
            CALL REDUIC(ICHE,IPOGEO,ICHELF)
          endif            
          MCHEL1=ICHELF
          IF (IERR.NE.0) GOTO 9901
          SEGACT,MCHEL1
          MCHAM1=MCHEL1.ICHAML(1)
          SEGDES,MCHEL1
          SEGACT,MCHAM1
          NBCOMP=MCHAM1.IELVAL(/1)
          IF (NBCOMP.EQ.1) THEN
            IPFLOD=MCHAM1.IELVAL(1)
            SEGDES,MCHAM1
          ELSE
C POUR CHAQUE ELEMENT,
C ON DETERMINE UN VECTEUR DIRIGE VERS L INTERIEUR DU MASSIF
C A PARTIR D UN POINT DE LA FACE ET DU CENTRE DE GRAVITE DU MASSIF
C ON COPIE LE CHAMP EN AJOUTANT UNE COMPOSANTE
            IF (MLMOTX.EQ.0) THEN
              MOTERR(1:8)='LISTMOTS'
              CALL ERREUR(37)
              GOTO 9901
            ENDIF
            MLMOTS=MLMOTX
            MELVAL=MCHAM1.IELVAL(1)
            SEGACT,MELVAL
            N1PTEL=VELCHE(/1)
            N1EL=VELCHE(/2)
            SEGDES,MELVAL
            N2PTEL=0
            N2EL=0
            NBCOMP=IDIM
            N2=NBCOMP+IDIM
            SEGINI,MCHAML
              IPFLOD=MCHAML
              DO I=1,N2
                SEGINI,MELVAL
                IELVAL(I)=MELVAL
                SEGDES,MELVAL
              ENDDO
              DO I=1,NINC
                IMOT1=MOTS(i)
                DO J=1,NINC
                  IMOT2=MCHAM1.NOMCHE(J)
                  IF (IMOT1.EQ.IMOT2) IVAL(I)=J
                ENDDO
              ENDDO
              DO I=1,NBCOMP
                MELVA1=MCHAM1.IELVAL(IVAL(I))
                MELVAL=IELVAL(I)
                SEGACT,MELVAL*MOD,MELVA1
                DO j=1,N1EL
                  DO k=1,N1PTEL
                    VELCHE(k,j)=MELVA1.VELCHE(k,j)
                  ENDDO
                ENDDO
                SEGDES,MELVA1
              ENDDO
C activation des composantes supplementaires
              DO i=NBCOMP+1,N2
                MELVAL=IELVAL(i)
                SEGACT,MELVAL*MOD
              ENDDO
              NBPTE1=N1PTEL
              NEL1=N1EL
              SEGDES,MCHAM1
              NUMPOI=1
              MELEME=IPOGEO
              IPT1=ITGEOM
              SEGACT,MELEME,IPT1
              NBMA1=NUM(/1)
              DO IEF=1,NUM(/2)
                DO IEM=1,IPT1.NUM(/2)
                  JNE=0
                  DO INM=1,IPT1.NUM(/1)
                    DO INF=1,NBMA1
                      IF (IPT1.NUM(INM,IEM).EQ.NUM(INF,IEF)) JNE=JNE+1
                    ENDDO
                  ENDDO
                  IF (JNE.EQ.NBMA1) GOTO 170
                ENDDO
                SEGDES,IPT1,MELEME
                DO j=1,N2
                  MELVAL=IELVAL(j)
                  SEGSUP,MELVAL
                ENDDO
                SEGDES,MCHAML
*? Achtung      SEGSUP,IPT3
*? Erreur a voir
                CALL ERREUR(21)
                GOTO 9901
C      CDG element de "volume"
C      CDG de la "face"
C      Calcul de la normale interieure (stocker dans MCHAML)
 170            NBM=IPT1.NUM(/1)
                IF (IDIM.EQ.2) THEN
                  XG=XZero
                  YG=XZero
                  DO INM=1,NBM
                    IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
                    XG=XG+XCOOR(IREFM+1)
                    YG=YG+XCOOR(IREFM+2)
                  ENDDO
                  XG=XG/NBM
                  YG=YG/NBM
                  XK=XZero
                  YK=XZero
                  DO INF=1,NBMA1
                    IREFF=(NUM(INF,IEF)-1)*idimp1
                    XK=XK+XCOOR(IREFF+1)
                    YK=YK+XCOOR(IREFF+2)
                  ENDDO
                  XK=XK/NBMA1
                  YK=YK/NBMA1
                  V1=XG-XK
                  V2=YG-YK
                  VN=SQRT(V1*V1+V2*V2)
                  V1=V1/VN
                  V2=V2/VN
                  DO INF=1,NBMA1
                    MELVAL=IELVAL(NBCOMP+1)
                    VELCHE(INF,IEF)=V1
                    MELVAL=IELVAL(NBCOMP+2)
                    VELCHE(INF,IEF)=V2
                  ENDDO
                ELSE IF (IDIM.EQ.3) THEN
                  XG=XZero
                  YG=XZero
                  ZG=XZero
                  DO INM=1,NBM
                    IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
                    XG=XG+XCOOR(IREFM+1)
                    YG=YG+XCOOR(IREFM+2)
                    ZG=ZG+XCOOR(IREFM+3)
                  ENDDO
                  XG=XG/NBM
                  YG=YG/NBM
                  ZG=ZG/NBM
                  XK=XZero
                  YK=XZero
                  ZK=XZero
                  DO INF=1,NBMA1
                    IREFF=(NUM(INF,IEF)-1)*idimp1
                    XK=XK+XCOOR(IREFF+1)
                    YK=YK+XCOOR(IREFF+2)
                    ZK=ZK+XCOOR(IREFF+3)
                  ENDDO
                  XK=XK/NBMA1
                  YK=YK/NBMA1
                  ZK=ZK/NBMA1
                  V1=XG-XK
                  V2=YG-YK
                  V3=ZG-ZK
                  VN=SQRT(V1*V1+V2*V2+V3*V3)
                  V1=V1/VN
                  V2=V2/VN
                  V3=V3/VN
                  DO INF=1,NBMA1
                    MELVAL=IELVAL(NBCOMP+1)
                    VELCHE(INF,IEF)=V1
                    MELVAL=IELVAL(NBCOMP+2)
                    VELCHE(INF,IEF)=V2
                    MELVAL=IELVAL(NBCOMP+3)
                    VELCHE(INF,IEF)=V3
                  ENDDO
                ELSE IF (IDIM.EQ.1) THEN
                  XG=XZero
                  DO INM=1,NBM
                    IREFM=(IPT1.NUM(INM,IEM)-1)*idimp1
                    XG=XG+XCOOR(IREFM+1)
                  ENDDO
                  XG=XG/NBM
                  XK=XZero
                  DO INF=1,NBMA1
                    IREFF=(NUM(INF,IEF)-1)*idimp1
                    XK=XK+XCOOR(IREFF+1)
                  ENDDO
                  XK=XK/NBMA1
                  V1=XG-XK
                  V1=V1/ABS(V1)
                  DO INF=1,NBMA1
                    MELVAL=IELVAL(NBCOMP+1)
                    VELCHE(INF,IEF)=V1
                  ENDDO
                ENDIF
              ENDDO
              DO j=1,IDIM
                MELVAL=IELVAL(NBCOMP+j)
                SEGDES,MELVAL
              ENDDO
              SEGDES,MCHAML
              SEGDES,IPT1,MELEME
            ENDIF
*   CHAMELEM ELEMENTAIRE DES FLUX NODAUX EQUIVALENTS
            L1=7
            N1=1
            N3=1
            SEGINI,MCHELM
            IPCHEL=MCHELM
            TITCHE='CHALEUR'
            IFOCHE=IFOUR
            INFCHE(1,1)=0
            IMACHE(1)=IPOGEO
            N2=1
            SEGINI,MCHAML
            ICHAML(1)=MCHAML
            NOMCHE(1)='FLUX'
            TYPCHE(1)='REAL*8'
*   CALCUL DES FLUX NODAUX EQUIVALENTS
*   FACES ASSOCIEES SEG2 OU SEG3
            IF (NEFACE.EQ.2.OR.NEFACE.EQ.3) THEN
              CALL FLUMA2(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ)
*   FACES ASSOCIEES TRI3,TRI6,QUA4 OU QUA8
            ELSE IF (NEFACE.EQ. 4.OR.NEFACE.EQ.6.OR.NEFACE.EQ.8.OR.
     .               NEFACE.EQ.10) THEN
              CALL FLUMA3(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ)
*   FACES ASSOCIEES POI1
            ELSE IF (NEFACE.EQ.45) THEN
              CALL FLUMA1(IPFLOD,IPOGEO,IPINTE,NUMPOI,IPFLEQ)
            ENDIF
            IF (NUMPOI.EQ.1) THEN
              MCHAM2=IPFLOD
              SEGACT,MCHAM2
              DO i=1,MCHAM2.IELVAL(/1)
                MELVAL=MCHAM2.IELVAL(i)
                SEGSUP,MELVAL
              ENDDO
              SEGSUP,MCHAM2
            ENDIF
            IF (IERR.NE.0) THEN
              SEGSUP,MCHAML,MCHELM
              GOTO 9901
            ENDIF
            IELVAL(1)=IPFLEQ
            SEGDES,MCHAML,MCHELM
*     ON TRANSFORME LE CHAMELEM EN CHPOINT
            CALL CHAMPO(IPCHEL,0,IPCH1,IDUM)
            MCHPOI=IPCH1
            SEGACT,MCHPOI
            DO i=1,IPCHP(/1)
              MSOUPO=IPCHP(i)
              SEGACT,MSOUPO*MOD
              NOCOMP(1)=nomcq
              SEGDES,MSOUPO
            ENDDO
            SEGDES,MCHPOI
            CALL DTCHEL(IPCHEL)
*    ON REGROUPE,LE CAS ECHEANT,LES DIFFERENTS CHPOINTS
            IF ((ISOU-IRRT).GT.1.OR.IMAIL.GT.1) THEN
              CALL ADCHPO(IPCH1,IPFLUX,IRET,XUn,XUn)
              IF (IRET.EQ.0) GOTO 9901
C*            CALL ECRCHA('GEOM')
              CALL DTCHPO(IPCH1)
C*            CALL ECRCHA('GEOM')
              CALL DTCHPO(IPFLUX)
              IPFLUX=IRET
            ELSE
              IPFLUX=IPCH1
            ENDIF
          ENDDO
 9901   CONTINUE
        SEGDES,IPT3
 9900   CONTINUE
        SEGDES,IMODEL
        IF (IERR.NE.0) GOTO 9999
      ENDDO

* IL N'EXISTE PAS D'ELEMENTS COMMUNS AU CHPOINT DES FLUX NODAUX
* ET A L'ENVELOPPE DU MASSIF
      IF (IRRT.EQ.NSOU) CALL ERREUR(408)

 9999 CONTINUE
      SEGDES,MMODEL
      IF (MLMOTX.NE.0) THEN
        MLMOTS = MLMOTX
        SEGDES,MLMOTS
      ENDIF

      RETURN
      END