1 PROGRAM XD3D 2C 3C Main program of xd3d. 4C xd3d was born in 1988 on IBM mainframe computers. 5C It is a free software under the Gnu Public License since July 2003. 6C Its main author is Francois Jouve <francois.jouve@polytechnique.fr> 7C http://www.cmap.polytechnique.fr/~jouve/xd3d 8C 9 INCLUDE 'com_boutons.f' 10 INCLUDE 'com_coor.f' 11 INCLUDE 'com_faces.f' 12 INCLUDE 'com_ombreiso.f' 13 INCLUDE 'com_options.f' 14 INCLUDE 'com_savetrace.f' 15 INCLUDE 'com_vieucu.f' 16ctrans common / dirobs / obsobs(3),uuuu(3),vvvv(3) 17C 18 REAL*8 VEC0(3),VEC1(3),SEC0,SEC1 19 DIMENSION ROTA0(3,3),ROTAINV(3,3),SYM(3,4),XC(8),YC(8),ZC(8) 20 CHARACTER*128 FICLEC,FICLEC2,CBIDON 21 CHARACTER*7 CNUM 22 CHARACTER*3 CNUM2,CNUM3 23 CHARACTER*2 CC 24 CHARACTER*1 CSOURI(5) 25 LOGICAL*4 DEBUT,GEOM,GVESTLA 26 DATA SYM / 1.,1.,1., 1.,-1.,1., -1.,1.,1., -1.,-1.,1. / 27C 28 INCLUDE 'Version.f' 29 INCLUDE 'com_coul.f' 30C 31CC DATA USR2 / 0.707106781186548 / 32CC DATA USR3 / 0.577350269189626 / 33CC DATA USR6 / 0.408248290463863 / 34 DATA R2R3 / 0.816496580927726 / 35cc DATA RAC3 / 1.73205080756888 / 36 DATA PI / 3.14159265358979 / 37 DATA CSOURI / '0','"','#','A','C' / 38C 2^1/8 39 DATA FACZOOM / 1.090507733 / 40C 41C Langue 42C 43 CALL INIT_TEMPS 44 CALL perfide(ILANG,IDEBUG) 45 ILANG0 = ILANG 46 CALL BERLITZ(ILANG) 47 CALL INITFLUSH 48 CHEMDOC = '/home/jouve/Doc/xd3d_doc.ps' 49 LENCHEM = 27 50 PROG = 'd3d' 51 LPROG = 3 52 CALL LONGUEUR(PROBIG,LPRO) 53C 54cc IFIXFIX = 1 55 IFIXFIX = 0 56 DFACX = 0. 57 DFACY = 0. 58 DFACZ = 0. 59 FACPTS = 1. 60 FACVIT0 = 1. 61 IAUTORELOAD = 0 62 IBATCH = 0 63 IBORD = 0 64 IBORDTHERMO = 1 65 IBOUT = 0 66 ICALSU = 0 67 ICOLAR = 2 68 ICOLAX = 7 69 ICOLAXB = 4 70 ICOULTHERMO = 11 71 ICPTS = 1 72 ICSEG = 7 73 IDEB = 0 74 IDEBRAP = 0 75 IDEPOUILLE = 0 76 IDEROUL = 0 77 IDIRL = 0 78 IECBOI = 0 79 IELIMI = 0 80 IELISO = 0 81 IEPBOR = 6 82 IEPSEG = 1 83 IFC = 1 84 IFONT0 = 0 85 IFONT1 = 1 86 IFONT2 = 2 87 IFONT3 = 3 88 IFONT4 = 4 89 IFONT5 = 5 90 IFONT7 = 7 91 IFONT8 = 8 92 IFREEZE = 0 93 IFRONT = 0 94 IGOTO = 1 95 ILEG = 0 96 ILEGAUTO = 0 97 ILEGMAN = 0 98 ILOGX = 0 99 ILOGY = 0 100 ILOGZ = 0 101 INUMINTER = 0 102 IOPMAR = 0 103 IOPTFORME = 0 104 IPARA = 0 105 IPROGRE = 0 106 IPROX = 95 107 IPROY = 77 108 IQUEST = 0 109 IREFRE = 0 110 IRQ = 0 111 ISAUVEGRAPH = 0 112 ISAUVEMESH = 0 113 ISOBID = 0 114 ISTDOUT = 0 115 ISYMR = 0 116 ITEMPS = 0 117 ITOUCHEX = 0 118 ITOUCHNB = 0 119 ITOUCHTAB = 0 120 ITPTS = 5 121 ITYP = 0 122 IVIT = 1 123 IWAVE = 0 124 LONCOUR = 0 125 LONISO = 0 126 LONLEG = 0 127 LONPS = 0 128 LONVIT = 0 129 NBCOUL = 64 130 NODEPL = 0 131C 132 BIG = 1.E+14 133 BIGS = BIG 134 USBIG = 1./BIG 135 XFMAX = -BIG 136 XFMIN = BIG 137 YFMAX = -BIG 138 YFMIN = BIG 139 VCOUPXYZ(1) = BIG 140 VCOUPXYZ(2) = BIG 141 VCOUPXYZ(3) = BIG 142C 143C Lecture de la ligne de commande 144C 145 IFC0 = IFC 146 CALL LIOPT(FICLEC,FICLEC2,XINIT_ROTX,XINIT_ROTY,XINIT_ROTZ 147 & ,XINIT_VISO,XINIT_VMIN,XINIT_VMAX,XINIT_FACT 148 & ,XINIT_FACTX,XINIT_FACTY,XINIT_FACTZ,XINIT_FACV 149 & ,XINIT_XCUR,XINIT_YCUR,XINIT_ZOOM 150 & ,INIT_TABLE,INIT_ISO,INIT_FICH 151 & ,INIT_FICH2,INIT_BORD,INIT_DEFPS,INIT_NBCOUL 152 & ,INIT_FLECH,INIT_RECON,INIT_ISOBID,INIT_IBOITE 153 & ,INIT_IECBOI,INIT_FOND,INIT_IAXES,INIT_IPERSP 154 & ,INIT_DIRL,INIT_MODE,INIT_DEPL,INIT_SYMINV,INIT_ICTFAC) 155 IF (IFC.NE.IFC0) THEN 156 ISAVEIFC = 1 157 ELSE 158 ISAVEIFC = 0 159 ENDIF 160C 161C Evaluation de la memoire 162C 163 IF (ISTDOUT.EQ.0) CALL ECRMEM 164C 165C Initialisation 166C 167 1 IOPT = 1 168 GEOM = .FALSE. 169 IBORD0 = IBORD 170 IFC0 = IFC 171 CALL INITIAL(IPARA) 172C common savetrace 173 ICENTRISO0 = ICENTRISO 174 INUMER0 = INUMER 175 ISO0 = ISO 176 IVALMAR0 = IVALMAR 177 IVIT0 = IVIT 178 IX00 = 0 179 IX10 = 0 180 IY00 = 0 181 IY10 = 0 182 PREM = .TRUE. 183C 184 IF (INIT_FOND.GE.0) ICTFON = INIT_FOND 185 CALL MA_SOURIS(CSOURI(1),CSOURI(2),CSOURI(3),CSOURI(4),CSOURI(5)) 186 IF (ISAVEIFC.EQ.1) IFC = IFC0 187C 188C Opt forme 189C 190 IF (IOPTFORME.NE.0) THEN 191 IF (IOPTFORME.EQ.1) THEN 192 FICLEC = NOM_FICH(1:LONG-8)//'.theta' 193 INIT_FICH = LONG-2 194 ELSEIF(IOPTFORME.EQ.2) THEN 195 FICLEC = NOM_FICH(1:LONG-8)//'.thetap' 196 INIT_FICH = LONG-1 197 ELSEIF(IOPTFORME.EQ.-3) THEN 198 FICLEC = NOM_FICH(1:LONG-8)//'.v' 199 INIT_FICH = LONG-6 200 ELSE 201cc FICLEC = NOM_FICH(1:LONG-8)//'.levelset' 202 FICLEC = NOM_FICH(1:LONG-8)//'.psi' 203 INIT_FICH = LONG-4 204 ENDIF 205 CALL REMETFULLPATH(FICLEC,INIT_FICH) 206 INIT_BORD = 3 207 XINIT_FACT = 0. 208 IF (IOPTFORME.GT.0) THEN 209 IF (NOM_FICH(LONG-1:LONG).EQ.'3D') THEN 210 IFC = -1 211 XINIT_VISO = 0.3 212 ICALSU = 2 213 ELSE 214 INIT_ISO = 11 215 ENDIF 216 ELSE 217 IF (NOM_FICH(LONG-1:LONG).EQ.'3D') THEN 218 IFC = -1 219 IF (IOPTFORME.EQ.-1) THEN 220 ICALSU = 1 221 ELSEIF(IOPTFORME.EQ.-3) THEN 222 ICALSU = 2 223 ELSE 224 ICALSU = 0 225 ENDIF 226 IF (IOPTFORME.EQ.-3) THEN 227 XINIT_VISO = 0.5 228 ELSE 229 XINIT_VISO = 0. 230 ENDIF 231 ELSE 232 IF (IOPTFORME.EQ.-1.OR.IOPTFORME.EQ.-3) THEN 233 INIT_ISO = 2 234 INIT_NBCOUL = 8 235 ELSE 236 INIT_ISO = 4 237 INIT_NBCOUL = 1 238 IEPISO = 0 239 XINIT_VMIN = -1. 240 XINIT_VMAX = 1. 241 ENDIF 242 ITOUCHNB = 1 243 ENDIF 244 ENDIF 245 ENDIF 246C 247 IF (INIT_MODE.GE.0.AND.INIT_MODE.LT.1000) THEN 248 IF (INIT_MODE.EQ.0) THEN 249 FICLEC = NOM_FICH(1:LONG-8)//'.mode' 250 INIT_FICH = LONG-3 251 ELSE 252 WRITE(CNUM2,'(I3.3)') INIT_MODE 253 FICLEC = NOM_FICH(1:LONG-8)//'_'//CNUM2//'.mode' 254 INIT_FICH = LONG+1 255 ENDIF 256 CALL REMETFULLPATH(FICLEC,INIT_FICH) 257 ITOUCHEX = 1 258 IF (XINIT_FACT.EQ.BIGS.OR.XINIT_FACT.EQ.311263.) XINIT_FACT = 1. 259 ENDIF 260C 261 IF (INIT_DEPL.GE.0.AND.INIT_DEPL.LT.1000) THEN 262 IF (INIT_DEPL.EQ.0) THEN 263 FICLEC = NOM_FICH(1:LONG-8)//'.depl' 264 INIT_FICH = LONG-3 265 ELSE 266 WRITE(CNUM2,'(I3.3)') INIT_DEPL 267 FICLEC = NOM_FICH(1:LONG-8)//'_'//CNUM2//'.depl' 268 INIT_FICH = LONG+1 269 ENDIF 270 CALL REMETFULLPATH(FICLEC,INIT_FICH) 271 ITOUCHEX = 1 272 IF (XINIT_FACT.EQ.BIGS) XINIT_FACT = 1. 273 ENDIF 274C 275 IPFK = 9999 276 IF (IPARA.EQ.0) DEBUT = .TRUE. 277C 278C Lecture des points 279C 280 CALL LECTURE(XINIT_FACT) 281C 282 IF (INIT_SYMINV.NE.0.AND.IDEMI.EQ.0) IDEMI = 2 283 IF (XINIT_ECH(1,1).NE.BIGS.OR.XINIT_ECH(2,1).NE.BIGS) THEN 284 IF (XINIT_ECH(1,1).NE.BIGS) THEN 285 XMI = XINIT_ECH(1,1) 286 ELSE 287 XMI = XMIN 288 ENDIF 289 IF (XINIT_ECH(2,1).NE.BIGS) THEN 290 XMA = XINIT_ECH(2,1) 291 ELSE 292 XMA = XMAX 293 ENDIF 294 XBMIN = MIN(XMI,XMA) 295 XBMAX = MAX(XMI,XMA) 296 CALL ARONDI(XBMIN,XBMAX,XECH,PROPX,NECHX,NBECH) 297 BX = (XBMAX-XBMIN)*0.5 298 BX0 = BX 299 IECHFX = 1 300 ELSE 301 IECHFX = 0 302 XBMIN = 0. 303 XBMAX = 0. 304 ENDIF 305 IF (XINIT_ECH(1,2).NE.BIGS.OR.XINIT_ECH(2,2).NE.BIGS) THEN 306 IF (XINIT_ECH(1,2).NE.BIGS) THEN 307 YMI = XINIT_ECH(1,2) 308 ELSE 309 YMI = YMIN 310 ENDIF 311 IF (XINIT_ECH(2,2).NE.BIGS) THEN 312 YMA = XINIT_ECH(2,2) 313 ELSE 314 YMA = YMAX 315 ENDIF 316 YBMIN = MIN(YMI,YMA) 317 YBMAX = MAX(YMI,YMA) 318 CALL ARONDI(YBMIN,YBMAX,YECH,PROPY,NECHY,NBECH) 319 BY = (YBMAX-YBMIN)*0.5 320 BY0 = BY 321 IECHFY = 1 322 ELSE 323 IECHFY = 0 324 YBMIN = 0. 325 YBMAX = 0. 326 ENDIF 327 IF (XINIT_ECH(1,3).NE.BIGS.OR.XINIT_ECH(2,3).NE.BIGS) THEN 328 IF (XINIT_ECH(1,3).NE.BIGS) THEN 329 ZMI = XINIT_ECH(1,3) 330 ELSE 331 ZMI = ZMIN 332 ENDIF 333 IF (XINIT_ECH(2,3).NE.BIGS) THEN 334 ZMA = XINIT_ECH(2,3) 335 ELSE 336 ZMA = ZMAX 337 ENDIF 338 ZBMIN = MIN(ZMI,ZMA) 339 ZBMAX = MAX(ZMI,ZMA) 340 CALL ARONDI(ZBMIN,ZBMAX,ZECH,PROPZ,NECHZ,NBECH) 341 BZ = (ZBMAX-ZBMIN)*0.5 342 BZ0 = BZ 343 BZ00 = BZ 344 IECHFZ = 1 345 ELSE 346 IECHFZ = 0 347 ZBMIN = 0. 348 ZBMAX = 0. 349 ENDIF 350 IF (IECHFX.NE.0.OR.IECHFY.NE.0.OR.IECHFZ.NE.0) IFIX = 0 351C 352 IF (ICOURB.LE.0) THEN 353 IF (XINIT_FACTX.EQ.BIGS) THEN 354 XINIT_FACTX = 1. 355 ELSEIF(XINIT_FACTX.EQ.0.) THEN 356 XINIT_FACTX = EXAX0 357 ENDIF 358 IF (XINIT_FACTY.EQ.BIGS) THEN 359 XINIT_FACTY = 1. 360 ELSEIF(XINIT_FACTY.EQ.0.) THEN 361 XINIT_FACTY = EXAY0 362 ENDIF 363 IF (XINIT_FACTZ.EQ.BIGS) THEN 364 XINIT_FACTZ = 1. 365 ELSEIF(XINIT_FACTZ.EQ.0.) THEN 366 XINIT_FACTZ = EXAZ0 367 ENDIF 368 ENDIF 369C 370 IF (IPARA.NE.0) THEN 371 IBORD = IBORD0 372 IFC = IFC0 373 ENDIF 374ctrans dist000 = dist 375ctrans call calpup(xpup,dist,obsobs,uuuu,vvvv) 376 IF (IPARA.EQ.0) THEN 377 IF (I2D.EQ.0.AND.IPS2D.EQ.0 378 &.AND.(ICOURB.GT.0.OR.IELIMI.EQ.0)) THEN 379 IPERSP = -2 380 ELSE 381 IPERSP = 1 382 IAXES = 0 383 IBORD = 0 384 ENDIF 385 ELSEIF(IDEBRAP.NE.0) THEN 386 IBORD = -1 387 IFC = -1 388 ENDIF 389 IPERSP0 = IPERSP 390 IF (INIT_IPERSP.NE.0) IPERSP = INIT_IPERSP 391 CALL METLAPERSP 392 CALL METLALIGHT 393 IAXESDEF = IAXES 394 IF (INIT_IAXES.GE.0) IAXES = INIT_IAXES 395C 396C Selection des faces exterieures 397C 398 IF (ICOURB.GT.0) THEN 399 CALL ELIMIN 400 IF (IREFRE.EQ.0) IBOITE = 0 401 ELSE 402 IF (ICOURB.EQ.-5) THEN 403 IF (ICOURXYZ.EQ.2) THEN 404 CALL ELIMIN3 405 ELSE 406 CALL ELIMIN 407 ENDIF 408 ELSE 409 CALL ELIMIN2 410 ENDIF 411 IF (IREFRE.EQ.0) IBOITE = 1 412 ENDIF 413 IF ((IFRONT.EQ.-1.AND.NUMSD.LE.1) 414 &.OR.(IFRONT.EQ.1.AND.IFBLO.EQ.0)) IFRONT = 0 415 IF (IFRONT.EQ.3.AND.IFBLO.EQ.0) IFRONT = 2 416C 417 DO I=1,NUMSD 418 ISDVU(I) = 1 419 ENDDO 420C 421 IF (LONCOUR.GT.0) THEN 422 IF (ICOURB.EQ.-5.or.ICOURB.GT.0) THEN 423 CALL INV3X3(ROTA,ROTLOC,IERR) 424 DO I=1,3 425 DO J=1,3 426 ROTA(J,I) = ROTLOC(J,I) 427 ENDDO 428 ENDDO 429 CALL ROTATE(0) 430 IF (NDS.EQ.3) THEN 431 CALL LICOUR3(IRC) 432 ELSE 433 CALL LICOUR4(IRC) 434 ENDIF 435 CALL INV3X3(ROTA,ROTLOC,IERR) 436 DO I=1,3 437 DO J=1,3 438 ROTA(J,I) = ROTLOC(J,I) 439 ENDDO 440 ENDDO 441 CALL ROTATE(0) 442 ELSE 443 CALL LICOUR(IRC) 444 ENDIF 445 IF (IRC.NE.0) LONCOUR = 0 446 ENDIF 447C 448 CALL INITBOUT 449 IF (NDS.NE.3) THEN 450 IF (NDS.EQ.4.AND.I2D.EQ.0.AND.ICOURB.GT.0) THEN 451 IF (ELEMENTS(1:14).EQ.'Quadrangles 3D') THEN 452 NDS = 4 453 ELSE 454 NDS = 3 455 ENDIF 456 ELSE 457 NDS = 4 458 ENDIF 459 ENDIF 460 NDS2 = NDS+1 461C 462C Reconstitution de l'oeil par symetrie 463C 464 CALL RECONS(NFACE,NF,NF4,NRECONMAX,XMED2,YMED2) 465 IF (INIT_RECON.GT.1) NFACE = NF*MIN(NRECONMAX,INIT_RECON) 466 IF (INIT_RECON.LT.0) NFACE = NF*NRECONMAX 467 NRECON = NFACE/NF 468C 469 IF (NRECON.GT.1) THEN 470 NF0 = NF 471 NRECON0 = 1 472 CALL SYMETRISE(NRECON0,1) 473 ENDIF 474C 475C Champ de deplacement= vitesse 476C 477 IF (IFVIT.EQ.2) THEN 478 DO I=1,NF 479 DO J=1,NDS 480 VITF(1,J,I) = VITN(1,NFAC(J,I)) 481 VITF(2,J,I) = VITN(2,NFAC(J,I)) 482 VITF(3,J,I) = VITN(3,NFAC(J,I)) 483 VALF(J,I) = VALX(NFAC(J,I)) 484 ENDDO 485 ENDDO 486 IF (ISYM.EQ.4) THEN 487 IF (NRECONMAX.GT.1) THEN 488 IF (IDEMI.EQ.2) THEN 489 SYM(1,2) = -1. 490 SYM(2,2) = 1. 491 ENDIF 492 DO I=NF+1,NF4 493 II = 1+(I-1)/NF 494 DO J=1,NDS 495 VITF(1,J,I) = SYM(1,II)*VITN(1,NFAC(J,I)) 496 VITF(2,J,I) = SYM(2,II)*VITN(2,NFAC(J,I)) 497 VITF(3,J,I) = VITN(3,NFAC(J,I)) 498 VALF(J,I) = VALX(NFAC(J,I)) 499 ENDDO 500 ENDDO 501 ENDIF 502 ELSE 503 DO N=1,NRECONMAX-1 504 IF (MOD(N,2).EQ.1) THEN 505 ANG = REAL(2*(N+1))*PI/REAL(ISYM) 506 COCO = COS(ANG) 507 SISI = SIN(ANG) 508 DO K=1,NF 509 I = NF*N+K 510 DO J=1,NDS 511 VITF(1,J,I) = COCO*VITN(1,NFAC(J,I)) 512 & + SISI*VITN(2,NFAC(J,I)) 513 VITF(2,J,I) = SISI*VITN(1,NFAC(J,I)) 514 & - COCO*VITN(2,NFAC(J,I)) 515 VITF(3,J,I) = VITN(3,NFAC(J,I)) 516 VALF(J,I) = VALX(NFAC(J,I)) 517 ENDDO 518 ENDDO 519 ELSE 520 ANG = REAL(2*N+4)*PI/REAL(ISYM) 521 COCO = COS(ANG) 522 SISI = SIN(ANG) 523 DO K=1,NF 524 I = NF*N+K 525 II = NF+K 526 DO J=1,NDS 527 VITF(1,J,I) = COCO*VITF(1,J,II) 528 & + SISI*VITF(2,J,II) 529 VITF(2,J,I) = SISI*VITF(1,J,II) 530 & - COCO*VITF(2,J,II) 531 VITF(3,J,I) = VITN(3,NFAC(J,I)) 532 VALF(J,I) = VALX(NFAC(J,I)) 533 ENDDO 534 ENDDO 535 ENDIF 536 ENDDO 537 ENDIF 538 ENDIF 539C 540C Initialisation du graphique 541C 542 IF (IBATCH.EQ.0) THEN 543 IF (DEBUT) THEN 544 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 545 CALL x11nomicone('Xd3d'//char(0),4) 546 CALL x11askbacking(IBACKINGSTORE) 547C 548C Il y a des pb avec les polygones convexes lorsqu'ils sont tres 549C allonges. On reste donc avec l'hypothese de polygones Complex 550C 551CCC CALL x11polyconvex(0) 552 CALL GETIDX(IDX0,IDY0,IECX,IECY) 553 ENDIF 554 NBOGO = MYBOGOVITESSE() 555 IF (I2D.EQ.0) THEN 556 NBIGF = 8*NBOGO 557 ELSE 558 NBIGF = 5*NBOGO 559 ENDIF 560 NOUTLINEM = NBOGO/3 561 CALL CALCOUTLINE(NFACE,0) 562 IF (IPROGRE.EQ.0) THEN 563 IF (NFACE.LE.NBIGF) THEN 564 IF (ILANG.EQ.0) THEN 565 PRINT*,'Double buffer (NFACE=',NFACE,', Seuil=',NBIGF,')' 566 ELSE 567 PRINT*, 568 & 'Double buffer (NFACE=',NFACE,', Threshold=',NBIGF,')' 569 ENDIF 570 IPROGRE = -1 571 ELSE 572 IF (ILANG.EQ.0) THEN 573 PRINT*, 574 & 'Pas de double buffer (NFACE=',NFACE,', Seuil=',NBIGF,')' 575 ELSE 576 PRINT*, 577 & 'No double buffer (NFACE=',NFACE,', Threshold=',NBIGF,')' 578 ENDIF 579 IPROGRE = 1 580 ENDIF 581 ENDIF 582 ELSE 583 CALL FSINN(IPROX,IPROY,PROBIG,-99,ITERMC) 584 ENDIF 585 IDEB = 1 586 IF (I2D.EQ.0.AND.IPS2D.EQ.0.AND.(ICOURB.GT.0.OR.IELIMI.EQ.0)) THEN 587 IRENO = 0 588 IF (IPARA.NE.0) THEN 589 NRECON = MIN(IPARA,NRECONMAX) 590 NFACE = NF*NRECON 591 CALL ROTATE(1) 592 ELSEIF((NUMSD.EQ.1.OR.ICOURB.GT.0).AND. 593 & (ITERMC.EQ.1.OR.ITERMC.EQ.3.OR.ITERMC.EQ.4)) THEN 594 ITABLE = 7 595 IF (INIT_ICTFAC.EQ.0) THEN 596 ICTFAC = 99 597 ELSE 598 ICTFAC = INIT_ICTFAC 599 ENDIF 600 ELSE 601 ITABLE = 1 602 ICTFAC = 0 603 ENDIF 604 ELSE 605 IF (IPARA.EQ.0) THEN 606 ITABLE = 1 607 ICTFAC = 0 608 ENDIF 609 IF (I2D.NE.0) THEN 610 IRENO = I2D+1 611 ELSE 612 IRENO = 2 613 ENDIF 614 CALL CALROT(ROTLOC,IRENO) 615 CALL ROTATE(1) 616 ENDIF 617 ICTFAC00 = ICTFAC 618 IDIRL0 = IDIRL 619 IF (INIT_DIRL.EQ.-1) THEN 620 ICTFAC = 0 621 ELSEIF(INIT_DIRL.GT.0) THEN 622 IDIRL = INIT_DIRL 623 CALL METLALIGHT 624 ENDIF 625C 626 IF (MIN(XINIT_ROTX,XINIT_ROTY,XINIT_ROTZ).LT.BIGS) THEN 627 CALL ARC(ANGX,ANGY,ANGZ) 628 IF (XINIT_ROTX.NE.BIGS) ANGX = XINIT_ROTX 629 IF (XINIT_ROTY.NE.BIGS) ANGY = XINIT_ROTY 630 IF (XINIT_ROTZ.NE.BIGS) ANGZ = XINIT_ROTZ 631 CALL INV3X3(ROTA,ROTLOC,IERR) 632 CALL ROTATE(1) 633 CALL ARCROT(ANGX,ANGY,ANGZ) 634 CALL ROTATE(0) 635 ENDIF 636C 637C Table de couleurs initiale : 75 couleurs 638C 639 IF (INIT_TABLE.NE.0) ITABLE = INIT_TABLE 640 IF (INIT_NBCOUL.NE.0) NBCOUL = INIT_NBCOUL 641 CALL CHNBCOL(NBCOUL,NVAL,0,ITABLE) 642 IF (IBATCH.NE.0.AND.IPOSTCOL.EQ.1) CALL METIPOST(-2) 643 CALL TABCOL(NVAL,IWAVE) 644C 645 IF (IPARA.NE.0) CALL EXAGERE(DFACX,DFACY,DFACZ,0) 646 IF (INIT_FICH.GT.0) THEN 647 IRC = 1 648 CALL LIVAL(FICLEC,INIT_FICH,IVAL,ICLAS,ICONTR,NDSEL,IRC) 649 IF (IVAL.NE.9999) THEN 650 IGOTO = 0 651 IF (XINIT_FACT.NE.BIGS 652 & .AND.XINIT_FACT.NE.311263.) FACEXA = XINIT_FACT 653 CALL ACTLIVAL(IVAL,ICONTR,FICLEC,INIT_FICH,IREFRE,IGOTO) 654 ENDIF 655 ENDIF 656 IF (INIT_FICH2.GT.0) THEN 657 IRC = 1 658 CALL LIVAL(FICLEC2,INIT_FICH2,IVAL,ICLAS,ICONTR,NDSEL,IRC) 659 IF (IVAL.NE.9999) THEN 660 IGOTO = 0 661 IF (XINIT_FACT.NE.BIGS 662 & .AND.XINIT_FACT.NE.311263.) FACEXA = XINIT_FACT 663 CALL ACTLIVAL(IVAL,ICONTR,FICLEC2,INIT_FICH2,IREFRE,IGOTO) 664 ENDIF 665 ENDIF 666C///// changer ca 667 IF (INIT_ISOBID.NE.0) THEN 668 IF (I2D.NE.0.AND.INIT_ISOBID.EQ.1) THEN 669 INIT_ISOBID = 0 670 ELSE 671 ISOBID = INIT_ISOBID 672 CALL MYISO 673 ENDIF 674 ENDIF 675 IF (INIT_ISO.NE.0) THEN 676 IF (IFISO.EQ.0) THEN 677 IF (ILANG.EQ.0) THEN 678 IF (ISTDOUT.EQ.0) THEN 679 PRINT*,'*** Pas de fichier scalaire' 680 IF (INIT_ISO.LT.10) THEN 681 WRITE(*,'(" *** Option -iso=",I1," ignor�e")') INIT_ISO 682 ELSE 683 WRITE(*,'(" *** Option -iso=",I2," ignor�e")') INIT_ISO 684 ENDIF 685 ELSE 686 PRINT*,'*** No scalar field' 687 IF (INIT_ISO.LT.10) THEN 688 WRITE(*,'(" *** Option -iso=",I1," ignored")') INIT_ISO 689 ELSE 690 WRITE(*,'(" *** Option -iso=",I2," ignored")') INIT_ISO 691 ENDIF 692 ENDIF 693 ENDIF 694 ELSE 695 IF (INIT_ISO.GE.6.AND.ICENTR.EQ.0) THEN 696 II = INIT_ISO 697 IF (INIT_ISO.EQ.11) THEN 698 INIT_ISO = 1 699 ELSE 700 INIT_ISO = INIT_ISO-5 701 ENDIF 702 IF (ISTDOUT.EQ.0) THEN 703 IF (ILANG.EQ.0) THEN 704 PRINT*,'*** Pas de valeurs aux centres des cellules' 705 PRINT*, 706 & '*** Option -iso=',II,' transform�e en -iso=' 707 & ,INIT_ISO 708 ELSE 709 PRINT*,'*** No piecewise constant field' 710 PRINT*, 711 & '*** Option -iso=',II,' changed into -iso=' 712 & ,INIT_ISO 713 ENDIF 714 ENDIF 715 ENDIF 716 II = INIT_ISO+1 717 CALL ACTISO2(II) 718 ISOINI = 0 719 CALL ACTISO(ISOINI,NBCOUL,IWAVE,IGOTO) 720 IF (INIT_NBCOUL.NE.0.OR.INIT_TABLE.NE.0) THEN 721 IF (INIT_NBCOUL.NE.0) NBCOUL = INIT_NBCOUL 722 IF (INIT_TABLE.NE.0) ITABLE = INIT_TABLE 723 IF (ITABLE.GT.2) THEN 724 IIII = -100000-NBCOUL 725 ELSE 726 CALL CHNBCOL(NBCOUL,NVAL,1,ITABLE) 727 IIII = -100000-NVAL 728 ENDIF 729 CALL TABCOL(IIII,IWAVE) 730Cfj CALL CHNBCOL(NBCOUL,NVAL,0,ITABLE) 731Cfj CALL TABCOL(NVAL,IWAVE) 732 ENDIF 733 ENDIF 734 ENDIF 735 IF (XINIT_VISO.NE.BIGS) THEN 736 IF (IFISO.EQ.0) THEN 737 IF (ISTDOUT.EQ.0) THEN 738 IF (ILANG.EQ.0) THEN 739 PRINT*,'*** Pas de fichier scalaire' 740 PRINT*,'*** Option -isosurf ignor�e' 741 ELSE 742 PRINT*,'*** No scalar field' 743 PRINT*,'*** Option -isosurf ignored' 744 ENDIF 745 ENDIF 746 ELSEIF(I2D.NE.0) THEN 747 IF (ISTDOUT.EQ.0) THEN 748 IF (ILANG.EQ.0) THEN 749 PRINT*,'*** Maillage 2d' 750 PRINT*,'*** Option -isosurf ignor�e' 751 ELSE 752 PRINT*,'*** 2d mesh' 753 PRINT*,'*** Option -isosurf ignored' 754 ENDIF 755 ENDIF 756 ELSEIF((XINIT_VISO.GT.VMAX.OR.XINIT_VISO.LT.VMIN) 757 & .AND.ICALSU.EQ.0) THEN 758 IF (ISTDOUT.EQ.0) THEN 759 IF (ILANG.EQ.0) THEN 760 PRINT*,'*** Isosurface',XINIT_VISO,' hors bornes' 761 & ,VMIN,VMAX 762 PRINT*,'*** Option -isosurf ignor�e' 763 ELSE 764 PRINT*,'*** Isosurface',XINIT_VISO,' out of bounds' 765 & ,VMIN,VMAX 766 PRINT*,'*** Option -isosurf ignored' 767 ENDIF 768 ENDIF 769 ELSE 770 VISO = XINIT_VISO 771 IBSOMB = 0 772 IF (IBSOMB.EQ.0) THEN 773 BSOMB = 0.5 774 ELSEIF(IBSOMB.EQ.0) THEN 775 BSOMB = 0.3 776 ELSE 777 BSOMB = 0.1 778 ENDIF 779 CALL CALSUR(1) 780 ICSUR = 16 781 ENDIF 782 ENDIF 783 IF (XINIT_VMIN.NE.BIGS) THEN 784 IF (ISO.NE.0) THEN 785 VMIN0 = VMIN 786 VMIN = XINIT_VMIN 787 ELSEIF(ISTDOUT.EQ.0) THEN 788 IF (ILANG.EQ.0) THEN 789 PRINT*,'*** Pas d''isovaleurs demand�es' 790 PRINT*,'*** Option -vmin=',XINIT_VMIN,' ignor�e' 791 ELSE 792 PRINT*,'*** No contour plot asked' 793 PRINT*,'*** Option -vmin=',XINIT_VMIN,' ignored' 794 ENDIF 795 ENDIF 796 ENDIF 797 IF (XINIT_VMAX.NE.BIGS) THEN 798 IF (ISO.NE.0) THEN 799 VMAX0 = VMAX 800 VMAX = XINIT_VMAX 801 ELSEIF(ISTDOUT.EQ.0) THEN 802 IF (ILANG.EQ.0) THEN 803 PRINT*,'*** Pas d''isovaleurs demand�es' 804 PRINT*,'*** Option -vmax=',XINIT_VMAX,' ignor�e' 805 ELSE 806 PRINT*,'*** No contour plot asked' 807 PRINT*,'*** Option -vmax=',XINIT_VMAX,' ignored' 808 ENDIF 809 ENDIF 810 ENDIF 811 IF (ISO.NE.0.AND.MIN(XINIT_VMIN,XINIT_VMAX).LT.BIGS) THEN 812 IF (VMAX.EQ.VMIN) THEN 813 VMIN = VMIN0 814 VMAX = VMAX0 815 ELSEIF(VMIN.GT.VMAX) THEN 816 VMIN0 = VMIN 817 VMIN = VMAX 818 VMAX = VMIN0 819 ENDIF 820 ENDIF 821 IF (INIT_FLECH.NE.0) THEN 822 IF (IFVIT.NE.0) THEN 823 IF (IVIT.GT.0) IVIT = -IVIT 824 IF (XINIT_FACV.NE.0.) THEN 825 FACVIT = XINIT_FACV 826 FACVIT0 = XINIT_FACV 827 ENDIF 828 ENDIF 829 ENDIF 830C 831 IF (INIT_DEFPS.NE.9999) THEN 832 CALL DEFPS(INIT_DEFPS,SIG,ANGPS,ICADPS,HELPPS,IDSEUL,0,ILANG) 833 IDEFPS = INIT_DEFPS 834 ENDIF 835 IF (INIT_BORD.NE.9999) THEN 836 II = INIT_BORD+1 837 CALL ACTBOR2(II) 838 ENDIF 839C 840 IF (ICOURB.LT.0.AND.(XINIT_FACTX.NE.1..OR.XINIT_FACTY.NE.1. 841 & .OR.XINIT_FACTZ.NE.1.)) THEN 842 FACEXAX0 = FACEXAX 843 FACEXAY0 = FACEXAY 844 FACEXAZ0 = FACEXAZ 845 FACEXAX = XINIT_FACTX 846 FACEXAY = XINIT_FACTY 847 FACEXAZ = XINIT_FACTZ 848 DFACX = FACEXAX-FACEXAX0 849 DFACY = FACEXAY-FACEXAY0 850 DFACZ = FACEXAZ-FACEXAZ0 851 CALL EXAGERE(DFACX,DFACY,DFACZ,0) 852 VMINSAUV = VMIN 853 VMAXSAUV = VMAX 854 IF (ISOBID.NE.0) CALL MYISO 855 VMIN = VMINSAUV 856 VMAX = VMAXSAUV 857 XINIT_FACTX = 1. 858 XINIT_FACTY = 1. 859 XINIT_FACTZ = 1. 860 ENDIF 861C 862 IF (INIT_IBOITE.GE.0) THEN 863 IBOITE = INIT_IBOITE 864 IECBOI = INIT_IECBOI 865 ENDIF 866C 867C Selection des faces dont la normale est contenue dans le 1/2 espace 868C qui "regarde" l'observateur (si ifc.eq.1) 869C 870 5000 CALL PROJET(NBON,XMIN,XMAX,YMIN,YMAX) 871C 872C Classement des faces selectionnees selon la place de la projection 873C du barycentre sur la droite passant par (0,0,0) et 874C dirigee par (1,1,1) (direction d'observation) 875C 876 IF (I2D.EQ.0.OR.(IDEFOR.EQ.2.AND.FACEXA.NE.0.)) THEN 877 IF (NSURF.GT.0.AND.IFC.LT.0) THEN 878 CALL PROSUR(NBON) 879 CALL RANGEMENT(NBON+NSURF) 880c CALL TEMPS(SEC0,IS) 881 CALL CORRIGE(IORDRE,NBON,NSURF,NEIS,NSENS) 882c CALL TEMPS(SEC1,IS) 883c PRINT*,'Corrige =',SEC1-SEC0 884 ELSE 885 CALL RANGEMENT(NBON) 886cguignard do n=1,nbon 887cguignard nn = nproje(n) 888cguignard do i=1,4 889cguignard call zfictif(XF(I,Nn),YF(I,Nn),ZF(I,Nn),yy(i,n),zz(i,n)) 890cguignard enddo 891cguignard enddo 892cguignard call mysort2(xx,yy,zz,iordre,nbon) 893 ENDIF 894 ELSE 895 DO I=1,NBON 896 IORDRE(I) = I 897 ENDDO 898 ENDIF 899C 900 5010 IF (DEBUT) THEN 901 FACT = 1.08 902 IF (IBOITE.NE.0) THEN 903 CALL PROBOI(XC,YC,ZC) 904 DO I=1,8 905 XMAX = MAX(XMAX,XBOITE(I)) 906 XMIN = MIN(XMIN,XBOITE(I)) 907 YMAX = MAX(YMAX,YBOITE(I)) 908 YMIN = MIN(YMIN,YBOITE(I)) 909 ENDDO 910 IF (MOD(IECBOI,2).EQ.0.AND.IECBOI.GT.0) FACT = 1.2 911 ENDIF 912 IF (IVIT.LT.0) THEN 913 XMIN = MIN(XMIN,XFMIN) 914 XMAX = MAX(XMAX,XFMAX) 915 YMIN = MIN(YMIN,YFMIN) 916 YMAX = MAX(YMAX,YFMAX) 917 ENDIF 918 XCUR = .5*(XMIN+XMAX) 919 YCUR = .5*(YMIN+YMAX) 920 XL = FACT*(XMAX-XCUR) 921 YH = FACT*(YMAX-YCUR) 922 IF (ICARRE.EQ.1) THEN 923 XLARG = MAX(XL,YH) 924 ELSE 925 XLARG = MAX(XL,YH*HXA4/HYA4) 926 ENDIF 927 XLCRIT = XLARG*.5 928 PASMIN2 = (.0025*XLARG)**2 929 DEBUT = .FALSE. 930 ELSE 931 IF (I2D.EQ.0) THEN 932 IRENO = 0 933 ELSE 934 IRENO = 1 935 ENDIF 936 ENDIF 937C 938 IF (IBATCH.EQ.1) THEN 939c 940c rajout un peu crade pour cadrer correctement les fleches 941c quand on genere un ps directement 942c 943 IF (IVIT.LT.0) THEN 944 CALL ACTPS(NBON,IWAVE,IGOTO) 945 CALL TRACE(NBON,IOPT,GEOM,ITYP,IREFRE,IABAND,IBOUT,0) 946 CALL FINDUPS(IPF) 947 IF (LONPS.GT.0) CALL EXEC('/bin/rm -f '//NOMPS(1:LONPS)) 948 XMIN = MIN(XMIN,XFMIN) 949 XMAX = MAX(XMAX,XFMAX) 950 YMIN = MIN(YMIN,YFMIN) 951 YMAX = MAX(YMAX,YFMAX) 952 XCUR = .5*(XMIN+XMAX) 953 YCUR = .5*(YMIN+YMAX) 954 XL = FACT*(XMAX-XCUR) 955 YH = FACT*(YMAX-YCUR) 956 IF (ICARRE.EQ.1) THEN 957 XLARG = MAX(XL,YH) 958 ELSE 959 XLARG = MAX(XL,YH*HXA4/HYA4) 960 ENDIF 961 XLCRIT = XLARG*.5 962 PASMIN2 = (.0025*XLARG)**2 963 ENDIF 964 IBATCH = 2 965 CALL ACTPS(NBON,IWAVE,IGOTO) 966 ENDIF 967 XLAREF = XLARG 968 XCUREF = XCUR 969 YCUREF = YCUR 970 IF (XINIT_ZOOM.NE.BIGS) THEN 971 XLARG = XLARG/XINIT_ZOOM 972 XINIT_ZOOM = BIGS 973 ENDIF 974 IF (XINIT_XCUR.NE.BIGS) THEN 975 XCUR = XINIT_XCUR 976 XINIT_XCUR = BIGS 977 ENDIF 978 IF (XINIT_YCUR.NE.BIGS) THEN 979 YCUR = XINIT_YCUR 980 XINIT_YCUR = BIGS 981 ENDIF 982C 983C Dessin .......... 984C 985 5001 CALL GSLW(0) 986 CALL GSPAT(16) 987 IF (XLARG.LE.XLCRIT) THEN 988 CALL LIBERAL(1) 989 ELSE 990 CALL LIBERAL(0) 991 ENDIF 992 XDMIN0 = XDMIN 993 YDMI20 = YDMI2 994 ICTFAC0 = ICTFAC 995 DXTRANS = 0. 996 DYTRANS = 0. 997 IF (IBACKINGSTORE.EQ.0) IREFRE = 1 998 CALL TRACE(NBON,IOPT,GEOM,ITYP,IREFRE,IABAND,IBOUT,0) 999 GEOM = .FALSE. 1000C 1001C Backing store manuel 1002C 1003 IF (IBACKINGSTORE.EQ.0.AND.IBATCH.EQ.0) CALL mybackingsave 1004C 1005 IF (IQUEST.NE.0) THEN 1006 IF (IQUEST.EQ.1900) GOTO 1900 1007 IF (IQUEST.EQ.2300) GOTO 2300 1008 IF (IQUEST.EQ.3501) GOTO 3501 1009 IF (IQUEST.EQ.3503) GOTO 3503 1010 IF (IQUEST.EQ.4900) GOTO 4900 1011 ENDIF 1012C 1013 IF (IABAND.NE.0) THEN 1014 IF (ILANG.EQ.0) THEN 1015 PRINT*,'Abandon de la sauvegarde PostScript et effacement de ' 1016 & //NOMPS(1:LONPS) 1017 ELSE 1018 PRINT*,'Cancelling PostScript generation and deleting ' 1019 & //NOMPS(1:LONPS) 1020 ENDIF 1021 CALL EXEC('/bin/rm -f '//NOMPS(1:LONPS)) 1022 IPOST = 1 1023 IOPT = -3 1024 IREFRE = 1 1025 IMUL = IMULSAUV 1026 CALL x11allevents 1027 CALL CHANGE_CURS(1) 1028 GOTO 5001 1029 ENDIF 1030 IF (IOPT.EQ.-3) THEN 1031 CALL GSLT(0) 1032 IEPBOR = IEPBOR0 1033 CALL GSLW(IEPBOR) 1034 CALL GSBND(XCADRE(1),XCADRE(3),YDMIN,YDMAX) 1035 IF (IDEFPS.EQ.8) THEN 1036 CALL GSCOL(ICTFON) 1037 CALL GSPLNEC(4,XCADRE,YCADRE) 1038 CALL GSLW(0) 1039 IF (IAXES.NE.0) CALL AXES(XHELP,XDMAX,YDMIN,YDMAX) 1040 IF (ILEG.GT.0) 1041 & CALL LEGENDE(XHELP,XDMAX,YDMIN,YDMAX,BID,BID,BID,BID,1) 1042 CALL LECADRE 1043 ELSE 1044 CALL GSCOL(ICOLAX) 1045 CALL GSPLNEC(4,XCADRE,YCADRE) 1046 CALL GSLW(0) 1047 ENDIF 1048 CALL GSBND(XDMIN,XHELP,YDMI2,YDMAX) 1049 II = IABS(IBOUT) 1050 IF (II.NE.0) THEN 1051 IF (ITB(II).EQ.9) THEN 1052 CALL MYBORD(XBOUT(1,II),YBOUT(1,II),BID,0,1,0,0) 1053 ELSE 1054 CALL MYBORD(XBOUT(1,II),YBOUT(1,II),BID,0,ITOUR2,7,15) 1055 ENDIF 1056 ENDIF 1057 IX0 = IVRAIECOORD(XHELP) 1058 IX1 = IVRAIECOORD(XDMAX) 1059 PIPI = 2.*(XDMAX-XHELP)/REAL(IABS(IX0-IX1)) 1060 XCADRE(1) = XPTHER - DXTHER*.5 - PIPI 1061 XCADRE(2) = XPTHER + DXTHER*.5 + PIPI 1062 YCADRE(1) = YPTHER - DYTHER*.5 - PIPI 1063 YCADRE(2) = YPTHER + DYTHER + PIPI*3.5 1064 CALL GSPAT(8) 1065 CALL MY_GSAREA2(XCADRE,YCADRE) 1066 CALL GSBND(XDMIN,XDMAX,YDMIN,YDMAX) 1067 CALL METS_CURSEUR(XCUR,YCUR) 1068 ELSEIF(IPOST.EQ.1.AND.ITYP.GT.-13.AND.CLIGNE) THEN 1069 IX0 = IVRAIECOORD(XHELP) 1070 IX1 = IVRAIECOORD(XDMAX) 1071 PIPI = 2.*(XDMAX-XHELP)/REAL(IABS(IX0-IX1)) 1072 XCADRE(1) = XPTHER - DXTHER*.5 - PIPI 1073 XCADRE(2) = XPTHER + DXTHER*.5 + PIPI 1074 YCADRE(1) = YPTHER - DYTHER*.5 - PIPI 1075 YCADRE(2) = YPTHER + DYTHER*.5 + PIPI 1076 CALL GSPAT(8) 1077 CALL GSBND(XDMIN,XHELP,YDMI2,YDMAX) 1078 CALL MY_GSAREA2(XCADRE,YCADRE) 1079 ENDIF 1080 IREFRE = 0 1081 IPREM = 0 1082 IBHELP = -9999 1083C 1084C Envoi du dessin sur l'ecran 1085C 1086 5002 IF (IBOUT.NE.0) THEN 1087 II = IABS(IBOUT) 1088 KB = KBOUT(II) 1089 IF (ITB(II).EQ.9) THEN 1090 ITO = 1 1091 IC1 = 0 1092 IC2 = 0 1093 ELSE 1094 ITO = ITOUR2 1095 IC1 = 7 1096 IC2 = 15 1097 ENDIF 1098 IF (IBOUT.GT.0) THEN 1099C 1100C mettre dans cette liste tous les boutons qui donnent un popup 1101C dans une fenetre separee. 1102C 1103 IF (IDEROUL.EQ.0.AND.KB.NE.-15.AND.KB.NE.13.AND.KB.NE.19 1104 & .AND.KB.NE.21.AND.KB.NE.23.AND.KB.NE.36.AND.KB.NE.38) THEN 1105 ITYP = -13 1106 ELSE 1107 ITYP = 0 1108 IDEROUL = 0 1109 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0,ITO,IC1,IC2) 1110 IBOUT = 0 1111 ENDIF 1112 ELSEIF(ITB(II).GT.0) THEN 1113 IF ((KB.EQ.-20.AND.IPROGRE.LT.0) 1114 & .OR.(KB.EQ.-17.AND.ITITAV.LT.0) 1115 & .OR.(KB.EQ. 4.AND.ISHRINK.LT.0) 1116 & .OR.(KB.EQ. 6.AND.IFC.LT.0) 1117 & .OR.(KB.EQ. 14.AND.ICARRE.LT.0) 1118 & .OR.(KB.EQ. 31.AND.ISENS.LT.0)) THEN 1119cc & .OR.(KBOUT(II).EQ.-5.AND.IVIT.LT.0) 1120 CALL MYBORD(XBOUT(1,II),YBOUT(1,II),BID,0,ITO,IC2,IC1) 1121 ELSE 1122 CALL MYBORD(XBOUT(1,II),YBOUT(1,II),BID,0,ITO,IC1,IC2) 1123 ENDIF 1124 IF (KB.NE.2.AND.KB.NE.24) IBOUT = 0 1125 IDEROUL = 0 1126 ENDIF 1127 IF (IBACKINGSTORE.EQ.0.AND.IBATCH.EQ.0) THEN 1128 IF (KB.EQ. 2.OR.KB.EQ. 7.OR.KB.EQ.-20 1129 & .OR.KB.EQ.13.OR.KB.EQ.19 1130 & .OR.KB.EQ.24.OR.KB.EQ.32 1131 & .OR.KB.EQ.36.OR.KB.EQ.38 1132 & .OR.(KB.GE.28.AND.KB.LE.30)) THEN 1133 CALL MYBORD(XBOUT(1,II),YBOUT(1,II),BID,0,ITO,IC1,IC2) 1134 CALL mybackingsave 1135 ENDIF 1136 ENDIF 1137 ENDIF 1138 XCONT = XDMA2 - PIXEL*5. 1139 YCONT = .5*(YDMI2 + YDMIN)-PIXEL 1140 IF (I2D.NE.0) THEN 1141 CALL ASFCOL(0) 1142 IF (IFONT8.EQ.9) THEN 1143 CALL GSLSS(9) 1144 ELSE 1145 CALL GSLSS(0) 1146 ENDIF 1147 CALL GSPATF(8) 1148 CALL GSPAT(16) 1149 ENDIF 1150 IOPT = 1 1151 IF (IFREEZE.NE.0) THEN 1152 CALL GSQCUR(WIN,XCUCU,YCUCU) 1153 IF (XCUCU.LE.XHELP) THEN 1154 CALL CHANGE_CURS(2) 1155 ELSE 1156 CALL CHANGE_CURS(1) 1157 ENDIF 1158 ENDIF 1159C 1160 IF (IBRELON.EQ.0.OR.IBACKINGSTORE.EQ.0) THEN 1161 CALL AREFRESH(IRELIM,IRELIVA,IRELIVI) 1162 IF (IRELIM.NE.0.OR.IRELIVA.NE.0.OR.IRELIVI.NE.0) THEN 1163 IF (IAUTORELOAD.EQ.0) THEN 1164 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,1,ITYP,0,IBREL) 1165 ELSE 1166 IBOUT = IBREL 1167 GOTO 4906 1168 ENDIF 1169 ENDIF 1170 ENDIF 1171 NBEV = 0 1172C 1173C////////////////////////////////////////////////////////////// 1174 5003 CALL ASREAD2(IIII,IPFK,ITYP) 1175C////////////////////////////////////////////////////////////// 1176 IF (IDEBUG.NE.0) PRINT*,'Apr�s ASREAD2',IIII,IPFK,ITYP,IBOUT 1177 IF (IBATCH.EQ.2) STOP 1178C 1179 IF ((DXTRANS.NE.0..OR.DYTRANS.NE.0.) 1180 & .AND.(IPFK.LT.549.OR.IPFK.GT.552) 1181 & .AND.IPFK.NE.5.AND.IPFK.NE.-14 1182 & .AND.(ITYP.NE.-14.OR.IPFK.NE.-9999)) THEN 1183cc print*,'recalcule dim' 1184 DXTRANS = 0. 1185 DYTRANS = 0. 1186 CALL CALCDIM(YYLAR,0) 1187 ENDIF 1188C 1189 IF (IBRELON.EQ.0.OR.IBACKINGSTORE.EQ.0) THEN 1190 NBEV = NBEV+1 1191 IF (NBEV.GE.40.AND.IPFK.EQ.-9999.AND.ITYP.EQ.0 1192 & .AND.INUMINTER.EQ.0.AND.IPREM.EQ.0) THEN 1193 NBEV = 0 1194 CALL AREFRESH(IRELIM,IRELIVA,IRELIVI) 1195 IF (IRELIM.NE.0.OR.IRELIVA.NE.0.OR.IRELIVI.NE.0) THEN 1196 IF (IAUTORELOAD.EQ.0) THEN 1197 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,1,ITYP,0,IBREL) 1198 CALL GSPATF(8) 1199 ELSE 1200 IBOUT = IBREL 1201 GOTO 4906 1202 ENDIF 1203 ENDIF 1204 ENDIF 1205 ENDIF 1206C 1207 IF (ITYP.EQ.0.AND.IPFK.EQ.-9999.AND.IFREEZE.EQ.0) THEN 1208 CALL GSQCUR(WIN,XCUCU,YCUCU) 1209 IF (IPREM.GE.1) THEN 1210 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1211 IF (IPREM.EQ.2) THEN 1212 CALL GSMOVE(XCUR0-XLARG0,YCUR0-YLARG0) 1213 CALL GSLINE(XCUR0+XLARG0,YCUR0-YLARG0) 1214 CALL GSLINE(XCUR0+XLARG0,YCUR0+YLARG0) 1215 CALL GSLINE(XCUR0-XLARG0,YCUR0+YLARG0) 1216 CALL GSLINE(XCUR0-XLARG0,YCUR0-YLARG0) 1217 ELSE 1218 IPREM = 2 1219 CALL GSLT(0) 1220 CALL GSCOL(5) 1221 IF (I2D.NE.0) THEN 1222 CALL ASFCOL(0) 1223 IF (IFONT8.EQ.9) THEN 1224 CALL GSLSS(9) 1225 ELSE 1226 CALL GSLSS(0) 1227 ENDIF 1228 ENDIF 1229 ENDIF 1230 XCUR2 = XCUCU 1231 YCUR2 = YCUCU 1232 XCUR0 = .5*(XCUR1+XCUR2) 1233 YCUR0 = .5*(YCUR1+YCUR2) 1234 XXLARG = .5*ABS(XCUR1-XCUR2) 1235 YYLARG = .5*ABS(YCUR1-YCUR2) 1236 IF (ICARRE.EQ.1) THEN 1237 XLARG0 = AMAX1(XXLARG,YYLARG) 1238 YLARG0 = XLARG0 1239 ELSE 1240 XLARG0 = AMAX1(XXLARG,YYLARG*HXA4/HYA4) 1241 YLARG0 = XLARG0*HYA4/HXA4 1242 ENDIF 1243 IF (XLARG0.EQ.0.) THEN 1244 XLARG0 = XLARG 1245 IF (ICARRE.EQ.1) THEN 1246 YLARG0 = XLARG0 1247 ELSE 1248 YLARG0 = XLARG0*HYA4/HXA4 1249 ENDIF 1250 ENDIF 1251 CALL GSMOVE(XCUR0-XLARG0,YCUR0-YLARG0) 1252 CALL GSLINE(XCUR0+XLARG0,YCUR0-YLARG0) 1253 CALL GSLINE(XCUR0+XLARG0,YCUR0+YLARG0) 1254 CALL GSLINE(XCUR0-XLARG0,YCUR0+YLARG0) 1255 CALL GSLINE(XCUR0-XLARG0,YCUR0-YLARG0) 1256 IF (I2D.NE.0) THEN 1257 CALL GSMIX(0) 1258 CALL AFFCOORD(XCONT,YCONT 1259 & ,XMED0+XCUCU*R2R3 1260 & ,YMED0+YCUCU*R2R3,BID,2,0) 1261 CALL GSMIX(1) 1262 ENDIF 1263 ELSEIF(INUMINTER.GT.0) THEN 1264 IF (INUMINTER.LE.2) THEN 1265 DISMIN = BIG 1266 NN = 0 1267 IOK = 0 1268 NOK = 0 1269 DO N=1,NBON 1270 DO I=1,NDS 1271 D2 = (XCUCU-XX(I,N))**2+(YCUCU-YY(I,N))**2 1272 IF (D2.LT.DISMIN) THEN 1273 IOK = I 1274 NOK = N 1275 NE = NPROJE(N) 1276 NN = NFAC(I,NE) 1277 DISMIN = D2 1278 ENDIF 1279 ENDDO 1280 ENDDO 1281 XJEUNE = XX(IOK,NOK) 1282 YJEUNE = YY(IOK,NOK) 1283 CALL GSMS(5) 1284 CALL GSMB(PIPI*3.,PIPI*3.) 1285 ELSE 1286 DISMIN = BIG 1287 NN = 0 1288 IOK = 0 1289 NOK = 0 1290 IF (NDS.EQ.3) THEN 1291 XCUCU3 = 3.*XCUCU 1292 YCUCU3 = 3.*YCUCU 1293 DO N=1,NBON 1294 XCC = XX(1,N)+XX(2,N)+XX(3,N) 1295 YCC = YY(1,N)+YY(2,N)+YY(3,N) 1296 D2 = (XCUCU3-XCC)**2+(YCUCU3-YCC)**2 1297 IF (D2.LT.DISMIN) THEN 1298 NOK = N 1299 DISMIN = D2 1300 XCCMIN = XCC/3. 1301 YCCMIN = YCC/3. 1302 ENDIF 1303 ENDDO 1304 ELSE 1305 XCUCU4 = 4.*XCUCU 1306 YCUCU4 = 4.*YCUCU 1307 DO N=1,NBON 1308 XCC = XX(1,N)+XX(2,N)+XX(3,N)+XX(4,N) 1309 YCC = YY(1,N)+YY(2,N)+YY(3,N)+YY(4,N) 1310 D2 = (XCUCU4-XCC)**2+(YCUCU4-YCC)**2 1311 IF (D2.LT.DISMIN) THEN 1312 NOK = N 1313 DISMIN = D2 1314 XCCMIN = XCC*.25 1315 YCCMIN = YCC*.25 1316 ENDIF 1317 ENDDO 1318 ENDIF 1319 NE = NPROJE(NOK) 1320 NN = NNUMFA(NE) 1321 XJEUNE = XCCMIN 1322 YJEUNE = YCCMIN 1323 ENDIF 1324 IF (INUMINTER.GE.2) THEN 1325 IF (XJEUNE.NE.XVIEUX.OR.YJEUNE.NE.YVIEUX) THEN 1326 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1327 IF (INUMINTER.EQ.2) THEN 1328 CALL GSCOL(7) 1329 CALL GSMARK(XVIEUX,YVIEUX) 1330 ELSE 1331 CALL GSPATF(1) 1332 CALL GSPAT(16) 1333 CALL MY_GSAREA(0,XX(1,NNVIEUX),YY(1,NNVIEUX),NDS) 1334 ENDIF 1335 CALL GSCHAR3(XVIEUX,YVIEUX,L,CNUM,ICENT0,-1) 1336 ELSE 1337 GOTO 5003 1338 ENDIF 1339 ELSE 1340 INUMINTER = 2 1341 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1342 CALL METS_CURSEUR(XX(IOK,NOK),YY(IOK,NOK)) 1343 ENDIF 1344 XVIEUX = XJEUNE 1345 YVIEUX = YJEUNE 1346 IF (INUMINTER.EQ.2) THEN 1347 NNVIEUX = NN 1348 ELSE 1349 NNVIEUX = NOK 1350 ENDIF 1351 IF (NN.LT.10) THEN 1352 WRITE(CNUM(1:1),'(I1)') NN 1353 L = 1 1354 ELSEIF(NN.LT.100) THEN 1355 WRITE(CNUM(1:2),'(I2)') NN 1356 L = 2 1357 ELSEIF(NN.LT.1000) THEN 1358 WRITE(CNUM(1:3),'(I3)') NN 1359 L = 3 1360 ELSEIF(NN.LT.10000) THEN 1361 WRITE(CNUM(1:4),'(I4)') NN 1362 L = 4 1363 ELSEIF(NN.LT.100000) THEN 1364 WRITE(CNUM(1:5),'(I5)') NN 1365 L = 5 1366 ELSEIF(NN.LT.1000000) THEN 1367 WRITE(CNUM(1:6),'(I6)') NN 1368 L = 6 1369 ELSE 1370 WRITE(CNUM(1:7),'(I7)') NN 1371 L = 7 1372 ENDIF 1373 IF (INUMINTER.EQ.2) THEN 1374 CALL GSCOL(7) 1375 CALL GSMARK(XVIEUX,YVIEUX) 1376 ELSE 1377 CALL GSPATF(1) 1378 CALL GSPAT(16) 1379 CALL MY_GSAREA(0,XX(1,NNVIEUX),YY(1,NNVIEUX),NDS) 1380 ENDIF 1381 CALL GSCHAR3(XVIEUX,YVIEUX,L,CNUM,ICENT,-1) 1382 ICENT0 = ICENT 1383 IF (I2D.NE.0) THEN 1384 IF (INUMINTER.EQ.2) THEN 1385 CALL AFFCOORD(XCONT,YCONT 1386 & ,XMED0+XX(IOK,NOK)*R2R3 1387 & ,YMED0+YY(IOK,NOK)*R2R3,BID,2,NN) 1388 ELSE 1389 CALL AFFCOORD(XCONT,YCONT 1390 & ,XMED0+XCUCU*R2R3 1391 & ,YMED0+YCUCU*R2R3,BID,2,NN) 1392 ENDIF 1393 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1394 CALL GSLSS(IFONT1) 1395 CALL ASFCOL(5) 1396 ELSEIF(INUMINTER.EQ.2) THEN 1397 CALL INV3X3(ROTA,ROTAINV,IERR) 1398 XINI = ROTAINV(1,1)*X(NN) 1399 & + ROTAINV(1,2)*Y(NN) + ROTAINV(1,3)*Z(NN) 1400 YINI = ROTAINV(2,1)*X(NN) 1401 & + ROTAINV(2,2)*Y(NN) + ROTAINV(2,3)*Z(NN) 1402 ZINI = ROTAINV(3,1)*X(NN) 1403 & + ROTAINV(3,2)*Y(NN) + ROTAINV(3,3)*Z(NN) 1404 CALL AFFCOORD(XCONT,YCONT,XMED0+XINI,YMED0+YINI,ZMED0+ZINI,3 1405 & ,NN) 1406 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1407 CALL GSLSS(IFONT1) 1408 CALL ASFCOL(5) 1409 ENDIF 1410 GOTO 5003 1411 ELSEIF(XCUCU.GE.XHELP) THEN 1412 IF (IBHELP.GE.0) THEN 1413 IBHELP = -9999 1414 CALL CLNINF(1) 1415 ENDIF 1416 IF (I2D.NE.0) CALL AFFCOORD(XCONT,YCONT 1417 & ,XMED0+XCUCU*R2R3 1418 & ,YMED0+YCUCU*R2R3,BID,2,0) 1419 ELSE 1420 CALL QBOUT(XCUCU,YCUCU,IBBB) 1421 IF (IBBB.EQ.0) THEN 1422 IF (IBBB.NE.IBHELP) THEN 1423 IBHELP = 0 1424 CALL CLNINF(0) 1425 ENDIF 1426 ELSE 1427 IF (ITB(IBBB).EQ.6) THEN 1428 IF (IBHELP.NE.0) THEN 1429 IBHELP = 0 1430 CALL CLNINF(0) 1431 ENDIF 1432 ELSEIF(IBBB.NE.IBHELP) THEN 1433 IBHELP = IBBB 1434 CALL ECHELP(IBHELP,0) 1435 ENDIF 1436 ENDIF 1437 ENDIF 1438 GOTO 5003 1439 ELSEIF(IPREM.NE.0.AND.IPFK.NE.26.AND.IPFK.NE.0) THEN 1440 GOTO 5003 1441 ENDIF 1442 IF (INUMINTER.NE.0) THEN 1443 IF (IPFK.EQ.0.OR.IPFK.EQ.26) THEN 1444 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1445 CALL GSCHAR3(XVIEUX,YVIEUX,L,CNUM,ICENT,-1) 1446 CALL GSMIX(0) 1447 CALL GSBND(XDMIN,XHELP,YDMIN,YDMAX) 1448 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0 1449 & ,ITOUR2,7,15) 1450 IF (INUMINTER.EQ.2) THEN 1451 IF (I2D.EQ.0) THEN 1452 CALL AFFCOORD(XCONT,YCONT,BID,BID,BID,0,0) 1453 IF (ILANG.EQ.0) THEN 1454 PRINT*,'Dernier noeud :',NNVIEUX,' (' 1455 & ,XMED0+XINI,',',YMED0+YINI,',',ZMED0+ZINI,')' 1456 ELSE 1457 PRINT*,'Last node:',NNVIEUX,' (' 1458 & ,XMED0+XINI,',',YMED0+YINI,',',ZMED0+ZINI,')' 1459 ENDIF 1460 ELSE 1461 IF (ILANG.EQ.0) THEN 1462 PRINT*,'Dernier noeud :',NNVIEUX,' (' 1463 & ,XMED0+XX(IOK,NOK)*R2R3,',',YMED0+YY(IOK,NOK)*R2R3,')' 1464 ELSE 1465 PRINT*,'Last node:',NNVIEUX,' (' 1466 & ,XMED0+XX(IOK,NOK)*R2R3,',',YMED0+YY(IOK,NOK)*R2R3,')' 1467 ENDIF 1468 ENDIF 1469 ENDIF 1470 INUMINTER = 0 1471 CALL CLNINF(0) 1472 CALL CHANGE_CURS(1) 1473 ELSEIF(IPFK.EQ.-13) THEN 1474 IF (INUMINTER.EQ.2) THEN 1475 IF (I2D.EQ.0) CALL AFFCOORD(XCONT,YCONT,BID,BID,BID,0,0) 1476 INUMINTER = 3 1477 ICENT = 5 1478 ELSE 1479 INUMINTER = 2 1480 ICENT = 7 1481 ENDIF 1482 CALL GSMIX(0) 1483 CALL CLNINF(INUMINTER) 1484 CALL GSLSS(IFONT1) 1485 CALL GSMIX(1) 1486 CALL ASFCOL(5) 1487 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1488 GOTO 5003 1489 ELSE 1490 GOTO 5003 1491 ENDIF 1492 ENDIF 1493 CALL ASFCOL(ICOLAX) 1494 CALL GSMIX(0) 1495C 1496 IF (IIII.LT.0) THEN 1497 CALL x11szscrn(IDX2,IDY2) 1498 IF (IDX.NE.IDX2.OR.IDY.NE.IDY2) THEN 1499cc GEOM = .FALSE. 1500 CALL GSCLR 1501 GOTO 5001 1502 ELSE 1503 GOTO 5003 1504 ENDIF 1505 ELSEIF(IPFK.EQ.9999) THEN 1506 IPOST = 1 1507 IOPT = -3 1508 IREFRE = 1 1509 IMUL = IMULSAUV 1510 CALL x11allevents 1511 GOTO 5001 1512 ELSEIF(IBOUT.GT.0.AND.ITB(IBOUT).GT.0) THEN 1513cc CALL GSBND(XDMIN,XHELP,YDMI2,YDMAX) 1514 IF ((KBOUT(IBOUT).EQ.-20.AND.IPROGRE.LT.0) 1515 & .OR.(KBOUT(IBOUT).EQ.-17.AND.ITITAV.LT.0) 1516 & .OR.(KBOUT(IBOUT).EQ. 4.AND.ISHRINK.LT.0) 1517 & .OR.(KBOUT(IBOUT).EQ. 6.AND.IFC.LT.0) 1518 & .OR.(KBOUT(IBOUT).EQ.14.AND.ICARRE.LT.0) 1519 & .OR.(KBOUT(IBOUT).EQ.31.AND.ISENS.LT.0)) THEN 1520ccc & .OR.(KBOUT(IBOUT).EQ.-5.AND.IVIT.LT.0) 1521 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0,ITOUR2,15,7) 1522 ELSEIF(ITB(IBOUT).EQ.9) THEN 1523 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0,1,0,0) 1524 ELSE 1525 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0,ITOUR2,7,15) 1526 ENDIF 1527 CALL viderbuff2 1528 IBOUT = 0 1529 ITYP = 0 1530 GOTO 5002 1531 ELSEIF(ITYP.NE.0.AND.IFREEZE.EQ.0) THEN 1532 IF (IPFK.EQ.-9999) THEN 1533 IPFK = ITYP 1534 ELSE 1535 CALL CHANGE_CURS(1) 1536 IF (ITYP.EQ.-13) THEN 1537Cfj DO J=1,3 1538Cfj DO I=1,3 1539Cfj ROTA0(I,J) = ROTA(I,J) 1540Cfj ROTA(I,J) = ROTAINV(I,J) 1541Cfj ENDDO 1542Cfj ENDDO 1543Cfj CALL ROTATE(0) 1544Cfj DO J=1,3 1545Cfj DO I=1,3 1546Cfj ROTA(I,J) = ROTA0(I,J) 1547Cfj ENDDO 1548Cfj ENDDO 1549 CALL MULT(ROTAINV,ROTA) 1550 DO J=1,3 1551 DO I=1,3 1552 ROTA0(I,J) = ROTA(I,J) 1553 ROTA(I,J) = ROTAINV(I,J) 1554 ENDDO 1555 ENDDO 1556Cfj 1557 CALL ROTATE(0) 1558 DO J=1,3 1559 DO I=1,3 1560 ROTA(I,J) = ROTA0(I,J) 1561 ENDDO 1562 ENDDO 1563 ITYP = 0 1564 IBOUT = IBROT 1565 GEOM = .TRUE. 1566 GOTO 5000 1567 ELSE 1568 ITYP = 0 1569 IREFRE = 1 1570 IOPT = -4 1571 GEOM = .TRUE. 1572 GOTO 5001 1573 ENDIF 1574 ENDIF 1575 ENDIF 1576C 1577C Zoom interactif (0) annule par Q 1578C 1579 IF (IPFK.EQ.0) THEN 1580 CALL GSQCUR(WIN,XCUCU,YCUCU) 1581 IF (XCUCU.LT.XHELP) THEN 1582 CALL QBOUT(XCUCU,YCUCU,IBBB) 1583Cfj IF (IBBB.EQ.IBFREEZ) THEN 1584Cfj CALL GSBND(XDMIN,XDMA2,YDMIN,YDMAX) 1585Cfj CALL GSPAT(15) 1586Cfj CALL GSMIX(1) 1587Cfj CALL MY_GSAREA2B(XHELP,XDMA2,YDMIN,YDMAX) 1588Cfj CALL GSMIX(0) 1589Cfj IF (IFREEZE.EQ.0) THEN 1590Cfj IFREEZE = 1 1591Cfj IBOUBOU = 0 1592Cfj CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,1,ITYP,IOPT,IBOUBOU) 1593Cfj GOTO 5003 1594Cfj ELSE 1595Cfj IFREEZE = 0 1596Cfj IBOUT = IBFREEZ 1597Cfj CALL GSPAT(8) 1598Cfj CALL MY_GSAREA2(XBOUT(1,IBOUT),YBOUT(1,IBOUT)) 1599Cfj IREFRE = 1 1600Cfj GEOM = .FALSE. 1601Cfj GOTO 5001 1602Cfj ENDIF 1603Cfj ELSEIF(IBBB.GT.0) THEN 1604 IF (IBBB.GT.0) THEN 1605Cfj 1606 IF (ITB(IBBB).NE.6.AND.ITB(IBBB).GT.0) THEN 1607 IF (IACTIF(IBBB).EQ.0) GOTO 5002 1608 IF (ITB(IBBB).GT.0) THEN 1609 CALL GSBND(XDMIN,XHELP,YDMIN,YDMAX) 1610 CALL MYBORD(XBOUT(1,IBBB),YBOUT(1,IBBB),BID,0,ITOUR2 1611 & ,15,7) 1612 CALL viderbuff2 1613 ENDIF 1614 IBOUT = IBBB 1615 IF (IBOUT.EQ.IBDOC) THEN 1616 CALL QUICESTCELUILA('gv',2,GVESTLA,0) 1617 IF (GVESTLA) THEN 1618 CALL EXEC('gv '//CHEMDOC(1:LENCHEM)//'&') 1619 ELSE 1620 CALL QUICESTCELUILA('ghostview',9,GVESTLA,0) 1621 IF (GVESTLA) 1622 & CALL EXEC('ghostview '//CHEMDOC(1:LENCHEM)//'&') 1623 ENDIF 1624 GOTO 5002 1625 ELSEIF(IBOUT.EQ.IBLANG) THEN 1626 GOTO 3505 1627 ELSE 1628 IPFK = KBOUT(IBOUT) 1629 IF (IMENU(IBOUT).NE.0) THEN 1630 CALL GSBND(XDMIN,XDMAX,YDMI2,YDMAX) 1631 CALL MENUS(IPFK,IBOUT,IDEROUL,IRC) 1632 IF (IDEROUL.EQ.0) THEN 1633 ITYP = 0 1634 GOTO 5003 1635 ENDIF 1636 IF (IPFK.EQ.-18.AND.ICOURB.GT.0) THEN 1637 IF (IDEROUL.GE.2) THEN 1638 IF (IDEROUL.EQ.2) THEN 1639 INUMER = -3 1640 ELSEIF(IDEROUL.EQ.3) THEN 1641 INUMER = 0 1642 ELSEIF(IDEROUL.EQ.4) THEN 1643 INUMER = -1 1644 ELSEIF(IDEROUL.EQ.5) THEN 1645 INUMER = 1 1646 ELSE 1647 INUMER = -2 1648 ENDIF 1649 GOTO 4903 1650 ENDIF 1651 IF (INUMINTER.EQ.0) THEN 1652 INUMINTER = 1 1653 CALL CHANGE_CURS(11) 1654 CALL GSBND(XDMIN,XHELP,YDMIN,YDMAX) 1655 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0 1656 & ,ITOUR2,15,7) 1657 CALL viderbuff2 1658 CALL CLNINF(2) 1659 CALL ASFCOL(5) 1660 CALL GSMIX(1) 1661 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1662 IX0 = IVRAIECOORD(XHELP) 1663 IX1 = IVRAIECOORD(XDMAX) 1664 PIPI = 2.*(XDMAX-XHELP)/REAL(IABS(IX0-IX1)) 1665 CALL GSLSS(IFONT1) 1666 ICENT = 7 1667 ELSE 1668 CALL ASFCOL(5) 1669 CALL GSMIX(1) 1670 CALL GSCHAR3(XVIEUX,YVIEUX,L,CNUM,ICENT,-1) 1671 CALL GSMIX(0) 1672 CALL GSBND(XDMIN,XHELP,YDMIN,YDMAX) 1673 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0 1674 & ,ITOUR2,7,15) 1675 CALL viderbuff2 1676 CALL CHANGE_CURS(2) 1677 INUMINTER = 0 1678 ENDIF 1679 GOTO 5003 1680 ELSEIF(IPFK.EQ.-6) THEN 1681 IF (IDEROUL.EQ.1) THEN 1682 GOTO 4100 1683 ELSE 1684 IDBID = MOD(IDEROUL-2,7) + 1 1685 IF (IDEROUL.EQ.16) THEN 1686 FFF = -1. 1687 ELSEIF(IDBID.EQ.1) THEN 1688 FFF = 1.1 1689 ELSEIF(IDBID.EQ.2) THEN 1690 FFF = 1.5 1691 ELSEIF(IDBID.EQ.3) THEN 1692 FFF = 2. 1693 ELSEIF(IDBID.EQ.4) THEN 1694 FFF = 3. 1695 ELSEIF(IDBID.EQ.5) THEN 1696 FFF = 4. 1697 ELSEIF(IDBID.EQ.6) THEN 1698 FFF = 5. 1699 ELSE 1700 FFF = 10. 1701 ENDIF 1702 IF (IDEROUL.LT.9) THEN 1703 FACVIT = FACVIT*FFF 1704 FACVIT0 = FACVIT0*FFF 1705 ELSE 1706 FACVIT = FACVIT/FFF 1707 FACVIT0 = FACVIT0/FFF 1708 ENDIF 1709 GEOM = .TRUE. 1710 GOTO 5001 1711 ENDIF 1712 ELSEIF(IPFK.EQ.-5) THEN 1713 GOTO 4000 1714 ELSEIF(IPFK.EQ.-2) THEN 1715 GOTO 5000 1716 ELSEIF(IPFK.EQ.3) THEN 1717 GOTO 301 1718 ELSEIF(IPFK.EQ.11) THEN 1719 GOTO 1101 1720 ELSEIF(IPFK.EQ.15.OR.IPFK.EQ.33.OR.IPFK.EQ.-1) THEN 1721 GOTO 5001 1722 ELSEIF(IPFK.EQ.17.AND.IACTIF(IBOUT).NE.0) THEN 1723 ISOINI = IRC 1724 GOTO 1701 1725 ELSEIF(IPFK.EQ.20.AND.ITABLE.GT.3000) THEN 1726 ITABLE = ITABLE-4000 1727 ICTFAC = ICTFAC+4000 1728 GOTO 2500 1729 ELSEIF(IPFK.EQ.22) THEN 1730 GOTO 2200 1731 ELSEIF(IPFK.EQ.25) THEN 1732 IF (ICTFAC.GT.3000) THEN 1733 GOTO 2500 1734 ELSE 1735 GOTO 2502 1736 ENDIF 1737 ELSEIF(IPFK.EQ.27) THEN 1738 ISOBID = IDEROUL 1739 GOTO 2702 1740 ELSEIF(IPFK.EQ.28) THEN 1741 GOTO 2801 1742 ENDIF 1743 ENDIF 1744 GOTO 7000 1745 ENDIF 1746 ENDIF 1747 ENDIF 1748 ELSEIF(IPREM.EQ.0.AND.XCUCU.GT.XDMAX) THEN 1749 GOTO 4300 1750 ELSEIF(IPREM.EQ.0.AND.IFREEZE.EQ.0) THEN 1751 IPREM = 1 1752 XCUR1 = XCUCU 1753 YCUR1 = YCUCU 1754 CALL ECHELP(NBOUT+1,1) 1755 CALL GSMIX(1) 1756 SIZMAR = .1*(XDMAX-XHELP) 1757 CALL GSMB(SIZMAR,SIZMAR) 1758 CALL GSMS(1) 1759 CALL GSCOL(7) 1760 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1761 CALL GSMARK(XCUR1,YCUR1) 1762 CALL GSMARK(XDMAX-(XCUR1-XHELP),YCUR1) 1763 CALL GSMARK(XDMAX-(XCUR1-XHELP),YDMAX-(YCUR1-YDMIN)) 1764 CALL GSMARK(XCUR1,YDMAX-(YCUR1-YDMIN)) 1765 IZOOMBID = 0 1766 GOTO 5003 1767 ELSEIF(IPREM.EQ.1) THEN 1768 IPFK = 26 1769 IZOOMBID = 1 1770 ELSEIF(IPREM.EQ.2) THEN 1771 XCUR = XCUR0 1772 YCUR = YCUR0 1773 FACVIT = FACVIT*XLARG/XLARG0 1774 XLARG = XLARG0 1775 PASMIN2 = (.0025*XLARG)**2 1776 ITYP = 0 1777 IREFRE = 1 1778 IOPT = -4 1779 GEOM = .TRUE. 1780 CALL CHANGE_CURS(1) 1781 GOTO 5001 1782 ENDIF 1783 ENDIF 1784 IDEROUL = 0 1785 7000 IPOSTCOL = 0 1786 IF (IFREEZE.NE.0) THEN 1787 IF (IPFK.EQ.-9999) GOTO 5003 1788 IF (IPFK.EQ.0.OR.IPFK.EQ.-13.OR.IPFK.EQ.-14) THEN 1789 CALL GSQCUR(WIN,XCUCU,YCUCU) 1790 IF (XCUCU.GE.XHELP) GOTO 5003 1791 ELSE 1792 IBOUBOU = -6666 1793 DO I=1,NBOUT 1794 IF (KBOUT(I).EQ.IPFK.AND.IACTIF(I).NE.0) IBOUBOU=I 1795 ENDDO 1796 IF (IBOUBOU.EQ.-6666) GOTO 5003 1797 ENDIF 1798 ELSE 1799 IF (ITYP.EQ.0.AND.(IPFK.EQ.-13.OR.IPFK.EQ.-14)) THEN 1800 CALL GSQCUR(WIN,XCUCU,YCUCU) 1801 IF (XCUCU.GE.XDMAX) THEN 1802C 1803C Pour recalculer la position de la table... 1804C 1805 CALL GSBND(XDMIN,XHELP,YDMI2,YDMAX) 1806 CALL INFO(XDMAX,XDMA2,YDMIN,YDMAX,NSURF) 1807 IF (ISO.NE.0.OR.ICTFAC.GE.0) THEN 1808 FACT = (YCUCU-YCOUL(1))/(YCOUL(NBCOL+1)-YCOUL(1)) 1809 IF (ISO.EQ.2) THEN 1810 ICPOINT = 19+NINT(FACT*REAL(NBCOL-1)) 1811 ELSE 1812 ICPOINT = 18+NINT(.5+FACT*REAL(NBCOL)) 1813 ENDIF 1814 IF (ICPOINT.GE.19.AND.ICPOINT.LE.NBCOL+18) THEN 1815 YBIDONCOM = YCUCU 1816 IBOUT = 3333 1817 CALL GSBND(XDMIN,XDMA2,YDMI2,YDMAX) 1818 CALL MENUS(IPFK,IBOUT,IDEROUL,ICPOINT) 1819 IF (IDEROUL.GE.1.AND.IDEROUL.LE.16) THEN 1820 CALL TABCOL(-(IDEROUL*1000+ICPOINT),IWAVE) 1821 IF (ITERMC.EQ.4) THEN 1822 GOTO 5001 1823 ELSE 1824 GOTO 5003 1825 ENDIF 1826 ELSE 1827 GOTO 5003 1828 ENDIF 1829 ELSE 1830 GOTO 5003 1831 ENDIF 1832 ELSE 1833 GOTO 5003 1834 ENDIF 1835 ENDIF 1836 ENDIF 1837 ENDIF 1838 NEGNEG = -21 1839 IF (IDEBUG.NE.0) PRINT*,'Avant GOTO, IPFK=',IPFK,' IBOUT=',IBOUT 1840 IF (IPFK.NE.NEGNEG.AND.IPFK.NE.2.AND.IPFK.NE.24.AND.IPFK.NE.28 1841 & .AND.IPFK.NE.9999.AND.IPFK.NE.-9.AND.IPFK.NE.26) NBPG = 0 1842 IF (IPFK.GE.NEGNEG.AND.IPFK.LE.39.AND.IPFK.NE.0) THEN 1843 IF (IBOUT.EQ.0) THEN 1844 DO I=1,NBOUT 1845 IF (KBOUT(I).EQ.IPFK.AND.KBOUT(I).GT.-10000 1846 & .AND.LBOUT(I).GT.0) THEN 1847 IBOUT = -I 1848 IF (IPFK.NE.-9) 1849 & CALL MYBORD(XBOUT(1,I),YBOUT(1,I),BID,0,ITOUR2,15,7) 1850 GOTO 7001 1851 ENDIF 1852 ENDDO 1853 ENDIF 1854 7001 GOTO (4906,4905,4904,4903,4902,4901,4900,501,4800,4700 1855 & ,4600,4500,4400,4300,4200,4100,4000,3900,3800,3700,3600 1856 & ,5003 1857 & ,100,200,300,400,500,600,700,800,900,1000,1100,1200,1300 1858 & ,1400,1500,1600,1700,1800,1900,2000,2100,2200,2300,2400 1859 & ,2500,2600,2700,2800,2900,3000,3100,3200,3300,3400,3500 1860 & ,3501,3502,3503,3504) IPFK+1-NEGNEG 1861C 1862C Fleches du clavier 1863C 1864 ELSEIF(IPFK.GE.549.AND.IPFK.LE.552.AND.IPROGRE.LT.0) THEN 1865 TRANS0 = (XDMAX-XHELP)*.0025 1866 IF (IPFK.EQ.549) THEN 1867 DYTRANS = DYTRANS+TRANS0 1868 ELSEIF(IPFK.EQ.550) THEN 1869 DXTRANS = DXTRANS-TRANS0 1870 ELSEIF(IPFK.EQ.551) THEN 1871 DXTRANS = DXTRANS+TRANS0 1872 ELSE 1873 DYTRANS = DYTRANS-TRANS0 1874 ENDIF 1875 XCUR = XMIL-DXTRANS 1876 YCUR = YMIL-DYTRANS 1877 GOTO 503 1878 ELSE 1879 GOTO 5003 1880 ENDIF 1881C////////////////////////////////////////////////////////////// 1882C 1883C Symetries (1) 1884C 1885 100 NF0 = NFACE 1886 NRECON0 = NRECON 1887 IF (IDEROUL.EQ.0) THEN 1888 NRECON = NRECON+1 1889 IF (NRECON.GT.NRECONMAX) NRECON=1 1890 ELSE 1891 NRECON = MIN(NRECONMAX,IDEROUL) 1892 ENDIF 1893 NFACE = NF*NRECON 1894C 1895 IF (NFACE.NE.NF0) THEN 1896 CALL SYMETRISE(NRECON0,0) 1897 IF (NSURF.GT.0) CALL CALSUR(1) 1898 GEOM = .TRUE. 1899 GOTO 5000 1900 ELSE 1901 GOTO 5003 1902 ENDIF 1903C 1904C Sauvegarde (Postscript et Postscript couleur) (2, O) 1905C 1906 200 CALL ACTPS(NBON,IWAVE,IGOTO) 1907 IF (IGOTO.EQ.5001) THEN 1908 GOTO 5001 1909 ELSE 1910 GOTO 5003 1911 ENDIF 1912C 1913C Fin ou annulation du zoom interactif (Q) 1914C 1915 2600 IF (IPREM.EQ.0) THEN 1916 GOTO 999 1917 ELSE 1918 IF (IZOOMBID.EQ.0) THEN 1919 CALL GSMIX(1) 1920 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 1921 CALL GSMOVE(XCUR0-XLARG0,YCUR0-YLARG0) 1922 CALL GSLINE(XCUR0+XLARG0,YCUR0-YLARG0) 1923 CALL GSLINE(XCUR0+XLARG0,YCUR0+YLARG0) 1924 CALL GSLINE(XCUR0-XLARG0,YCUR0+YLARG0) 1925 CALL GSLINE(XCUR0-XLARG0,YCUR0-YLARG0) 1926 CALL GSCOL(7) 1927 CALL GSMARK(XCUR1,YCUR1) 1928 CALL GSMARK(XDMAX-(XCUR1-XHELP),YCUR1) 1929 CALL GSMARK(XDMAX-(XCUR1-XHELP),YDMAX-(YCUR1-YDMIN)) 1930 CALL GSMARK(XCUR1,YDMAX-(YCUR1-YDMIN)) 1931 ENDIF 1932 CALL GSMIX(0) 1933 CALL CLNINF(1) 1934 IPREM = 0 1935 GOTO 5003 1936 ENDIF 1937C 1938C Shrink (4) 1939C 1940 400 ISHRINK = -ISHRINK 1941 GEOM = .TRUE. 1942 GOTO 5000 1943C 1944C Translation de l'image (5)... 1945C 1946 500 CALL GSQCUR(WIN,XCUR,YCUR) 1947 CALL METS_CURSEUR(XMIL,YMIL) 1948 503 IF (XCUR.NE.XMIL.OR.YCUR.NE.YMIL) THEN 1949 DXTRANS = XMIL-XCUR 1950 DYTRANS = YMIL-YCUR 1951 XCUR = XMIL-DXTRANS 1952 YCUR = YMIL-DYTRANS 1953 CALL VRAIECOORD(XHELP,YDMAX,IX0,IY0) 1954 CALL VRAIECOORD(XDMAX,YDMIN,IX1,IY1) 1955 PIPI = .5*REAL(IEPBOR)*(XDMAX-XHELP)/REAL(IABS(IX0-IX1)) 1956 ILARG = IX1-IX0-IEPBOR 1957 IHAUT = IY1-IY0-IEPBOR 1958 IX0 = IX0+IEPBOR/2 1959 IY0 = IY0+IEPBOR/2 1960 IX1 = IX1-IEPBOR/2 1961 IY1 = IY1-IEPBOR/2 1962 IX2OLD = IX0 1963 IY2OLD = IY0 1964 ILARGOLD = ILARG 1965 IHAUTOLD = IHAUT 1966 CALL GSBND(XHELP+PIPI,XDMAX-PIPI,YDMIN+PIPI,YDMAX-PIPI) 1967 GOTO 502 1968 ELSE 1969 GOTO 5003 1970 ENDIF 1971C 1972C ...ou par curseur (") 1973C 1974 501 CALL GSQCUR(WIN,XCUR111,YCUR111) 1975 IF (ITYP.EQ.0) THEN 1976 ITYP = -14 1977 DXTRANS = 0. 1978 DYTRANS = 0. 1979 DXTRAN0 = 0. 1980 DYTRAN0 = 0. 1981 CALL CHANGE_CURS(4) 1982CImage 1983 CALL VRAIECOORD(XHELP,YDMAX,IX0,IY0) 1984 CALL VRAIECOORD(XDMAX,YDMIN,IX1,IY1) 1985 PIPI = .5*REAL(IEPBOR)*(XDMAX-XHELP)/REAL(IABS(IX0-IX1)) 1986 ILARG = IX1-IX0-IEPBOR 1987 IHAUT = IY1-IY0-IEPBOR 1988 IX0 = IX0+IEPBOR/2 1989 IY0 = IY0+IEPBOR/2 1990 IX1 = IX1-IEPBOR/2 1991 IY1 = IY1-IEPBOR/2 1992 IX2OLD = IX0 1993 IY2OLD = IY0 1994 ILARGOLD = ILARG 1995 IHAUTOLD = IHAUT 1996 CALL GSBND(XHELP+PIPI,XDMAX-PIPI,YDMIN+PIPI,YDMAX-PIPI) 1997 ELSE 1998 DXTRAN0 = DXTRANS 1999 DYTRAN0 = DYTRANS 2000 DDDX = XCUR111-XCUR000 2001 DDDY = YCUR111-YCUR000 2002 IF (I2D.NE.0) THEN 2003 CALL AFFCOORD(XCONT,YCONT,XMED0+XCUR111*R2R3 2004 & ,YMED0+YCUR111*R2R3,BID,2,0) 2005 CALL GSBND(XHELP+PIPI,XDMAX-PIPI,YDMIN+PIPI,YDMAX-PIPI) 2006 ENDIF 2007 IF ((DDDX**2+DDDY**2).GT.PASMIN2) THEN 2008 XCUR = XCUR-DDDX 2009 YCUR = YCUR-DDDY 2010 DXTRANS = DXTRANS+DDDX 2011 DYTRANS = DYTRANS+DDDY 2012 ELSE 2013 GOTO 5003 2014 ENDIF 2015 ENDIF 2016 XCUR000 = XCUR111 2017 YCUR000 = YCUR111 2018ctrans ddxp = -usr2*dx - .5*r2r3*dy 2019ctrans ddyp = usr2*dx - .5*r2r3*dy 2020ctrans ddzp = r2r3*dy 2021ctrans xpup(1) = xpup(1) + ddxp 2022ctrans xpup(2) = xpup(2) + ddyp 2023ctrans xpup(3) = xpup(3) + ddzp 2024ctrans call calpup(xpup,dist,obsobs,uuuu,vvvv) 2025C 2026cc CALL GSPAT(ICTFON) 2027cc CALL MY_GSAREA(0,XCADRE,YCADRE,4) 2028 502 IF (IPROGRE.GT.0) THEN 2029 CALL VRAIECOORD(XHELP+DXTRANS,YDMAX+DYTRANS,IX2,IY2) 2030 IX2 = IX2+IEPBOR/2 2031 IY2 = IY2+IEPBOR/2 2032 IF (IX2.GT.IX2OLD) THEN 2033 CALL x11clearrect(IX2OLD,IY0,IX2-IX2OLD,IHAUT) 2034 ELSEIF(MIN(IX1,IX2+ILARG).LT.IX2OLD+ILARGOLD) THEN 2035 III = MIN(IX1,IX2+ILARG) 2036 JJJ = IX2OLD+ILARGOLD-III 2037 CALL x11clearrect(III,IY0,JJJ,IHAUT) 2038 ENDIF 2039 IF (IY2.GT.IY2OLD) THEN 2040 CALL x11clearrect(IX0,IY2OLD,ILARG,IY2-IY2OLD) 2041 ELSEIF(MIN(IY1,IY2+IHAUT).LT.IY2OLD+IHAUTOLD) THEN 2042 III = MIN(IY1,IY2+IHAUT) 2043 JJJ = IY2OLD+IHAUTOLD-III 2044 CALL x11clearrect(IX0,III,ILARG,JJJ) 2045 ENDIF 2046 CALL x11metrect(IX2,IY2,ILARG,IHAUT) 2047 IX2OLD = MAX(IX2,IX0) 2048 IY2OLD = MAX(IY2,IY0) 2049 ILARGOLD = MIN(IX1,IX2OLD+ILARG) - IX2OLD 2050 IHAUTOLD = MIN(IY1,IY2OLD+IHAUT) - IY2OLD 2051 ELSE 2052 CALL VRAIECOORD(XHELP-DXTRANS,YDMAX-DYTRANS,IX2,IY2) 2053cc print*,'passe par ici',IX2,IY2,XHELP,YDMAX,DXTRANS,DYTRANS 2054 IX2 = IX2+IEPBOR/2+ISHIFTX 2055 IY2 = IY2+IEPBOR/2+ISHIFTY 2056 CALL x11metrect2(IX2,IY2,ILARG,IHAUT,IX0,IY0) 2057 ENDIF 2058 GOTO 5003 2059C 2060C Parties cachees (6) 2061C 2062Cfj 600 IF (IPREFC.EQ.2) THEN 2063Cfj IF (IFC.EQ.1) THEN 2064Cfj IFC = 2 2065Cfj ELSEIF(IFC.EQ.2) THEN 2066Cfj IFC = -1 2067Cfj ELSE 2068Cfj IFC = 1 2069Cfj ENDIF 2070Cfj ELSE 2071Cfj IFC = -IFC 2072Cfj ENDIF 2073 600 IF (IPREFC.EQ.2) THEN 2074 IF (IFC.EQ.1) THEN 2075 IFC = 2 2076 ELSEIF(IFC.EQ.2) THEN 2077 IFC = -1 2078 ELSEIF(IFC.EQ.-1) THEN 2079 IF (I2D.EQ.0) THEN 2080 IFC = -2 2081 ELSE 2082 IFC = 1 2083 ENDIF 2084 ELSE 2085 IFC = 1 2086 ENDIF 2087 ELSE 2088 IF (IFC.EQ.1) THEN 2089 IFC = -1 2090 ELSEIF(IFC.EQ.-1) THEN 2091 IF (I2D.EQ.0) THEN 2092 IFC = -2 2093 ELSE 2094 IFC = 1 2095 ENDIF 2096 ELSE 2097 IFC = 1 2098 ENDIF 2099 ENDIF 2100 GEOM = .TRUE. 2101 GOTO 5000 2102C 2103C Rotation autour de Ox (7) 2104C 2105 700 CALL ROTX(IANG(IANGLE)) 2106 IOPT = -2 2107 IBOUT = -IBROT 2108 GEOM = .TRUE. 2109 GOTO 5000 2110C 2111C Rotation autour de Oz (8) 2112C 2113 800 CALL ROTZ(IANG(IANGLE)) 2114 IOPT = -2 2115 IBOUT = -IBROT 2116 GEOM = .TRUE. 2117 GOTO 5000 2118C 2119C Rotation autour de Oy (9) 2120C 2121 900 CALL ROTY(IANG(IANGLE)) 2122 IOPT = -2 2123 IBOUT = -IBROT 2124 GEOM = .TRUE. 2125 GOTO 5000 2126C 2127C Zoom arriere (A) 2128C 2129 1000 CALL GSQCUR(WIN,XCUR,YCUR) 2130 IF (IIII.EQ.0) THEN 2131 XLARG = XLARG*FACZOOM 2132 FACVIT = FACVIT/FACZOOM 2133 ELSE 2134 XLARG = XLARG*FACZOOM*FACZOOM 2135 FACVIT = FACVIT/(FACZOOM*FACZOOM) 2136 ENDIF 2137 IOPT = -4 2138 GEOM = .TRUE. 2139 IREFRE = 1 2140 GOTO 5001 2141C 2142C Changement de l'angle courant (B) 2143C 2144 1100 IANGLE = IANGLE+1 2145 IOPT = 0 2146 IF (IANGLE.GT.14) IANGLE = 1 2147 1101 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUT) 2148 GEOM = .TRUE. 2149 GOTO 5002 2150C 2151C Zoom avant (C) 2152C 2153 1200 CALL GSQCUR(WIN,XCUR,YCUR) 2154 IF (IIII.EQ.0) THEN 2155 XLARG = XLARG/FACZOOM 2156 FACVIT = FACVIT*FACZOOM 2157 ELSE 2158 XLARG = XLARG/(FACZOOM*FACZOOM) 2159 FACVIT = FACVIT*FACZOOM*FACZOOM 2160 ENDIF 2161 IOPT = -4 2162 GEOM = .TRUE. 2163 IREFRE = 1 2164 GOTO 5001 2165C 2166C Fichier d'isovaleurs de vitesses ou de forces (D) 2167C 2168 1300 IRC = 0 2169 LBID = 0 2170 CALL LIVAL(CBIDON,LBID,IVAL,ICLAS,ICONTR,NDSEL,IRC) 2171 IF (IVAL.EQ.9999) THEN 2172 IBOUT = ABS(IBOUT) 2173 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2174 CALL GSBND(XDMIN,XHELP,YDMI2,YDMAX) 2175 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0,ITOUR2,7,15) 2176 CALL viderbuff2 2177 GOTO 5002 2178 ENDIF 2179 CALL ACTLIVAL(IVAL,ICONTR,CBIDON,LBID,IREFRE,IGOTO) 2180cc IF (IFISO.NE.IFISO0) THEN 2181cc CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBISO) 2182cc CALL MYBORD(XBOUT(1,IBISO),YBOUT(1,IBISO),BID,0,ITOUR2 2183cc & ,7,15) 2184cc ENDIF 2185 IF (IGOTO.EQ.1301) THEN 2186 GOTO 1300 2187 ELSE 2188 IF (IGOTO.EQ.5001) THEN 2189 GOTO 5001 2190 ELSE 2191 GOTO 5000 2192 ENDIF 2193 ENDIF 2194C 2195C Dessin carre ou rectangulaire (E) 2196C 2197 1400 ICARRE = -ICARRE 2198 IF (ICARRE.EQ.1) THEN 2199 XLARG = XLARG*HYA4/HXA4 2200 IPROX = 95 2201 ELSE 2202 XLARG = XLARG*HXA4/HYA4 2203 IPROX = 80 2204 ENDIF 2205 IPROY = 77 2206 PASMIN2 = (.0025*XLARG)**2 2207cc IPIPIX = -NINT(REAL(IECX*IPROX)*.01) 2208cc IPIPIY = -NINT(REAL(IECY*IPROY)*.01) 2209cc CALL TAILLE_FEN(IPIPIX,IPIPIY,1) 2210 CALL TAILLE_FEN(IPROX,IPROY,1) 2211 CALL GSCLR 2212 GOTO 5001 2213C 2214C Frontieres de sous-domaines et frontieres referencees (F) 2215C 2216 1500 IF (ICOURB.GT.0) THEN 2217 IF (IFRONT.EQ.0) THEN 2218 IF (IFBLO.NE.0) THEN 2219 IFRONT = 1 2220 ELSE 2221 IFRONT = 2 2222 ENDIF 2223 ELSEIF(IFRONT.EQ.1) THEN 2224 IFRONT = 2 2225 ELSEIF(IFRONT.EQ.2) THEN 2226 IF (IFBLO.NE.0) THEN 2227 IFRONT = 3 2228 ELSE 2229 IF (NUMSD.GT.1) THEN 2230 IFRONT = -1 2231 ELSE 2232 IFRONT = 3 2233 ENDIF 2234 ENDIF 2235 ELSEIF(IFRONT.EQ.3) THEN 2236 IF (NUMSD.GT.1) THEN 2237 IFRONT = -1 2238 ELSE 2239 IFRONT = 0 2240 ENDIF 2241 ELSE 2242 IFRONT = 0 2243 ENDIF 2244 GOTO 5001 2245 ELSE 2246 IF (FACEXAX.NE.EXAX0 2247 & .OR.FACEXAY.NE.EXAY0 2248 & .OR.FACEXAZ.NE.EXAZ0) THEN 2249 EXAX00 = FACEXAX 2250 EXAY00 = FACEXAY 2251 EXAZ00 = FACEXAZ 2252 FACEXAX = EXAX0 2253 FACEXAY = EXAY0 2254 FACEXAZ = EXAZ0 2255 DFACX = FACEXAX-EXAX00 2256 DFACY = FACEXAY-EXAY00 2257 DFACZ = FACEXAZ-EXAZ00 2258 ELSE 2259 FACEXAX0 = FACEXAX 2260 FACEXAY0 = FACEXAY 2261 FACEXAZ0 = FACEXAZ 2262 FACEXAX = EXAX00 2263 FACEXAY = EXAY00 2264 FACEXAZ = EXAZ00 2265 DFACX = FACEXAX-FACEXAX0 2266 DFACY = FACEXAY-FACEXAY0 2267 DFACZ = FACEXAZ-FACEXAZ0 2268 ENDIF 2269 DEBUT = .TRUE. 2270 IREFRE = 1 2271 CALL EXAGERE(DFACX,DFACY,DFACZ,0) 2272 IF (ISOBID.NE.0) CALL MYISO 2273 GOTO 5000 2274 ENDIF 2275C 2276C Legendes (G) 2277C 2278 1600 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 2279 IF (ILEG.EQ.0) THEN 2280 CALL FSTERM(1) 2281 CALL ECR16COUL(ICTLEG,ILANG) 2282 IF (ILANG.EQ.0) THEN 2283 CALL LIENTIER('Couleur de la l�gende ( < 0 = cancel) ?' 2284 & ,0,ICTLEG) 2285 IF (ICTLEG.LT.0.OR.ICTLEG.GT.15) GOTO 1601 2286 CALL LIENTIER 2287 & ('Sens d''�criture (0:horizontal ; 1:vertical) ?',0,ISLEG) 2288 IF (ISLEG.NE.0) ISLEG = 1 2289 IF (ICTLEG.LT.0.OR.ICTLEG.GT.15) ICTLEG = 7 2290 CALL LIENTIER('Taille de la l�gende '// 2291 & '(0:normale ; 1:grande ; 2:petite ; 3:monstre) ?',0,IIIII) 2292 ELSE 2293 CALL LIENTIER('Legend''s color ( < 0 = cancel) ?',0,ICTLEG) 2294 IF (ICTLEG.LT.0.OR.ICTLEG.GT.15) GOTO 1601 2295 CALL LIENTIER 2296 & ('Writing direction (0:horizontal ; 1:vertical) ?',0,ISLEG) 2297 IF (ISLEG.NE.0) ISLEG = 1 2298 IF (ICTLEG.LT.0.OR.ICTLEG.GT.15) ICTLEG = 7 2299 CALL LIENTIER('Legend''s size '// 2300 & '(0:normal ; 1:large ; 2:small ; 3:huge) ?',0,IIIII) 2301 ENDIF 2302 IF (IIIII.EQ.1) THEN 2303 FACLEG = 1./.65 2304 ELSEIF(IIIII.EQ.2) THEN 2305 FACLEG = .45/.65 2306 ELSEIF(IIIII.EQ.3) THEN 2307 FACLEG = (1./.65)**2 2308 ELSE 2309 FACLEG = 1. 2310 ENDIF 2311 IF (LONLEG.GT.0) THEN 2312 IF (ILANG.EQ.0) THEN 2313 PRINT*,'L�gende pr�c�dente :' 2314 ELSE 2315 PRINT*,'Previous legend:' 2316 ENDIF 2317 PRINT*,LEG(1:LONLEG) 2318 ENDIF 2319 IF (ILANG.EQ.0) THEN 2320 CALL LILIGNE('Entrez la l�gende (maximum 132 caract�res)' 2321 & ,0,LEG,LONLEG) 2322 ELSE 2323 CALL LILIGNE('Type the legend (maximum 132 characters)' 2324 & ,0,LEG,LONLEG) 2325 ENDIF 2326 ILEGMAN = 1 2327 ILEGAUTO = 0 2328 1601 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2329 CALL GSPATF(ICTFON) 2330 CALL GSLW(0) 2331 CALL GSPAT(16) 2332 ILEG = 1 2333 CALL LEGENDE(XHELP,XDMAX,YDMIN,YDMAX,BID,BID,BID,BID,1) 2334 CALL GSBND(XDMIN,XDMAX,YDMIN,YDMAX) 2335 GOTO 5002 2336 ELSEIF(ILEG.LT.0) THEN 2337 IF (LONLEG.GT.0) THEN 2338 ILEG = 1 2339 ELSE 2340 ILEG = 0 2341 ENDIF 2342 ELSEIF(IFREEZE.EQ.0) THEN 2343 ILEG = ILEG+1 2344 IF (ILEG.EQ.6) ILEG = 0 2345 CALL VRAIECOORD(XHELP,YDMAX,IX0,IY0) 2346 CALL VRAIECOORD(XDMAX,YDMIN,IX1,IY1) 2347 ILARG = IX1-IX0 2348 IHAUT = IY1-IY0 2349 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 2350 CALL x11metrect2(IX0+ISHIFTX,IY0+ISHIFTY,ILARG,IHAUT,IX0,IY0) 2351Cfj 2352 IF (IAXES.NE.0) CALL AXES(XHELP,XDMAX,YDMIN,YDMAX) 2353 IF (ILEG.GT.0) 2354 & CALL LEGENDE(XHELP,XDMAX,YDMIN,YDMAX,BID,BID,BID,BID,1) 2355 CALL LECADRE 2356 CALL GSBND(XDMIN,XDMAX,YDMIN,YDMAX) 2357 GOTO 5002 2358Cfj ELSE 2359Cfj GEOM = .TRUE. 2360Cfj GOTO 5001 2361Cfj ENDIF 2362 ELSE 2363 ILEG = ILEG+1 2364 IF (ILEG.EQ.6) ILEG = 0 2365 CALL GSBND(XDMIN,XDMAX,YDMIN,YDMAX) 2366 GOTO 5003 2367 ENDIF 2368C 2369C Isovaleurs (H) 2370C 2371 1700 ISOINI = ISO 2372 1701 CALL ACTISO(ISOINI,NBCOUL,IWAVE,IGOTO) 2373 IF (IGOTO.EQ.5000) THEN 2374 GOTO 5000 2375 ELSE 2376 GOTO 5002 2377 ENDIF 2378C 2379C Changement de couleur des traits (I) 2380C 2381 1800 ICT = ICT+1 2382 IF (ICT.EQ.17) ICT = 1 2383 ICOLAR = ICT-1 2384 GEOM = .TRUE. 2385 GOTO 5001 2386Cfj CALL TABCOL(-(ICT*1000+3),IWAVE) 2387Cfj CALL ASFCOL(ICT-1) 2388Cfj IF (ITERMC.EQ.4) THEN 2389Cfj GEOM = .TRUE. 2390Cfj GOTO 5001 2391Cfj ELSE 2392Cfj IOPT = 0 2393Cfj CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUT) 2394Cfj GOTO 5002 2395Cfj ENDIF 2396C 2397C Changement des bornes des iso (J) 2398C 2399 1900 IQUEST = 0 2400 IF (ISO.NE.0) THEN 2401 VMIN2 = VMIN 2402 VMAX2 = VMAX 2403 CALL QUEST_BORNES(ILANG,VMIN0,VMAX0,VMIN2,VMAX2,IRQ) 2404 IF (IRQ.EQ.-2) THEN 2405 IQUEST = 1900 2406 ELSE 2407 IQUEST = 0 2408 ENDIF 2409 IF (IRQ.NE.0.AND.IRQ.NE.-2) GOTO 5002 2410Cfj CALL FSTERM(1) 2411Cfj IF (ILANG.EQ.0) THEN 2412Cfj PRINT*,'Anciennes bornes :',VMIN,VMAX 2413Cfj PRINT*,'Bornes maximales :',VMIN0,VMAX0 2414Cfj CALL LI2REEL1( 2415Cfj & 'Nouvelles bornes ? (2 valeurs �gales --> bornes max)' 2416Cfj & ,0,VMIN2,VMAX2) 2417Cfj ELSE 2418Cfj PRINT*,'Previous bounds:',VMIN,VMAX 2419Cfj PRINT*,'Maximal bounds:',VMIN0,VMAX0 2420Cfj CALL LI2REEL1( 2421Cfj & 'New bounds? (2 equal values --> max bounds)' 2422Cfj & ,0,VMIN2,VMAX2) 2423Cfj ENDIF 2424 IF (VMIN2.LT.VMAX2) THEN 2425 VMIN = VMIN2 2426 VMAX = VMAX2 2427 ELSEIF(VMAX2.LT.VMIN2) THEN 2428 VMIN = VMAX2 2429 VMAX = VMIN2 2430 ELSE 2431 VMIN = VMIN0 2432 VMAX = VMAX0 2433 ENDIF 2434 IVFIXE = 0 2435Cfj CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2436 CALL GSPATF(ICTFON) 2437 CALL GSLW(0) 2438C CALL GSCLP(1) 2439 GOTO 5001 2440 ELSE 2441 GOTO 5002 2442 ENDIF 2443C 2444C Modification de la table des couleurs (K) 2445C 2446 2000 IF (ISO.NE.0.OR.(IVIT.LT.0.AND.ICTFLE.GT.15) 2447 & .OR.ICTFAC.GT.15) THEN 2448 ITOUCHTAB = 1 2449 IF (ITABLE.EQ.NTABMAX) THEN 2450 ITABLE = 1 2451 ELSEIF(ITABLE.EQ.52.OR.ITABLE.EQ.54) THEN 2452 ITABLE = ITABLE-1 2453 ELSE 2454 ITABLE = ITABLE+1 2455 ENDIF 2456 IF (ITABLE.GT.2) THEN 2457 IF (ITABLE.GE.33.AND.MOD(NBCOUL,2).EQ.1) NBCOUL = NBCOUL+1 2458 IIII = -100000-NBCOUL 2459 ELSE 2460 CALL CHNBCOL(NBCOUL,NVAL,1,ITABLE) 2461 IIII = -100000-NVAL 2462 ENDIF 2463 IWAVE = 0 2464 CALL TABCOL(IIII,IWAVE) 2465 ENDIF 2466 IF (ITERMC.EQ.4) THEN 2467 GOTO 5001 2468 ELSE 2469 IOPT = 0 2470 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUT) 2471 GOTO 5002 2472 ENDIF 2473C 2474C Changement du nb de couleurs (L) 2475C 2476 2100 IF (ISO.NE.0.OR.ICTFAC.GT.15) THEN 2477 CALL QUEST_NBISO(ILANG,NBCOUL,IEPISO,IRQ) 2478 IF (IRQ.NE.0) GOTO 5002 2479 NBCOUL = MAX(2,MIN(NBCOUL,250)) 2480 ITOUCHNB = 1 2481C 2482C Ne pas tout effacer. On peut reprendre la partie 2483C 'valeurs-limites pour chaque couleur' 2484C 2485Cfj CALL FSTERM(1) 2486Cfj IVFIXE = 0 2487Cfj PRINT*,' ' 2488Cfj IF (ILANG.EQ.0) THEN 2489Cfj PRINT*,'Pour contr�ler l''�paisseur des isovaleurs au trait,' 2490Cfj PRINT*, 2491Cfj & 'mettez le signe "-" devant le nombre d''isovaleurs voulues' 2492Cfj ELSE 2493Cfj PRINT*,'To control the line thickness,' 2494Cfj PRINT*,'type "-" number of wanted lines' 2495Cfj ENDIF 2496Cfj 2101 IF (ILANG.EQ.0) THEN 2497Cfj PRINT*,'Nombre de couleurs actuel =',NBCOUL 2498Cfj CALL LIENTIER('Nombre d''isovaleurs ?',0,NBCOUL) 2499Cfj ELSE 2500Cfj PRINT*,'Current number of colors =',NBCOUL 2501Cfj CALL LIENTIER('Number of colors ?',0,NBCOUL) 2502Cfj ENDIF 2503Cfj IF (NBCOUL.EQ.0) THEN 2504Cfj IF (ILANG.EQ.0) THEN 2505Cfj PRINT*, 2506Cfj &'*** Vous pouvez rentrer les valeurs-limites pour chaque couleur' 2507Cfj CALL LIENTIER( 2508Cfj &'Nombre d''isovaleurs (0 pour l''�chelonnage standard) ?' 2509Cfj & ,0,IREP) 2510Cfj ELSE 2511Cfj PRINT*, 2512Cfj &'*** You can give the limit values for each color' 2513Cfj CALL LIENTIER( 2514Cfj & 'Number of colors (0 for the default scale) ?' 2515Cfj & ,0,IREP) 2516Cfj ENDIF 2517Cfj IF (IREP.EQ.0) THEN 2518Cfj GOTO 2101 2519Cfj ELSEIF(IREP.LT.0) THEN 2520Cfj NBCOUL = -IREP 2521Cfj IF (ILANG.EQ.0) THEN 2522Cfj CALL LIENTIER('Epaisseur des iso au trait en pixels ?',0 2523Cfj & ,IEPISO) 2524Cfj ELSE 2525Cfj CALL LIENTIER( 2526Cfj & 'Lines thickness for contour plot (pixels) ?',0,IEPISO) 2527Cfj ENDIF 2528Cfj IEPISO = MAX(-1,IEPISO) 2529Cfj ELSE 2530Cfj NBCOUL = IREP 2531Cfj IEPISO = MIN(4,MAX(0,NINT(15./REAL(NBCOUL)))) 2532Cfj IF (NBCOUL.GE.100) IEPISO = -1 2533Cfj ENDIF 2534Cfj IF (NBCOUL.GT.1) THEN 2535Cfj VAL(1) = VMIN 2536Cfj VAL(NBCOUL+1) = VMAX 2537Cfj IVFIXE = 1 2538Cfj IF (ILANG.EQ.0) THEN 2539Cfj PRINT*, 2540Cfj & 'Bornes de l''intervalle de valeurs possibles :',VMIN,VMAX 2541Cfj ELSE 2542Cfj PRINT*,'Bounds allowed:',VMIN,VMAX 2543Cfj ENDIF 2544Cfj DO I=2,NBCOUL 2545Cfj WRITE(CNUM2,'(I3)') I-1 2546Cfj WRITE(CNUM3,'(I3)') I 2547Cfj 2102 IF (ILANG.EQ.0) THEN 2548Cfj CALL LIREEL1( 2549Cfj & 'Valeur de l''interface entre les couleurs ' 2550Cfj & //CNUM2//' et '//CNUM3//' ?',0,VAVA) 2551Cfj ELSE 2552Cfj CALL LIREEL1( 2553Cfj & 'Value for the interface between colors ' 2554Cfj & //CNUM2//' and '//CNUM3//' ?',0,VAVA) 2555Cfj ENDIF 2556Cfj IF (VAVA.LT.VAL(I-1)) THEN 2557Cfj IF (ILANG.EQ.0) THEN 2558Cfj PRINT*,'*** La valeur doit �tre >=',VAL(I-1) 2559Cfj ELSE 2560Cfj PRINT*,'*** The value must be >=',VAL(I-1) 2561Cfj ENDIF 2562Cfj GOTO 2102 2563Cfj ELSEIF(VAVA.GT.VMAX) THEN 2564Cfj IF (ILANG.EQ.0) THEN 2565Cfj PRINT*,'*** La valeur doit �tre <=',VMAX 2566Cfj ELSE 2567Cfj PRINT*,'*** The value must be <=',VMAX 2568Cfj ENDIF 2569Cfj GOTO 2102 2570Cfj ELSE 2571Cfj VAL(I) = VAVA 2572Cfj ENDIF 2573Cfj ENDDO 2574Cfj ENDIF 2575Cfj ELSEIF(NBCOUL.LT.0) THEN 2576Cfj NBCOUL = -NBCOUL 2577Cfj IF (ITABLE.GE.33.AND.MOD(NBCOUL,2).EQ.1) NBCOUL = NBCOUL+1 2578Cfj IF (ILANG.EQ.0) THEN 2579Cfj CALL LIENTIER('Epaisseur des iso au trait en pixels ?' 2580Cfj & ,0,IEPISO) 2581Cfj ELSE 2582Cfj CALL LIENTIER('Lines thickness for contour plot (pixels) ?' 2583Cfj & ,0,IEPISO) 2584Cfj ENDIF 2585Cfj IEPISO = MAX(-1,IEPISO) 2586Cfj ELSE 2587 IF (ITABLE.GE.33.AND.MOD(NBCOUL,2).EQ.1) NBCOUL = NBCOUL+1 2588 IEPISO = MIN(4,MAX(0,NINT(15./REAL(NBCOUL)))) 2589 IF (NBCOUL.GE.100) IEPISO = -1 2590Cfj ENDIF 2591Cfj NBCOUL = MIN(250,NBCOUL) 2592 ITT = ITABLE 2593 ITABLE = ITT-MOD(ITT+1,2) 2594 IF (ITABLE.EQ.1.OR.ITABLE.EQ.2) THEN 2595 CALL CHNBCOL(NBCOUL,NVAL,1,ITABLE) 2596 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2597 CALL GSPATF(ICTFON) 2598 CALL TABCOL(NVAL,IWAVE) 2599 ELSE 2600 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2601 CALL GSPATF(ICTFON) 2602 CALL TABCOL(NBCOUL,IWAVE) 2603 ENDIF 2604 IF (ITT.NE.ITABLE) THEN 2605 ITABLE = ITT 2606 IF (ITABLE.NE.2) THEN 2607 IIII = -100000-NBCOUL 2608 ELSE 2609 CALL CHNBCOL(NBCOUL,NVAL,1,ITABLE) 2610 IIII = -100000-NVAL 2611 ENDIF 2612 CALL TABCOL(IIII,IWAVE) 2613 ENDIF 2614 GOTO 5001 2615 ELSE 2616 GOTO 5002 2617 ENDIF 2618C 2619C Axes (M) 2620C 2621 2200 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 2622 IF (I2D.EQ.0) THEN 2623 IAXESMAX = 4 2624 ELSE 2625 IAXESMAX = 5 2626 ENDIF 2627 IF (IFREEZE.NE.0) THEN 2628 IF (IAXES.EQ.4) THEN 2629 IAXES = 0 2630 ELSE 2631 IAXES = IAXES+1 2632 ENDIF 2633 GOTO 5003 2634 ENDIF 2635 IF (IAXES.GE.IAXESMAX) THEN 2636 IAXES = 0 2637 ELSE 2638 IAXES = IAXES+1 2639 ENDIF 2640 CALL VRAIECOORD(XHELP,YDMAX,IX0,IY0) 2641 CALL VRAIECOORD(XDMAX,YDMIN,IX1,IY1) 2642 ILARG = IX1-IX0 2643 IHAUT = IY1-IY0 2644 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 2645 CALL x11metrect2(IX0+ISHIFTX,IY0+ISHIFTY,ILARG,IHAUT,IX0,IY0) 2646 IF (IAXES.NE.0) CALL AXES(XHELP,XDMAX,YDMIN,YDMAX) 2647 IF (ILEG.GT.0) 2648 & CALL LEGENDE(XHELP,XDMAX,YDMIN,YDMAX,BID,BID,BID,BID,1) 2649 CALL LECADRE 2650 CALL GSBND(XDMIN,XDMAX,YDMIN,YDMAX) 2651 GOTO 5002 2652C 2653C Exageration (N) 2654C 2655 2300 IQUEST = 0 2656 IF (IEXAG.NE.0) THEN 2657 IF (ICOURB.GT.0) THEN 2658Cfj CALL FSTERM(1) 2659 ITOUCHEX = 1 2660 FACEXA0 = FACEXA 2661 IF (DEPMAX.NE.0.) THEN 2662 CONSEIL = 0.3*DIMMAXREF/DEPMAX 2663 ELSE 2664 CONSEIL = 1. 2665 ENDIF 2666 CALL QUEST_EXAG(ILANG,DIMMAXREF,DIMMAX,DEPMAX,FACEXA,CONSEIL 2667 & ,IRQ) 2668 IF (IRQ.EQ.-2) THEN 2669 IQUEST = 2300 2670 ELSE 2671 IQUEST = 0 2672 ENDIF 2673Cfj IF (ILANG.EQ.0) THEN 2674Cfj PRINT*, 2675Cfj & 'Dimension maximale de l''objet non-d�form� =',DIMMAXREF 2676Cfj PRINT*, 2677Cfj & 'Dimension maximale de l''objet d�form� =',DIMMAX 2678Cfj PRINT*, 2679Cfj & 'D�placement maximal =',DEPMAX 2680Cfj PRINT*, 2681Cfj & 'Facteur d''exag�ration pr�c�dent =',FACEXA 2682Cfj PRINT*, 2683Cfj & 'Facteur d''exag�ration conseill� =',CONSEIL 2684Cfj CALL LIREEL1('Nouveau facteur d''exag�ration ?',0,FACEXA) 2685Cfj ELSE 2686Cfj PRINT*, 2687Cfj & 'Maximum dimension of the undeformed object =',DIMMAXREF 2688Cfj PRINT*, 2689Cfj & 'Maximum dimension of the deformed object =',DIMMAX 2690Cfj PRINT*, 2691Cfj & 'Maximal displacement =',DEPMAX 2692Cfj PRINT*, 2693Cfj & 'Previous exageration factor =',FACEXA 2694Cfj PRINT*, 2695Cfj & 'Recommended exageration factor =',CONSEIL 2696Cfj CALL LIREEL1('New exageration factor?',0,FACEXA) 2697Cfj ENDIF 2698 DFACX = FACEXA-FACEXA0 2699 DFACY = FACEXA-FACEXA0 2700 DFACZ = FACEXA-FACEXA0 2701 FACEXAX = FACEXA 2702 FACEXAY = FACEXA 2703 FACEXAZ = FACEXA 2704 IF (I2D.NE.0.AND.FACEXA0.EQ.0..AND.FACEXA.NE.0. 2705 & .AND.IPERSP.EQ.1 2706 & .AND.NOM_VIT(LONVIT-4:LONVIT).NE.'.depl' 2707 & .AND.NOM_VIT(LONVIT-4:LONVIT).NE.'.mode') THEN 2708 IPERSP = -2 2709 CALL METLAPERSP 2710 IF (ICTFAC.LT.16) ICTFAC=99 2711 II = IABS(IBOUT) 2712 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBPERSP) 2713 CALL MYBORD(XBOUT(1,IBPERSP),YBOUT(1,IBPERSP),BID,0,ITOUR2 2714 & ,7,15) 2715 CALL MYBORD(XBOUT(1,II),YBOUT(1,II),BID,0,ITOUR2,7,15) 2716 CALL viderbuff2 2717 ENDIF 2718 ELSE 2719Cfj CALL FSTERM(1) 2720 FACEXAX0 = FACEXAX 2721 FACEXAY0 = FACEXAY 2722 FACEXAZ0 = FACEXAZ 2723Cfj IF (ILANG.EQ.0) THEN 2724Cfj PRINT*,'Dimensions de l''objet =',DIMMAXX,DIMMAXY,DIMMAXZ 2725Cfj PRINT*,'D�placements maximaux =',DEPXM,DEPYM,DEPZM 2726Cfj PRINT*,'Facteurs d''exag�ration en x, y, et z pr�c�dents =' 2727Cfj & ,FACEXAX,FACEXAY,FACEXAZ 2728Cfj CALL LI3REEL1('Facteurs d''exag�ration en x, y et z ?',0 2729Cfj & ,FACEXAX,FACEXAY,FACEXAZ) 2730Cfj ELSE 2731Cfj PRINT*,'Object''s dimensions =' 2732Cfj & ,DIMMAXX,DIMMAXY,DIMMAXZ 2733Cfj PRINT*,'Maximum displacements =',DEPXM,DEPYM,DEPZM 2734Cfj PRINT*,'Previous exageration factors =' 2735Cfj & ,FACEXAX,FACEXAY,FACEXAZ 2736Cfj CALL LI3REEL1('Exageration factors for x, y and z ?',0 2737Cfj & ,FACEXAX,FACEXAY,FACEXAZ) 2738Cfj ENDIF 2739 CALL QUEST_EXA3(ILANG,FACEXAX,FACEXAY,FACEXAZ,IRQ) 2740 IF (IRQ.EQ.0) THEN 2741 DFACX = FACEXAX-FACEXAX0 2742 DFACY = FACEXAY-FACEXAY0 2743 DFACZ = FACEXAZ-FACEXAZ0 2744 ENDIF 2745 ENDIF 2746 IF ((FACEXA.EQ.FACEXA0.AND.ICOURB.GT.0).OR. 2747 & (FACEXAX.EQ.FACEXAX0.AND. 2748 & FACEXAY.EQ.FACEXAY0.AND. 2749 & FACEXAZ.EQ.FACEXAZ0.AND.ICOURB.LT.0) ) THEN 2750c CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2751 GOTO 5001 2752 ELSE 2753C Les isosurf se symetrisent mal si on va directement a 2754C une symetrie donnee, mais marchent bien si on suit la sequence 2755C 1/4 2/4 3/4 4/4 1/4 2756C C'est bizarre mais au lieu de reflechir, on fait comme ca: 2757C et comme il n'y a pas que les iso qui deconnent, on fait pareil pour le cas 2758C general 2759C 2760 IF (NRECON.GT.1) THEN 2761 NRECON0 = NRECON 2762 NFACE0 = NFACE 2763 NRECON = 1 2764 NFACE = NF 2765 CALL SYMETRISE(NRECON0,0) 2766 CALL EXAGERE(DFACX,DFACY,DFACZ,0) 2767 IF (NSURF.GT.0) CALL CALSUR(1) 2768 NRECON = NRECON0 2769 NFACE = NFACE0 2770 NRECON0 = 1 2771 CALL SYMETRISE(NRECON0,0) 2772 IF (NSURF.GT.0.AND.ICTFAC.GT.15.AND.ICTFAC.LE.97) 2773 & CALL ELISO(IRC) 2774 ELSE 2775 CALL EXAGERE(DFACX,DFACY,DFACZ,0) 2776 IF (NSURF.GT.0) CALL CALSUR(1) 2777 ENDIF 2778 IF (ISOBID.NE.0) CALL MYISO 2779cc?? IF (ISO.NE.0) CALL MYISO 2780 GOTO 5000 2781 ENDIF 2782 ELSE 2783 GOTO 5002 2784 ENDIF 2785C 2786C PostScript couleur (O) 2787C 2788 2400 IPOSTCOL = 1 2789 IPFK = 2 2790 GOTO 200 2791C 2792C Couleur des faces (P) 2793C 2794 2500 CALL FSTERM(1) 2795 IF (ICTFAC.LT.3000) THEN 2796 CALL ECR16COUL(ICTFAC,ILANG) 2797 ICTFAC0 = ICTFAC 2798 ELSE 2799 ICTFAC0 = ICTFAC-4000 2800 PRINT*,' ' 2801 IF (ILANG.EQ.0) THEN 2802 PRINT*, 2803 &'Options disponibles pour les tables de couleurs personnelles :' 2804 ELSE 2805 PRINT*, 2806 &'Available options for the personnal color tables:' 2807 ENDIF 2808 PRINT*,' ' 2809 ENDIF 2810 IF (ILANG.EQ.0) THEN 2811 PRINT*, 2812 & '41 : Table progressive entre 2 couleurs donn�es (en RVB)' 2813 PRINT*,'43 : Fusion de 2 tables de couleur' 2814 PRINT*,'45 : Table blanc -> couleur donn�e -> noir' 2815 IF (ICTFAC.LT.3000) THEN 2816 PRINT*,'99 : R�flectance normale' 2817 PRINT*,'98 : R�flectance forte' 2818 PRINT*,'97 : Lissage Gouraud' 2819 PRINT*,'96 : Lissage Gouraud r�flectance forte' 2820 IF (I2D.EQ.0) 2821 & PRINT*,'-1 : Coloriage en fonction des num�ros de faces' 2822 IF (IFLAG3.NE.0) 2823 & PRINT*,'-2 : Coloriage en fonction des mat�riaux' 2824 IF (NUMSD.GT.1) 2825 & PRINT*,'-3 : Coloriage en fonction des sous-domaines' 2826 ENDIF 2827 ELSE 2828 PRINT*, 2829 & '41 : Progressive table between 2 given colors (RGB)' 2830 PRINT*,'43 : Fusion of 2 color tables' 2831 PRINT*,'45 : Table white -> given color -> black' 2832 IF (ICTFAC.LT.3000) THEN 2833 PRINT*,'99 : Default reflectance' 2834 PRINT*,'98 : Strong reflectance' 2835 PRINT*,'97 : Gouraud smoothing' 2836 PRINT*,'96 : Gouraud smoothing with strong reflectance' 2837 IF (I2D.EQ.0) 2838 & PRINT*,'-1 : Filling according to the facets numbers' 2839 IF (IFLAG3.NE.0) 2840 & PRINT*,'-2 : Filling according to the materials numbers' 2841 IF (NUMSD.GT.1) 2842 & PRINT*,'-3 : Filling according to the sub-domains numbers' 2843 ENDIF 2844 ENDIF 2845 PRINT*,' ' 2846 IF (ICTFAC.LT.3000) THEN 2847 IF (ILANG.EQ.0) THEN 2848 CALL LIENTIER('Couleur des faces ?',0,III) 2849 ELSE 2850 CALL LIENTIER('Facets color ?',0,III) 2851 ENDIF 2852 ELSE 2853 IF (ILANG.EQ.0) THEN 2854 CALL LIENTIER('Table personnelle ?',0,III) 2855 ELSE 2856 CALL LIENTIER('Customized color table ?',0,III) 2857 ENDIF 2858 ENDIF 2859C 2860C rajout provisoire pour table de couleurs perso de coul1-->coul2 2861C 2862 IF (III.EQ.41) THEN 2863 IF (ILANG.EQ.0) THEN 2864 CALL LI3ENTIER('RVB initiaux (3 entiers 0<256) ?',0 2865 & ,IROUGE0,IVERT0,IBLEU0) 2866 CALL LI3ENTIER('RVB finaux (3 entiers 0<256) ?',0 2867 & ,IROUGE1,IVERT1,IBLEU1) 2868 ELSE 2869 CALL LI3ENTIER('Initial RGB (3 integers 0<256) ?',0 2870 & ,IROUGE0,IVERT0,IBLEU0) 2871 CALL LI3ENTIER('Final RGB (3 integers 0<256) ?',0 2872 & ,IROUGE1,IVERT1,IBLEU1) 2873 ENDIF 2874 IROUGE0 = MIN(255,MAX(0,IROUGE0)) 2875 IVERT0 = MIN(255,MAX(0,IVERT0)) 2876 IBLEU0 = MIN(255,MAX(0,IBLEU0)) 2877 IROUGE1 = MIN(255,MAX(0,IROUGE1)) 2878 IVERT1 = MIN(255,MAX(0,IVERT1)) 2879 IBLEU1 = MIN(255,MAX(0,IBLEU1)) 2880 ITABLE = 51 2881 IIII = -100000-NBCOUL 2882 CALL TABCOL(IIII,IWAVE) 2883 IF (ICTFAC.GT.3000) ICTFAC = ICTFAC0 2884 GOTO 2502 2885C 2886C Deux tables bout a bout 2887C 2888 ELSEIF(III.EQ.43) THEN 2889 IF (ILANG.EQ.0) THEN 2890 PRINT*, 2891 &'Nombre de tables de couleurs pr�d�finies disponibles =',NTABMAX 2892 CALL LIENTIER( 2893 & 'Num�ro de la premi�re table de couleurs ?',0,ITABLE1) 2894 CALL LIENTIER( 2895 & 'Num�ro de la seconde table de couleurs ?',0,ITABLE2) 2896 PRINT*,NBCOUL 2897 & ,' couleurs dans la table -> prochain choix entre' 2898 & ,2,' et',NBCOUL-1 2899 CALL LIENTIER('Limite entre les 2 tables ?',0,ILIMTAB) 2900 ELSE 2901 PRINT*,'Number of available color tables =',NTABMAX 2902 CALL LIENTIER('Number of the first color table ?',0,ITABLE1) 2903 CALL LIENTIER('Number of the second color table ?',0,ITABLE2) 2904 PRINT*,NBCOUL,' colors in the table -> next choice between' 2905 & ,2,' and',NBCOUL-1 2906 CALL LIENTIER('Limit between the 2 tables ?',0,ILIMTAB) 2907 ENDIF 2908 ITABLE1 = MIN(NTABMAX,MAX(ITABLE1,1)) 2909 ITABLE2 = MIN(NTABMAX,MAX(ITABLE2,1)) 2910 ILIMTAB = MAX(2,MIN(NBCOUL-1,ILIMTAB)) 2911 XLIMTAB = REAL(ILIMTAB)/REAL(NBCOUL) 2912 ITABLE = 53 2913 IIII = -100000-NBCOUL 2914 CALL TABCOL(IIII,IWAVE) 2915 IF (ICTFAC.GT.3000) ICTFAC = ICTFAC0 2916 GOTO 2502 2917C 2918C Table de couleurs perso de blanc-->coul-->noir 2919C 2920 ELSEIF(III.EQ.45) THEN 2921 IF (ILANG.EQ.0) THEN 2922 PRINT*,'Table : blanc - couleur - noir' 2923 CALL LI3ENTIER('RVB couleur centrale (3 entiers 0<256) ?',0 2924 & ,IROUGE0,IVERT0,IBLEU0) 2925 ELSE 2926 PRINT*,'Table : white - color - black' 2927 CALL LI3ENTIER('Central color RGB (3 integers 0<256) ?',0 2928 & ,IROUGE0,IVERT0,IBLEU0) 2929 ENDIF 2930 IROUGE0 = MIN(255,MAX(0,IROUGE0)) 2931 IVERT0 = MIN(255,MAX(0,IVERT0)) 2932 IBLEU0 = MIN(255,MAX(0,IBLEU0)) 2933 ITABLE = 55 2934 IIII = -100000-NBCOUL 2935 CALL TABCOL(IIII,IWAVE) 2936 IF (ICTFAC.GT.3000) ICTFAC = ICTFAC0 2937 GOTO 2502 2938 ENDIF 2939 ICTFAC = III 2940 IF ((ICTFAC.LT.-3).OR. 2941 & (ICTFAC.EQ.-1.AND.I2D.NE.0).OR. 2942 & (ICTFAC.EQ.-2.AND.IFLAG3.EQ.0).OR. 2943 & (ICTFAC.EQ.-3.AND.NUMSD.LE.1).OR. 2944 & (ICTFAC.GT.15.AND.(ICTFAC.LT.96.OR.ICTFAC.GT.99))) THEN 2945 ICTFAC = 0 2946 ENDIF 2947 2502 IF (ICTFAC.GE.-3.AND.ICTFAC.LE.-1) IFC = 1 2948 IF (NSURF.GT.0.AND.ICTFAC.GT.15.AND.ICTFAC.LE.97 2949 & .AND.IELISO.EQ.0) THEN 2950 CALL ELISO(IRC) 2951 IF (IRC.EQ.0) THEN 2952 IELISO = 1 2953 ELSE 2954 ICTFAC = ICTFAC0 2955 ENDIF 2956 ENDIF 2957 2503 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2958 IF (ICTFAC.GT.15) THEN 2959Cfj IF (ITABLE.NE.7.AND.ITABLE.NE.51) THEN 2960Cfj ITABLE = 7 2961Cfj IIII = -100000-NBCOUL 2962Cfj CALL TABCOL(IIII,IWAVE) 2963Cfj ENDIF 2964 GOTO 5000 2965 ELSE 2966 GOTO 5001 2967 ENDIF 2968C 2969C Couleur du fond (3) 2970C 2971 300 CALL FSTERM(1) 2972Cfj ICTFON0 = ICTFON 2973 CALL ECR16COUL(ICTFON,ILANG) 2974 PRINT*,' ' 2975 IF (ILANG.EQ.0) THEN 2976 CALL LIENTIER('Couleur du fond ?',0,ICTFON) 2977 ELSE 2978 CALL LIENTIER('Background color ?',0,ICTFON) 2979 ENDIF 2980 IF (ICTFON.LT.0.OR.ICTFON.GT.15) ICTFON = 0 2981 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 2982CC GEOM = .TRUE. 2983 301 IF (ICTFON.EQ.0.OR.ICTFON.EQ.3.OR.ICTFON.EQ.11 2984 &.OR.ICTFON.EQ.13.OR.ICTFON.EQ.14.OR.ICTFON.EQ.15) THEN 2985 ICOLAXB = 4 2986 ICOLAX = 7 2987 ELSE 2988 ICOLAXB = 3 2989 ICOLAX = 0 2990 ENDIF 2991 GOTO 5001 2992C 2993C Iso bidon (R) 2994C 2995 2700 IF (IDEROUL.EQ.0) THEN 2996 2701 ISOBID = ISOBID+1 2997 IF (ISOBID.GT.16) ISOBID = 1 2998 IF (ISOBID.EQ.1.AND.I2D.NE.0) GOTO 2701 2999 IF (ISOBID.GE.4.AND.ISOBID.LE.8.AND.IFVIT.EQ.0) GOTO 2701 3000 IF (ISOBID.EQ.4.AND.I2D.EQ.2) GOTO 2701 3001 IF (ISOBID.EQ.5.AND.I2D.EQ.3) GOTO 2701 3002 IF (ISOBID.EQ.6.AND.I2D.EQ.1) GOTO 2701 3003 IF (ISOBID.EQ.8.AND.I2D.EQ.0) GOTO 2701 3004 IF (ISOBID.GE.9.AND.ISOBID.LE.12.AND.NBCORN.EQ.0) GOTO 2701 3005 IF (ISOBID.GE.13.AND.ICOURB.LT.0) GOTO 2701 3006 ENDIF 3007cc print*,isobid 3008 2702 CALL MYISO 3009 IF (ISO.EQ.0 3010 &.OR.(ISO.EQ.3.AND.ISOBID.LT.14) 3011 &.OR.(ISO.NE.3.AND.ISOBID.GE.14)) THEN 3012 IF (ISO.EQ.0) THEN 3013 ITABLE0 = ITABLE 3014 IF (ITABLE.NE.1) THEN 3015 NBCOUL = 20 3016 ITABLE = 1 3017 IIII = -100000-NBCOUL 3018 CALL TABCOL(IIII,IWAVE) 3019 ENDIF 3020 ENDIF 3021 IF (ISOBID.GE.14) THEN 3022 ISO = 3 3023 ELSE 3024 ISO = 1 3025 ENDIF 3026 ICADPS = 1 3027 IF (ICARRE.EQ.1) THEN 3028 ANGPS = -90. 3029 ELSE 3030 ANGPS = 0. 3031 ENDIF 3032 CALL DEFPS(IDEFPS,SIG,ANGPS,ICADPS,HELPPS,IDSEUL,1,ILANG) 3033 IF (I2D.NE.0) THEN 3034 IFC0 = IFC 3035 IFC = 1 3036 ENDIF 3037 ENDIF 3038 IF (ISOBID.GE.14) THEN 3039 ICENTR = 1 3040 ELSE 3041 ICENTR = 0 3042 ENDIF 3043 ICENTRISO = 0 3044 CALL INITBOUT 3045 IREFRE = 1 3046 IVFIXE = 0 3047 GOTO 5000 3048C 3049C Definition du Postscript : signature, cadre, orientation (S) 3050C 3051cc 2800 IDEFPS = IDEFPS+1 3052 2800 IF (IDEFPS.GE.7) THEN 3053 IDEFPS = IDEFPS+1 3054 ELSE 3055 IDEFPS = IDEFPS+2 3056 ENDIF 3057c IF (IDEFPS.GE.10) IDEFPS = 0 3058 IF (IDEFPS.GE.10) IDEFPS = 1 3059 2801 IOPT = 0 3060 CALL DEFPS(IDEFPS,SIG,ANGPS,ICADPS,HELPPS,IDSEUL,0,ILANG) 3061 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUT) 3062 GOTO 5002 3063C 3064C Renormalisation echelle (T) 3065C 3066 2900 DEBUT = .TRUE. 3067 FACVIT = FACVIT0 3068 IOPT = -4 3069 IREFRE = 1 3070 GEOM = .TRUE. 3071 GOTO 5010 3072C 3073C Cadrage initial (U) 3074C 3075 3000 IF (IDEROUL.EQ.0) THEN 3076 IRENO = IRENO+1 3077 IF (IRENO.GT.8) IRENO = 1 3078 ELSE 3079 IRENO = IDEROUL 3080 ENDIF 3081 CALL INV3X3(ROTA,ROTLOC,IERR) 3082 CALL ROTATE(1) 3083 IF (IRENO.NE.1) THEN 3084 CALL CALROT(ROTLOC,IRENO) 3085 CALL ROTATE(1) 3086 ENDIF 3087 DEBUT = .TRUE. 3088 IOPT = -5 3089 IREFRE = 1 3090 FACVIT = FACVIT0 3091ctrans xpup(1) = dist000 3092ctrans xpup(2) = dist000 3093ctrans xpup(3) = dist000 3094ctrans call calpup(xpup,dist,obs,u,v) 3095 GEOM = .TRUE. 3096 GOTO 5000 3097C 3098C Inversion du point de vue (V) 3099C 3100 3100 ISENS = -ISENS 3101 GEOM = .TRUE. 3102 GOTO 5000 3103C 3104C Rotation dans le plan de projection (perp. a (1,1,1)) (W) 3105C 3106CC 3200 IF (IBOUT.LE.0) CALL GSQCUR(WIN,XCUR,YCUR) 3107 3200 CALL ROTP(IANG(IANGLE)) 3108 IOPT = -2 3109 GEOM = .TRUE. 3110 GOTO 5000 3111C 3112C Frontiere / mailles (X) 3113C 3114 3300 IF (IBORD.EQ.-1) THEN 3115 IF (IEPBOR2.EQ.1) THEN 3116 IEPBOR2 = 2 3117 ELSE 3118 IEPBOR2 = 1 3119 IBORD = 1 3120 ENDIF 3121 ELSE 3122 IBORD = IBORD-1 3123 IF (IBORD.EQ.-1) THEN 3124 IEPBOR2 = 1 3125 ELSE 3126 IEPBOR2 = 2 3127 ENDIF 3128 ENDIF 3129 IF (ISOCOUP.EQ.1) THEN 3130 IF (IBORD.NE.-1.AND.IMAILL.GT.0) THEN 3131 ICSUR = 8 3132 ELSE 3133 ICSUR = 16 3134 ENDIF 3135 ENDIF 3136 GEOM = .TRUE. 3137 GOTO 5001 3138C 3139C Taille papier (Y) 3140C 3141 3400 IF (HYA4.EQ.HYA4B) THEN 3142 HYA4 = HYA4A 3143 IPROY = 68 3144 ELSE 3145 HYA4 = HYA4B 3146 IPROY = 77 3147 ENDIF 3148 IF (ICARRE.EQ.1) THEN 3149 IPROX = 95 3150 ELSE 3151 IPROX = 80 3152 ENDIF 3153 CALL GSCLR 3154 CALL TAILLE_FEN(IPROX,IPROY,1) 3155 GOTO 5001 3156C 3157C Changement de fichier (Z) 3158C 3159 3500 CALL FSTERM(1) 3160 IF (I2D.EQ.0) THEN 3161 IF (ILANG.EQ.0) THEN 3162 CALL LIENTIER( 3163 & 'On conserve les param�tres d''affichage (1:oui ; 0:non) ?' 3164 & ,0,IPARA) 3165 ELSE 3166 CALL LIENTIER( 3167 & 'Display parameters are preserved (1:yes ; 0:no) ?' 3168 & ,0,IPARA) 3169 ENDIF 3170 IF (IPARA.NE.0) IPARA = NFACE/NF 3171 ELSE 3172 IPARA = 0 3173 ENDIF 3174 LONG = 0 3175 IREFRE = 1 3176ccc CALL GSCLR 3177 GOTO 1 3178C 3179C Position angulaire donnee ({) 3180C 3181Cfj 3501 CALL FSTERM(1) 3182Cfj CALL INV3X3(ROTA,ROTLOC,IERR) 3183Cfj CALL ROTATE(1) 3184Cfj IF (ILANG.EQ.0) THEN 3185Cfj CALL LI3REEL1( 3186Cfj & 'Pos. angulaires autour de Ox, Oy, Oz (3 valeurs en degr�s) ?' 3187Cfj & ,0,ANGX,ANGY,ANGZ) 3188Cfj ELSE 3189Cfj CALL LI3REEL1( 3190Cfj & 'Angular position about Ox, Oy, Oz (3 values in degrees) ?' 3191Cfj & ,0,ANGX,ANGY,ANGZ) 3192Cfj ENDIF 3193Cfj CALL ARCROT(ANGX,ANGY,ANGZ) 3194Cfj CALL ROTATE(0) 3195Cfj IOPT = -2 3196Cfj GEOM = .TRUE. 3197Cfj GOTO 5000 3198 3501 IQUEST = 0 3199 CALL ARC(ANGX,ANGY,ANGZ) 3200 CALL QUEST_POSANG(ILANG,ANGX,ANGY,ANGZ,IRQ) 3201 IF (IRQ.EQ.0.OR.IRQ.EQ.-2) THEN 3202 CALL INV3X3(ROTA,ROTLOC,IERR) 3203 CALL ROTATE(1) 3204 CALL ARCROT(ANGX,ANGY,ANGZ) 3205 CALL ROTATE(0) 3206 IOPT = -2 3207 GEOM = .TRUE. 3208 IF (IRQ.EQ.-2) THEN 3209 IQUEST = 3501 3210 ELSE 3211 IQUEST = 0 3212 ENDIF 3213 GOTO 5000 3214 ELSE 3215 IBOUT = ABS(IBOUT) 3216 CALL GSBND(XDMIN,XHELP,YDMI2,YDMAX) 3217 CALL MYBORD(XBOUT(1,IBOUT),YBOUT(1,IBOUT),BID,0,ITOUR2,7,15) 3218 CALL viderbuff2 3219 GOTO 5002 3220 ENDIF 3221C 3222C Sauvegardes dans fichier(s) bitmap(s) (|) 3223C 3224 3502 CALL FSTERM(1) 3225 CALL FORMATS_BIT(IFORMAT,ILANG) 3226 IF (IFORMAT.LT.-1) THEN 3227 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3228 GOTO 5002 3229 ELSE 3230 CALL BITMAPS(NBON,IFORMAT,GEOM,ITYP,IREFRE,IBOUT,IOPT) 3231 CALL TAILLE_FEN(IPROX,IPROY,1) 3232 CALL x11nomfenetre(PROBIG,LPRO) 3233 CALL x11szscrn(IDX,IDY) 3234 IREFRE = 1 3235 CALL GSCLR 3236 GOTO 5000 3237 ENDIF 3238C 3239C Echelles (surfaces) (/) 3240C 3241 3600 CALL FSTERM(1) 3242 IF (ILANG.EQ.0) THEN 3243 PRINT*, 3244 &'Contr�le de l''affichage de la "bounding box" et des �chelles :' 3245 PRINT*,' Types de boites disponibles :' 3246 PRINT*,' 0 : pas de boite' 3247 PRINT*,' 1 : boite "ouverte" vers l''observateur (3 faces)' 3248 PRINT*,' 2 : boite ferm�e (6 faces)' 3249 CALL LIENTIER('Type de boite ?',0,IBOITE) 3250 ELSE 3251 PRINT*,'Parameters for the bounding box and scales:' 3252 PRINT*,' Boxes types:' 3253 PRINT*,' 0 : no boxes' 3254 PRINT*,' 1 : open box (3 facets)' 3255 PRINT*,' 2 : closed box (6 facets)' 3256 CALL LIENTIER('Box type ?',0,IBOITE) 3257 ENDIF 3258 IF (IBOITE.LE.0.OR.IBOITE.GT.2) THEN 3259 IBOITE = 0 3260 ELSE 3261Cfj IF (ILANG.EQ.0) THEN 3262Cfj PRINT*,' Types d''�chelles disponibles :' 3263Cfj PRINT*,' 0 : pas d''�chelle' 3264Cfj PRINT*,' 1 : traits sur les axes sans chiffres' 3265Cfj PRINT*,' 2 : traits sur les axes avec chiffres' 3266Cfj PRINT*,' 3 : traits et grilles sur les faces sans chiffres' 3267Cfj PRINT*,' 4 : traits et grilles sur les faces avec chiffres' 3268Cfj CALL LIENTIER('Type d''�chelles ?',0,IECBOI) 3269Cfj ELSE 3270Cfj PRINT*,' Scales types:' 3271Cfj PRINT*,' 0 : no scales' 3272Cfj PRINT*,' 1 : scales on axis without numbers' 3273Cfj PRINT*,' 2 : scales on axis with numbers' 3274Cfj PRINT*,' 3 : scales on axis and grids without numbers' 3275Cfj PRINT*,' 4 : scales on axis and grids with numbers' 3276Cfj CALL LIENTIER('Scale type ?',0,IECBOI) 3277Cfj ENDIF 3278Cfj IF (IECBOI.LT.0.OR.IECBOI.GT.4) IECBOI = 0 3279 IF (ILANG.EQ.0) THEN 3280 CALL LIENTIER('Traits sur les axes (1:oui ; 0:non) ?',0,ITIC) 3281 CALL LIENTIER('Num�ros sur les axes (1:oui ; 0:non) ?',0,INUM) 3282 CALL LIENTIER('Grilles (1:oui ; 0:non) ?',0,IGRI) 3283 ELSE 3284 CALL LIENTIER('Tics on axis (1:yes ; 0:no) ?',0,ITIC) 3285 CALL LIENTIER('Numbers on axis (1:yes ; 0:no) ?',0,INUM) 3286 CALL LIENTIER('Grids (1:yes ; 0:no) ?',0,IGRI) 3287 ENDIF 3288 IF (ITIC.NE.0.OR.INUM.NE.0.OR.IGRI.NE.0) THEN 3289 IECBOI = 1 3290 IF (ITIC.EQ.0) IECBOI = IECBOI+4 3291 IF (INUM.NE.0) IECBOI = IECBOI+1 3292 IF (IGRI.NE.0) IECBOI = IECBOI+2 3293 ELSE 3294 IECBOI = 0 3295 ENDIF 3296 ENDIF 3297 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3298 GOTO 5001 3299C 3300C Sous-domaines (.) 3301C 3302 3700 IF (NUMSD.GT.1) THEN 3303 IF (NUMSD.GT.2) THEN 3304 IVU = 0 3305 IPREMVU = 0 3306 DO K=1,NUMSD 3307 IF (ISDVU(K).GT.0) THEN 3308 IVU = IVU+1 3309 IF (IPREMVU.EQ.0) IPREMVU = K 3310 ENDIF 3311 ENDDO 3312 IF (IVU.EQ.NUMSD.OR.IPREMVU.EQ.0) THEN 3313 ISDVU(1) = 1 3314 DO K=2,NUMSD 3315 ISDVU(K) = 0 3316 ENDDO 3317 ELSEIF(IPREMVU.EQ.NUMSD) THEN 3318 DO K=1,NUMSD 3319 ISDVU(K) = 1 3320 ENDDO 3321 ELSE 3322 DO K=1,NUMSD 3323 ISDVU(K) = 0 3324 ENDDO 3325 ISDVU(IPREMVU+1) = 1 3326 ENDIF 3327 ELSE 3328 IF (ISDVU(1).EQ.1.AND.ISDVU(2).EQ.1) THEN 3329 ISDVU(2) = 0 3330 ELSEIF(ISDVU(1).EQ.1.AND.ISDVU(2).EQ.0) THEN 3331 ISDVU(1) = 0 3332 ISDVU(2) = 1 3333 ELSE 3334 ISDVU(1) = 1 3335 ENDIF 3336 ENDIF 3337 GOTO 5000 3338 ELSE 3339 GOTO 5002 3340 ENDIF 3341C 3342C Mailles ou pas (-) 3343C 3344 3800 IMAILL = -IMAILL 3345 IBOUT = -9999 3346 GEOM = .TRUE. 3347 GOTO 5000 3348C 3349C Shrink prop au champ scalaire (,) 3350C 3351 3900 IF ((IFISO*ICENTR).NE.0.AND.ISHRINK.LT.0) THEN 3352 IF (ISHPRO.GT.0) THEN 3353 ISHPRO = -1 3354 ELSEIF(ISHPRO.EQ.-1) THEN 3355 ISHPRO = -2 3356 ELSE 3357 ISHPRO = 1 3358 ENDIF 3359 IF (ISHPRO.LT.0) THEN 3360 CALL FSTERM(1) 3361 IF (ILANG.EQ.0) THEN 3362 CALL LIREEL1('Valeur minimale vue (0<V<1) ?',0,VSHPRO) 3363 ELSE 3364 CALL LIREEL1('Minimum value displayed (0<V<1) ?',0,VSHPRO) 3365 ENDIF 3366 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3367 ENDIF 3368 GEOM = .TRUE. 3369 GOTO 5000 3370 ELSE 3371 GOTO 5002 3372 ENDIF 3373C 3374C Vitesses, fleches (+) 3375C 3376 4000 IF (IFVIT.NE.0) THEN 3377 IVIT = -IVIT 3378 IF (IVIT.LT.0.AND.ICTFLE.GT.15) THEN 3379 VITCOUL = .TRUE. 3380 ELSE 3381 VITCOUL = .FALSE. 3382 ENDIF 3383 IF (ICTFLE.GT.15.AND.ISO.EQ.0) THEN 3384 IF (IVIT.LT.0) THEN 3385 ITABLE0 = ITABLE 3386 IF (ITABLE.NE.1) THEN 3387 ITABLE = 1 3388 IIII = -100000-NBCOUL 3389 CALL TABCOL(IIII,IWAVE) 3390 ENDIF 3391 ICADPS = 1 3392 ELSEIF(ITABLE.NE.ITABLE0) THEN 3393 ITABLE = ITABLE0 3394 IIII = -100000-NBCOUL 3395 CALL TABCOL(IIII,IWAVE) 3396 ENDIF 3397 ENDIF 3398 GEOM = .TRUE. 3399 GOTO 5000 3400 ELSE 3401 GOTO 5002 3402 ENDIF 3403C 3404C Taille des fleches (*) 3405C 3406 4100 IF (IFVIT.NE.0) THEN 3407 FFF = 1. 3408 CALL QUEST_EXAFLE(ILANG,FFF,IRQ) 3409 IF (FFF.EQ.1.) GOTO 5002 3410Cfj CALL FSTERM(1) 3411Cfj IF (ILANG.EQ.0) THEN 3412Cfj CALL LIREEL1 3413Cfj & ('Facteur multiplicatif pour la taille des fl�ches ?',0,FFF) 3414Cfj ELSE 3415Cfj CALL LIREEL1 3416Cfj & ('Multiplicative factor for the arrows size ?',0,FFF) 3417Cfj ENDIF 3418 IF (FFF.EQ.0.) FFF = 1.E-4 3419 FACVIT = FACVIT*FFF 3420 FACVIT0 = FACVIT0*FFF 3421Cfj CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3422 GEOM = .TRUE. 3423 GOTO 5001 3424 ELSE 3425 GOTO 5002 3426 ENDIF 3427C 3428C maillages : Comparaison de deux fichiers de valeurs ()) 3429C surfaces : courbes sur la surface 3430C 3431 4200 IF (ICOURB.GT.0) THEN 3432 CALL FSTERM(1) 3433 CALL LIISO2S(ICLAS,IRC) 3434 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3435 IF (IRC.NE.0) GOTO 5002 3436 IF (ISO.EQ.0) THEN 3437 GOTO 5001 3438 ELSE 3439 GOTO 5000 3440 ENDIF 3441 ENDIF 3442C 3443C On se branche ici pour l'option secrete "`" (Bob) 3444C 3445 CALL FSTERM(1) 3446 4201 IF (ILANG.EQ.0) THEN 3447 CALL LIFICHTAB( 3448 & 'Nom du fichier de points ?',0,NOM_COUR,LONCOUR,0) 3449 ELSE 3450 CALL LIFICHTAB( 3451 & 'Name of the points file ?',0,NOM_COUR,LONCOUR,0) 3452 ENDIF 3453 IF (LONCOUR.LT.0) THEN 3454 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3455 GOTO 5002 3456 ENDIF 3457 IF (ICOURB.EQ.-5.OR.ICOURB.GT.0) THEN 3458 CALL INV3X3(ROTA,ROTLOC,IERR) 3459 DO I=1,3 3460 DO J=1,3 3461 ROTA(J,I) = ROTLOC(J,I) 3462 ENDDO 3463 ENDDO 3464 CALL ROTATE(0) 3465 IF (NDS.EQ.3) THEN 3466 CALL LICOUR3(IRC) 3467 ELSE 3468 CALL LICOUR4(IRC) 3469 ENDIF 3470 CALL INV3X3(ROTA,ROTLOC,IERR) 3471 DO I=1,3 3472 DO J=1,3 3473 ROTA(J,I) = ROTLOC(J,I) 3474 ENDDO 3475 ENDDO 3476 CALL ROTATE(0) 3477 ELSE 3478 CALL LICOUR(IRC) 3479 ENDIF 3480 IF (IRC.NE.0) THEN 3481 IF (ILANG.EQ.0) THEN 3482 PRINT*,'*** Mauvais fichier' 3483 ELSE 3484 PRINT*,'*** Bad file' 3485 ENDIF 3486 GOTO 4201 3487 ENDIF 3488 CALL ECR16COULB(ILANG) 3489 IF (ILANG.EQ.0) THEN 3490 CALL LIENTIER('Couleur des points de la courbe ?',0,ICPTS) 3491 IF (ICPTS.LT.0.OR.ICPTS.GT.15) ICPTS = 1 3492 CALL LIENTIER('Couleur des lignes de la courbe ?',0,ICSEG) 3493 IF (ICSEG.LT.0.OR.ICSEG.GT.15) ICSEG = 7 3494 CALL LIREEL1('Taille des points (1. --> d�faut) ?',0,FACPTS) 3495 FACPTS = MAX(0.,FACPTS) 3496 CALL LIENTIER( 3497 & 'Epaisseur des lignes (<-1 ==> pas de lignes) ?',0,IEPSEG) 3498 PRINT*,'Les types de marqueurs sont :' 3499 PRINT*,' 0 : pas de marqueur' 3500 PRINT*,' 1 : +' 3501 PRINT*,' 2 : x' 3502 PRINT*,' 3 : *' 3503 PRINT*,' 4 : o' 3504 PRINT*,' 5 : o plein' 3505 PRINT*,' 6 : carr� plein' 3506 PRINT*,' 7 : carr� vide' 3507 PRINT*,' 8 : losange' 3508 PRINT*,' 9 : losange plein' 3509 PRINT*,' 10 : triangle' 3510 PRINT*,' 11 : triangle plein' 3511 PRINT*,' 12 : triangle invers�' 3512 PRINT*,' 13 : triangle invers� plein' 3513 CALL LIENTIER( 3514 & 'Types des marqueurs aux points (<0 -> variable) ?',0,ITPTS) 3515 CALL LIENTIER( 3516 & 'Marqueurs cach�s (0) ou toujours vus (1) ?',0,IOPMAR) 3517 ELSE 3518 CALL LIENTIER('Dots color?',0,ICPTS) 3519 IF (ICPTS.LT.0.OR.ICPTS.GT.15) ICPTS = 1 3520 CALL LIENTIER('Lines color?',0,ICSEG) 3521 IF (ICSEG.LT.0.OR.ICSEG.GT.15) ICSEG = 7 3522 CALL LIREEL1('Dots size (1. --> default) ?',0,FACPTS) 3523 FACPTS = MAX(0.,FACPTS) 3524 CALL LIENTIER( 3525 & 'Lines thickness (<-1 ==> no lines) ?',0,IEPSEG) 3526 PRINT*,'Marker types:' 3527 PRINT*,' 0 : no markers' 3528 PRINT*,' 1 : +' 3529 PRINT*,' 2 : x' 3530 PRINT*,' 3 : *' 3531 PRINT*,' 4 : o' 3532 PRINT*,' 5 : o filled' 3533 PRINT*,' 6 : filled square' 3534 PRINT*,' 7 : empty square' 3535 PRINT*,' 8 : losange' 3536 PRINT*,' 9 : filled losange' 3537 PRINT*,' 10 : triangle' 3538 PRINT*,' 11 : filled triangle' 3539 PRINT*,' 12 : upsidedown triangle' 3540 PRINT*,' 13 : filled upsidedown triangle' 3541 CALL LIENTIER( 3542 & 'Markers type (<0 -> variable)?',0,ITPTS) 3543 CALL LIENTIER( 3544 & 'Hidden markers (0) or always seen (1)?',0,IOPMAR) 3545 ENDIF 3546 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3547 GEOM = .TRUE. 3548 GOTO 5000 3549Cfj ELSE 3550Cfj GOTO 5002 3551Cfj ENDIF 3552C 3553C Infos dans le cadre a droite (() 3554C 3555 4300 IF (IINFO.GT.0) THEN 3556 IINFO = -1 3557 ELSEIF(IINFO.EQ.-1) THEN 3558 IINFO = -2 3559 ELSE 3560 IINFO = 1 3561 ENDIF 3562 IOPT = -1 3563 GEOM = .TRUE. 3564 IBOUT = -9999 3565 GOTO 5001 3566C 3567C Affichage des valeurs sur le graphique (') 3568C 3569 4400 IF (ISO.NE.0) THEN 3570 CALL FINDFA(XCU,YCU,NBON,IORDRE,NN,NDS,XX,YY,VALGRA 3571 & ,ISO,NPROJE,VALF,0) 3572 IF (NN.NE.0) THEN 3573 NE = NNUMFA(NPROJE(NN)) 3574 IF (ILANG.EQ.0) THEN 3575 IF (NN.EQ.NE) THEN 3576 PRINT*,'Valeur =',VALGRA,' (�l�ment',NN,')' 3577 ELSE 3578 PRINT*,'Valeur =',VALGRA,' (�l�ment',NE,', face',NN,')' 3579 ENDIF 3580 ELSE 3581 IF (NN.EQ.NE) THEN 3582 PRINT*,'Value =',VALGRA,' (element',NN,')' 3583 ELSE 3584 PRINT*,'Value =',VALGRA,' (element',NE,', face',NN,')' 3585 ENDIF 3586 ENDIF 3587 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 3588 CALL ECRVAL(XCU,YCU,VALGRA) 3589 NBPG = NBPG+1 3590 IF (NBPG.GT.NBPGM) THEN 3591 NBPG = NBPGM 3592 DO I=1,NBPGM-1 3593 VALG(I) = VALG(I+1) 3594 XXXG(I) = XXXG(I+1) 3595 YYYG(I) = YYYG(I+1) 3596 ENDDO 3597 ENDIF 3598 VALG(NBPG) = VALGRA 3599 XXXG(NBPG) = XCU 3600 YYYG(NBPG) = YCU 3601 ENDIF 3602 ENDIF 3603 GOTO 5003 3604C 3605C Orientation de la lumiere (&) 3606C 3607 4500 IDIRL = IDIRL+1 3608 IF (IDIRL.GT.6) IDIRL = 0 3609 CALL METLALIGHT 3610 IF (ICTFAC0.GT.15.OR.ICTFAC.NE.ICTFAC0) THEN 3611 GEOM = .TRUE. 3612 IF (ICTFAC.NE.ICTFAC0) THEN 3613 CALL INITBOUT 3614 IREFRE = 1 3615 ENDIF 3616 GOTO 5000 3617 ELSE 3618 GOTO 5002 3619 ENDIF 3620C 3621C Perspective (%) 3622C 3623 4600 IF (IPERSP.EQ.1) THEN 3624 IPERSP = -1 3625 ELSEIF(IPERSP.EQ.-1) THEN 3626 IPERSP = -2 3627 ELSEIF(IPERSP.EQ.-2) THEN 3628 IPERSP = -3 3629 ELSEIF(IPERSP.EQ.-3) THEN 3630 IPERSP = 1 3631 ENDIF 3632 CALL METLAPERSP 3633ctrans dist000 = dist 3634ctrans call calpup(xpup,dist,obs,u,v) 3635 GEOM = .TRUE. 3636 GOTO 5000 3637C 3638C Couleurs imposees ($) 3639C 3640 4700 CALL FSTERM(1) 3641 IF (ILANG.EQ.0) THEN 3642 PRINT*,'Couleurs impos�es :' 3643 CALL ECR16COULB(ILANG) 3644 CALL LIENTIER('Nombre de couleurs impos�es ?',0,NCIMP) 3645 ELSE 3646 PRINT*,'Imposed colors:' 3647 CALL ECR16COULB(ILANG) 3648 CALL LIENTIER('Number of imposed colors?',0,NCIMP) 3649 ENDIF 3650 NCIMP = MIN(NBCOUL,MAX(0,NCIMP)) 3651 IF (NCIMP.GT.0) THEN 3652 IF (ILANG.EQ.0) THEN 3653 PRINT*,'On va imposer',NCIMP,' valeurs' 3654 CALL LIENTIER('Ok (1:oui, 0:non) ?',0,IOK) 3655 ELSE 3656 PRINT*,'We are going to impose',NCIMP,' values' 3657 CALL LIENTIER('Ok (1:yes, 0:no)?',0,IOK) 3658 ENDIF 3659 IF (IOK.EQ.0) NCIMP = 0 3660 ENDIF 3661 IF (NCIMP.GT.0) THEN 3662 IF (ILANG.EQ.0) THEN 3663 PRINT*,'Les valeurs � rep�rer doivent �tre comprises entre' 3664 & ,VMIN,' et',VMAX 3665 ELSE 3666 PRINT*,'Values must lie between',VMIN,' and',VMAX 3667 ENDIF 3668 NNN = 0 3669 DO I=1,NCIMP 3670 IF (NCIMP.EQ.1) THEN 3671 IF (ILANG.EQ.0) THEN 3672 CALL LI2REEL1( 3673 & 'Entrez la valeur � rep�rer et sa nouvelle couleur',0,VVVV,XK2) 3674 ELSE 3675 CALL LI2REEL1( 3676 & 'Type the value to mark and its new color',0,VVVV,XK2) 3677 ENDIF 3678 ELSE 3679 IF (I.EQ.1) THEN 3680 IF (ILANG.EQ.0) THEN 3681 CALL LI2REEL1( 3682 & 'Entrez la premiere valeur � rep�rer et sa nouvelle couleur' 3683 & ,0,VVVV,XK2) 3684 ELSE 3685 CALL LI2REEL1( 3686 & 'Type first the value to mark and its new color',0,VVVV,XK2) 3687 ENDIF 3688 ELSE 3689 IF (I.LT.10) THEN 3690 WRITE(CNUM(1:2),'(I2)') I 3691 LL = 2 3692 ELSEIF(I.LT.100) THEN 3693 WRITE(CNUM(1:3),'(I3)') I 3694 LL = 3 3695 ELSE 3696 WRITE(CNUM(1:4),'(I4)') I 3697 LL = 4 3698 ENDIF 3699 IF (ILANG.EQ.0) THEN 3700 CALL LI2REEL1('Entrez la'//CNUM(1:LL)// 3701 & '�me valeur � rep�rer et sa nouvelle couleur' 3702 & ,0,VVVV,XK2) 3703 ELSE 3704 CALL LI2REEL1('Type the '//CNUM(1:LL)// 3705 & 'th value to mark and its new color',0,VVVV,XK2) 3706 ENDIF 3707 ENDIF 3708 ENDIF 3709 K2 = NINT(XK2) 3710 IF (VVVV.GE.VMIN.AND.VVVV.LE.VMAX) THEN 3711 NNN = NNN+1 3712 K2 = 1+MIN(15,MAX(0,K2)) 3713 K1 = 18 + NINT(.5+REAL(NBCOUL)*(VVVV-VMIN)/(VMAX-VMIN)) 3714 IF (ILANG.EQ.0) THEN 3715 PRINT*,'Couleur',K1-18,' chang�e en',K2-1 3716 ELSE 3717 PRINT*,'Color',K1-18,' changed into',K2-1 3718 ENDIF 3719 CALL TABCOL(-(K2*1000+K1),IWAVE) 3720 ELSE 3721 IF (ILANG.EQ.0) THEN 3722 PRINT*,'Valeur en dehors des bornes' 3723 ELSE 3724 PRINT*,'Values off the bounds' 3725 ENDIF 3726 ENDIF 3727 ENDDO 3728 IF (ILANG.EQ.0) THEN 3729 PRINT*,NNN,' couleurs modifi�es' 3730 ELSE 3731 PRINT*,NNN,' modified colors' 3732 ENDIF 3733 ENDIF 3734 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3735 IF (NNN.GT.0) THEN 3736 IF (ITERMC.EQ.4) THEN 3737CC GEOM = .FALSE. 3738 GOTO 5001 3739 ELSE 3740 IOPT = 0 3741 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUT) 3742 GOTO 5002 3743 ENDIF 3744 ELSE 3745 GOTO 5002 3746 ENDIF 3747C 3748C Rotation a la souris (#) 3749C 3750 4800 CALL GSQCUR(WIN,XCUR111,YCUR111) 3751 IF (ITYP.EQ.0) THEN 3752 CALL CHANGE_CURS(3) 3753 CALL VEC23(XCUR111,YCUR111,VEC1) 3754 DO J=1,3 3755 VEC0(J) = VEC1(J) 3756 ENDDO 3757 ITYP = -13 3758 CALL INV3X3(ROTA,ROTAINV,IERR) 3759 XCUR000 = XCUR111 3760 YCUR000 = YCUR111 3761 CALL GSBND(XHELP,XDMAX,YDMIN,YDMAX) 3762 CALL GSPAT(ICTFON) 3763 XCADRE(1) = XHELP 3764 XCADRE(2) = XDMAX 3765 XCADRE(3) = XDMAX 3766 XCADRE(4) = XHELP 3767 YCADRE(1) = YDMIN 3768 YCADRE(2) = YDMIN 3769 YCADRE(3) = YDMAX 3770 YCADRE(4) = YDMAX 3771 CALL MY_GSAREA(0,XCADRE,YCADRE,4) 3772 ELSE 3773 TOTO = (XCUR111-XCUR000)**2+(YCUR111-YCUR000)**2 3774 IF (TOTO.GT.PASMIN2) THEN 3775 CALL VEC23(XCUR111,YCUR111,VEC1) 3776 CALL ROTINT(VEC0,VEC1) 3777 DO J=1,3 3778 VEC0(J) = VEC1(J) 3779 ENDDO 3780 XCUR000 = XCUR111 3781 YCUR000 = YCUR111 3782 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUT) 3783 ELSE 3784 GOTO 5003 3785 ENDIF 3786 ENDIF 3787 CALL ECHEL(-2,BIDON) 3788 IF (IAXES.NE.0.AND.IAXES.LT.5) CALL AXES(XHELP,XDMAX,YDMIN,YDMAX) 3789 CALL GSLW(IEPBOR) 3790 CALL GSPLNEC(4,XCADRE,YCADRE) 3791 CALL GSLW(0) 3792 GOTO 5003 3793C 3794C Maillages 3d : Isosurface (!) 3795C Surfaces : coupes suivant Ox ou Oy et appel de xgraphic (!) 3796C 3797 4900 IF (ICOURB.GT.0) THEN 3798 IQUEST = 0 3799 IF (I2D.EQ.0) THEN 3800C Maillages 3d : Isosurface (!) 3801 IF (IFISO.NE.0.AND.IVOL.NE.0.AND.VMINISO.LT.VMAXISO) THEN 3802 III = 0 3803 IF (LONISO.GT.5) THEN 3804 IF (NOM_ISO(LONISO-5:LONISO).EQ.'.theta') III = 1 3805 ENDIF 3806 IF (LONISO.GT.6) THEN 3807 IF (NOM_ISO(LONISO-6:LONISO).EQ.'.thetap') III = 1 3808 ENDIF 3809 IF (LONISO.GT.3) THEN 3810 IF (NOM_ISO(LONISO-3:LONISO).EQ.'.psi') III = 2 3811 ENDIF 3812 CALL QUEST_ISOSURF(ILANG,VMINISO,VMAXISO,NSURF,VISO,ICALSU 3813 & ,BSOMB,ICSUR,III,IRQ) 3814 IF (IRQ.EQ.0.OR.IRQ.EQ.-2) THEN 3815 ISOCOUP = 2 3816 IF (IRQ.EQ.-2) THEN 3817 IQUEST = 4900 3818 ELSE 3819 IQUEST = 0 3820 ENDIF 3821c GEOM = .TRUE. 3822 IF (IFC.GT.0) IFC = -1 3823 IF ((VISO.LT.VMINISO.AND.(ICALSU.EQ.0.OR.ICALSU.EQ.1)) 3824 & .OR.(VISO.GT.VMAXISO.AND.(ICALSU.EQ.0.OR.ICALSU.EQ.2))) 3825 & THEN 3826 NSURF = 0 3827 ELSE 3828 CALL CALSUR(1) 3829 ENDIF 3830 GOTO 5000 3831 ELSE 3832 GOTO 5002 3833 ENDIF 3834Cfj CALL FSTERM(1) 3835Cfj IF (ILANG.EQ.0) THEN 3836Cfj PRINT*,'Bornes des valeurs',VMINISO,VMAXISO 3837Cfj IF (NSURF.GT.0) THEN 3838Cfj IF (ICALSU.EQ.0) THEN 3839Cfj PRINT*,'Isosurface actuelle =',VISO 3840Cfj ELSEIF(ICALSU.EQ.1) THEN 3841Cfj PRINT*,'Isosurface actuelle <=',VISO 3842Cfj ELSE 3843Cfj PRINT*,'Isosurface actuelle >=',VISO 3844Cfj ENDIF 3845Cfj ENDIF 3846Cfj CALL LIREEL1('Valeur de l''isosurface ?',0,VISO) 3847Cfj ELSE 3848Cfj PRINT*,'Bounds of the values',VMINISO,VMAXISO 3849Cfj IF (NSURF.GT.0) THEN 3850Cfj IF (ICALSU.EQ.0) THEN 3851Cfj PRINT*,'Current surface =',VISO 3852Cfj ELSEIF(ICALSU.EQ.1) THEN 3853Cfj PRINT*,'Current surface <=',VISO 3854Cfj ELSE 3855Cfj PRINT*,'Current surface >=',VISO 3856Cfj ENDIF 3857Cfj ENDIF 3858Cfj CALL LIREEL1('Isosurface''s value?',0,VISO) 3859Cfj ENDIF 3860Cfj IF (VISO.LT.VMINISO.OR.VISO.GT.VMAXISO) THEN 3861Cfj NSURF = 0 3862Cfj CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3863Cfj GOTO 5001 3864Cfj ELSE 3865Cfj IF (ILANG.EQ.0) THEN 3866Cfj CALL LIENTIER('Juste l''iso (0) <iso (1) >iso (2) ?' 3867Cfj & ,0,ICALSU) 3868Cfj ELSE 3869Cfj CALL LIENTIER('Surface only (0) <iso (1) >iso (2) ?' 3870Cfj & ,0,ICALSU) 3871Cfj ENDIF 3872Cfj IF (ICALSU.NE.1.AND.ICALSU.NE.2) ICALSU = 0 3873Cfj IF (ICALSU.NE.0) THEN 3874Cfj IF (ILANG.EQ.0) THEN 3875Cfj CALL LIENTIER( 3876Cfj & 'Bord du domaine clair (0), moyen (1) ou sombre (2) ?',0,IBSOMB) 3877Cfj ELSE 3878Cfj CALL LIENTIER( 3879Cfj & 'Domain''s boundaries light (0), medium (1) or dark (2) ?' 3880Cfj & ,0,IBSOMB) 3881Cfj ENDIF 3882Cfj IF (IBSOMB.EQ.0) THEN 3883Cfj BSOMB = 0.5 3884Cfj ELSEIF(IBSOMB.EQ.1) THEN 3885Cfj BSOMB = 0.3 3886Cfj ELSE 3887Cfj BSOMB = 0.1 3888Cfj ENDIF 3889Cfj ENDIF 3890Cfj CALL CALSUR(1) 3891Cfj IF (NSURF.GT.0) THEN 3892Cfj ICSUR = 16 3893Cfj CALL ECR16COUL(ICSUR,ILANG) 3894Cfj IF (ILANG.EQ.0) THEN 3895Cfj PRINT*,'>15 : pas de trac� des ar�tes' 3896Cfj CALL LIENTIER('Couleur des ar�tes de l''isosurface ?' 3897Cfj & ,0,ICSUR) 3898Cfj ELSE 3899Cfj PRINT*,'>15 : no vertex drawn' 3900Cfj CALL LIENTIER('Vertices color?',0,ICSUR) 3901Cfj ENDIF 3902Cfj IF (ICSUR.LT.0) ICSUR = 16 3903Cfj ifc = -1 3904Cfj CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3905Cfj GOTO 5000 3906Cfj ELSE 3907Cfj CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 3908Cfj GOTO 5001 3909Cfj ENDIF 3910Cfj ENDIF 3911 ELSE 3912 CALL FSALRM 3913 GOTO 5002 3914 ENDIF 3915 ELSE 3916C 3917C Maillages 2d : affichage en 3d suivant le champ scalaire (a faire) 3918C 3919 GOTO 5002 3920 ENDIF 3921 ELSEIF(ICOURB.NE.-5) THEN 3922C 3923C Surfaces : coupes suivant Ox ou Oy et appel de xgraphic (!) 3924C 3925 CALL QUICESTCELUILA('xgraphic',8,GVESTLA,0) 3926 IF (.NOT.GVESTLA) THEN 3927 IF (ILANG.EQ.0) THEN 3928 PRINT*,'*** Pas de xgraphic, pas de coupes...' 3929 ELSE 3930 PRINT*,'*** No xgraphic, no cross-sections...' 3931 ENDIF 3932 GOTO 5002 3933 ENDIF 3934 CALL FSTERM(1) 3935 IF (ILANG.EQ.0) THEN 3936 CALL LIENTIER( 3937 & 'Nombre de coupes (>0 fichiers temporaires, <0 on les garde) ?' 3938 & ,0,NCOUP) 3939 ELSE 3940 CALL LIENTIER( 3941 & 'Number of cross-sections (>0 scratch files, <0 files saved)?' 3942 & ,0,NCOUP) 3943 ENDIF 3944 IF (NCOUP.NE.0) THEN 3945 CALL ARC(ANGX,ANGY,ANGZ) 3946 CALL INV3X3(ROTA,ROTLOC,IERR) 3947 CALL ROTATE(1) 3948 CALL PREMIER_LIBRE(ICOUP) 3949 DO I=1,IABS(NCOUP) 3950 WRITE(CC,'(I2.2)') I 3951 IF (NCOUP.GT.0) THEN 3952 OPEN(ICOUP,FILE='/tmp/coupe'//CC//'.'//MOI) 3953 ELSE 3954 OPEN(ICOUP,FILE=NOM_FICH(1:LONG2)//'.coupe'//CC) 3955 ENDIF 3956 IF (ILANG.EQ.0) THEN 3957 CALL LIENTIER('Coupe // Ox (0) ou // Oy (1) ?',0,IPL) 3958 ELSE 3959 CALL LIENTIER( 3960 & 'Cross-section // Ox (0) or // Oy (1) ?',0,IPL) 3961 ENDIF 3962 IF (IPL.EQ.0) THEN 3963 IF (ILANG.EQ.0) THEN 3964 PRINT*,'Bornes en Y :',YMIREE,YMAREE 3965 CALL LIREEL1('Valeur de Y ?',0,YCOUP) 3966 YCOUP = MIN(MAX(YCOUP,YMIREE),YMAREE) 3967 YCOUP = YCOUP-YMED 3968 WRITE(ICOUP,'(A,G11.5)') 3969 & '# Coupe du fichier '//NOM_FICH(1:LONG)//' par le plan Y =' 3970 & ,YCOUP+YMED 3971 ELSE 3972 PRINT*,'Y bounds:',YMIREE,YMAREE 3973 CALL LIREEL1('Y value?',0,YCOUP) 3974 YCOUP = MIN(MAX(YCOUP,YMIREE),YMAREE) 3975 YCOUP = YCOUP-YMED 3976 WRITE(ICOUP,'(A,G11.5)') 3977 & '# Cross-section of'//NOM_FICH(1:LONG)//' / plan Y =' 3978 & ,YCOUP+YMED 3979 ENDIF 3980 KK = 0 3981 J = 1 3982 DO K=1,NUMY-1 3983 IF (KK.EQ.0.AND.Y(J).LE.YCOUP.AND.Y(J+NUMX).GE.YCOUP) 3984 & KK = K 3985 J = J+NUMX 3986 ENDDO 3987 FAC = (YCOUP-Y((KK-1)*NUMX+1))/(Y(KK*NUMX+1)-Y(KK)) 3988 IF (KK.EQ.0.OR.FAC.GT.1..OR.FAC.LT.0.) THEN 3989 IF (ILANG.EQ.0) THEN 3990 PRINT*,'*** Probl�me',KK,FAC 3991 ELSE 3992 PRINT*,'*** Error',KK,FAC 3993 ENDIF 3994 ENDIF 3995 DO K=1,NUMX 3996 J1 = (KK-1)*NUMX + K 3997 J2 = J1+NUMX 3998 WRITE(ICOUP,*) X(K)+XMED0,FAC*Z(J2)+(1.-FAC)*Z(J1)+ZMED0 3999 ENDDO 4000 ELSE 4001 IF (ILANG.EQ.0) THEN 4002 PRINT*,'Bornes en X :',XMIREE,XMAREE 4003 CALL LIREEL1('Valeur de X ?',0,XCOUP) 4004 XCOUP = MIN(MAX(XCOUP,XMIREE),XMAREE) 4005 XCOUP = XCOUP-XMED0 4006 WRITE(ICOUP,'(A,G11.5)') 4007 & '# Coupe du fichier '//NOM_FICH(1:LONG)//' par le plan X =' 4008 & ,XCOUP+XMED0 4009 ELSE 4010 PRINT*,'X bounds:',XMIREE,XMAREE 4011 CALL LIREEL1('X value?',0,XCOUP) 4012 XCOUP = MIN(MAX(XCOUP,XMIREE),XMAREE) 4013 XCOUP = XCOUP-XMED0 4014 WRITE(ICOUP,'(A,G11.5)') 4015 & '# Cross-section of '//NOM_FICH(1:LONG)//' / plan X =' 4016 & ,XCOUP+XMED0 4017 ENDIF 4018 KK = 0 4019 DO K=1,NUMX-1 4020 IF (KK.EQ.0.AND.X(K).LE.XCOUP.AND.X(K+1).GE.XCOUP) 4021 & KK = K 4022 ENDDO 4023 FAC = (XCOUP-X(KK))/(X(KK+1)-X(KK)) 4024 IF (KK.EQ.0.OR.FAC.GT.1..OR.FAC.LT.0.) THEN 4025 IF (ILANG.EQ.0) THEN 4026 PRINT*,'*** Probl�me',KK,FAC 4027 ELSE 4028 PRINT*,'*** Error',KK,FAC 4029 ENDIF 4030 ENDIF 4031 DO K=1,NUMY 4032 J1 = (K-1)*NUMX + KK 4033 J2 = J1+1 4034 WRITE(ICOUP,*) Y(J1)+YMED0 4035 & ,FAC*Z(J2)+(1.-FAC)*Z(J1)+ZMED0 4036 ENDDO 4037 ENDIF 4038 CLOSE(ICOUP) 4039 ENDDO 4040 IF (NCOUP.GT.0) THEN 4041 CALL EXEC('xgraphic -win65 /tmp/coupe*'//MOI//'>/dev/null&') 4042 CALL EXEC( 4043 & 'sleep 5 ; /bin/rm -f /tmp/coupe*'//MOI//'>/dev/null') 4044 ELSE 4045 CALL EXEC( 4046 & 'xgraphic -win65 '//NOM_FICH(1:LONG2)//'.coupe*>/dev/null&') 4047 ENDIF 4048 CALL ARCROT(ANGX,ANGY,ANGZ) 4049 CALL ROTATE(0) 4050 ENDIF 4051 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 4052 GOTO 5002 4053 ELSE 4054 GOTO 5002 4055 ENDIF 4056C 4057C touche secrete (`) 4058C 4059 4901 CALL FSTERM(1) 4060 IF (ILANG.EQ.0) THEN 4061 PRINT*,'*** Options secr�tes !' 4062 PRINT*,'*** Espace r�serv� aux experts...' 4063 PRINT*,'Options possibles :' 4064 PRINT*,'1: Courbes sur maillage.' 4065 PRINT*,'2: Sauvegarde des segments dans un fichier de points.' 4066 PRINT*,'autre: abandon et retour au mode normal.' 4067 ELSE 4068 PRINT*,'*** Hidden options !' 4069 PRINT*,'*** Experts only...' 4070 PRINT*,'Available options:' 4071 PRINT*,'1: Curves on mesh.' 4072 PRINT*,'2: Save segments in a file.' 4073 PRINT*,'others: cancel and return to normal mode.' 4074 ENDIF 4075 CALL LIENTIER('Option ?',0,III) 4076C 4077C courbes sur maillage (identique aux courbes sur les surfaces) 4078C 4079 IF (III.EQ.1) THEN 4080 GOTO 4201 4081C 4082C fichier pour xgraphic (marc) (`) 4083C 4084 ELSEIF(III.EQ.2) THEN 4085 IF (IPERSP.EQ.1) THEN 4086 FAFA = R2R3 4087 ELSE 4088 FAFA = .5*RAC3 4089 ENDIF 4090 IF (ISO.EQ.0) THEN 4091 TITRE = NOM_FICH 4092 LLL = LONG 4093 ELSE 4094 TITRE = NOM_FICH(1:LONG)//' - '//NOM_ISO(1:LONISO) 4095 LLL = LONG + 3 + LONISO 4096 ENDIF 4097 LPOINT = LONG 4098 4911 IF (NOM_FICH(LPOINT:LPOINT).NE.'.'.AND.LPOINT.GT.1) THEN 4099 LPOINT = LPOINT-1 4100 GOTO 4911 4101 ENDIF 4102 IF (LPOINT.EQ.1) THEN 4103 LPOINT = LONG 4104 ELSE 4105 LPOINT = LPOINT-1 4106 ENDIF 4107 CALL INITSAUVE(NOM_FICH(1:LPOINT)//'.graph',LPOINT+6,XMED0,YMED0 4108 & ,FAFA,TITRE,LLL) 4109 ISAUVEGRAPH = 1 4110 GEOM = .TRUE. 4111 GOTO 5001 4112 ELSE 4113 CALL FSINN(IPROX,IPROY,PROBIG,IDEB,ITERMC) 4114 GOTO 5002 4115 ENDIF 4116C 4117C Titre du avoir3D (_) 4118C 4119 4902 IF (LONTIT.GT.0) THEN 4120 ITITAV = -ITITAV 4121 IF (IFREEZE.NE.0) GOTO 5003 4122 IF (ITITAV.LT.0) THEN 4123 CALL TITIT(XHELP,XDMAX,YDMIN,YDMAX) 4124 GOTO 5002 4125 ELSE 4126 GEOM = .TRUE. 4127 GOTO 5001 4128 ENDIF 4129 ELSE 4130 GOTO 5002 4131 ENDIF 4132C 4133C Numeros (^) (maillages only) 4134C 4135 4903 IF (ICOURB.GT.0) THEN 4136C 4137C INUMER = 0 : Pas de numeros 4138C = 1 : elements 4139C = -1 : noeuds 4140C = -2 : references 4141C = -3 : references non nulles 4142C 4143 IF (INUMER.EQ.0) THEN 4144 INUMER = -1 4145 ELSEIF(INUMER.EQ.-1) THEN 4146 INUMER = 1 4147 ELSEIF(INUMER.EQ.1) THEN 4148 INUMER = -2 4149 ELSEIF(INUMER.EQ.-2) THEN 4150 INUMER = -3 4151 ELSE 4152 INUMER = 0 4153 ENDIF 4154 GEOM = .TRUE. 4155 GOTO 5000 4156 ELSE 4157 GOTO 5003 4158 ENDIF 4159C 4160C Tables oscillantes (]) provisoire pour Alexandre 4161C 4162 4904 IWAVE = IWAVE+1 4163 IF (IWAVE.EQ.11.OR.IWAVE.GT.NBCOUL/5) IWAVE=0 4164 IIII = -100000-NBCOUL 4165 CALL TABCOL(IIII,IWAVE) 4166 IF (ITERMC.EQ.4) THEN 4167 GOTO 5001 4168 ELSE 4169 IOPT = 0 4170 GOTO 5002 4171 ENDIF 4172C 4173C Mode progressif ou non (\) 4174C 4175 4905 IPROGRE = -IPROGRE 4176 IF (IPROGRE.LT.0) THEN 4177 CALL VRAIECOORD(XHELP,YDMAX,IX0,IY0) 4178 CALL VRAIECOORD(XDMAX,YDMIN,IX1,IY1) 4179 PIPI = .5*REAL(IEPBOR)*(XDMAX-XHELP)/REAL(IABS(IX0-IX1)) 4180 ILARG = IX1-IX0-IEPBOR 4181 IHAUT = IY1-IY0-IEPBOR 4182 IX0 = IX0+IEPBOR/2 4183 IY0 = IY0+IEPBOR/2 4184 IX1 = IX1-IEPBOR/2 4185 IY1 = IY1-IEPBOR/2 4186 IX0S = IX0+ISHIFTX 4187 IY0S = IY0+ISHIFTY 4188 CALL GSPROGRE(2) 4189 CALL GSPATF(ICTFON) 4190 CALL GSPAT(16) 4191 CALL GSBND(XHELP*2.-XDMAX,XDMAX*2.-XHELP 4192 & ,YDMIN*2.-YDMAX,YDMAX*2.-YDMIN) 4193 CALL MY_GSAREA2B(XHELP*2.-XDMAX,XDMAX*2.-XHELP 4194 & ,YDMIN*2.-YDMAX,YDMAX*2.-YDMIN) 4195 CALL GSPROGRE(0) 4196 CALL x11garderect2(IX0,IY0,ILARG,IHAUT,IX0S,IY0S) 4197 ENDIF 4198 GOTO 5002 4199C 4200C Mise a jour des fichiers ouverts ([) (refresh/reload) 4201C 4202 4906 CALL GSBND(XDMIN,XHELP,YDMIN,YDMAX) 4203 CALL MYBORD(XBOUT(1,IBREL),YBOUT(1,IBREL),BID,0,ITOUR2,15,7) 4204 CALL viderbuff2 4205 CALL AREFRESH(IRELIM,IRELIVA,IRELIVI) 4206CC print*,IRELIM,IRELIVA,IRELIVI 4207 IF (IRELIVI.NE.0) THEN 4208 IRC = 1 4209Cfj IF (NOM_ISO(1:1).NE.'$') THEN 4210Cfj CALL LIVAL(NOM_ISO,LONISO,IVAL,ICLAS,ICONTR,NDSEL,IRC) 4211Cfj IF (IVAL.EQ.-1) THEN 4212Cfj III = 2 4213Cfj ELSE 4214Cfj III = 0 4215Cfj ENDIF 4216Cfj ELSE 4217 III = 0 4218Cfj ENDIF 4219 LBID = LONISO 4220 IF (LBID.GT.0) CBIDON(1:LBID) = NOM_ISO(1:LONISO) 4221 CALL LIVAL(NOM_VIT,LONVIT,IVAL,ICLAS,ICONTR,NDSEL,IRC) 4222 IF (FACEXA.EQ.0..OR.I2D.EQ.0) THEN 4223 CALL LIVIT(ICLAS,III,NOM_VIT,LONVIT,IRC,0,0) 4224 ELSE 4225 CALL LIVIT(ICLAS,III,NOM_VIT,LONVIT,IRC,0,1) 4226 ENDIF 4227 LONISO = LBID 4228 IF (LBID.GT.0) NOM_ISO(1:LONISO) = CBIDON(1:LBID) 4229 ENDIF 4230 IF (IRELIVA.NE.0) THEN 4231 IRC = 1 4232 CALL LIVAL(NOM_ISO,LONISO,IVAL,ICLAS,ICONTR,NDSEL,IRC) 4233 IF (I2D.NE.0.AND.FACEXA.NE.0.) THEN 4234 DFACX = -FACEXA 4235 DFACY = -FACEXA 4236 DFACZ = -FACEXA 4237 CALL EXAGERE(DFACX,DFACY,DFACZ,0) 4238 FACEXA0 = FACEXA 4239 IEXA = 1 4240 ELSE 4241 IEXA = 0 4242 ENDIF 4243 CALL LIISO(ICLAS,NOM_ISO,LONISO,IRC,ICONTR,1,IVAL) 4244 IF (IEXA.EQ.1) THEN 4245 FACEXA = FACEXA0 4246 DFACX = FACEXA 4247 DFACY = FACEXA 4248 DFACZ = FACEXA 4249 CALL EXAGERE(DFACX,DFACY,DFACZ,0) 4250 ENDIF 4251 IF (ISO.EQ.0.AND.(IVAL.EQ.1.OR.IVAL.EQ.4).AND.NSURF.LE.0) THEN 4252 IOPT = -1 4253 ELSE 4254ccc IF (IREP.EQ.0.AND.(VISO.LT.VMINISO.OR.VISO.GT.VMAXISO)) THEN 4255 IF ((VISO.LT.VMINISO.AND.(ICALSU.EQ.0.OR.ICALSU.EQ.1)) 4256 & .OR.(VISO.GT.VMAXISO.AND.(ICALSU.EQ.0.OR.ICALSU.EQ.2))) THEN 4257 NSURF = 0 4258 ELSEif(nsurf.gt.0) then 4259 print*,'passe',nrecon,nsurf,nf 4260 if (nrecon.gt.1) then 4261Cfj nrecon0 = nrecon 4262Cfj nface0 = nface 4263Cfj nrecon = 1 4264Cfj nface = nf 4265Cfj call symetrise(nrecon0,0) 4266Cfjc call exagere(-facexa,-facexa,-facexa,0) 4267 if (nsurf.gt.0) call calsur(0) 4268Cfj nrecon = nrecon0 4269Cfj nface = nface0 4270Cfj nrecon0 = 1 4271Cfj call symetrise(nrecon0,0) 4272Cfj if (nsurf.gt.0.and.ictfac.gt.15.and.ictfac.le.97) 4273Cfj & call eliso(irc) 4274 GEOM = .TRUE. 4275 else 4276 CALL CALSUR(0) 4277 endif 4278cc IF (NSURF.GT.0) CALL CALSUR(1) 4279 ENDIF 4280 ENDIF 4281 ENDIF 4282C 4283 IF (IRELIM.EQ.0) THEN 4284 IF (IRELIVA.EQ.0.AND.IRELIVI.EQ.0) THEN 4285 GOTO 5002 4286 ELSE 4287 IF (NBPG.GT.0) THEN 4288 DO I=1,NBPG 4289 CALL FINDFA(XXXG(I),YYYG(I),NBON,IORDRE,NN,NDS,XX,YY 4290 & ,VALGRA,ISO,NPROJE,VALF,1) 4291 IF (NN.NE.0) THEN 4292 NE = NNUMFA(NPROJE(NN)) 4293 IF (ILANG.EQ.0) THEN 4294 IF (NN.EQ.NE) THEN 4295 PRINT*,'Nouvelle valeur =',VALGRA,' (�l�ment',NN,')' 4296 ELSE 4297 PRINT*, 4298 & 'Nouvelle valeur =',VALGRA,' (�l�ment',NE,', face',NN,')' 4299 ENDIF 4300 ELSE 4301 IF (NN.EQ.NE) THEN 4302 PRINT*,'New value =',VALGRA,' (element',NN,')' 4303 ELSE 4304 PRINT*, 4305 & 'New value =',VALGRA,' (element',NE,', face',NN,')' 4306 ENDIF 4307 ENDIF 4308 ELSE 4309 PRINT*,'*** Biz',I 4310 ENDIF 4311 VALG(I) = VALGRA 4312 ENDDO 4313 ENDIF 4314 IF (ILANG.EQ.0) THEN 4315 PRINT*,'--- fin relecture ---' 4316 ELSE 4317 PRINT*,'--- end of reload ---' 4318 ENDIF 4319 IF (ISO.EQ.0.AND.(IVAL.EQ.1.OR.IVAL.EQ.4).AND.NSURF.LE.0) THEN 4320 GOTO 5001 4321 ELSE 4322 GOTO 5000 4323 ENDIF 4324 ENDIF 4325 ELSE 4326 IF (ILANG.EQ.0) THEN 4327 PRINT*,'--- fin relecture ---' 4328 ELSE 4329 PRINT*,'--- end of reload ---' 4330 ENDIF 4331 IPARA = -NFACE/NF 4332 IREFRE = 1 4333 NOM_FICH(1:LONG0) = NOMF0(1:LONG0) 4334 LONG = LONG0 4335 GOTO 1 4336 ENDIF 4337C 4338C Coupes (}) 4339C 4340 3503 IQUEST = 0 4341 IF (ICOURB.GT.0.AND.I2D.EQ.0.AND.IVOL.NE.0) THEN 4342 CALL INV3X3(ROTA,ROTLOC,IERR) 4343 CALL ROTATE(1) 4344 CALL INV3X3(ROTLOC,ROTA,IERR) 4345 VMINXYZ(1) = BIG 4346 VMAXXYZ(1) = -BIG 4347 VMINXYZ(2) = BIG 4348 VMAXXYZ(2) = -BIG 4349 VMINXYZ(3) = BIG 4350 VMAXXYZ(3) = -BIG 4351 DO I=1,NUMNP 4352 VMINXYZ(1) = MIN(VMINXYZ(1),X(I)) 4353 VMAXXYZ(1) = MAX(VMAXXYZ(1),X(I)) 4354 VMINXYZ(2) = MIN(VMINXYZ(2),Y(I)) 4355 VMAXXYZ(2) = MAX(VMAXXYZ(2),Y(I)) 4356 VMINXYZ(3) = MIN(VMINXYZ(3),Z(I)) 4357 VMAXXYZ(3) = MAX(VMAXXYZ(3),Z(I)) 4358 ENDDO 4359 VMINXYZ(1) = VMINXYZ(1) + XMED0 4360 VMAXXYZ(1) = VMAXXYZ(1) + XMED0 4361 VMINXYZ(2) = VMINXYZ(2) + YMED0 4362 VMAXXYZ(2) = VMAXXYZ(2) + YMED0 4363 VMINXYZ(3) = VMINXYZ(3) + ZMED0 4364 VMAXXYZ(3) = VMAXXYZ(3) + ZMED0 4365 IF (VCOUPXYZ(1).EQ.BIG) VCOUPXYZ(1) = (VMINXYZ(1)+VMAXXYZ(1))*.5 4366 IF (VCOUPXYZ(2).EQ.BIG) VCOUPXYZ(2) = (VMINXYZ(2)+VMAXXYZ(2))*.5 4367 IF (VCOUPXYZ(3).EQ.BIG) VCOUPXYZ(3) = (VMINXYZ(3)+VMAXXYZ(3))*.5 4368 IPCOUP0 = IPCOUP 4369 IF (IPCOUP.EQ.0) IPCOUP = 3 4370 CALL QUEST_COUPE(ILANG,VMINXYZ,VMAXXYZ,VCOUPXYZ,VCOUP 4371 & ,IPCOUP,IPCOUP0,ICOUPSU,IRQ) 4372 IF (IRQ.EQ.0.OR.IRQ.EQ.-2) THEN 4373 ISOCOUP = 1 4374 BSOMB = 0.3 4375 IF (IBORD.NE.-1.AND.IMAILL.GT.0) THEN 4376 ICSUR = 8 4377 ELSE 4378 ICSUR = 16 4379 ENDIF 4380 VCOUPXYZ(IPCOUP) = VCOUP 4381 IF (IFC.GT.0) IFC = -1 4382 IF ((VCOUP.LT.VMINXYZ(IPCOUP) 4383 & .AND.(ICOUPSU.EQ.0.OR.ICOUPSU.EQ.1)) 4384 & .OR.(VCOUP.GT.VMAXXYZ(IPCOUP) 4385 & .AND.(ICOUPSU.EQ.0.OR.ICOUPSU.EQ.2))) THEN 4386 NSURF = 0 4387 ELSE 4388 DO I=1,NUMNP 4389 VALXB(I) = VALX(I) 4390 ENDDO 4391 IF (IPCOUP.EQ.1) THEN 4392 DO I=1,NUMNP 4393 VALX(I) = X(I) + XMED0 4394 ENDDO 4395 ELSEIF(IPCOUP.EQ.2) THEN 4396 DO I=1,NUMNP 4397 VALX(I) = Y(I) + YMED0 4398 ENDDO 4399 ELSE 4400 DO I=1,NUMNP 4401 VALX(I) = Z(I) + ZMED0 4402 ENDDO 4403 ENDIF 4404 ICALSU = ICOUPSU 4405 VISO = VCOUP 4406 IFVISO = 1 4407 CALL CALSUR(1) 4408 DO I=1,NUMNP 4409 VALX(I) = VALXB(I) 4410 ENDDO 4411 ENDIF 4412 IF (IRQ.EQ.-2) THEN 4413 IQUEST = 3503 4414 ELSE 4415 IQUEST = 0 4416 ENDIF 4417c GEOM = .TRUE. 4418 CALL ROTATE(0) 4419 GOTO 5000 4420 ELSE 4421 CALL ROTATE(0) 4422 GOTO 5002 4423 ENDIF 4424 ELSE 4425 GOTO 5002 4426 ENDIF 4427C 4428C Type de fleche (~) (dernier caractere dispo) 4429C 4430 3504 IF (IFVIT.NE.0) THEN 4431 III = IABS(ITYPFL) 4432 III = III+1 4433 IF (III.GT.4) III = 1 4434 IF (ITYPFL.GT.0) THEN 4435 ITYPFL = III 4436 ELSE 4437 ITYPFL = -III 4438 ENDIF 4439 GOTO 5001 4440 ELSE 4441 GOTO 5002 4442 ENDIF 4443C 4444C Anglais / Francais 4445C 4446 3505 IF (ILANG.EQ.0) THEN 4447 ILANG = 1 4448 IF (ELEMENTS.EQ.'Hexa�dres 27 noeuds') 4449 & ELEMENTS = 'Hexaedrons 27 nodes' 4450 IF (ELEMENTS.EQ.'Hexa�dres 8 noeuds') 4451 & ELEMENTS = 'Hexaedrons 8 nodes' 4452 IF (ELEMENTS.EQ.'Tetra�dres') THEN 4453 ELEMENTS = 'Tetraedrons' 4454 LELEM = 11 4455 ENDIF 4456 ELSE 4457 ILANG = 0 4458 IF (ELEMENTS.EQ.'Hexaedrons 27 nodes') 4459 & ELEMENTS = 'Hexa�dres 27 noeuds' 4460 IF (ELEMENTS.EQ.'Hexaedrons 8 nodes') 4461 & ELEMENTS = 'Hexa�dres 8 noeuds' 4462 IF (ELEMENTS.EQ.'Tetraedrons') THEN 4463 ELEMENTS = 'Tetra�dres' 4464 LELEM = 10 4465 ENDIF 4466 ENDIF 4467 IREFRE = 1 4468 CALL INFO(XDMAX,XDMA2,YDMIN,YDMAX,NSURF) 4469 CALL INITBOUT 4470 IBOUBOU = 0 4471 CALL HELP(XDMIN,XHELP,YDMI2,YDMAX,IREFRE,ITYP,IOPT,IBOUBOU) 4472 GOTO 5002 4473C 4474 999 CALL TABCOL(0,IWAVE) 4475 CALL FSTERM(0) 4476 CALL ECOPT(0) 4477 END 4478C----------------------------------------------------------------------- 4479 SUBROUTINE ECRMEM 4480 INCLUDE 'com_coor.f' 4481 INCLUDE 'com_faces.f' 4482 INCLUDE 'com_options.f' 4483C 4484 XMPO = ( 44.*REAL(NPMAX) )*4./1048576. 4485 XMFA = ( 84.*REAL(NFMAX) + 4.*REAL(NTMAX) 4486 & + REAL(NEMAX) + 8.*REAL(NCMAX) 4487 & +14.*REAL(NOMAX) )*4./1048576. 4488 IF (ILANG.EQ.0) THEN 4489 WRITE(*,3131) NPMAX,XMPO,NFMAX,XMFA,XMPO+XMFA 4490 ELSE 4491 WRITE(*,3132) NPMAX,XMPO,NFMAX,XMFA,XMPO+XMFA 4492 ENDIF 4493 3131 FORMAT(/'Nombre max de noeuds : NPMAX =',I8,' -->',F6.1,' Mo', 4494 & /'Nombre max de faces : NFMAX =',I8,' -->',F6.1,' Mo', 4495 & /' ---> M�moire totale >',F6.1,' Mo',/) 4496 3132 FORMAT(/'Max number of nodes: NPMAX =',I8,' -->',F6.1,' Mo', 4497 & /'Max number of facets: NFMAX =',I8,' -->',F6.1,' Mo', 4498 & /' ---> Total memory >',F6.1,' Mo',/) 4499 END 4500C----------------------------------------------------------------------- 4501 SUBROUTINE AFFCOORD(XCONT,YCONT,V1,V2,V3,IDIM,NUM) 4502 INCLUDE 'com_options.f' 4503 CHARACTER*40 CCOOR 4504C 4505 PIPI = PIXEL*2. 4506 CALL GSBND(XHELP+PIPI,XDMA2-PIPI,YDMI2+PIPI,YDMIN-PIPI) 4507 IF (IDIM.EQ.0) THEN 4508 CCOOR = ' ' 4509 LL = 39 4510 ELSE 4511 IF (NUM.EQ.0) THEN 4512 LL = 0 4513 ELSE 4514 LL = 8 4515 WRITE(CCOOR(1:8),'(I7," ")') NUM 4516 ENDIF 4517 IF (IDIM.EQ.2) THEN 4518 WRITE(CCOOR(LL+1:LL+29),'("(",G13.5,",",G13.5,")")') V1,V2 4519 LL = LL+29 4520 ELSEIF(IDIM.EQ.3) THEN 4521 WRITE(CCOOR(LL+1:LL+31),'("(",2(G9.3,","),G9.3,")")') V1,V2,V3 4522 LL = LL+31 4523 ENDIF 4524 ENDIF 4525 CALL ASFCOL(0) 4526 CALL GSPATF(8) 4527 IF (IFONT8.EQ.9) THEN 4528 CALL GSLSS(9) 4529 ELSE 4530 CALL GSLSS(0) 4531 ENDIF 4532 CALL AFFICHE_COMPTEUR(XCONT,YCONT,LL,CCOOR,6) 4533 END 4534