1 : C TCISO SOURCE GOUNAND 13/10/21 21:15:35 7822 2 : C 3 : SUBROUTINE TCISO(VCHC,XX,YY,zz,VV,NPT,NISO) 4 : C 5 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 6 : C C 7 : C TRACER DES ISOVALEURS D UN CHAMPOINT C 8 : C PAR COLORIAGE DE ZONE C 9 : C LE NOEUD 1 EST CENTRAL A L'ELEMENT C 10 : C TRAITE LE CAS OU TOUT L'ELEMENT EST D'UNE COULEUR C 11 : C APPELE TRISO SINON C 12 : C C 13 : CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC 14 : C 15 : REAL VCHC 16 : C 17 : -INC CCOPTIO 18 : -INC CCREEL 19 : -INC CCGEOME 20 : -INC CCTRACE 21 : C 22 : PARAMETER (NTR=64) 23 : LOGICAL RANGE,IDEP 24 : DIMENSION VCHC(*),XTR(NTR),YTR(NTR),ZTR(NTR),VVN(NTR) 25 : dimension vvo(3) 26 : dimension xx(*),yy(*),zz(*),vv(*) 27 : * RANGE(XXX)= XXX.GE.-0.000001.AND.XXX.LE.1.000001 28 : RANGE(XXX)= XXX.GE.(-xszpre).AND.XXX.LE.(1.+xszpre) 29 : 30 : VSTART= -xsgran 31 : VFINAL= xsgran 32 : VALHAU=VSTART 33 : if (iogra.eq.6) then 34 : valbas=vchc(1) 35 : * valhau=vchc(niso) 36 : valhau=vchc(max(niso-1,1)) 37 : do 300 i=1,npt 38 : vvn(i)=(vv(i)-valbas)/(valhau-valbas) 39 : 300 continue 40 : xtr(1)=xx(1) 41 : ytr(1)=yy(1) 42 : ztr(1)=zz(1) 43 : vvo(1)=vvn(1) 44 : do 310 ipt=2,npt 45 : ipn=ipt+1 46 : if (ipn.gt.npt) ipn=2 47 : xtr(2)=xx(ipt) 48 : ytr(2)=yy(ipt) 49 : ztr(2)=zz(ipt) 50 : vvo(2)=vvn(ipt) 51 : xtr(3)=xx(ipn) 52 : ytr(3)=yy(ipn) 53 : ztr(3)=zz(ipn) 54 : vvo(3)=vvn(ipn) 54 : call ogltriso(xtr,ytr,ztr,vvo,3) 55 : * WRITE(IOIMP,*) ' coul ',vvn(1),vvn(2),vvn(3) 56 : 310 continue 57 : endif 58 : IF (ISOTYP.GT.0.and.iogra.ne.6) THEN 59 : DO 50 KK=1,NISO 60 : VALBAS=VALHAU 61 : VALHAU=VFINAL 62 : * IF (KK.NE.NISO) VALHAU=(VCHC(KK)+VCHC(KK+1))/2 63 : * TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))/1e+5 64 : IF (KK.NE.NISO) VALHAU=VCHC(KK) 65 : * TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))/1e+5 66 : TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))*xszpre 67 : * toll=max(REAL(XPETIT),toll) 68 : toll=max(xspeti,toll) 69 : NP=0 70 : C VALBAS ET VALHAU SONT LES FRONTIERES DE LA ZONE A COLORIER 71 : C JE CRAINS QU'IL FAILLE RECENSER LES CAS POSSIBLES 72 : C LES POINT EXTERIEURS SONT ILS TOUS DANS LA ZONE ? 73 : np=0 74 : do 10 ipt=2,npt 75 : IF ((VALBAS-toll).LE.VV(IPT).AND.(VALHAU+toll).GE.VV(IPT) 76 : $ ) THEN 77 : NP=NP+1 78 : XTR(NP)=XX(IPT) 79 : YTR(NP)=YY(IPT) 80 : ELSE 81 : np=0 82 : goto 11 83 : ENDIF 84 : 10 continue 85 : if (niso.lt.16) then 85 : * CALL TRAISO(NP,XTR,YTR,ICOTAB(KK*(2-NISO/8))) 85 : CALL TRAISO(NP,XTR,YTR,ICOTAB(ISOTAB(KK,NISO))) 86 : else 86 : CALL TRAISO(NP,XTR,YTR,KK) 87 : endif 88 : goto 51 89 : 11 CONTINUE 90 : * write(ioimp,*) 'un des points nest pas dans la zone' 91 : C un des points n'est pas dans la zone 92 : C 1 est il dedans ? 93 : IF ((VALBAS-TOLL).LE.VV(1).AND.(VALHAU+TOLL).GE.VV(1)) THEN 94 : DO 20 ipt=2,npt 95 : iptn=ipt+1 96 : if (iptn.gt.npt) iptn=2 97 : C IPT est il dedans 98 : IF ((VALBAS-toll).LE.VV(IPT).AND.(VALHAU+toll).GE 99 : $ .VV(IPT)) THEN 100 : NP=NP+1 101 : XTR(NP)=XX(IPT) 102 : YTR(NP)=YY(IPT) 103 : ELSE 104 : C SI IPT EST DEDANS INUTILE DE TESTER LE RAYON 105 : vdiff=sign(max(toll,abs(vv(ipt)-vv(1))),vv(ipt) 106 : $ -vv(1)) 107 : UPOSH=(VALHAU+TOLL-VV(1))/vdiff 108 : UPOSB=(VALBAS-TOLL-VV(1))/vdiff 109 : UP=MAX(UPOSB,UPOSH) 110 : IF (RANGE(UP)) THEN 111 : NP=NP+1 112 : XTR(NP)=XX(1)+UP*(XX(ipt)-XX(1)) 113 : YTR(NP)=YY(1)+UP*(YY(ipt)-YY(1)) 114 : ELSE 115 : UP=MIN(UPOSB,UPOSH) 116 : IF (RANGE(UP)) THEN 117 : NP=NP+1 118 : XTR(NP)=XX(1)+UP*(XX(ipt)-XX(1)) 119 : YTR(NP)=YY(1)+UP*(YY(ipt)-YY(1)) 120 : ENDIF 121 : ENDIF 122 : ENDIF 123 : vdiff=sign(max(toll,abs(vv(iptn)-vv(ipt))),vv(iptn) 124 : $ -vv(ipt)) 125 : UPOSH=(VALHAU+TOLL-VV(ipt))/vdiff 126 : UPOSB=(VALBAS-TOLL-VV(ipt))/vdiff 127 : UP=MIN(UPOSB,UPOSH) 128 : IF (RANGE(UP)) THEN 129 : NP=NP+1 130 : XTR(NP)=XX(ipt)+UP*(XX(iptn)-XX(ipt)) 131 : YTR(NP)=YY(ipt)+UP*(YY(iptn)-YY(ipt)) 132 : ENDIF 133 : UP=MAX(UPOSB,UPOSH) 134 : IF (RANGE(UP)) THEN 135 : NP=NP+1 136 : XTR(NP)=XX(ipt)+UP*(XX(iptn)-XX(ipt)) 137 : YTR(NP)=YY(ipt)+UP*(YY(iptn)-YY(ipt)) 138 : ENDIF 139 : 20 continue 140 : if (niso.lt.16) then 140 : * CALL TRAISO(NP,XTR,YTR,ICOTAB(KK*(2-NISO/8))) 140 : CALL TRAISO(NP,XTR,YTR,ICOTAB(ISOTAB(KK,NISO))) 141 : else 141 : CALL TRAISO(NP,XTR,YTR,KK) 142 : endif 143 : goto 50 144 : endif 145 : C 1 n'est pas dans la zone ! 146 : C on tourne autour de 1 en cherchant un point de depart ! 147 : * write(ioimp,*) '1 nest pas dans la zone' 148 : iq=0 149 : if (vv(1).lt.(valbas-toll)) iq=1 150 : if (vv(1).gt.(valhau+toll)) iq=2 151 : if (iq.eq.0) write (ioimp,*) ' prob iq ' 152 : * sg : iptf n'etait pas initialisee. On l'initialise a 1 mais on nest 153 : * pas sur 154 : iptf=1 155 : iptft=2 156 : iptd=npt 157 : 44 continue 158 : np=0 159 : do 30 ipt=iptft,npt 160 : if (iptd.ge.iptf.and.ipt.gt.iptd) goto 50 161 : if (iq.eq.1.and.vv(ipt).lt.(valbas-toll)) goto 30 162 : if (iq.eq.2.and.vv(ipt).gt.(valhau+toll)) goto 30 163 : goto 31 164 : 30 continue 165 : C pas de point de depart il n'y a rien a faire 166 : * write(ioimp,*) 'pas de point de depart' 167 : goto 50 168 : 31 continue 169 : do 32 irec=1,npt-2 170 : ipt2=ipt-irec 171 : if (ipt2.le.1) ipt2=ipt2+npt-1 172 : if (iq.eq.1.and.vv(ipt2).lt.(valbas-toll)) goto 33 173 : if (iq.eq.2.and.vv(ipt2).gt.(valhau+toll)) goto 33 174 : 32 continue 175 : c WRITE(IOIMP,*) ' prob toujours pas de point de depart ' 176 : 33 continue 177 : iptd=ipt2 178 : C IPTD ne traverse pas et iptd+1 traverse 179 : do 40 iptb=iptd,iptd+npt-2 180 : ipt=iptb 181 : if (ipt.gt.npt) ipt=ipt-npt+1 182 : iptn=ipt+1 183 : if (iptn.gt.npt) iptn=iptn-npt+1 184 : vdiff=sign(max(toll,abs(vv(iptn)-vv(ipt))),vv(iptn) 185 : $ -vv(ipt)) 186 : UPOSH=(VALHAU+TOLL-VV(ipt))/vdiff 187 : UPOSB=(VALBAS-TOLL-VV(ipt))/vdiff 188 : UP=MIN(UPOSB,UPOSH) 189 : IF (RANGE(UP)) THEN 190 : NP=NP+1 191 : XTR(NP)=XX(ipt)+UP*(XX(iptn)-XX(ipt)) 192 : YTR(NP)=YY(ipt)+UP*(YY(iptn)-YY(ipt)) 193 : ENDIF 194 : UP=MAX(UPOSB,UPOSH) 195 : IF (RANGE(UP)) THEN 196 : NP=NP+1 197 : XTR(NP)=XX(ipt)+UP*(XX(iptn)-XX(ipt)) 198 : YTR(NP)=YY(ipt)+UP*(YY(iptn)-YY(ipt)) 199 : ENDIF 200 : C IPTN Y est il ? 201 : npin=np 202 : IF ((VALBAS-toll).LE.VV(IPTN).AND.(VALHAU+toll).GE 203 : $ .VV(IPTN)) THEN 204 : NP=NP+1 205 : XTR(NP)=XX(IPTN) 206 : YTR(NP)=YY(IPTN) 207 : ELSE 208 : C SI IPTN EST DEDANS INUTILE DE TESTER LE RAYON 209 : vdiff=sign(max(toll,abs(vv(iptn)-vv(1))),vv(iptn)-vv(1 210 : $ )) 211 : UPOSH=(VALHAU+TOLL-VV(1))/vdiff 212 : UPOSB=(VALBAS-TOLL-VV(1))/vdiff 213 : UP=MAX(UPOSB,UPOSH) 214 : IF (RANGE(UP)) THEN 215 : NP=NP+1 216 : XTR(NP)=XX(1)+UP*(XX(iptn)-XX(1)) 217 : YTR(NP)=YY(1)+UP*(YY(iptn)-YY(1)) 218 : ELSE 219 : UP=MIN(UPOSB,UPOSH) 220 : IF (RANGE(UP)) THEN 221 : NP=NP+1 222 : XTR(NP)=XX(1)+UP*(XX(iptn)-XX(1)) 223 : YTR(NP)=YY(1)+UP*(YY(iptn)-YY(1)) 224 : ENDIF 225 : ENDIF 226 : ENDIF 227 : if (np.eq.npin) goto 41 228 : C on est arrive au bout dans ce sens 229 : 40 continue 230 : c WRITE(IOIMP,*) ' on ne devrai pas passer la', valhau, valbas,toll 231 : 41 continue 232 : iptf=ipt 233 : C on revient en arriere de iptf a iptd 234 : C apres iptf, il ne se passe plus rien 235 : C avant iptd, il ne se passe plus rien 236 : do 42 iptb=iptf,iptf-npt+1,-1 237 : ipt=iptb 238 : if (ipt.le.1) ipt=ipt+npt-1 239 : if (ipt.eq.iptd) goto 48 240 : vdiff=sign(max(toll,abs(vv(ipt)-vv(1))),vv(ipt)-vv(1)) 241 : UPOSH=(VALHAU+TOLL-VV(1))/vdiff 242 : UPOSB=(VALBAS-TOLL-VV(1))/vdiff 243 : UP=MIN(UPOSB,UPOSH) 244 : IF (RANGE(UP)) THEN 245 : NP=NP+1 246 : XTR(NP)=XX(1)+UP*(XX(ipt)-XX(1)) 247 : YTR(NP)=YY(1)+UP*(YY(ipt)-YY(1)) 248 : ELSE 249 : UP=MAX(UPOSB,UPOSH) 250 : IF (RANGE(UP)) THEN 251 : NP=NP+1 252 : XTR(NP)=XX(1)+UP*(XX(ipt)-XX(1)) 253 : YTR(NP)=YY(1)+UP*(YY(ipt)-YY(1)) 254 : ENDIF 255 : ENDIF 256 : 42 continue 257 : 48 continue 258 : if (niso.lt.16) then 258 : * CALL TRAISO(NP,XTR,YTR,ICOTAB(KK*(2-NISO/8))) 258 : CALL TRAISO(NP,XTR,YTR,ICOTAB(ISOTAB(KK,NISO))) 259 : else 259 : CALL TRAISO(NP,XTR,YTR,KK) 260 : endif 261 : iptft=max(iptft,iptf+1) 262 : if (iptft.lt.npt) goto 44 263 : 50 CONTINUE 264 : 51 CONTINUE 265 : IF (ISOTYP.EQ.2) THEN 265 : call chcoul(IDNOIR) 266 : DO 250 KK=1,NISO-1 267 : * TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))/1e+5 268 : * VALDES = (VCHC(KK)+VCHC(KK+1))/2 269 : * TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))/1e+5 270 : TOLL=ABS(VCHC(min(niso-1,KK+1))-VCHC(max(1,KK-1)))*xszpre 271 : VALDES = VCHC(KK) 272 : do 220 ipt=2,npt 273 : NP=0 274 : iptn=ipt+1 275 : if (iptn.gt.npt) iptn=2 276 : UPOS=-1. 277 : IF (ABS(VV(iptn)-VV(ipt)).GT.TOLL) 278 : * UPOS=(VALDES-VV(ipt))/(VV(iptn)-VV(ipt)) 279 : IF (RANGE(UPOS)) THEN 280 : NP=NP+1 281 : XTR(NP)=XX(ipt)+UPOS*(XX(iptn)-XX(ipt)) 282 : YTR(NP)=YY(ipt)+UPOS*(YY(iptn)-YY(ipt)) 283 : ENDIF 284 : UPOS=-1. 285 : IF (ABS(VV(ipt)-VV(1)).GT.TOLL) 286 : * UPOS=(VALDES-VV(1))/(VV(ipt)-VV(1)) 287 : IF (RANGE(UPOS)) THEN 288 : NP=NP+1 289 : XTR(NP)=XX(1)+UPOS*(XX(ipt)-XX(1)) 290 : YTR(NP)=YY(1)+UPOS*(YY(ipt)-YY(1)) 291 : ENDIF 292 : UPOS=-1. 293 : IF (ABS(VV(iptn)-VV(1)).GT.TOLL) 294 : * UPOS=(VALDES-VV(1))/(VV(iptn)-VV(1)) 295 : IF (RANGE(UPOS)) THEN 296 : NP=NP+1 297 : XTR(NP)=XX(1)+UPOS*(XX(iptn)-XX(1)) 298 : YTR(NP)=YY(1)+UPOS*(YY(iptn)-YY(1)) 299 : ENDIF 300 : * il convient de fermer la ligne 301 : if (np.gt.2) then 302 : np=np+1 303 : xtr(np)=xtr(1) 304 : ytr(np)=ytr(1) 305 : endif 305 : if (np.gt.1) call polrl(np,xtr,ytr,ztr) 306 : 220 continue 307 : 250 CONTINUE 308 : ENDIF 309 : ELSEIF (iogra.ne.6) THEN 310 : DO 150 KK=1,NISO-1 311 : * TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))/1e+3 312 : TOLL=ABS(VCHC(min(niso,KK+1))-VCHC(max(1,KK-1)))*xszpre 313 : VALDES = VCHC(KK) 314 : NP=0 315 : do 270 ipt=2,npt 316 : iptn=ipt+1 317 : if (iptn.gt.npt) iptn=2 318 : UPOS=-1. 319 : IF (ABS(VV(iptn)-VV(ipt)).GT.TOLL) 320 : * UPOS=(VALDES-VV(ipt))/(VV(iptn)-VV(ipt)) 321 : IF (RANGE(UPOS)) THEN 322 : NP=NP+1 323 : XTR(NP)=XX(ipt)+UPOS*(XX(iptn)-XX(ipt)) 324 : YTR(NP)=YY(ipt)+UPOS*(YY(iptn)-YY(ipt)) 325 : ENDIF 326 : UPOS=-1. 327 : IF (ABS(VV(ipt)-VV(1)).GT.TOLL) 328 : * UPOS=(VALDES-VV(1))/(VV(ipt)-VV(1)) 329 : IF (RANGE(UPOS)) THEN 330 : NP=NP+1 331 : XTR(NP)=XX(1)+UPOS*(XX(ipt)-XX(1)) 332 : YTR(NP)=YY(1)+UPOS*(YY(ipt)-YY(1)) 333 : ENDIF 334 : UPOS=-1. 335 : IF (ABS(VV(iptn)-VV(1)).GT.TOLL) 336 : * UPOS=(VALDES-VV(1))/(VV(iptn)-VV(1)) 337 : IF (RANGE(UPOS)) THEN 338 : NP=NP+1 339 : XTR(NP)=XX(1)+UPOS*(XX(iptn)-XX(1)) 340 : YTR(NP)=YY(1)+UPOS*(YY(iptn)-YY(1)) 341 : ENDIF 342 : * il convient de fermer la ligne 343 : if (np.gt.2) then 344 : np=np+1 345 : xtr(np)=xtr(1) 346 : ytr(np)=ytr(1) 347 : endif 348 : if (np.gt.1) then 349 : *sg if (niso.lt.16) then 350 : if (niso.lt.13) then 350 : *sg CALL CHCOUL(ICOTAB(KK*(2-NISO/8))) 350 : CALL CHCOUL(ICOTAB(ISOTA0(KK,NISO))) 351 : else 351 : CALL CHCOUL(ICOTAB(MOD(KK,12)+1)) 351 : *sg CALL CHCOUL(KK) 352 : endif 352 : call polrl(np,xtr,ytr,ztr) 353 : endif 354 : 270 continue 355 : 150 CONTINUE 356 : ENDIF 357 : RETURN 358 : END 359 : 360 : 361 : 362 : 363 : 364 : 365 : 366 : 367 : 368 : 369 : 370 : 371 :
© Cast3M 2003 - All rights reserved.
Disclaimer