Numérotation des lignes :

amelio
C AMELIO    SOURCE    CHAT      05/01/12    21:21:20     5004C   CE SOUS PROGRAMME AMELIORE LA QUALITE DU MAILLAGE ISSU DE TRANSFC   EN DEUX TEMPS   INVERSION DES DIAGONALES PUIS DEPLACEMENT DES NOEUDSC      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 DUC    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 101C  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 101C  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*&lt;&lt;&lt;&lt;&lt; 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 2C  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 5C  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  CONTINUEC  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      RETURNC  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  

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