1 : C J3FAC0 SOURCE CHAT 07/10/30 21:16:31 5942 2 : SUBROUTINE J3FAC0 3 : C---------------------------------------------------- 4 : C TEST POUR LES FACES 5 : C PP 6/97 6 : C Pierre Pegon/JRC Ispra 7 : C---------------------------------------------------- 8 : IMPLICIT INTEGER(I-N) 9 : IMPLICIT REAL*8(A-H,O-Z) 10 : -INC CCOPTIO 11 : -INC SMTABLE 12 : -INC SMELEME 13 : -INC SMCOORD 14 : -INC CCGEOME 15 : -INC CCNOYAU 16 : -INC CCASSIS 17 : C 18 : SEGMENT BLOCOM 19 : INTEGER POINT(NPOINT) 20 : REAL*8 YCOOR(IDIM+1,NPOINT) 21 : INTEGER MAILL(MM1) 22 : ENDSEGMENT 23 : POINTEUR BLOCO1.BLOCOM 24 : C 25 : SEGMENT VWORK 26 : INTEGER FWWORK(NFACE) 27 : ENDSEGMENT 28 : SEGMENT VWORK1.VWORK 29 : C 30 : SEGMENT WWORK 31 : REAL*8 PORIG(3),VNORM(3),VI(3),VJ(3) 32 : INTEGER FWORK 33 : INTEGER TWORK(NTROU) 34 : ENDSEGMENT 35 : C 36 : SEGMENT WORK 37 : REAL*8 XYC(2,NPTO) 38 : INTEGER IST(3,NPTO) 39 : REAL*8 DENS(NPTO) 40 : INTEGER JUN 41 : ENDSEGMENT 42 : C 43 : C LECTURE DE LA TABLE ET DE LA TOLERANCE 44 : C 44 : CALL LIROBJ('TABLE',MTABLE,1,IRETOU) 45 : IF(IERR.NE.0) RETURN 45 : CALL LIRREE(TOL,1,IRETOU) 46 : IF(IERR.NE.0) RETURN 47 : C 48 : C VERIFICATION DE LA DIMENSION 49 : C 50 : IF (IDIM.NE.3)THEN 51 : WRITE(IOIMP,*)'J3FAC0: on n"est pas en 3D' 52 : RETURN 53 : ENDIF 54 : C 55 : C VERIFICATIONS DIVERSES 56 : C 57 : SEGACT, MTABLE 58 : MM=MLOTAB 59 : C 60 : NFACE=MM-1 61 : SEGINI,VWORK1 62 : C 63 : NPOINT=0 64 : MM1=NFACE 65 : SEGINI,BLOCOM 66 : C 67 : IIE1=0 68 : if(nbesc.ne.0) segact ipiloc 69 : DO IE1=1,MM 70 : IF (MTABTI(IE1).EQ.'MOT ')THEN 71 : C 72 : C ON VERIFIE LA VALEUR DE L'INDICE MOT ET LE CONTENU 73 : C 74 : JF=IPCHAR(MTABII(IE1)+1) 75 : ID=IPCHAR(MTABII(IE1)) 76 : IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN 77 : WRITE(IOIMP,*)'J3FAC0: un indice de type mot est errone' 78 : GOTO 9999 79 : ENDIF 80 : IF (MTABTV(IE1).NE.'MOT ')THEN 81 : WRITE(IOIMP,*)'J3FAC0: le SOUSTYPE doit etre un MOT' 82 : GOTO 9999 83 : ENDIF 84 : JF=IPCHAR(MTABIV(IE1)+1) 85 : ID=IPCHAR(MTABIV(IE1)) 86 : IF (ICHARA(ID:JF-1).NE.'LISTE_DE_BLOCS')THEN 87 : WRITE(IOIMP,*)'J3FAC0: le SOUSTYPE doit etre LISTE_DE_BLOCS' 88 : GOTO 9999 89 : ENDIF 90 : ELSEIF (MTABTI(IE1).EQ.'ENTIER ')THEN 91 : C 92 : C ON VERIFIE LE CONTENU DES INDICES ENTIERS 93 : C 94 : IF (MTABTV(IE1).NE.'TABLE')THEN 95 : WRITE(IOIMP,*)'J3FAC0: un indice entier n"est pas une table' 96 : GOTO 9999 97 : ENDIF 98 : MTAB1=MTABIV(IE1) 99 : SEGACT,MTAB1 100 : MM1=MTAB1.MLOTAB 101 : C 102 : NFACE=MM1-1 103 : SEGINI,VWORK 104 : IIE1=IIE1+1 105 : VWORK1.FWWORK(IIE1)=VWORK 106 : C 107 : IIE2=0 108 : DO IE2=1,MM1 109 : if(nbesc.ne.0) segact ipiloc 110 : IF (MTAB1.MTABTI(IE2).EQ.'MOT ')THEN 111 : IDM=MTAB1.MTABII(IE2) 112 : JF=IPCHAR(IDM+1) 113 : ID=IPCHAR(IDM) 114 : IF (ICHARA(ID:JF-1).NE.'SOUSTYPE')THEN 115 : WRITE(IOIMP,*)'J3FAC0: pas de sous-type' 116 : GOTO 9999 117 : ENDIF 118 : IF (MTAB1.MTABTV(IE2).NE.'MOT ')THEN 119 : WRITE(IOIMP,*)'J3FAC0: sous-type de type incorrect' 120 : GOTO 9999 121 : ENDIF 122 : IDF=MTAB1.MTABIV(IE2) 123 : JF=IPCHAR(IDF+1) 124 : ID=IPCHAR(IDF) 125 : IF (ICHARA(ID:JF-1).NE.'LISTE_DE_FACES')THEN 126 : WRITE(IOIMP,*)'J3FAC0: sous-type incorrect' 127 : GOTO 9999 128 : ENDIF 129 : ELSEIF (MTAB1.MTABTI(IE2).EQ.'ENTIER ')THEN 130 : IF (MTAB1.MTABTV(IE2).NE.'MAILLAGE')THEN 131 : WRITE(IOIMP,*)'indice entier non maillage' 132 : GOTO 9999 133 : ENDIF 134 : MELEME=MTAB1.MTABIV(IE2) 135 : SEGACT,MELEME 136 : IF(ITYPEL.NE.2)THEN 137 : WRITE(IOIMP,*)'maillage non de seg2' 138 : GOTO 9999 139 : ENDIF 140 : C 141 : NPTO=ICOLOR(/1) 142 : IF(NUM(1,1).NE.NUM(2,NPTO))THEN 143 : WRITE(IOIMP,*)'maillage non ferme' 144 : GOTO 9999 145 : ENDIF 146 : C 147 : NTROU=0 148 : SEGINI,WWORK 149 : C 150 : SEGINI,WORK 151 : FWORK=WORK 152 : IIE2=IIE2+1 153 : FWWORK(IIE2)=WWORK 154 : C 154 : CALL J3LOAD(NUM,WWORK,NPTO,TOL,IRET) 155 : IF(IRET.GT.0)GOTO 9999 155 : CALL J3ORIE(1,XYC,DENS,NPTO,1,TOL,IRET) 156 : IF(IRET.GT.0)GOTO 9999 157 : IF(IIMPI.EQ.1789)THEN 158 : WRITE(IOIMP,*)'J3FAC0:LOAD DE LA FACE ',IIE1,IIE2 158 : CALL J3LIWW(WWORK) 159 : ENDIF 159 : CALL J3LOAP(MELEME,NPTO,BLOCOM,NPOINT) 160 : C 161 : SEGDES,MELEME*NOMOD 162 : ELSE 163 : GOTO 9999 164 : ENDIF 165 : ENDDO 166 : ELSE 167 : WRITE(IOIMP,*)'J3FAC0: un type d"indice est errone' 168 : GOTO 9999 169 : ENDIF 170 : C 171 : C DANS MAILL SE TROUVE LE NOMBRE DE PT TOTAL CHARGE A 172 : C LA FIN DE CHAQUE BLOC 173 : C 174 : IF(IIE1.NE.0)MAILL(IIE1)=NPOINT 175 : ENDDO 176 : if(nbesc.ne.0) segdes ipiloc 177 : C 178 : C ON VERIFIE QUE LES POINTS DE CHAQUE BLOK SONT 2 A 2 DISJOINTS 179 : C 179 : CALL J3DISJ(BLOCOM,TOL,IRET) 180 : IF(IRET.GT.0) GOTO 9999 181 : C 182 : C ON GENERE LA NOUVELLE ARBORESCENCE DE FACE 183 : C 183 : CALL J3FAC1(VWORK1,TOL,IRET) 184 : IF(IRET.GT.0) GOTO 9999 185 : C 186 : C ON TRAITE LES CAS QUI PEUVENT DONNER DU SOUCIS A SURF 187 : C 187 : CALL J3SURE(VWORK1,IRET,TOL) 188 : IF(IRET.GT.0) GOTO 9999 188 : CALL J3SURF(VWORK1,TOL) 189 : C 190 : C ON CHARGE LE RESULTAT DANS LA TABLE DE SORTIE MAIS LES POINTS 191 : C SONT MIS DANS UN BLOCOM 192 : C 193 : BLOCO1=BLOCOM 194 : C 195 : MTAB1=MTABLE 196 : SEGINI,MTABLE=MTAB1 197 : SEGDES,MTAB1*NOMOD 198 : C 199 : MM1=0 200 : NPOINT=0 201 : SEGINI,BLOCOM 202 : C 203 : IIE1=0 204 : DO IE1=1,MM 205 : IF (MTABTI(IE1).EQ.'ENTIER ')THEN 206 : IIE1=IIE1+1 207 : VWORK=VWORK1.FWWORK(IIE1) 208 : M=FWWORK(/1)+1 209 : SEGINI,MTAB1 210 : MTAB1.MLOTAB=M 211 : MTABIV(IE1)=MTAB1 212 : C 213 : IM=1 214 : MTAB1.MTABTI(IM)='MOT ' 215 : MTAB1.MTABII(IM)=IDM 216 : MTAB1.MTABTV(IM)='MOT ' 217 : MTAB1.MTABIV(IM)=IDF 218 : C 219 : DO IE2=1,M-1 220 : C 221 : WWORK=FWWORK(IE2) 222 : NTROU=TWORK(/1) 223 : WORK=FWORK 224 : C 225 : NBNN=2 226 : NBELEM=XYC(/2) 227 : NBSOUS=0 228 : NBREF=0 229 : SEGINI,MELEME 230 : ITYPEL=2 231 : C 232 : NPOINT1=NPOINT 233 : NPOINT=NPOINT+NBELEM 234 : MM1=MM1+1 235 : SEGADJ,BLOCOM 236 : MAILL(MM1)=MELEME 237 : C 238 : DO IE3=1,NBELEM 239 : JE3=NPOINT1+IE3 240 : DO IE4=1,3 241 : YCOOR(IE4,JE3)=XYC(1,IE3)*VI(IE4)+XYC(2,IE3)*VJ(IE4) 242 : > +PORIG(IE4) 243 : ENDDO 244 : YCOOR(4 ,JE3)=DENS(IE3) 245 : DENS(IE3)=FLOAT(JE3) 246 : POINT(JE3)=JE3 247 : ENDDO 248 : DO IE3=1,NBELEM 249 : NUM(1,IE3)=INT(DENS(IE3)) 250 : IF(IE3.EQ.NBELEM)THEN 251 : NUM(2,IE3)=INT(DENS(1)) 252 : ELSE 253 : NUM(2,IE3)=INT(DENS(IE3+1)) 254 : ENDIF 255 : ICOLOR(IE3)=IDCOUL 256 : ENDDO 257 : C 258 : IF(NTROU.NE.0)THEN 259 : DO IE3=1,NTROU 260 : NBELE1=NBELEM 261 : SEGSUP,WORK 262 : WORK=TWORK(IE3) 263 : NBELE2=XYC(/2) 264 : NBELEM=NBELE1+NBELE2 265 : SEGADJ,MELEME 266 : C 267 : NPOINT1=NPOINT 268 : NPOINT=NPOINT+NBELE2 269 : SEGADJ,BLOCOM 270 : C 271 : DO IE4=1,NBELE2 272 : JE4=NPOINT1+IE4 273 : DO IE5=1,3 274 : YCOOR(IE5,JE4)=XYC(1,IE4)*VI(IE5)+XYC(2,IE4)*VJ(IE5) 275 : > +PORIG(IE5) 276 : ENDDO 277 : YCOOR(4 ,JE4)=DENS(IE4) 278 : DENS(IE4)=FLOAT(JE4) 279 : POINT(JE4)=JE4 280 : ENDDO 281 : DO IE4=1,NBELE2 282 : NUM(1,NBELE1+IE4)=INT(DENS(IE4)) 283 : IF(IE4.EQ.NBELE2)THEN 284 : NUM(2,NBELE1+IE4)=INT(DENS(1)) 285 : ELSE 286 : NUM(2,NBELE1+IE4)=INT(DENS(IE4+1)) 287 : ENDIF 288 : ICOLOR(NBELE1+IE4)=IDCOUL 289 : ENDDO 290 : ENDDO 291 : ENDIF 292 : C 293 : C SEGDES,MELEME 294 : SEGSUP,WORK 295 : C 296 : IM=IM+1 297 : MTAB1.MTABTI(IM)='ENTIER ' 298 : MTAB1.MTABII(IM)=IE2 299 : MTAB1.MTABTV(IM)='MAILLAGE' 300 : MTAB1.MTABIV(IM)=MELEME 301 : ENDDO 302 : C SEGDES,MTAB1 303 : SEGSUP,VWORK 304 : C 305 : ENDIF 306 : ENDDO 307 : C SEGDES,MTABLE 308 : SEGSUP,VWORK1 309 : C 310 : C ON AJOUTE MAINTENANT LES POINT QUI TOMBENT SUR DES SEGMENTS 311 : C 311 : CALL J3ARET(BLOCOM,TOL) 312 : C 313 : C ON VERIFIE QUE LES POTS EN VIS A VIS ONT LA MEME DENSITE 314 : C ET ON REND LES COORDONNES IDENTIQUES 315 : C 315 : CALL J3DISK(BLOCOM,TOL,IRET) 316 : IF(IRET.NE.0)THEN 317 : SEGSUP,BLOCOM,BLOCO1,MTABLE 318 : GOTO 9998 319 : ENDIF 320 : C 321 : C ON CHARGE MAINTENANT LES POINTS DANS LA PILE DES POINTS TOUT 322 : C EN ELIMINANT AVEC LES CAS EXISTANT ET EN TRAITANT LES CAS 323 : C TORDUS (POUR SURF) 324 : C 324 : CALL J3UNLO(BLOCOM,BLOCO1,MTABLE,TOL) 325 : SEGSUP,BLOCOM,BLOCO1 326 : C 326 : CALL ECROBJ('TABLE',MTABLE) 327 : C 328 : RETURN 329 : C 330 : 9999 SEGSUP,BLOCOM 330 : CALL J3DETR(VWORK1) 331 : SEGDES,MTABLE*NOMOD 331 : 9998 CALL ERREUR(21) 332 : RETURN 333 : END 334 : 335 :
© Cast3M 2003 - All rights reserved.
Disclaimer