C LISSAG    SOURCE    FANDEUR   22/01/03    21:15:27     11136          
      SUBROUTINE LISSAG
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8(A-H,O-Z)
-INC PPARAM
-INC CCOPTIO
-INC SMELEME
-INC SMLREEL
-INC SMCHPOI
-INC SMCOORD
      SEGMENT EDICON
        INTEGER  KSTRT, KSTEP, NMIR, IS
        REAL*8  CROT , SROT , SYMFCT
        LOGICAL LREAL, LIMAG
      ENDSEGMENT
      SEGMENT ICPR(nbpts)
      SEGMENT IVOISI
         INTEGER IVOI(LL,MM),INB(MM)
      ENDSEGMENT
      SEGMENT ICOO
        REAL*8 X(MV),Y(MV),P(MV),WNODE(MV)
        INTEGER LISVO(MV)
      ENDSEGMENT
      SEGMENT IVAL
        REAL*8 VAL(nbpts)
      ENDSEGMENT
      SEGMENT ITRAVA
        REAL*8 KENN(M42,2),SIGMA(M42),DELRHO(M42),C(M50,M50)
        REAL*8 AK(M50),UM(M50),RM(M50)
       INTEGER IL(M50)
      ENDSEGMENT
      CHARACTER*4 MCLE(3)
      DATA MCLE/'PLAN','AXIS','POID'/
      IF (IDIM .NE. 2) THEN
          CALL ERREUR(19)
          RETURN
      ENDIF
      U=0
      UX=1
      UY=2
      UXX=3
      UXY=4
      UYY=5
      CALL LIROBJ('MAILLAGE',IPT1,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIROBJ('MAILLAGE',IPT2,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIROBJ('CHPOINT ',MCHPOI,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIRENT ( ITYPE,1,IRETOU)
      IF(IERR.NE.0) RETURN
      CALL LIRMOT ( MCLE,2,ICOOR,1)
      IF(IERR.NE.0) RETURN
      CALL LIRMOT( MCLE(3),1,IVAL,0)
        W1ST=1.
        W1ND=1.
      IF(IVAL.NE.0) THEN
           CALL LIRREE( W1ST,1,IRETOU)
      IF(IERR.NE.0) RETURN
           CALL LIRREE( W1ND,1,IRETOU)
      IF(IERR.NE.0) RETURN
      ENDIF
      CALL LIROBJ( 'POINT   ', IPO,0,IRETOU)
             XORG=0.D0
             YORG=0.D0
          IF(IRETOU.NE.0) THEN
                XORG=XCOOR((IPO-1)*(IDIM+1) +1)
                YORG=XCOOR((IPO-1)*(IDIM+1) +1)
          ENDIF
C
C
C  MISE SOUS FORME D'ELEMENTS POINTS DU 2EME MAILLAGE. IL SERVIRA AU
C  CHPOINT RESULTAT
C
      SEGACT IPT2
      CALL CHANGE(IPT2,1)
C       WRITE(6,FMT='( '' SORTIE DE CHANGE '')')
C
C IVOI(I,J)=K VEUT DIRE QUE LE IEME VOISIN DU NOEUD J A LENUMERO GLOBAL K
C INB(J)= K VEUT DIRE QUE LE JEME POINT LOCAL A K VOISIN
C
      SEGINI ICPR
      SEGACT IPT1
      MELEME = IPT1
      IF(ITYPEL.EQ.1) THEN
         CALL ERREUR(16)
         RETURN
      ENDIF
      LIS = MAX(IPT1.LISOUS(/1),1)
      MM =  0
      DO 2 L=1,LIS
      IF(IPT1.LISOUS(/1).NE.0) THEN
         MELEME=IPT1.LISOUS(L)
         SEGACT MELEME
      ENDIF
      NBEL= NUM(/2)
      NBP= NUM(/1)
      DO 3 I=1,NBEL
        DO 3 J=1,NBP
        IKI =NUM(J,I)
        IF(ICPR(IKI).NE.0) GO TO 3
        MM = MM + 1
        ICPR(IKI) = MM
   3  CONTINUE
      IF(IPT1.LISOUS(/1).NE.0) THEN
         SEGDES MELEME
      ENDIF
   2  CONTINUE
   4  CONTINUE
C  INITIALISATION DE LL AU PIFIFL FAUDRA TESTER LES DEBORDEMENTS
      IV = NBP - 1
      LL= IV * 3
      SEGINI IVOISI
      MELEME = IPT1
      LIS=MAX(1,IPT1.LISOUS(/1))
      DO 6 LI=1,LIS
      IF(IPT1.LISOUS(/1).NE.0) THEN
        MELEME=IPT1.LISOUS(LI)
        SEGACT MELEME
      ENDIF
      DO 7 I=1,NUM(/2)
        DO 8 J=1,NUM(/1)-1
          IGLO= NUM(J,I)
          ILO = ICPR(IGLO)
          DO 9 K = J+1,NUM(/1)
             IGLA= NUM(K,I)
             ILA = ICPR(IGLA)
             IF(INB(ILO).GT.0) THEN
                DO 10 L=1,INB(ILO)
                  IF(IVOI(L,ILO).EQ.IGLA) GO TO 9
  10            CONTINUE
             ENDIF
             INB(ILO)=INB(ILO)+1
             INB(ILA)=INB(ILA)+1
             IF(INB(ILO).GT.LL.OR.INB(ILA).GT.LL) THEN
                LL = LL + IV
                SEGADJ IVOISI
             ENDIF
             IVOI(INB(ILO),ILO)=IGLA
             IVOI(INB(ILA),ILA)=IGLO
    9     CONTINUE
    8   CONTINUE
    7 CONTINUE
      IF(IPT1.LISOUS(/1).EQ.0) THEN
         SEGDES MELEME
      ENDIF
    6 CONTINUE
C      WRITE(6,FMT='('' ICPR'',/,(10I6))')(ICPR(KJI),KJI=1,27)
C      WRITE(6,FMT='('' INB'',/,(10I6))')(INB(KJI),KJI=1,17)
C      DO 1234 KL=1,17
C      WRITE(6,FMT='('' IVOI'',/,(10I6))')(IVOI(KJI,KL),KJI=1,INB(KL))
C 1234 CONTINUE
      SEGINI EDICON
C
C
C  ON BOUCLE SUR LES POINTS DU 2EME  MAILLAGE LES ETAPES SONT:
C  RECHERCHE DU POINT DU MAILLAGE 1 LE PLUS PROCHE
C  FABRICATION DE LA PREMIERE COUCHE DE VOISINS
C  FABRICATION DE LA DEUXIEME COUCHE DE VOISINS
C  FABRICATION DU TABLEAU CONTENANT LES COORDONNEES
C  FABRICATIONS DU TABLEAU CONTENANT LES VALEURS DU CHAMP
C  APPEL DE LA FONCTION LISSAGE
C  REMPLISSAGE DU CHPOINT RESULTAT
C  FIN DE BOUCLE
C
C  ECLATEMENT DU CHPOINT INITIAL
C
      SEGACT MCHPOI
      NAT=JATTRI(/1)
      IF(IPCHP(/1).NE.1) CALL ERREUR (25)
      IF(IERR.NE.0) RETURN
      MSOUPO=IPCHP(1)
      SEGACT MSOUPO
      IPT3=IGEOC
      SEGACT IPT3
      MPOVAL=IPOVAL
      SEGINI IVAL
      SEGACT MPOVAL
      DO 19 I=1,IPT3.NUM(/2)
        IGLO=IPT3.NUM(1,I)
        VAL(IGLO)=VPOCHA(I,1)
   19 CONTINUE
      SEGDES MPOVAL,IPT3
C  CREATION DU CHPOINT RESULTAT
      NSOUPO=1
      SEGINI MCHPO1
      DO 18 II=1,NAT
        MCHPO1.JATTRI(II)=JATTRI(II)
   18 CONTINUE
      NC=7
      SEGINI MSOUPO
      MCHPO1.IPCHP(1)=MSOUPO
      MCHPO1.IFOPOI=IFOUR
      SEGDES MCHPO1,MCHPOI
      NOCOMP(1)='A'
      NOCOMP(2)='BX'
      NOCOMP(3)='BY'
      NOCOMP(4)='BXX'
      NOCOMP(5)='BXY'
      NOCOMP(6)='BYX'
      NOCOMP(7)='BYY'
      NOHARM(1)=NIFOUR
      NOHARM(2)=NIFOUR
      NOHARM(3)=NIFOUR
      NOHARM(4)=NIFOUR
      NOHARM(5)=NIFOUR
      NOHARM(6)=NIFOUR
      NOHARM(7)=NIFOUR
      IGEOC=IPT2
      SEGACT IPT2
      N = IPT2.NUM(/2)
      SEGINI MPOVAL
      IPOVAL=MPOVAL
      SEGDES MSOUPO
      MV=50
      SEGINI ICOO
       M42 = 42
       M50 = 50
      M42 = 84
      M50 = 100
      SEGINI ITRAVA
      IDIM1=IDIM+1
      DO 20 I=1,IPT2.NUM(/2)
        IP=IPT2.NUM(1,I)
        DISMI=123456789.E+10
        XA=  XCOOR((IP-1)*IDIM1+1)
        XB=  XCOOR((IP-1)*IDIM1+2)
        XC=0.D0
        IPMIN=0
        IF(IDIM.GT.2)XC=XCOOR((IP-1)*IDIM1+3)
        DO 21 J=1,ICPR(/1)
          IF(ICPR(J).EQ.0) GO TO 21
          YA=XCOOR((J-1)*IDIM1 +1)
          YB=XCOOR((J-1)*IDIM1+2)
          YC=0.D0
          IF(IDIM.GT.2)YC=XCOOR((J-1)*IDIM1+3)
          XDI=(YA-XA)*(YA-XA) + (YB-XB)*(YB-XB) + (YC-XC)*(YC-XC)
          IF(XDI.LE.DISMI) THEN
            DISMI=XDI
            IPMIN=J
          ENDIF
   21   CONTINUE
C        WRITE(6,FMT='( '' POINT INI ET PROCHE '',2I5)') IP,IPMIN
        ILOC=ICPR(IPMIN)
        INN=INB(ILOC)
        IF(INN.GT.LISVO(/1)) THEN
          MV=MV+50
          SEGSUP ICOO
          SEGINI ICOO
        ENDIF
        LISVO(1)=IPMIN
        DO 22 K=1,INN
          LISVO(K+1)=IVOI(K,ILOC)
   22   CONTINUE
        IDE=INN+1
        DO 23 K=1,INN+1
          ILOA=ICPR(LISVO(K))
          INV=INB(ILOA)
          DO 24 L=1,INV
            ICAND = IVOI(L,ILOA)
            DO 25 M=1,IDE
              IF(ICAND.EQ.LISVO(M) ) GO TO 24
   25       CONTINUE
            IDE=IDE+1
            IF(IDE.GT.MV) THEN
              MV=MV+50
              SEGADJ ICOO
            ENDIF
            LISVO(IDE)=ICAND
   24     CONTINUE
   23   CONTINUE
        DO 26 K=1,IDE
          IGLO= LISVO(K)
          X(K)=XCOOR((IGLO-1)*(IDIM+1)+ 1)
          Y(K)=XCOOR((IGLO-1)*(IDIM+1)+ 2)
          WNODE(K)=W1ND
          P(K)=VAL(IGLO)
   26   CONTINUE
        DO 27 K=1,INN
   27   WNODE(K) = W1ST
C       WRITE(6,FMT= '('' LISTE DES VOISINS '',/,(10I6))')(LISVO(KJI),
C      $KJI=1,IDE)
C       WRITE(6,FMT= '('' WNODE  '',/,(6E12.5))')(WNODE(KIJ),KIJ=1,IDE)
C       WRITE(6,FMT= '('' POTENTIEL'',/,(6E12.5))')(P(KIJ),KIJ=1,IDE)
        IBON=1
C       CALCUL  DES PARAMETRES
        M42CA = 84
        M50CA = 100
        IF ( M42.GT.M42CA) THEN
           M42=M42CA
           IBON=0
         ENDIF
         IF(M50.GT.M50CA) THEN
             M50=M50CA
           IBON=0
          ENDIF
         IF(IBON.EQ.0) THEN
            SEGSUP ITRAVA
           SEGINI ITRAVA
         ENDIF
C   APPEL DE LA FONCTION LISSAGE  EN SORTIE U,UX,UY,UXX,UXY,UYY SONT
C   LES RESULTATS
C
      KFLAG= 2
      IF ( ICOOR.EQ.1) THEN
C       WRITE (ISORT,'(A)') ,'***********  CARTESIEN ***************  '
      CALL CARSYM (ITYPE,EDICON)
      CALL CARWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
     *XORG,YORG,IDE,EDICON,ICOO,ITRAVA)
      V1= U
      V2=   UY
      V3= - UX
             IF (KFLAG.GT. 1) THEN
      V4 = UXY
      V5 = UYY
      V6 = - UXX
      V7 = - UXY
             END IF
      END IF
      IF ( ICOOR.EQ.2) THEN
C       WRITE (ISORT,'(A)') ,'***********  AXISYMETRIE***************  '
      CALL CYLSYM (ITYPE,EDICON)
      CALL CYLWRK(XA,XB,KFLAG,U,UX,UY,UXX,UXY,UYY,ITYPE,
     *IDE,EDICON,ICOO,ITRAVA)
      V1 = U
      V2 = - UY
      V3 =   UX
             IF (KFLAG.GT. 1) THEN
      V4 = - UXY
      V5 = - UYY
      V6 =  UXX
      V7 =  UXY
             END IF
      END IF
C
C
C
C
C   ON REMPLIT LES VALEURS
C
       VPOCHA(I,1)=V1
       VPOCHA(I,2)=V2
       VPOCHA(I,3)=V3
       VPOCHA(I,4)=V4
       VPOCHA(I,5)=V5
       VPOCHA(I,6)=V6
       VPOCHA(I,7)=V7
   20  CONTINUE
       SEGDES MPOVAL,IPT2
       SEGSUP ICPR,ICOO,IVOISI,IVAL
       CALL ECROBJ('CHPOINT ',MCHPO1)
       RETURN
       END