1 : C INTERB SOURCE FANDEUR 13/01/16 21:15:21 7665 2 : 3 : SUBROUTINE INTERB(IMAMA1,IMAMA2,IRET,IMAMA3) 4 : 5 : ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 6 : C 7 : C INTERSECTION (sens ensembliste) DE DEUX MAILLAGES 8 : C 9 : ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 10 : C 11 : c IPT1,IPT2 : les 2 maillages 12 : c IRET : code de retour (0 = OK, 1 = intersection vide) 13 : C IPT3 : maillage de l'intersection (=0 si IRET = 1) 14 : C 15 : C Suppose que chaque maillage n'a pas 2 sous-zones de même type 16 : C 17 : ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 18 : IMPLICIT INTEGER(I-N) 19 : LOGICAL VERIF 20 : 21 : -INC CCOPTIO 22 : -INC SMELEME 23 : 24 : IRET = 0 25 : ipt1 = IMAMA1 26 : ipt2 = IMAMA2 27 : ipt3 = 0 28 : 29 : SEGACT,IPT1,IPT2 30 : NBSOU1=IPT1.LISOUS(/1) 31 : NBSOU2=IPT2.LISOUS(/1) 32 : 33 : * Structure 1er maillage ? 34 : IF (NBSOU1.NE.0) THEN 35 : * il est composé 36 : GOTO 10 37 : ELSE 38 : * IPT1 est simple, INTERC verifiera s'il est vide 39 : ENDIF 40 : 41 : * Structure 2e maillage ? 42 : IF (NBSOU2.NE.0) THEN 43 : * il est composé 44 : GOTO 11 45 : ELSE 46 : * IPT2 est simple, INTERC verifiera s'il est vide 47 : ENDIF 48 : 49 : C LES DEUX MAILLAGES SONT SIMPLES 50 : * =============================== 50 : CALL INTERC(IPT1,IPT2,IPT3) 51 : GOTO 1000 52 : 53 : C UN DES DEUX EST COMPOSÉ, L'AUTRE SIMPLE 54 : * ======================================= 55 : 10 IF (NBSOU2.NE.0) THEN 56 : GOTO 20 57 : ELSE 58 : GOTO 12 59 : ENDIF 60 : C LE 2e EST COMPOSÉ, LE 1ER SIMPLE : on les intervertit 61 : 11 IS = IPT2 62 : IPT2 = IPT1 63 : IPT1 = IS 64 : 65 : C on les a dans l'ordre IPT1=composé, IPT2=simple ... 66 : 12 CONTINUE 67 : NBSOU1 = IPT1.LISOUS(/1) 68 : * Recherche de la sous-zone de même type dans IPT2 69 : ITYP2 = IPT2.ITYPEL 70 : DO IS = 1, NBSOU1 71 : IPT4 = IPT1.LISOUS(IS) 72 : SEGACT,IPT4 73 : IF (IPT4.ITYPEL .EQ. ITYP2) THEN 74 : IF (IPT2.EQ.IPT4) THEN 75 : C le petit est inclus dans le grand 76 : IPT3 = IPT2 77 : ELSE 78 : * on determine l'intersection pour cette seule sous-zone 78 : CALL INTERC(IPT2,IPT4,IPT3) 79 : SEGDES,IPT4 80 : ENDIF 81 : GOTO 1000 82 : ENDIF 83 : SEGDES,IPT4 84 : ENDDO 85 : c on n'en a pas trouvé 86 : GOTO 1000 87 : 88 : C LES DEUX MAILLAGES SONT COMPOSÉS 89 : * ================================ 90 : 20 CONTINUE 91 : NBELEM=0 92 : NBNN =0 93 : NBREF =0 94 : NBSOUS=MIN(NBSOU1,NBSOU2) 95 : SEGINI,IPT4 96 : 97 : I3=0 98 : DO 21 I1=1,NBSOU1 99 : IPT5=IPT1.LISOUS(I1) 100 : SEGACT IPT5 101 : * Recherche de la sous-zone de même type dans IPT2 102 : ITYP5 = IPT5.ITYPEL 103 : DO 22 I2=1,NBSOU2 104 : IPT6=IPT2.LISOUS(I2) 105 : SEGACT IPT6 106 : IF (ITYP5.EQ.IPT6.ITYPEL) THEN 107 : * on l'a trouvée, on fait l'intersection 108 : IF (IPT5.EQ.IPT6) THEN 109 : C les deux sous-maillages sont confondus 110 : IPT7=IPT5 111 : ELSE 111 : CALL INTERC(IPT5,IPT6,IPT7) 112 : SEGDES IPT6 113 : IF (IPT7.NE.0) SEGDES,IPT7 114 : ENDIF 115 : IF (IPT7.NE.0) THEN 116 : * intersection non vide, on stocke le maillage obtenu 117 : I3 = I3+1 118 : IPT4.LISOUS(I3)=IPT7 119 : ENDIF 120 : GOTO 23 121 : ENDIF 122 : 22 CONTINUE 123 : 23 CONTINUE 124 : SEGDES IPT5 125 : 21 CONTINUE 126 : 127 : * Maillage résultat 128 : * Aucune sous-zone ... 129 : IF (I3.EQ.0) THEN 130 : SEGSUP,IPT4 131 : ELSE 132 : NBSOUS = I3 133 : SEGADJ,IPT4 134 : IPT3 = IPT4 135 : * Si une seule sous-zone ... 136 : IF (I3.EQ.1) THEN 137 : IPT3 = IPT4.LISOUS(1) 138 : SEGSUP,IPT4 139 : ENDIF 140 : ENDIF 141 : * GOTO 1000 142 : 143 : 1000 CONTINUE 144 : SEGDES,IPT1,IPT2 145 : IF (IPT3.EQ.0) THEN 146 : IRET = 1 147 : ELSE 148 : SEGDES,IPT3 149 : IRET = 0 150 : ENDIF 151 : IMAMA3 = IPT3 152 : 153 : RETURN 154 : END 155 : 156 :
© Cast3M 2003 - All rights reserved.
Disclaimer