1 : C COMBL2 SOURCE CHAT 06/03/16 21:15:21 5336 2 : SUBROUTINE COMBL2 3 : C-------------------------------------------------------------------- 4 : C 5 : C TABL1 = COMB TABL2 FLOT1; 6 : C 7 : C FLOT1 : TOLERANCE 8 : C 9 : C Pierre Pegon/JRC Ispra (??96 et 12/98) 10 : C-------------------------------------------------------------------- 11 : IMPLICIT INTEGER(I-N) 12 : IMPLICIT REAL*8 (A-H,O-Z) 13 : C 14 : -INC CCOPTIO 15 : -INC SMTABLE 16 : -INC SMELEME 17 : -INC SMCOORD 18 : -INC CCNOYAU 19 : -INC CCASSIS 20 : C 21 : C2002 SEGMENT,BLOCOM 22 : C2002 INTEGER POINT(NPOINT) 23 : C2002 REAL*8 XX(NPOINT),YY(NPOINT),DD(NPOINT) 24 : C2002 INTEGER MAILL(MM1) 25 : C2002 ENDSEGMENT 26 : C 27 : SEGMENT BLOCOM 28 : INTEGER POINT(NPOINT) 29 : REAL*8 YCOOR(IDIM+1,NPOINT) 30 : INTEGER MAILL(MM1) 31 : ENDSEGMENT 32 : C 32 : CALL LIROBJ('TABLE',MTABLE,1,IRETOU) 33 : IF(IERR.NE.0) RETURN 33 : CALL LIRREE(XTOL,1,IRETOU) 34 : IF(IERR.NE.0) RETURN 35 : XTOL2=XTOL**2 36 : C 37 : C VERIFICATION DE LA DIMENSION 38 : C 39 : IF (IDIM.NE.2)THEN 40 : WRITE(IOIMP,*)'GENJOI: on n"est pas en 2D' 41 : RETURN 42 : ENDIF 43 : C 44 : C VERIFICATIONS DIVERSES 45 : C - SOUS TYPE DE LA TABLE 46 : C - NATURE DES MAILLAGE DE LA TABLE (SIMPLE, POI1 OU SEG2) 47 : C ET CALCUL DU NOMBRE DE POINT 48 : C 49 : NPOINT=0 50 : SEGACT, MTABLE 51 : MM=MLOTAB 52 : if(nbesc.ne.0) segact ipiloc 53 : DO IE1=1,MM 54 : IF (MTABTI(IE1).EQ.'MOT ')THEN 55 : C 56 : C ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU 57 : C 58 : JF=IPCHAR(MTABII(IE1)+1) 59 : ID=IPCHAR(MTABII(IE1)) 60 : IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN 61 : WRITE(IOIMP,*)'COMB: un indice de type mot est errone' 62 : GOTO 9999 63 : ENDIF 64 : IF (MTABTV(IE1).NE.'MOT ')THEN 65 : WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre un MOT' 66 : GOTO 9999 67 : ENDIF 68 : JF=IPCHAR(MTABIV(IE1)+1) 69 : ID=IPCHAR(MTABIV(IE1)) 70 : IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN 71 : WRITE(IOIMP,*)'COMB: le SOUSTYPE doit etre LISTE_DE_BLOCS' 72 : GOTO 9999 73 : ENDIF 74 : ELSEIF (MTABTI(IE1).EQ.'ENTIER ')THEN 75 : C 76 : C ON VERIFIE LE CONTENU DES INDICES ENTIERS 77 : C 78 : IF (MTABTV(IE1).NE.'MAILLAGE')THEN 79 : ENDIF 80 : MELEME=MTABIV(IE1) 81 : SEGACT,MELEME 82 : IF(LISOUS(/1).NE.0.OR.(ITYPEL.NE.1.AND.ITYPEL.NE.2))THEN 83 : WRITE(IOIMP,*)'COMB: un maillage est errone' 84 : SEGDES,MELEME 85 : GOTO 9999 86 : ENDIF 87 : NPOINT=NPOINT+ICOLOR(/1) 88 : SEGDES,MELEME 89 : ELSE 90 : WRITE(IOIMP,*)'COMB: un type d"indice est errone' 91 : GOTO 9999 92 : ENDIF 93 : ENDDO 94 : if(nbesc.ne.0) segdes ipiloc 95 : C 96 : C ON CHARGE LE NUMERO DES POINTS ... 97 : C 98 : IPOINT=0 99 : IMAILL=0 100 : MM1=MM-1 101 : SEGINI,BLOCOM 102 : DO IE1=1,MM 103 : IF (MTABTI(IE1).EQ.'ENTIER ')THEN 104 : IMAILL=IMAILL+1 105 : MELEME=MTABIV(IE1) 106 : MAILL(IMAILL)=MELEME 107 : SEGACT,MELEME 108 : DO IE2=1,ICOLOR(/1) 109 : IPOINT=IPOINT+1 110 : POINT(IPOINT)=NUM(1,IE2) 111 : ENDDO 112 : SEGDES,MELEME 113 : ENDIF 114 : ENDDO 115 : C 116 : C ... ON LES ORDONNE ... 117 : C 117 : CALL ORDO02(POINT,NPOINT,.TRUE.) 118 : C 119 : C ... ET ON VERIFIE QU'ILS SONT TOUS 2 A 2 DIFFERENT 120 : C 121 : IPOINT=POINT(1) 122 : DO IE1=2,NPOINT 123 : IPOIN1=POINT(IE1) 124 : IF(IPOIN1.EQ.IPOINT)THEN 125 : WRITE(IOIMP,*)'COMB: deux points sont identiques' 126 : GOTO 9998 127 : ENDIF 128 : IPOINT=IPOIN1 129 : ENDDO 130 : C 131 : C ON CHARGES LES COORDONNES ET LA DENSITE DE TOUS LES POINTS 132 : C 133 : DO IE1=1,NPOINT 134 : IREF=(POINT(IE1)-1)*(IDIM+1) 135 : C2002 XX(IE1)=XCOOR(IREF+1) 136 : C2002 YY(IE1)=XCOOR(IREF+2) 137 : C2002 DD(IE1)=XCOOR(IREF+3) 138 : DO IE2=1,IDIM+1 139 : YCOOR(IE2,IE1)=XCOOR(IREF+IE2) 140 : ENDDO 141 : ENDDO 142 : C+2002 143 : C 144 : C ON VERIFIE QUE LES POINTS EN VIS A VIS ONT LA MEME DENSITE 145 : C ET ON REND LES COORDONNES IDENTIQUES 146 : C 147 : IRETOU=0 147 : CALL J3DISK(BLOCOM,XTOL,IRETOU) 148 : IF(IRETOU.NE.0)THEN 149 : WRITE(IOIMP,*)'COMBL2: Pbs de pt en vis-a-vis' 150 : GOTO 9998 151 : ENDIF 152 : C 153 : SEGACT MCOORD*MOD 154 : DO IE1=1,NPOINT 155 : IREF=(POINT(IE1)-1)*(IDIM+1) 156 : DO IE2=1,IDIM+1 157 : XCOOR(IREF+IE2)=YCOOR(IE2,IE1) 158 : ENDDO 159 : ENDDO 160 : C+2002 161 : C 162 : C ON BOUCLE MAINTENANT SUR TOUS LES BLOCS ... 163 : C 164 : NBSOUS=0 165 : DO IE1=1,MM1 166 : MELEME=MAILL(IE1) 167 : SEGACT,MELEME 168 : NBNN=ITYPEL 169 : NBELEM=ICOLOR(/1) 170 : NBREF=LISREF(/1) 171 : C 172 : C ... ET SUR TOUS LEURS COTES 173 : C (ON SIMULE "DO 3 IE2=1,NBELEM" AVEC IE2 ET NBELEM EVENTUELLEMENT CH 174 : C 175 : IE2=0 176 : 1 IE2=IE2+1 177 : IF(IE2.GT.NBELEM)GOTO 3 178 : C DO 3 IE2=1,NBELEM 179 : IREF=(NUM(1,IE2)-1)*(IDIM+1) 180 : XX1=XCOOR(IREF+1) 181 : YY1=XCOOR(IREF+2) 182 : IF(IE2.EQ.NBELEM)THEN 183 : IREF=(NUM(1,1)-1)*(IDIM+1) 184 : ELSE 185 : IREF=(NUM(1,IE2+1)-1)*(IDIM+1) 186 : ENDIF 187 : XX2=XCOOR(IREF+1) 188 : YY2=XCOOR(IREF+2) 189 : D12=(XX1-XX2)**2+(YY1-YY2)**2 190 : C 191 : C ON BOUCLE SUR TOUS LES POINTS ... 192 : C 193 : DO 2 IE3=1,NPOINT 194 : C2002 XXI=XX(IE3) 195 : C2002 YYI=YY(IE3) 196 : XXI=YCOOR(1,IE3) 197 : YYI=YCOOR(2,IE3) 198 : DI1=(XXI-XX1)**2+(YYI-YY1)**2 199 : DI2=(XXI-XX2)**2+(YYI-YY2)**2 200 : C 201 : C ... ON ELIMINE CEUX QUI SONT TROP LOIN ... 202 : C 203 : IF((DI1.GT.D12+XTOL2).OR.(DI2.GT.D12+XTOL2))GOTO 2 204 : C 205 : C ... ON ELIMINE CEUX QUI SONT TROP PRES ... 206 : C 207 : IF((DI1.LT.XTOL2).OR.(DI2.LT.XTOL2))GOTO 2 208 : C 209 : C ... CEUX QUI NE SONT PAS ENTRE ... 210 : C 211 : AAA=((XXI-XX1)*(XX2-XX1)+(YYI-YY1)*(YY2-YY1))/D12 212 : IF(AAA.LT.0.D0.OR.AAA.GT.1.D0)GOTO 2 213 : C 214 : C ... ET CEUX QUI SONT TROP LOIN DU SEGMENT 215 : C 216 : BBB=((XXI-XX1)-AAA*(XX2-XX1))**2 217 : > +((YYI-YY1)-AAA*(YY2-YY1))**2 218 : IF(BBB.GT.XTOL2)GOTO 2 219 : C 220 : C ON INCERE LES POINT RESTANT DANS LE MAILLAGE APRES DUPLICATION 221 : C EVENTUELLE ... 222 : C 223 : C PP 2001: On change un peu la filosophie: on incere le point du segm 224 : C le plus proche du point conside. Cela ne change rien si le 225 : C sont sans epaisseurs... 226 : C 227 : C 228 : NBPTS=XCOOR(/1)/(IDIM+1)+1 229 : SEGADJ MCOORD 230 : IREF=(NBPTS-1)*(IDIM+1) 231 : C PP20001 XCOOR(IREF+1)=XXI 232 : C PP20001 XCOOR(IREF+2)=YYI 233 : XCOOR(IREF+1)=XX1+AAA*(XX2-XX1) 234 : XCOOR(IREF+2)=YY1+AAA*(YY2-YY1) 235 : C PP20001 236 : C 2002 XCOOR(IREF+3)=DD(IE3) 237 : XCOOR(IREF+3)=YCOOR(IDIM+1,IE3) 238 : IF(MELEME.EQ.MAILL(IE1))THEN 239 : IPT1=MELEME 240 : SEGINI,MELEME=IPT1 241 : SEGDES,IPT1 242 : ENDIF 243 : NBELEM=NBELEM+1 244 : SEGADJ, MELEME 245 : ICOLOR(NBELEM)=ICOLOR(NBELEM-1) 246 : IF(ITYPEL.EQ.1)THEN 247 : IF(IE2.LT.NBELEM-1)THEN 248 : DO IE4=NBELEM,IE2+2,-1 249 : NUM(1,IE4)=NUM(1,IE4-1) 250 : ENDDO 251 : ENDIF 252 : NUM(1,IE2+1)=NBPTS 253 : ELSE 254 : DO IE4=NBELEM,IE2+1,-1 255 : NUM(1,IE4)=NUM(1,IE4-1) 256 : NUM(2,IE4)=NUM(2,IE4-1) 257 : ENDDO 258 : NUM(1,IE2+1)=NBPTS 259 : NUM(2,IE2)=NBPTS 260 : ENDIF 261 : 262 : C 263 : C ... ET ON REPASSE PAR LE NOUVEAU SEGMENT EN SORTANT DE LA BOUCLE PO 264 : C 265 : IE2=IE2-1 266 : GOTO 1 267 : C 268 : C FIN BOUCLE POINT 269 : C 270 : 2 CONTINUE 271 : C 272 : C FIN BOUCLE COTE 273 : C 274 : GOTO 1 275 : 3 CONTINUE 276 : IF(MELEME.EQ.MAILL(IE1))THEN 277 : SEGDES,MELEME 278 : ELSE 279 : MAILL(IE1)=MELEME 280 : SEGDES,MELEME 281 : ENDIF 282 : C 283 : C FIN BOUCLE BLOC 284 : C 285 : ENDDO 286 : C 287 : C ON CREE ET ON REMPLIT LA TABLE DE SORTIE 288 : C 289 : IMAILL=0 290 : MTAB1=MTABLE 291 : SEGINI,MTABLE=MTAB1 292 : SEGDES,MTAB1 293 : DO IE1=1,MM 294 : IF (MTABTI(IE1).EQ.'ENTIER ')THEN 295 : IMAILL=IMAILL+1 296 : MTABIV(IE1)=MAILL(IMAILL) 297 : ENDIF 298 : ENDDO 299 : C 300 : C ON REND LA MAIN A GIBIANE 301 : C 302 : SEGSUP,BLOCOM 303 : SEGDES,MTABLE 303 : CALL ECROBJ('TABLE',MTABLE) 304 : C 305 : RETURN 306 : C 307 : C ERREURS 308 : C 309 : 9998 SEGSUP,BLOCOM 310 : 9999 SEGDES,MTABLE 311 : RETURN 312 : END 313 :
© Cast3M 2003 - All rights reserved.
Disclaimer