Télécharger la plaquette Cast3M


fr en

Télécharger amelio.eso

Retour à la liste

Numérotation des lignes : 

amelio

  1. C AMELIO    SOURCE    CHAT      05/01/12    21:21:20     5004
  2. C   CE SOUS PROGRAMME AMELIORE LA QUALITE DU MAILLAGE ISSU DE TRANSF
  3. C   EN DEUX TEMPS   INVERSION DES DIAGONALES PUIS DEPLACEMENT DES NOEUDS
  4. C
  5.       SUBROUTINE AMELIO(X,NUM,NUMELG ,NUMNP,NUMINI,ICLE,IVOI,ISUP,QUAL,
  6.      # KON,NCTIN,NBNN)
  7.       IMPLICIT INTEGER(I-N)
  8.       IMPLICIT REAL*8 (A-H,O-Z)
  9.  
  10. -INC PPARAM
  11. -INC CCOPTIO
  12.       DIMENSION X(3,1),NUM(NBNN,1),IVOI(1),KON(ISUP,1)
  13. C  LA QUALITE N'EST AUTRE QUE LE RAPPORT DE LA SURFACE ET DU CARRE DU
  14. C    PLUS GRAND COTE
  15.       CAL(I,J,K)=((X(1,J)-X(1,I))*(X(2,K)-X(2,J))-(X(2,J)-X(2,I))*
  16.      # (X(1,K)-X(1,J)))/(0.866*MAX((X(1,J)-X(1,I))**2+(X(2,J)-X(2,I))
  17.      # **2,(X(1,K)-X(1,J))**2+(X(2,K)-X(2,J))**2,(X(1,I)-X(1,K))**2+
  18.      #  (X(2,I)-X(2,K))**2))
  19.       ANG(I,J,K)=ATAN2((X(1,J)-X(1,K))*(X(2,J)-X(2,I))-(X(2,J)-X(2,K))*
  20.      #  (X(1,J)-X(1,I)),(X(1,J)-X(1,K))*(X(1,J)-X(1,I))+(X(2,J)-X(2,K))*
  21.      #  (X(2,J)-X(2,I)))
  22.       IF (IIMPI.EQ.1) WRITE (IOIMP,1000) NUMELG,NUMINI,NUMNP
  23.  1000 FORMAT(' AJUST A FAIT ',I5,' ELEMENTS ET LES NOEUDS DE ',I5,' A ',
  24.      #I6)
  25.       IF (NUMELG.LE.1) RETURN
  26.       IRANGE=NUMNP-NCTIN+1
  27.       DO 200 I=1,IRANGE
  28.  200  IVOI(I)=0
  29.       DO 202 I=1,NBNN
  30.       DO 201 J=1,NUMELG
  31.       IF (NUM(I,J).EQ.0) GOTO 201
  32.       IA=NUM(I,J)-NCTIN+1
  33.       IF (IA.LT.1) GOTO 201
  34.       IVOI(IA)=IVOI(IA)+1
  35.       KON(IVOI(IA),IA)=J
  36.  201  CONTINUE
  37.  202  CONTINUE
  38.       IF (ICLE.EQ.10) GOTO 501
  39.       I=0
  40.    1  I=I+1
  41.       IF (I.GT.NUMELG) GOTO 3
  42.       I1=NUM(1,I)
  43.       I2=NUM(2,I)
  44.       I3=NUM(3,I)
  45.       CALI=CAL(I1,I2,I3)
  46.       IF (NBNN.EQ.3.AND.CALI.GE.QUAL) GOTO 1
  47.       IF (NBNN.EQ.4.AND.NUM(4,I).NE.0) GOTO 1
  48.       DO 4 IPOI=1,3
  49.       IRP=NUM(IPOI,I)-NCTIN+1
  50.       IF (IRP.LT.1) GOTO 4
  51.       NM=IVOI(IRP)
  52.       IF (NM.EQ.0) GOTO 4
  53.       DO 2 JAUX=1,NM
  54.       J=KON(JAUX,IRP)
  55.       IF (J.GT.NUMELG) GOTO 2
  56.       IF (NBNN.EQ.4.AND.NUM(4,J).NE.0) GOTO 2
  57.       IF (I1.EQ.NUM(1,J)) GOTO 11
  58.       IF (I1.EQ.NUM(2,J)) GOTO 21
  59.       IF (I1.EQ.NUM(3,J)) GOTO 31
  60.       IF (I2.EQ.NUM(1,J)) GOTO 41
  61.       IF (I2.EQ.NUM(2,J)) GOTO 51
  62.       IF (I2.EQ.NUM(3,J)) GOTO 61
  63.       GOTO 2
  64.   11  IF (I2.EQ.NUM(3,J)) GOTO 12
  65.       IF (I3.NE.NUM(2,J)) GOTO 2
  66.       IAA=I1
  67.       I1=I3
  68.       I3=I2
  69.       I2=IAA
  70.       JJ=NUM(3,J)
  71.       GOTO 100
  72.   12  JJ=NUM(2,J)
  73.       GOTO 100
  74.   21  IF (I2.EQ.NUM(1,J)) GOTO 22
  75.       IF (I3.NE.NUM(3,J)) GOTO 2
  76.       IAA=I1
  77.       I1=I3
  78.       I3=I2
  79.       I2=IAA
  80.       JJ=NUM(1,J)
  81.       GOTO 100
  82.   22  JJ=NUM(3,J)
  83.       GOTO 100
  84.   31  IF (I2.EQ.NUM(2,J)) GOTO 32
  85.       IF (I3.NE.NUM(1,J)) GOTO 2
  86.       IAA=I1
  87.       I1=I3
  88.       I3=I2
  89.       I2=IAA
  90.       JJ=NUM(2,J)
  91.       GOTO 100
  92.   32  JJ=NUM(1,J)
  93.       GOTO 100
  94.   41  IF (I3.NE.NUM(3,J)) GOTO 2
  95.       IAA=I1
  96.       I1=I2
  97.       I2=I3
  98.       I3=IAA
  99.       JJ=NUM(2,J)
  100.       GOTO 100
  101.   51  IF (I3.NE.NUM(1,J)) GOTO 2
  102.       IAA=I1
  103.       I1=I2
  104.       I2=I3
  105.       I3=IAA
  106.       JJ=NUM(3,J)
  107.       GOTO 100
  108.   61  IF (I3.NE.NUM(2,J)) GOTO 2
  109.       IAA=I1
  110.       I1=I2
  111.       I2=I3
  112.       I3=IAA
  113.       JJ=NUM(1,J)
  114.  100  CONTINUE
  115.       IF (NBNN.EQ.3) GOTO 101
  116. C  ON TENTE D'ASSEMBLER UN QUADRANGLE
  117.       IF (IIMPI.EQ.2) WRITE (IOIMP,1013) I,J,I1,JJ,I2,I3
  118.  1013 FORMAT (' TEST QUADRANGLES AVEC LES TRIANGLES ',6I5)
  119.       AN=ANG(I3,I1,JJ)
  120.       IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  121.       AN=ANG(I1,JJ,I2)
  122.       IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  123.       AN=ANG(JJ,I2,I3)
  124.       IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  125.       AN=ANG(I2,I3,I1)
  126.       IF (AN.LE.0..OR.AN.GE.2.5) GOTO 101
  127. C  VA POUR UN QUADRANGLE
  128.       NUM(1,I)=I1
  129.       NUM(2,I)=JJ
  130.       NUM(3,I)=I2
  131.       NUM(4,I)=I3
  132.       IF (IIMPI.NE.0) WRITE (IOIMP,1012) I,J,I1,JJ,I2,I3
  133.  1012 FORMAT (' REUNION DES TRIANGLES ',6I5)
  134.       NUMELG=NUMELG-1
  135.       IF (I.GT.J) I=I-1
  136.       DO 102 K=J,NUMELG
  137.       NUM(1,K)=NUM(1,K+1)
  138.       NUM(2,K)=NUM(2,K+1)
  139.       NUM(3,K)=NUM(3,K+1)
  140.       NUM(4,K)=NUM(4,K+1)
  141.  102  CONTINUE
  142. *  OCTOBRE 1987 IL FAUT AUSSI METTRE A JOUR KON
  143.       DO 103 K1=1,ISUP
  144.       DO 104 K2=1,IRANGE
  145. *>>>>> P.M. 16/11/90
  146. *+*   IF (KON(K1,K2).GT.J) KON(K1,K2)=KON(K1,K2)-1
  147.       IF (KON(K1,K2).GT.J) THEN
  148.          KON(K1,K2)=KON(K1,K2)-1
  149.       ELSE IF (KON(K1,K2).EQ.J) THEN
  150.          IVOI(K2) = IVOI(K2) - 1
  151.          DO 105 K1B = K1,IVOI(K2)
  152.             KON(K1B,K2) = KON(K1B+1,K2)
  153.   105    CONTINUE
  154.       END IF
  155. *<<<<<
  156.  104  CONTINUE
  157.  103  CONTINUE
  158.       ICLE=6
  159.       GOTO 1
  160.  101  IF (CALI.GE.QUAL.AND.NBNN.EQ.4) GOTO 2
  161.       CALS=CAL(I1,JJ,I3)
  162.       IF (CALS.LT.CALI) GOTO 2
  163.       CALT=CAL(JJ,I2,I3)
  164.       IF (CALT.LT.CALI) GOTO 2
  165. C  ON PEUT COUPER SUIVANT LA DEUXIEME DIAGONALE
  166.       NUM(1,I)=I1
  167.       NUM(2,I)=JJ
  168.       NUM(3,I)=I3
  169.       NUM(1,J)=JJ
  170.       NUM(2,J)=I2
  171.       NUM(3,J)=I3
  172.       IF (CALS.LT.QUAL.OR.CALT.LT.QUAL) ICLE=6
  173.       GOTO 5
  174.    2  CONTINUE
  175.    4  CONTINUE
  176.       IF (CALI.GE.QUAL) GOTO 5
  177. C  C'EST L'ECHEC
  178.       IF (IIMPI.EQ.1) WRITE (IOIMP,1005) I,I1,I2,I3,CALI
  179.  1005 FORMAT (' ELEMENT ',I5,' FORME DES NOEUDS SOMMETS ',3I5,' QUALITE
  180.      # ',G12.5)
  181.       IF (ICLE.NE.6) ICLE=5
  182.    5  CONTINUE
  183.       GOTO 1
  184.    3  CONTINUE
  185. C  DEPLACEMENT DES NOEUDS
  186.       GOTO 560
  187.  501  CONTINUE
  188.       IF (NUMINI.GT.NUMNP) RETURN
  189.       DO 500 I=NUMINI,NUMNP
  190.       IR=I-NCTIN+1
  191.       LONG=IVOI(IR)
  192.       IF (LONG.EQ.0) GOTO 500
  193.       XGRAV=0.
  194.       YGRAV=0.
  195.       XNOMB=0.
  196.       DO 502 J=1,LONG
  197.       LEL=KON(J,IR)
  198.       I1=NUM(1,LEL)
  199.       I2=NUM(3,LEL)
  200.       IF (I1.NE.I) GOTO 540
  201.       I1=NUM(2,LEL)
  202.       IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I2=NUM(4,LEL)
  203.       GOTO 541
  204.  540  IF (I2.NE.I) GOTO 541
  205.       I2=NUM(2,LEL)
  206.       IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I1=NUM(4,LEL)
  207.  541  CONTINUE
  208.       XCOF=1.
  209.       XGRAV=XGRAV+XCOF*(X(1,I1)+X(1,I2))
  210.       YGRAV=YGRAV+XCOF*(X(2,I1)+X(2,I2))
  211.       XNOMB=XNOMB+2.*XCOF
  212.       IF (NBNN.NE.4.OR.NUM(4,LEL).EQ.0) GOTO 502
  213.       I5=NUM(1,LEL)+NUM(2,LEL)+NUM(3,LEL)+NUM(4,LEL)-I-I1-I2
  214.       XGRAV=XGRAV+2.*XCOF*X(1,I5)
  215.       YGRAV=YGRAV+2.*XCOF*X(2,I5)
  216.       XNOMB=XNOMB+2.*XCOF
  217.  502  CONTINUE
  218.       X(1,I)=XGRAV/XNOMB
  219.       X(2,I)=YGRAV/XNOMB
  220.  500  CONTINUE
  221.       DO 510 IAAUX=NUMINI,NUMNP
  222.       I=NUMNP-IAAUX+NUMINI
  223.       IR=I-NCTIN+1
  224.       LONG=IVOI(IR)
  225.       IF (LONG.EQ.0) GOTO 510
  226.       XGRAV=0.
  227.       YGRAV=0.
  228.       XNOMB=0.
  229.       DO 512 J=1,LONG
  230.       LEL=KON(J,IR)
  231.       I1=NUM(1,LEL)
  232.       I2=NUM(3,LEL)
  233.       IF (I1.NE.I) GOTO 550
  234.       I1=NUM(2,LEL)
  235.       IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I2=NUM(4,LEL)
  236.       GOTO 551
  237.  550  IF (I2.NE.I) GOTO 551
  238.       I2=NUM(2,LEL)
  239.       IF (NBNN.EQ.4.AND.NUM(4,LEL).NE.0) I1=NUM(4,LEL)
  240.  551  CONTINUE
  241.       XCOF=1.
  242.       XGRAV=XGRAV+XCOF*(X(1,I1)+X(1,I2))
  243.       YGRAV=YGRAV+XCOF*(X(2,I1)+X(2,I2))
  244.       XNOMB=XNOMB+2.*XCOF
  245.       IF (NBNN.NE.4.OR.NUM(4,LEL).EQ.0) GOTO 512
  246.       I5=NUM(1,LEL)+NUM(2,LEL)+NUM(3,LEL)+NUM(4,LEL)-I-I1-I2
  247.       XGRAV=XGRAV+2*XCOF*X(1,I5)
  248.       YGRAV=YGRAV+2*XCOF*X(2,I5)
  249.       XNOMB=XNOMB+2*XCOF
  250.  512  CONTINUE
  251.       X(1,I)=XGRAV/XNOMB
  252.       X(2,I)=YGRAV/XNOMB
  253.  510  CONTINUE
  254.       RETURN
  255.  560  CONTINUE
  256.       IF (IIMPI.EQ.1) WRITE (IOIMP,1011)
  257.  1011 FORMAT(' RECHERCHE DE LA QUALITE MINIMALE APRES DEPLACEMENT DES NO
  258.      #EUDS')
  259.       CALI=1.
  260.       ISAUV=1
  261.       I=0
  262.  520  I=I+1
  263.       IF (I.GT.NUMELG) GOTO 590
  264.       IF (NBNN.EQ.4.AND.NUM(4,I).NE.0) GOTO 530
  265.  591  CONTINUE
  266.       I1=NUM(1,I)
  267.       I2=NUM(2,I)
  268.       I3=NUM(3,I)
  269.       CALJ=CAL(I1,I2,I3)
  270.       IF (CALJ.GE.CALI) GOTO 520
  271.       ISAUV=I
  272.       CALI=CALJ
  273.       GOTO 520
  274.  590  CONTINUE
  275.       I1=NUM(1,ISAUV)
  276.       I2=NUM(2,ISAUV)
  277.       I3=NUM(3,ISAUV)
  278.       IF (IIMPI.EQ.1) WRITE (IOIMP,1005) ISAUV,I1,I2,I3,CALI
  279.       NUM2=NUMELG
  280.       RETURN
  281. C  ON CONVERTIT LES QUADRANGLES APLATIS EN COUPLES DE TRIANGLES
  282.  530  CONTINUE
  283.       I1=NUM(1,I)
  284.       I2=NUM(2,I)
  285.       I3=NUM(3,I)
  286.       I4=NUM(4,I)
  287.       ANG1=ANG(I4,I1,I2)
  288.       IF (ANG1.GT.0..AND.ANG1.LT.2.6) GOTO 522
  289.  523  ICLE=6
  290.       NUM(4,I)=0
  291.       NUMELG=NUMELG+1
  292.       NUM(1,NUMELG)=I1
  293.       NUM(2,NUMELG)=I3
  294.       NUM(3,NUMELG)=I4
  295.       NUM(4,NUMELG)=0
  296.       GOTO 591
  297.  522  ANG3=ANG(I2,I3,I4)
  298.       IF (ANG3.LT.0..OR.ANG3.GT.2.6) GOTO 523
  299.  525  ANG2=ANG(I1,I2,I3)
  300.       IF (ANG2.GT.0..AND.ANG2.LT.2.6) GOTO 526
  301.  527  NUM(4,I)=0
  302.       ICLE=6
  303.       NUM(3,I)=I4
  304.       NUMELG=NUMELG+1
  305.       NUM(1,NUMELG)=I2
  306.       NUM(2,NUMELG)=I3
  307.       NUM(3,NUMELG)=I4
  308.       NUM(4,NUMELG)=0
  309.       GOTO 591
  310.  526  ANG4=ANG(I3,I4,I1)
  311.       IF (ANG4.LT.0..OR.ANG4.GT.2.6) GOTO 527
  312.       GOTO 520
  313.       END
  314.  
  315.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales