C FLUCOQ    SOURCE    BP208322  13/07/30    21:15:01     7809           

C=======================================================================
C=                            F L U C O Q                              =
C=                            -----------                              =
C=                                                                     =
C=  Fonction :                                                         =
C=  ----------                                                         =
C=   Calcul des flux nodaux equivalents a une condition de FLUX IMPOSE =
C=   pour des elements de type COQUE                                   =
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 COQUE               =
C=   IPENVE   Pointeur sur l'enveloppe d'un maillage COQUE             =
C=   IPGEOM   Pointeur sur un MAILLAGE elementaire du CHPOINT          =
C=   IPOGEO   Pointeur sur un MAILLAGE commun au CHPOINT et au COQUE   =
C=                                                                     =
C=======================================================================

      SUBROUTINE FLUCOQ (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
      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
      IFOI=0
      DO ISOU=1,NSOU

        IPCHEL=0

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

        IPENVE=ITGEOM

*  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)

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

*  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
              NEFACE=NUMGEO(NEF)
*      RECUPERATION DES CARACTERISTIQUES D'INTEGRATION
            CALL TSHAPE(NEFACE,'GAUSS',IPINTE)
*       ECHEC DANS L'ACQUISITION DES CARACTERISTIQUES D'INTEGRATION
            IF (IERR.NE.0) THEN
              SEGDES,IPT3
              GOTO 8
            ENDIF

*   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) THEN
              SEGDES,IPT3
              GOTO 8
            ENDIF
            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)
                RETURN
              ENDIF
              MLMOTS=MLMOTX
              SEGACT,MLMOTS
              NINC=MOTS(/2)
              IF (NINC.NE.IDIM) THEN
                CALL ERREUR(21)
                SEGDES,MLMOTS
                GOTO 8
              ENDIF
              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
              SEGDES,MLMOTS
              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
                SEGSUP,IPT3
                GOTO 8
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
              SEGDES,IPT3
              SEGSUP,MCHAML,MCHELM
              GOTO 8
            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 8
C*            CALL ECRCHA('GEOM')
              CALL DTCHPO(IPCH1)
C*            CALL ECRCHA('GEOM')
              CALL DTCHPO(IPFLUX)
              IPFLUX=IRET
            ELSE
              IPFLUX=IPCH1
            ENDIF
          ENDDO
          SEGDES,IPT3
*  ON N'A PAS TROUVE DE MAILLAGE COMMUN A CETTE PARTIE DE
*  L'ENVELOPPE ET DU CHPOINT
        ELSE IF (IRR.EQ.1) THEN
          IRRT=IRRT+1
        ENDIF
      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)

 8    DO i=1,IFOI
        IMODEL=KMODEL(i)
        SEGDES,IMODEL
      ENDDO
      SEGDES,MMODEL

      RETURN
      END