C AMELIO    SOURCE    CHAT      05/01/12    21:21:20     5004
C   CE SOUS PROGRAMME AMELIORE LA QUALITE DU MAILLAGE ISSU DE TRANSF
C   EN DEUX TEMPS   INVERSION DES DIAGONALES PUIS DEPLACEMENT DES NOEUDS
C
      SUBROUTINE AMELIO(X,NUM,NUMELG ,NUMNP,NUMINI,ICLE,IVOI,ISUP,QUAL,
     # KON,NCTIN,NBNN)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)

-INC PPARAM
-INC CCOPTIO
      DIMENSION X(3,1),NUM(NBNN,1),IVOI(1),KON(ISUP,1)
C  LA QUALITE N'EST AUTRE QUE LE RAPPORT DE LA SURFACE ET DU CARRE DU
C    PLUS GRAND COTE
      CAL(I,J,K)=((X(1,J)-X(1,I))*(X(2,K)-X(2,J))-(X(2,J)-X(2,I))*
     # (X(1,K)-X(1,J)))/(0.866*MAX((X(1,J)-X(1,I))**2+(X(2,J)-X(2,I))
     # **2,(X(1,K)-X(1,J))**2+(X(2,K)-X(2,J))**2,(X(1,I)-X(1,K))**2+
     #  (X(2,I)-X(2,K))**2))
      ANG(I,J,K)=ATAN2((X(1,J)-X(1,K))*(X(2,J)-X(2,I))-(X(2,J)-X(2,K))*
     #  (X(1,J)-X(1,I)),(X(1,J)-X(1,K))*(X(1,J)-X(1,I))+(X(2,J)-X(2,K))*
     #  (X(2,J)-X(2,I)))
      IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NUMELG,NUMINI,NUMNP
 1000 FORMAT(' AJUST A FAIT ',I5,' ELEMENTS ET LES NOEUDS DE ',I5,' A ',
     #I6)
      IF (NUMELG.LE.1) RETURN
      IRANGE=NUMNP-NCTIN+1
      DO 200 I=1,IRANGE
 200  IVOI(I)=0
      DO 202 I=1,NBNN
      DO 201 J=1,NUMELG
      IF (NUM(I,J).EQ.0) GOTO 201
      IA=NUM(I,J)-NCTIN+1
      IF (IA.LT.1) GOTO 201
      IVOI(IA)=IVOI(IA)+1
      KON(IVOI(IA),IA)=J
 201  CONTINUE
 202  CONTINUE
      IF (ICLE.EQ.10) GOTO 501
      I=0
   1  I=I+1
      IF (I.GT.NUMELG) GOTO 3
      I1=NUM(1,I)
      I2=NUM(2,I)
      I3=NUM(3,I)
      CALI=CAL(I1,I2,I3)
      IF (NBNN.EQ.3.AND.CALI.GE.QUAL) GOTO 1
      IF (NBNN.EQ.4.AND.NUM(4,I).NE.0) GOTO 1
      DO 4 IPOI=1,3
      IRP=NUM(IPOI,I)-NCTIN+1
      IF (IRP.LT.1) GOTO 4
      NM=IVOI(IRP)
      IF (NM.EQ.0) GOTO 4
      DO 2 JAUX=1,NM
      J=KON(JAUX,IRP)
      IF (J.GT.NUMELG) GOTO 2
      IF (NBNN.EQ.4.AND.NUM(4,J).NE.0) GOTO 2
      IF (I1.EQ.NUM(1,J)) GOTO 11
      IF (I1.EQ.NUM(2,J)) GOTO 21
      IF (I1.EQ.NUM(3,J)) GOTO 31
      IF (I2.EQ.NUM(1,J)) GOTO 41
      IF (I2.EQ.NUM(2,J)) GOTO 51
      IF (I2.EQ.NUM(3,J)) GOTO 61
      GOTO 2
  11  IF (I2.EQ.NUM(3,J)) GOTO 12
      IF (I3.NE.NUM(2,J)) GOTO 2
      IAA=I1
      I1=I3
      I3=I2
      I2=IAA
      JJ=NUM(3,J)
      GOTO 100
  12  JJ=NUM(2,J)
      GOTO 100
  21  IF (I2.EQ.NUM(1,J)) GOTO 22
      IF (I3.NE.NUM(3,J)) GOTO 2
      IAA=I1
      I1=I3
      I3=I2
      I2=IAA
      JJ=NUM(1,J)
      GOTO 100
  22  JJ=NUM(3,J)
      GOTO 100
  31  IF (I2.EQ.NUM(2,J)) GOTO 32
      IF (I3.NE.NUM(1,J)) GOTO 2
      IAA=I1
      I1=I3
      I3=I2
      I2=IAA
      JJ=NUM(2,J)
      GOTO 100
  32  JJ=NUM(1,J)
      GOTO 100
  41  IF (I3.NE.NUM(3,J)) GOTO 2
      IAA=I1
      I1=I2
      I2=I3
      I3=IAA
      JJ=NUM(2,J)
      GOTO 100
  51  IF (I3.NE.NUM(1,J)) GOTO 2
      IAA=I1
      I1=I2
      I2=I3
      I3=IAA
      JJ=NUM(3,J)
      GOTO 100
  61  IF (I3.NE.NUM(2,J)) GOTO 2
      IAA=I1
      I1=I2
      I2=I3
      I3=IAA
      JJ=NUM(1,J)
 100  CONTINUE
      IF (NBNN.EQ.3) GOTO 101
C  ON TENTE D'ASSEMBLER UN QUADRANGLE
      IF (IIMPI.EQ.2) WRITE (IOIMP,1013) I,J,I1,JJ,I2,I3
 1013 FORMAT (' TEST QUADRANGLES AVEC LES TRIANGLES ',6I5)
      AN=ANG(I3,I1,JJ)
      IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
      AN=ANG(I1,JJ,I2)
      IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
      AN=ANG(JJ,I2,I3)
      IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
      AN=ANG(I2,I3,I1)
      IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
C  VA POUR UN QUADRANGLE
      NUM(1,I)=I1
      NUM(2,I)=JJ
      NUM(3,I)=I2
      NUM(4,I)=I3
      IF (IIMPI.NE.0) WRITE (IOIMP,1012) I,J,I1,JJ,I2,I3
 1012 FORMAT (' REUNION DES TRIANGLES ',6I5)
      NUMELG=NUMELG-1
      IF (I.GT.J) I=I-1
      DO 102 K=J,NUMELG
      NUM(1,K)=NUM(1,K+1)
      NUM(2,K)=NUM(2,K+1)
      NUM(3,K)=NUM(3,K+1)
      NUM(4,K)=NUM(4,K+1)
 102  CONTINUE
*  OCTOBRE 1987 IL FAUT AUSSI METTRE A JOUR KON
      DO 103 K1=1,ISUP
      DO 104 K2=1,IRANGE
*>>>>> P.M. 16/11/90
*+*   IF (KON(K1,K2).GT.J) KON(K1,K2)=KON(K1,K2)-1
      IF (KON(K1,K2).GT.J) THEN
         KON(K1,K2)=KON(K1,K2)-1
      ELSE IF (KON(K1,K2).EQ.J) THEN
         IVOI(K2) = IVOI(K2) - 1
         DO 105 K1B = K1,IVOI(K2)
            KON(K1B,K2) = KON(K1B+1,K2)
  105    CONTINUE
      END IF
*<<<<<
 104  CONTINUE
 103  CONTINUE
      ICLE=6
      GOTO 1
 101  IF (CALI.GE.QUAL.AND.NBNN.EQ.4) GOTO 2
      CALS=CAL(I1,JJ,I3)
      IF (CALS.LT.CALI) GOTO 2
      CALT=CAL(JJ,I2,I3)
      IF (CALT.LT.CALI) GOTO 2
C  ON PEUT COUPER SUIVANT LA DEUXIEME DIAGONALE
      NUM(1,I)=I1
      NUM(2,I)=JJ
      NUM(3,I)=I3
      NUM(1,J)=JJ
      NUM(2,J)=I2
      NUM(3,J)=I3
      IF (CALS.LT.QUAL.OR.CALT.LT.QUAL) ICLE=6
      GOTO 5
   2  CONTINUE
   4  CONTINUE
      IF (CALI.GE.QUAL) GOTO 5
C  C'EST L'ECHEC
      IF (IIMPI.EQ.1) WRITE (IOIMP,1005) I,I1,I2,I3,CALI
 1005 FORMAT (' ELEMENT ',I5,' FORME DES NOEUDS SOMMETS ',3I5,' QUALITE
     # ',G12.5)
      IF (ICLE.NE.6) ICLE=5
   5  CONTINUE
      GOTO 1
   3  CONTINUE
C  DEPLACEMENT DES NOEUDS
      GOTO 560
 501  CONTINUE
      IF (NUMINI.GT.NUMNP) RETURN
      DO 500 I=NUMINI,NUMNP
      IR=I-NCTIN+1
      LONG=IVOI(IR)
      IF (LONG.EQ.0) GOTO 500
      XGRAV=0.
      YGRAV=0.
      XNOMB=0.
      DO 502 J=1,LONG
      LEL=KON(J,IR)
      I1=NUM(1,LEL)
      I2=NUM(3,LEL)
      IF (I1.NE.I) GOTO 540
      I1=NUM(2,LEL)
      IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I2=NUM(4,LEL)
      GOTO 541
 540  IF (I2.NE.I) GOTO 541
      I2=NUM(2,LEL)
      IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I1=NUM(4,LEL)
 541  CONTINUE
      XCOF=1.
      XGRAV=XGRAV+XCOF*(X(1,I1)+X(1,I2))
      YGRAV=YGRAV+XCOF*(X(2,I1)+X(2,I2))
      XNOMB=XNOMB+2.*XCOF
      IF (NBNN.NE.4.OR.NUM(4,LEL).EQ.0) GOTO 502
      I5=NUM(1,LEL)+NUM(2,LEL)+NUM(3,LEL)+NUM(4,LEL)-I-I1-I2
      XGRAV=XGRAV+2.*XCOF*X(1,I5)
      YGRAV=YGRAV+2.*XCOF*X(2,I5)
      XNOMB=XNOMB+2.*XCOF
 502  CONTINUE
      X(1,I)=XGRAV/XNOMB
      X(2,I)=YGRAV/XNOMB
 500  CONTINUE
      DO 510 IAAUX=NUMINI,NUMNP
      I=NUMNP-IAAUX+NUMINI
      IR=I-NCTIN+1
      LONG=IVOI(IR)
      IF (LONG.EQ.0) GOTO 510
      XGRAV=0.
      YGRAV=0.
      XNOMB=0.
      DO 512 J=1,LONG
      LEL=KON(J,IR)
      I1=NUM(1,LEL)
      I2=NUM(3,LEL)
      IF (I1.NE.I) GOTO 550
      I1=NUM(2,LEL)
      IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I2=NUM(4,LEL)
      GOTO 551
 550  IF (I2.NE.I) GOTO 551
      I2=NUM(2,LEL)
      IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I1=NUM(4,LEL)
 551  CONTINUE
      XCOF=1.
      XGRAV=XGRAV+XCOF*(X(1,I1)+X(1,I2))
      YGRAV=YGRAV+XCOF*(X(2,I1)+X(2,I2))
      XNOMB=XNOMB+2.*XCOF
      IF (NBNN.NE.4.OR.NUM(4,LEL).EQ.0) GOTO 512
      I5=NUM(1,LEL)+NUM(2,LEL)+NUM(3,LEL)+NUM(4,LEL)-I-I1-I2
      XGRAV=XGRAV+2*XCOF*X(1,I5)
      YGRAV=YGRAV+2*XCOF*X(2,I5)
      XNOMB=XNOMB+2*XCOF
 512  CONTINUE
      X(1,I)=XGRAV/XNOMB
      X(2,I)=YGRAV/XNOMB
 510  CONTINUE
      RETURN
 560  CONTINUE
      IF (IIMPI.EQ.1) WRITE (IOIMP,1011)
 1011 FORMAT(' RECHERCHE DE LA QUALITE MINIMALE APRES DEPLACEMENT DES NO
     #EUDS')
      CALI=1.
      ISAUV=1
      I=0
 520  I=I+1
      IF (I.GT.NUMELG) GOTO 590
      IF (NBNN.EQ.4.AND.NUM(4,I).NE.0) GOTO 530
 591  CONTINUE
      I1=NUM(1,I)
      I2=NUM(2,I)
      I3=NUM(3,I)
      CALJ=CAL(I1,I2,I3)
      IF (CALJ.GE.CALI) GOTO 520
      ISAUV=I
      CALI=CALJ
      GOTO 520
 590  CONTINUE
      I1=NUM(1,ISAUV)
      I2=NUM(2,ISAUV)
      I3=NUM(3,ISAUV)
      IF (IIMPI.EQ.1) WRITE (IOIMP,1005) ISAUV,I1,I2,I3,CALI
      NUM2=NUMELG
      RETURN
C  ON CONVERTIT LES QUADRANGLES APLATIS EN COUPLES DE TRIANGLES
 530  CONTINUE
      I1=NUM(1,I)
      I2=NUM(2,I)
      I3=NUM(3,I)
      I4=NUM(4,I)
      ANG1=ANG(I4,I1,I2)
      IF (ANG1.GT.0..AND.ANG1.LT.2.6) GOTO 522
 523  ICLE=6
      NUM(4,I)=0
      NUMELG=NUMELG+1
      NUM(1,NUMELG)=I1
      NUM(2,NUMELG)=I3
      NUM(3,NUMELG)=I4
      NUM(4,NUMELG)=0
      GOTO 591
 522  ANG3=ANG(I2,I3,I4)
      IF (ANG3.LT.0..OR.ANG3.GT.2.6) GOTO 523
 525  ANG2=ANG(I1,I2,I3)
      IF (ANG2.GT.0..AND.ANG2.LT.2.6) GOTO 526
 527  NUM(4,I)=0
      ICLE=6
      NUM(3,I)=I4
      NUMELG=NUMELG+1
      NUM(1,NUMELG)=I2
      NUM(2,NUMELG)=I3
      NUM(3,NUMELG)=I4
      NUM(4,NUMELG)=0
      GOTO 591
 526  ANG4=ANG(I3,I4,I1)
      IF (ANG4.LT.0..OR.ANG4.GT.2.6) GOTO 527
      GOTO 520
      END