C NLOCA1    SOURCE    CHAT      11/03/16    21:28:35     6902           
      SUBROUTINE NLOCA1(IPCHI,IPLMOT,IPCHCO, IPCHO,    IRET)
C_______________________________________________________________________
C
C           CALCUL DE LA MOYENNE NONLOCALE
C
C
C    Entrees:
C    ________
C
C           IPCHI  Pointeur sur un MCHAML de ss-type indifferent
C           IPLMOT Pointeur sur un LISTMOTS de noms de composante
C
C           IPCHCO Pointeur sur un MCHAML de Connectivite
C                  (ss-type CONNECTIVITE NON LOCAL)
C
C    Sorties:
C    ________
C
C           IPCHO  Pointeur sur un MCHAML de meme ss-type que IPCHI
C                  avec les composantes IPLMOT moyennees
C                  les composantes non reconnues dans iplmot sont
C                  recopiees
C
C           IRET   1 ou 0 suivant succes ou pas
C
C
C     Appele par: NLOCAL
C     -----------
C
C     Appel a:
C     --------
C
C           NLOVEP verification et preparation de la moyenne
C           TRTRVE point translate
C           TRSYPT point symetrique par rapport a un point
C           TRSYDR point symetrique par rapport a une droite
C           TRSYPL point symetrique par rapport a un plan
C           DOXE, JACOBI
C
C   P.PEGON OCTOBRE 92 D'APRES C. LA BORDERIE AVRIL 1992 D'APRES P. PEGON
C_______________________________________________________________________
C
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
*
-INC SMMODEL
-INC CCOPTIO
-INC SMELEME
-INC SMCOORD
-INC SMCHAML
-INC SMLENTI
-INC SMLREEL
-INC SMLMOTS
-INC SMINTE
**
*      SEGMENT INFO
*       INTEGER INFELE(JG)
*      ENDSEGMENT
*
      SEGMENT,WRK1
        REAL*8 XE(3,NBNN)
      ENDSEGMENT
*
      SEGMENT NLOC1
        INTEGER ILOC2 (NZONEF)
      END SEGMENT
*
      SEGMENT NLOC2
        INTEGER MPCHAM (NDOUBL)
        INTEGER ILOC4  (NDOUBL)
        INTEGER MODLAC,MAILEF,MINTEF
        INTEGER MAILAC (NSZACC)
        INTEGER MINTAC (NSZACC)
        INTEGER ILOC3  (NSZACC)
        INTEGER ILOC3I,ILOC3O
        INTEGER MELCAR
      END SEGMENT
*
      SEGMENT NLOC3
        INTEGER     MELVAC (NCOMP)
      END SEGMENT
*
      SEGMENT NLOC4
        INTEGER JCLE
        REAL*8 PT1(3),PT2(3),DISP
        INTEGER MELPNI,MELPLI
      END SEGMENT
*
      SEGMENT,WRK2
        REAL*8 XEJ(3,NBNJ),SHP(6,NBNJ)
      ENDSEGMENT
*
      SEGMENT WRK3
        REAL*8 SOMCOM(NCOMP,NBPGAU)
        REAL*8 SOMJAC(      NBPGAU)
      END SEGMENT
*
      POINTEUR MLCOMP.MLENTI
      POINTEUR MLNIMO.MLENTI
*
C
      DIMENSION XXX(3),XXXJ(3)
C+PP
      DATA XMULTL/1.5/
C+PP
      NHRM=NIFOUR
      IRET=1
C
C     ON VERIFIE/PREPARE LES DONNEES
C
      CALL NLOVEP(IPCHCO,IPCHI,IPLMOT, IPCHO,NLOC1,    IRET)
      IF (IRET.EQ.0)RETURN
C
C     ON TRAITE L'INFORMATION
C
C     BOUCLE SUR LES ZONES EFFECTIVES
C
      NZONEF=ILOC2(/1)
      DO ISOUCF=1,NZONEF
C     write(IOIMP,*)'ZONE EFFECTIVE',ISOUCF
         NLOC2=ILOC2(ISOUCF)
         MINTE1=MINTEF
         IPT1=MAILEF
         NDOUBL=ILOC4(/1)
         NLOC3=ILOC3I
         NCOMP=MELVAC(/1)
C
C     NOMBRE DE POINTS DE GAUSS PAR ELEMENTS POUR LA SS ZONE A MOYENNER
C
         NBPGAU=MINTE1.POIGAU(/1)
C
C     NOMBRE D'ELEMENTS ET DE NOEUDS POUR LA SS ZONE A MOYENNER
C
         NBELEM=IPT1.NUM(/2)
         NBNN  =IPT1.NUM(/1)
         SEGINI WRK1
         SEGINI WRK3
C
C     DEBUT DE LA BOUCLE SUR LES ELEMENTS
C
         DO IB=1,NBELEM
C     write(IOIMP,*)' ELEMENT NUMERO',IB
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IB
C
           CALL DOXE(XCOOR,IDIM,NBNN,IPT1.NUM,IB,XE)
C
C      INITIALISATION DES DIVERSES INTEGRATIONS
C
           DO IGAU=1,NBPGAU
             SOMJAC(IGAU)=0.D0
             DO IE1=1,NCOMP
               SOMCOM(IE1,IGAU)=0.D0
             END DO
           END DO
C
C     ON BOUCLE SUR LES DOUBLONS
C
           DO IDOUBL=1,NDOUBL
             NLOC4=ILOC4(IDOUBL)
             ICLE=JCLE
C
C    ON RECUPERE LE NUMERO D'ORDRE DES SOUS ZONES ACCESSIBLES
C
             MELVAL=MELPNI
             MLNIMO=IELCHE(1,IB)
C     write(IOIMP,*)'  DOUBLON ICLE MLNIMO ',IDOUBL,ICLE,MLNIMO
C
C    CET ELEMENT EST IL EN CONNECTIVITE ?
C
             IF (MLNIMO.NE.0)THEN
               SEGACT,MLNIMO
C
C     ON RECUPERE LA LISTE DES ELEMENTS  ACCESSIBLES DANS
C     LE CHAMELEM DE CONNECTIVITE
C
               MELVAL=MELPLI
               MLENTI=IELCHE(1,IB)
               SEGACT,MLENTI
C
C   ON CREE UN MLENT1 QUI PERMETTRA DE TROUVER LE DEBUT DE L'INFORMATION
C   CONCERNANT CHAQUE SS ZONE
C
               JG=1
               SEGINI MLENT1
               MLENT1.LECT(1)=1
               NSOUSA=MLNIMO.LECT(/1)
               IF (NSOUSA.GT.1)THEN
                 DO IISOUJ=2,NSOUSA
                   JG=MLENT1.LECT(/1)+1
                   SEGADJ MLENT1
                   MLENT1.LECT(JG)=MLENT1.LECT(JG-1)+
     1                             LECT(MLENT1.LECT(JG-1))+1
                 END DO
               ENDIF
C
C     DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION
C
               DO IGAU=1,NBPGAU
C
C     ON RECUPERE LA LONGUEUR CARACTERISTIQUE
C
                 MELVAL=MELCAR
                 XLONG=VELCHE(MIN(IGAU,VELCHE(/1)),MIN(IB,VELCHE(/2)))
C     write(IOIMP,*)'   GAUSS-P,XLONG ',IGAU,XLONG
C
C     ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION
C
                 DO IE1=1,3
                   XXX(IE1)=0.D0
                   DO IE2=1,NBNN
                     CGAUSS=MINTE1.SHPTOT(1,IE2,IGAU)
                     XXX(IE1)=XXX(IE1)+XE(IE1,IE2)*CGAUSS
                   END DO
                 END DO
C     write(IOIMP,*)'   XXX ',XXX
C
C     DEBUT DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES
C
                 DO IISOUJ=1,NSOUSA
                   IISOUS=MLNIMO.LECT(IISOUJ)
                   NLOC3=ILOC3(IISOUS)
                   IPT2=MAILAC(IISOUS)
                   MINTE2=MINTAC(IISOUS)
C 
                   NBPGAJ=MINTE2.POIGAU(/1)
                   NBNJ  =IPT2.NUM(/1)
C
                   IG1=MLENT1.LECT(IISOUJ)
                   NBELEJ=LECT(IG1)
C     write(IOIMP,*)'    ZONES-AC,IISOUS ',IISOUJ,IISOUS
C
C     DEBUT DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES
C
                   SEGINI,WRK2
                   DO IIBJ=1,NBELEJ
                     IG1=IG1+1
                     IBJ=LECT(IG1)
C     write(IOIMP,*)'     ELEMENT_AC ',IBJ
C
C     ON CHERCHE  LES COORDONNEES DES NOEUDS DE L ELEMENT IIBJ
C
                     CALL DOXE(XCOOR,IDIM,NBNJ,IPT2.NUM,IBJ,XEJ)
C
C     DEBUT DE LA BOUCLE SUR LES PTS D'INTEGRATION
C
                     DO IGAUJ=1,NBPGAJ
C
C      ON CHERCHE LA POSITION ABSOLUE DU POINT D"INTEGRATION
C
                       DO IE1=1,3
                         XXXJ(IE1)=0.D0
                         DO IE2=1,NBNJ
                           CGAUSS=MINTE2.SHPTOT(1,IE2,IGAUJ)
                           XXXJ(IE1)=XXXJ(IE1)+XEJ(IE1,IE2)*CGAUSS
                         END DO
                       END DO
C     write(IOIMP,*)'      GAUSS-AC ',IGAUJ
C     write(IOIMP,*)'      XXXJ-AS ',XXXJ
C
C     ON TRANSFORME CES COORDONNEES EN FONCTION DES SYMETRIE OU DE LA
C     TRANSLATION
C
                       IF(ICLE.EQ.2)CALL TRTRVE(XXXJ,1,PT1     )
                       IF(ICLE.EQ.3)CALL TRSYPT(XXXJ,1,PT1     )
                       IF(ICLE.EQ.4)CALL TRSYDR(XXXJ,1,PT1,PT2 )
                       IF(ICLE.EQ.5)CALL TRSYPL(XXXJ,1,PT1,DISP)
C     write(IOIMP,*)'      XXXJ-PS ',XXXJ
C
C      ON REMPLIT LES SHP
C
                       DO IE1=1,6
                         DO IE2=1,NBNJ
                           SHP(IE1,IE2)=MINTE2.SHPTOT(IE1,IE2,IGAUJ)
                         END DO
                       END DO
C
C      ON CALCULE LE JACOBIEN
C
                       CALL JACOBI(XEJ,SHP,IDIM,NBNJ,DJAC)
C
C      ON CALCULE LA VALEUR DE LA GAUSSIENNE
C
                       XXLONG=(XXX(1)-XXXJ(1))**2+(XXX(2)-XXXJ(2))**2+
     1                        (XXX(3)-XXXJ(3))**2
                       XXLONG=SQRT(XXLONG)
C     write(IOIMP,*)'      XXLONG,DJAC ',XXLONG,DJAC
                       IF(XXLONG.LE.XMULTL*XLONG)THEN
                         GDEX=EXP(-(2*XXLONG/XLONG)**2)
                         DJAC=MINTE2.POIGAU(IGAUJ)*GDEX*ABS(DJAC)
                         DO IE1=1,NCOMP
                           MELVAL=MELVAC(IE1)
C
C              ON DOIT RETROUVER LE NUMERO D'ELEMENT ATTACHE AU CHAMELEM
C              CORRESPONDANT A CELUI DU MELEME
C
                           IBMN=MIN(IBJ  ,VELCHE(/2))
                           IGMN=MIN(IGAUJ,VELCHE(/1))
                           SOMCOM(IE1,IGAU)=SOMCOM(IE1,IGAU)
     1                                    +VELCHE(IGMN,IBMN)*DJAC
C     write(IOIMP,*)'      VELCHE,DJAC ',VELCHE(IGMN,IBMN),DJAC
                         END DO
                         SOMJAC(IGAU)=SOMJAC(IGAU)+DJAC
                       ENDIF
C
C     FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION
C
                     END DO
C
C     FIN DE LA BOUCLE SUR LES ELEMENTS ACCESSIBLES
C
                   END DO
C
                   SEGSUP,WRK2
C
C     FIN DE LA BOUCLE SUR LES DIFFERENTES ZONES ACCESSIBLES
C
                 END DO
C
C     FIN DE LA BOUCLE SUR LES PTS D'INTEGRATION
C
               END DO
               SEGDES MLENTI
               SEGDES MLNIMO
               SEGSUP MLENT1
C
C     FIN DU TEST D'EXISTENCE DE CONNECTIVITE SUR L'ELEMENT
C
             ENDIF
C
C     FIN DE LA BOUCLE SUR LES DOUBLONS
C
           END DO
C
           NLOC3=ILOC3O
           DO IGAU=1,NBPGAU
             DO IE1=1,NCOMP
               MELVAL=MELVAC(IE1)
               SEGACT MELVAL*MOD
               VELCHE(IGAU,IB)=SOMCOM(IE1,IGAU)/SOMJAC(IGAU)
             END DO
           END DO
C
C     FIN DE LA BOUCLE SUR LES ELEMENTS
C
         END DO
         SEGSUP WRK1
         SEGSUP WRK3
C
C     FIN DE LA BOUCLE SUR LES SOUS ZONES EFFECTIVES
C
      END DO
C
C      DESACTIVATIONS/SUPRESSION
C      WARNING SUR LES DOUBLONS DE MODEL!
C
      DO IZONEF=1,NZONEF
        NLOC2=ILOC2(IZONEF)
        NDOUBL=ILOC4(/1)
        DO IDOUBL=1,NDOUBL
          NLOC4=ILOC4(IDOUBL)
          MELVAL=MELPNI
          SEGDES,MELVAL
          MELVAL=MELPLI
          SEGDES,MELVAL
          SEGSUP,NLOC4
        ENDDO
        NSZACC=ILOC3(/1)
        DO ISZACC=1,NSZACC
          NLOC3=ILOC3(ISZACC)
          SEGSUP,NLOC3
        ENDDO
        NLOC3=ILOC3I
        NCOMP=MELVAC(/1)
        DO ICOMP=1,NCOMP
          MELVAL=MELVAC(ICOMP)
          SEGDES,MELVAL
        ENDDO
        SEGSUP,NLOC3
        NLOC3=ILOC3O
        NCOMP=MELVAC(/1)
        DO ICOMP=1,NCOMP
          MELVAL=MELVAC(ICOMP)
          SEGDES,MELVAL
        ENDDO
        SEGSUP,NLOC3
        MMODEL=MODLAC
        DO ISZACC=1,NSZACC
          MINTE=MINTAC(ISZACC)
          SEGDES,MINTE
          IMODEL=KMODEL(ISZACC)
          SEGDES,IMODEL
        ENDDO
        MELEME=MAILEF
        SEGDES,MELEME
      ENDDO
      DO IZONEF=1,NZONEF
        NLOC2=ILOC2(IZONEF)
        MMODEL=MODLAC
        SEGDES,MMODEL
        SEGSUP,NLOC2
      ENDDO
      SEGSUP,NLOC1
C
C     BYE BYE
C
      RETURN
      END