1 : C TRIA2 SOURCE SH236661 13/11/25 21:15:11 7869 2 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 3 : SUBROUTINE TRIA2(IPT1,XDEN,IPT5) 4 : C 5 : C Maillage de l'interieur d'un contour/enveloppe par triangulation de 6 : C Delaunay puis ajout de points 7 : C 8 : C IPT1 : Maillage initial constitue : 9 : C - de SEG2 (contour ferme) ou de TRI3 (surface) en dimension 2 10 : C - de TRI3 (enveloppe fermee) ou de TET4 (volume) en dimension 3 11 : C XDEN : Critere sur la taille de maille maximale cible (le maillage est 12 : C raffine en ajoutant des points au milieu des aretes) 13 : C IPT5 : Maillage de sortie constitue : 14 : C - de TRI3 en dimension 2 15 : C - de TET4 en dimension 3 16 : C 17 : IMPLICIT INTEGER(I-N) 18 : IMPLICIT REAL*8 (A-H,O-Z) 19 : C 20 : -INC CCOPTIO 21 : -INC SMELEME 22 : -INC SMCOORD 23 : -INC CCGEOME 24 : -INC SMLENTI 25 : PARAMETER (ICMIN=1000) 26 : DIMENSION XA(3),XB(3),XPMIL(3) 27 : DIMENSION LNBOIT(8) 28 : C 29 : SEGMENT,MCIRCONS 30 : REAL*8 TRC(NBE1,4) 31 : ENDSEGMENT 32 : POINTEUR ITRC1.MCIRCONS 33 : C 34 : SEGMENT,MADJACEN 35 : INTEGER LEAC(NBL1,IDIM+1,2) 36 : ENDSEGMENT 37 : POINTEUR ILEA1.MADJACEN 38 : C 39 : POINTEUR LNCONT.MLENTI 40 : C 41 : SEGACT,IPT1 42 : NBSZ=IPT1.LISOUS(/1) 43 : NTYP=IPT1.ITYPEL 44 : I1=0 45 : C On change le maillage d'entree en POI1 --> IPT2 46 : SEGINI,IPT3=IPT1 46 : CALL CHANGE(IPT3,1) 47 : SEGINI,IPT2=IPT3 48 : 101 CONTINUE 49 : C Maillage englobant a utiliser dans INCL --> IPT3 50 : IF (I1.EQ.0) THEN 51 : IF ((IDIM.EQ.3).AND.(NTYP.EQ.4)) THEN 51 : CALL ECROBJ('MAILLAGE',IPT1) 51 : CALL VOLUME 51 : CALL LIROBJ('MAILLAGE',IPT3,1,IRETOU) 52 : IF (IERR.NE.0) RETURN 53 : SEGACT,IPT3 54 : ELSE 55 : SEGINI,IPT3=IPT1 56 : ENDIF 57 : ELSE 58 : SEGINI,IPT3=IPT5 59 : ENDIF 60 : C Calcul du contour/enveloppe de reference --> IPT4 61 : IF (IDIM.EQ.2) THEN 62 : IF (IPT3.ITYPEL.EQ.2) THEN 63 : SEGINI,IPT4=IPT1 64 : ELSE 64 : CALL ECROBJ('MAILLAGE',IPT3) 64 : CALL PRCONT 64 : CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU) 65 : IF (IERR.NE.0) RETURN 66 : SEGACT,IPT4 67 : ENDIF 68 : ELSEIF (IDIM.EQ.3) THEN 68 : CALL ECROBJ('MAILLAGE',IPT3) 68 : CALL ENVVOL 68 : CALL LIROBJ('MAILLAGE',IPT4,1,IRETOU) 69 : IF (IERR.NE.0) RETURN 70 : SEGACT,IPT4 71 : ENDIF 72 : C Creation d'une liste des numeros de noeuds 73 : IF (I1.EQ.0) THEN 74 : JG=(XCOOR(/1))/(IDIM+1) 75 : SEGINI,LNCONT 76 : C et marquage des noeuds situes sur le contour/enveloppe IPT4 77 : DO I=1,IPT4.NUM(/2) 78 : DO J=1,IPT4.NUM(/1) 79 : LNCONT.LECT(IPT4.NUM(J,I))=1 80 : ENDDO 81 : ENDDO 82 : ENDIF 83 : C Triangulation de DELAUNAY de IPT2 --> IPT5 84 : C (sans ajout de points) 85 : IF (IDIM.EQ.2) XBOI=200. 86 : IF (IDIM.EQ.3) XBOI=500. 87 : c 88 : MPOVAL=0 88 : CALL DELAUN(MPOVAL,IPT2,XBOI,0,IPT5,LNBOIT,ITRC1,ILEA1) 89 : c 90 : IF (IDIM.NE.1) SEGSUP,ITRC1,ILEA1 91 : SEGACT,IPT2,IPT5 92 : C En cas d'erreur dans DELAUN 93 : IF (IERR.EQ.2) THEN 94 : IERR=0 95 : C On rend le maillage pour controle 96 : SEGSUP,IPT2,IPT3,LNCONT 97 : SEGDES,IPT1 98 : GOTO 999 99 : ENDIF 100 : C On isole les elements de IPT5 inclus dans IPT3 par appel a 101 : C INCLUS option 'BARY' 101 : CALL ECRCHA('BARY') 101 : IF (IDIM.EQ.3) CALL ECRCHA('VOLU') 101 : CALL ECROBJ('MAILLAGE',IPT3) 101 : CALL ECROBJ('MAILLAGE',IPT5) 101 : CALL INCLUS 102 : C Les elements inclus sont ranges dans IPT5 (on ecrase le precedent) 103 : SEGSUP,IPT5 103 : CALL LIROBJ('MAILLAGE',IPT5,1,IRETOU) 104 : IF (IERR.NE.0) RETURN 105 : SEGACT,IPT5 106 : C Creation du contour/enveloppe de IPT5 --> IPT6 106 : CALL ECROBJ('MAILLAGE',IPT5) 107 : IF (IDIM.EQ.2) THEN 107 : CALL PRCONT 108 : ELSEIF (IDIM.EQ.3) THEN 108 : CALL ENVVOL 109 : ENDIF 109 : CALL LIROBJ('MAILLAGE',IPT6,1,IRETOU) 110 : IF (IERR.NE.0) RETURN 111 : SEGACT,IPT6 112 : C Test si les noeuds du contour IPT6 sont marques 113 : DO I=1,IPT6.NUM(/2) 114 : DO J=1,IPT6.NUM(/1) 115 : IF (LNCONT.LECT(IPT6.NUM(J,I)).NE.1) THEN 116 : C Maillage incorrect 116 : CALL ERREUR(426) 117 : SEGSUP,IPT2,IPT3,LNCONT 118 : SEGDES,IPT1 119 : GOTO 999 120 : ENDIF 121 : ENDDO 122 : ENDDO 123 : IF (XDEN.NE.0.) THEN 124 : C Maillage des lignes de la triangulation --> IPT7 125 : NBELE0=XCOOR(/1)/(IDIM+1) 126 : NBELE00=NBELE0 127 : NBELE2=IPT2.NUM(/2) 127 : CALL ECROBJ('MAILLAGE',IPT5) 127 : CALL CHANLG 127 : CALL LIROBJ('MAILLAGE',IPT7,1,IRETOU) 128 : IF (IERR.NE.0) RETURN 129 : SEGACT,IPT7 130 : C On anticipe l'ajout de noeuds sur le contour/enveloppe de 131 : C reference, il faudra les marquer dans LNCONT 132 : NLI=IPT7.NUM(/2) 133 : LNC0=LNCONT.LECT(/1) 134 : JG=LNC0+NLI 135 : SEGADJ,LNCONT 136 : C Boucle sur les lignes pour l'ajout de noeuds milieux 137 : DO I=1,IPT7.NUM(/2) 138 : C Calcul de la distance de la ligne AB 139 : NA=IPT7.NUM(1,I) 140 : NB=IPT7.NUM(2,I) 141 : DAB=0. 142 : DO J=1,IDIM 143 : XA(J)=XCOOR((NA-1)*(IDIM+1)+J) 144 : XB(J)=XCOOR((NB-1)*(IDIM+1)+J) 145 : DAB=DAB+((XA(J)-XB(J))**2) 146 : ENDDO 147 : DAB=DAB**0.5 148 : IF (DAB.GT.XDEN) THEN 149 : C Creation d'un nouveau noeud au milieu de AB 150 : NBELE2=NBELE2+1 151 : NBELE0=NBELE0+1 152 : NBPTS0=XCOOR(/1)/(IDIM+1) 153 : C Ajustement du segment MCOORD si besoin 154 : IF (NBPTS0.LT.NBELE0) THEN 155 : NBPTS=NBPTS0+ICMIN 156 : SEGADJ,MCOORD 157 : ENDIF 158 : C Ecriture des coordonnees du nouveau noeud dans XCOOR 159 : DO J=1,IDIM 160 : XPMIL(J)=0.5*(XA(J)+XB(J)) 161 : XCOOR(((NBELE0-1)*(IDIM+1))+J)=XPMIL(J) 162 : ENDDO 163 : C et sa densite 164 : XCOOR(((NBELE0-1)*(IDIM+1))+(IDIM+1))=0. 165 : C Ajustement du segment IPT2 si besoin 166 : NBE2=IPT2.NUM(/2) 167 : IF (NBE2.LT.NBELE2) THEN 168 : NBNN=1 169 : NBELEM=NBE2+ICMIN 170 : NBSOUS=0 171 : NBREF=0 172 : SEGADJ,IPT2 173 : ENDIF 174 : C Ajout de ce point dans le maillage de points IPT2 175 : IPT2.NUM(1,NBELE2)=NBELE0 176 : C Si le point est sur le bord, on le marque dans LNCONT 177 : IF ((LNCONT.LECT(NA).EQ.1).AND.(LNCONT.LECT(NB).EQ.1)) 178 : & THEN 179 : LNCONT.LECT(NBELE0)=1 180 : ENDIF 181 : ENDIF 182 : ENDDO 183 : C Ajustement de LNCONT 184 : JG=LNC0+(NBELE0-NBELE00) 185 : SEGADJ,LNCONT 186 : C Ajustement final de MCOORD et IPT2 187 : IF (NBELE0.NE.NBELE00) THEN 188 : NBPTS=NBELE0 189 : SEGADJ,MCOORD 190 : NBNN=1 191 : NBELEM=NBELE2 192 : NBSOUS=0 193 : NBREF=0 194 : SEGADJ,IPT2 195 : C Suppression des maillages temporaires utilises 196 : SEGSUP,IPT3,IPT7 197 : C On remonte pour refaire la triangulation 198 : I1=1 199 : GOTO 101 200 : ENDIF 201 : SEGSUP,IPT7 202 : ENDIF 203 : C Ecriture sortie/fin 204 : SEGSUP,IPT2,IPT3,LNCONT 205 : SEGDES,IPT1 206 : C Sortie/fin 207 : 999 RETURN 208 : END 209 : 210 : 211 :
© Cast3M 2003 - All rights reserved.
Disclaimer