1 : C PTRINI SOURCE PV 05/09/22 21:25:59 5181 2 : CSSP TRINIT VERSION 04/08/89 MODIFIEE POUR DRIVER PHIGS 3 : C------------------------------------------------------ 4 : SUBROUTINE PTRINI(NOL,AXAX,AYAY,TITRE,HAUTT,VALEU,NCOUMA) 5 : ***** 6 : ***** definitions standards de PHIGS 7 : ***** 8 : IMPLICIT INTEGER(I-N) 9 : external long 10 : PARAMETER (PUNCON = 1 ) 11 : PARAMETER (PLDLN = 2 ) 12 : C archive state 13 : PARAMETER (PARCL = 0 ) 14 : PARAMETER (PAROP = 1 ) 15 : C attribute identifier 16 : PARAMETER (PLN = 0 ) 17 : PARAMETER (PLWSC = 1 ) 18 : PARAMETER (PPLCI = 2 ) 19 : PARAMETER (PMK = 3 ) 20 : PARAMETER (PMKSC = 4 ) 21 : PARAMETER (PPMCI = 5 ) 22 : PARAMETER (PTXFN = 6 ) 23 : PARAMETER (PTXPR = 7 ) 24 : PARAMETER (PCHXP = 8 ) 25 : PARAMETER (PCHSP = 9 ) 26 : PARAMETER (PTXCI = 10 ) 27 : PARAMETER (PIS = 11 ) 28 : PARAMETER (PISI = 12 ) 29 : PARAMETER (PICI = 13 ) 30 : PARAMETER (PEDFG = 14 ) 31 : PARAMETER (PEDT = 15 ) 32 : PARAMETER (PEWSC = 16 ) 33 : PARAMETER (PEDCI = 17 ) 34 : PARAMETER (PPSHM = 18 ) 35 : PARAMETER (PISHM = 19 ) 36 : PARAMETER (PIRPR = 20 ) 37 : PARAMETER (PIREQ = 21 ) 38 : PARAMETER (PBIS = 22 ) 39 : PARAMETER (PBISI = 23 ) 40 : PARAMETER (PBIC = 24 ) 41 : PARAMETER (PBISHM = 25 ) 42 : PARAMETER (PBIRPR = 26 ) 43 : PARAMETER (PBIREQ = 27 ) 44 : PARAMETER (PCAPCR = 28 ) 45 : PARAMETER (PSAPCR = 29 ) 46 : C aspect source 47 : PARAMETER (PBUNDL = 0 ) 48 : PARAMETER (PINDIV = 1 ) 49 : C clipping indicator 50 : PARAMETER (PNCLIP = 0 ) 51 : PARAMETER (PCLIP = 1 ) 52 : C colour available 53 : PARAMETER (PMONOC = 0 ) 54 : PARAMETER (PCOLOR = 1 ) 55 : C colour model 56 : PARAMETER (PINDCT = 0 ) 57 : PARAMETER (PRGB = 1 ) 58 : PARAMETER (PCIE = 2 ) 59 : PARAMETER (PHSV = 3 ) 60 : PARAMETER (PHLS = 4 ) 61 : C composition type 62 : PARAMETER (PCPRE = 0 ) 63 : PARAMETER (PCPOST = 1 ) 64 : PARAMETER (PCREPL = 2 ) 65 : C conflict resolution 66 : PARAMETER (PCRMNT = 0 ) 67 : PARAMETER (PCRABA = 1 ) 68 : PARAMETER (PCRUPD = 2 ) 69 : C control flag 70 : PARAMETER (PCONDI = 0 ) 71 : PARAMETER (PALWAY = 1 ) 72 : C deferral mode 73 : PARAMETER (PASAP = 0 ) 74 : PARAMETER (PBNIG = 1 ) 75 : PARAMETER (PBNIL = 2 ) 76 : PARAMETER (PASTI = 3 ) 77 : PARAMETER (PWAITD = 4 ) 78 : C device coordinate units 79 : PARAMETER (PMETRE = 0 ) 80 : PARAMETER (POTHU = 1 ) 81 : C display surface empty 82 : PARAMETER (PNEMPT = 0 ) 83 : PARAMETER (PEMPTY = 1 ) 84 : C dynamic modification 85 : PARAMETER (PIRG = 0 ) 86 : PARAMETER (PIMM = 1 ) 87 : PARAMETER (PCBS = 2 ) 88 : C echo switch 89 : PARAMETER (PNECHO = 0 ) 90 : PARAMETER (PECHO = 1 ) 91 : C edit mode 92 : PARAMETER (PINSRT = 0 ) 93 : PARAMETER (PREPLC = 1 ) 94 : C element type 95 : PARAMETER ( PEALL = 0 ) 96 : PARAMETER ( PENIL = 1 ) 97 : PARAMETER ( PEPL3 = 2 ) 98 : PARAMETER ( PEPL = 3 ) 99 : PARAMETER ( PEPM3 = 4 ) 100 : PARAMETER ( PEPM = 5 ) 101 : PARAMETER ( PETX3 = 6 ) 102 : PARAMETER ( PETX = 7 ) 103 : PARAMETER ( PEATR3 = 8 ) 104 : PARAMETER ( PEATR = 9 ) 105 : PARAMETER ( PEFA3 = 10 ) 106 : PARAMETER ( PEFA = 11 ) 107 : PARAMETER ( PEFAS3 = 12 ) 108 : PARAMETER ( PEFAS = 13 ) 109 : PARAMETER ( PECA3 = 14 ) 110 : PARAMETER ( PECA = 15 ) 111 : PARAMETER ( PEGDP3 = 16 ) 112 : PARAMETER ( PEGDP = 17 ) 113 : PARAMETER ( PEPLI = 18 ) 114 : PARAMETER ( PEPMI = 19 ) 115 : PARAMETER ( PETXI = 20 ) 116 : PARAMETER ( PEII = 21 ) 117 : PARAMETER ( PEEDI = 22 ) 118 : PARAMETER ( PELN = 23 ) 119 : PARAMETER ( PELWSC = 24 ) 120 : PARAMETER ( PEPLCI = 25 ) 121 : PARAMETER ( PEMK = 26 ) 122 : PARAMETER ( PEMKSC = 27 ) 123 : PARAMETER ( PEPMCI = 28 ) 124 : PARAMETER ( PETXFN = 29 ) 125 : PARAMETER ( PETXPR = 30 ) 126 : PARAMETER ( PECHXP = 31 ) 127 : PARAMETER ( PECHSP = 32 ) 128 : PARAMETER ( PETXCI = 33 ) 129 : PARAMETER ( PECHH = 34 ) 130 : PARAMETER ( PECHUP = 35 ) 131 : PARAMETER ( PETXP = 36 ) 132 : PARAMETER ( PETXAL = 37 ) 133 : PARAMETER ( PEATCH = 38 ) 134 : PARAMETER ( PEATCU = 39 ) 135 : PARAMETER ( PEATP = 40 ) 136 : PARAMETER ( PEATAL = 41 ) 137 : PARAMETER ( PEANST = 42 ) 138 : PARAMETER ( PEIS = 43 ) 139 : PARAMETER ( PEISI = 44 ) 140 : PARAMETER ( PEICI = 45 ) 141 : PARAMETER ( PEEDFG = 46 ) 142 : PARAMETER ( PEEDT = 47 ) 143 : PARAMETER ( PEEWSC = 48 ) 144 : PARAMETER ( PEEDCI = 49 ) 145 : PARAMETER ( PEPA = 50 ) 146 : PARAMETER ( PEPRPV = 51 ) 147 : PARAMETER ( PEPARF = 52 ) 148 : PARAMETER ( PEADS = 53 ) 149 : PARAMETER ( PERES = 54 ) 150 : PARAMETER ( PEIASF = 55 ) 151 : PARAMETER ( PEHRID = 56 ) 152 : PARAMETER ( PELMT3 = 57 ) 153 : PARAMETER ( PELMT = 58 ) 154 : PARAMETER ( PEGMT3 = 59 ) 155 : PARAMETER ( PEGMT = 60 ) 156 : PARAMETER ( PEMCV3 = 61 ) 157 : PARAMETER ( PEMCV = 62 ) 158 : PARAMETER ( PEMCLI = 63 ) 159 : PARAMETER ( PERMCV = 64 ) 160 : PARAMETER ( PEVWI = 65 ) 161 : PARAMETER ( PEEXST = 66 ) 162 : PARAMETER ( PELB = 67 ) 163 : PARAMETER ( PEAP = 68 ) 164 : PARAMETER ( PEGSE = 69 ) 165 : PARAMETER ( PEPKID = 70 ) 166 : C element type PHIGS+ 167 : PARAMETER ( PEPLS3 = 71 ) 168 : PARAMETER ( PEFSD3 = 72 ) 169 : PARAMETER ( PETRS3 = 73 ) 170 : PARAMETER ( PEQMD3 = 74 ) 171 : PARAMETER ( PESFS3 = 75 ) 172 : PARAMETER ( PENBSC = 76 ) 173 : PARAMETER ( PENBSS = 77 ) 174 : PARAMETER ( PECAP3 = 78 ) 175 : PARAMETER ( PETXCL = 79 ) 176 : PARAMETER ( PEPMCL = 80 ) 177 : PARAMETER ( PEEDCL = 81 ) 178 : PARAMETER ( PEPLCL = 82 ) 179 : PARAMETER ( PECAPC = 83 ) 180 : PARAMETER ( PEPLSM = 84 ) 181 : PARAMETER ( PEICL = 85 ) 182 : PARAMETER ( PEBICL = 86 ) 183 : PARAMETER ( PEBISY = 87 ) 184 : PARAMETER ( PEBISI = 88 ) 185 : PARAMETER ( PERFP = 89 ) 186 : PARAMETER ( PEBRFP = 90 ) 187 : PARAMETER ( PEISM = 91 ) 188 : PARAMETER ( PEBISM = 92 ) 189 : PARAMETER ( PEIRFE = 93 ) 190 : PARAMETER ( PEBIRE = 94 ) 191 : PARAMETER ( PESAPC = 95 ) 192 : PARAMETER ( PEPSCH = 96 ) 193 : PARAMETER ( PEFDGM = 97 ) 194 : PARAMETER ( PEFCUM = 98 ) 195 : PARAMETER ( PELSST = 99 ) 196 : PARAMETER ( PEDPCI = 100 ) 197 : PARAMETER ( PECMI = 101 ) 198 : PARAMETER ( PERCLM = 102 ) 199 : C GDP attributes 200 : PARAMETER (PPLATT = 0 ) 201 : PARAMETER (PPMATT = 1 ) 202 : PARAMETER (PTXATT = 2 ) 203 : PARAMETER (PINATT = 3 ) 204 : PARAMETER (PEDATT = 4 ) 205 : C input class 206 : PARAMETER (PNCLAS = 0 ) 207 : PARAMETER (PLOCAT = 1 ) 208 : PARAMETER (PSTROK = 2 ) 209 : PARAMETER (PVALUA = 3 ) 210 : PARAMETER (PCHOIC = 4 ) 211 : PARAMETER (PPICK = 5 ) 212 : PARAMETER (PSTRIN = 6 ) 213 : C input device status 214 : PARAMETER (PNONE = 0 ) 215 : PARAMETER (POK = 1 ) 216 : PARAMETER (PNPICK = 2 ) 217 : PARAMETER (PNCHOI = 2 ) 218 : C interior style 219 : PARAMETER (PHOLLO = 0 ) 220 : PARAMETER (PSOLID = 1 ) 221 : PARAMETER (PPATTR = 2 ) 222 : PARAMETER (PHATCH = 3 ) 223 : PARAMETER (PISEMP = 4 ) 224 : C linetype 225 : PARAMETER (PLSOLI = 1 ) 226 : PARAMETER (PLDASH = 2 ) 227 : PARAMETER (PLDOT = 3 ) 228 : PARAMETER (PLDASD = 4 ) 229 : C makertype 230 : PARAMETER (PPOINT = 1 ) 231 : PARAMETER (PPLUS = 2 ) 232 : PARAMETER (PAST = 3 ) 233 : PARAMETER (POMARK = 4 ) 234 : PARAMETER (PXMARK = 5 ) 235 : C modellin clipping operater 236 : PARAMETER (PMCREP = 1 ) 237 : PARAMETER (PMCINT = 2 ) 238 : C modification mode 239 : PARAMETER (PNIVE = 0 ) 240 : PARAMETER (PUWOR = 1 ) 241 : PARAMETER (PUQUM = 2 ) 242 : C more simultaneous events 243 : PARAMETER (PNMORE = 0 ) 244 : PARAMETER (PMORE = 1 ) 245 : C off/on switch for edge flag and error handling mode 246 : PARAMETER (POFF = 0 ) 247 : PARAMETER (PON = 1 ) 248 : C open-structure status 249 : PARAMETER (PNONST = 0 ) 250 : PARAMETER (POPNST = 1 ) 251 : C operating mode 252 : PARAMETER (PREQU = 0 ) 253 : PARAMETER (PSAMPL = 1 ) 254 : PARAMETER (PEVENT = 2 ) 255 : C path order 256 : PARAMETER (PPOTOP = 0 ) 257 : PARAMETER (PPOBOT = 1 ) 258 : C polyline/fill area control flag 259 : PARAMETER (PPLINE = 0 ) 260 : PARAMETER (PFILLA = 1 ) 261 : PARAMETER (PFILAS = 2 ) 262 : C presence of invalid values 263 : PARAMETER (PABSNT = 0 ) 264 : PARAMETER (PPRSNT = 1 ) 265 : C reference handling flag 266 : PARAMETER (PDELE = 0 ) 267 : PARAMETER (PKEEP = 1 ) 268 : C regeneration flag 269 : PARAMETER (PPOSTP = 0 ) 270 : PARAMETER (PPERFO = 1 ) 271 : C / relative input priority 272 : PARAMETER (PHIGHR = 0 ) 273 : PARAMETER (PLOWER = 1 ) 274 : C search direction 275 : PARAMETER (PBWD = 0 ) 276 : PARAMETER (PFWD = 1 ) 277 : C search success indicator 278 : PARAMETER (PFAIL = 0 ) 279 : PARAMETER (PSUCC = 1 ) 280 : C state of visual representation 281 : PARAMETER (PVROK = 0 ) 282 : PARAMETER (PVRDFR = 1 ) 283 : PARAMETER (PVRSIM = 2 ) 284 : C structure network source 285 : PARAMETER (PCSS = 0 ) 286 : PARAMETER (PARCHV = 1 ) 287 : C structure state value 288 : PARAMETER (PSTCL = 0 ) 289 : PARAMETER (PSTOP = 1 ) 290 : C structure status indicator 291 : PARAMETER (PSNOEX = 0 ) 292 : PARAMETER (PSEMPT = 1 ) 293 : PARAMETER (PSNEMP = 2 ) 294 : C system state value 295 : PARAMETER (PPHCL = 0 ) 296 : PARAMETER (PPHOP = 1 ) 297 : C text alignment horizontal 298 : PARAMETER (PAHNOR = 0 ) 299 : PARAMETER (PALEFT = 1 ) 300 : PARAMETER (PACENT = 2 ) 301 : PARAMETER (PARITE = 3 ) 302 : C text alignment vartical 303 : PARAMETER (PAVNOR = 0 ) 304 : PARAMETER (PATOP = 1 ) 305 : PARAMETER (PACAP = 2 ) 306 : PARAMETER (PAHALF = 3 ) 307 : PARAMETER (PABASE = 4 ) 308 : PARAMETER (PABOTT = 5 ) 309 : C text path 310 : PARAMETER (PRIGHT = 0 ) 311 : PARAMETER (PLEFT = 1 ) 312 : PARAMETER (PUP = 2 ) 313 : PARAMETER (PDOWN = 3 ) 314 : C text precision 315 : PARAMETER (PSTRP = 0 ) 316 : PARAMETER (PCHARP = 1 ) 317 : PARAMETER (PSTRKP = 2 ) 318 : C type of returned values 319 : PARAMETER (PSET = 0 ) 320 : PARAMETER (PREALI = 1 ) 321 : C update state 322 : PARAMETER (PNPEND = 0 ) 323 : PARAMETER (PPEND = 1 ) 324 : C vector/raster/other type 325 : PARAMETER (PVECTR = 0 ) 326 : PARAMETER (PRASTR = 1 ) 327 : PARAMETER (POTHWK = 2 ) 328 : C viewtype 329 : PARAMETER (PPARL = 0 ) 330 : PARAMETER (PPERS = 1 ) 331 : C workstation category 332 : PARAMETER (POUTPT = 0 ) 333 : PARAMETER (PINPUT = 1 ) 334 : PARAMETER (POUTIN = 2 ) 335 : PARAMETER (PMO = 3 ) 336 : PARAMETER (PMI = 4 ) 337 : C workstation dependence indicator 338 : PARAMETER (PWKI = 0 ) 339 : PARAMETER (PWKD = 1 ) 340 : C workstation state value 341 : PARAMETER (PWSCL = 0 ) 342 : PARAMETER (PWSOP = 1 ) 343 : C current(and requested values 344 : PARAMETER (PCURVL = 0 ) 345 : PARAMETER (PRQSVL = 1 ) 346 : C error handling 347 : PARAMETER (EOPPH = 0 ) 348 : PARAMETER (ECLPH = 1 ) 349 : PARAMETER (EOPWK = 2 ) 350 : PARAMETER (ECLWK = 3 ) 351 : PARAMETER (ERST = 4 ) 352 : PARAMETER (EUWK = 5 ) 353 : PARAMETER (ESDUS = 6 ) 354 : PARAMETER (EMSG = 7 ) 355 : PARAMETER (EPL3 = 8 ) 356 : PARAMETER (EPL = 9 ) 357 : PARAMETER (EPM3 = 10 ) 358 : PARAMETER (EPM = 11 ) 359 : PARAMETER (ETX3 = 12 ) 360 : PARAMETER (ETX = 13 ) 361 : PARAMETER (EATR3 = 14 ) 362 : PARAMETER (EATR = 15 ) 363 : PARAMETER (EFA3 = 16 ) 364 : PARAMETER (EFA = 17 ) 365 : PARAMETER (EFAS3 = 18 ) 366 : PARAMETER (EFAS = 19 ) 367 : PARAMETER (ECA3 = 20 ) 368 : PARAMETER (ECA = 21 ) 369 : PARAMETER (EGDP3 = 22 ) 370 : PARAMETER (EGDP = 23 ) 371 : PARAMETER (ESPLI = 24 ) 372 : PARAMETER (ESPMI = 25 ) 373 : PARAMETER (ESTXI = 26 ) 374 : PARAMETER (ESII = 27 ) 375 : PARAMETER (ESEDI = 28 ) 376 : PARAMETER (ESLN = 29 ) 377 : PARAMETER (ESLWSC = 30 ) 378 : PARAMETER (ESPLCI = 31 ) 379 : PARAMETER (ESMK = 32 ) 380 : PARAMETER (ESMKSC = 33 ) 381 : PARAMETER (ESPMCI = 34 ) 382 : PARAMETER (ESTXFN = 35 ) 383 : PARAMETER (ESTXPR = 36 ) 384 : PARAMETER (ESCHXP = 37 ) 385 : PARAMETER (ESCHSP = 38 ) 386 : PARAMETER (ESTXCI = 39 ) 387 : PARAMETER (ESCHH = 40 ) 388 : PARAMETER (ESCHUP = 41 ) 389 : PARAMETER (ESTXP = 42 ) 390 : PARAMETER (ESTXAL = 43 ) 391 : PARAMETER (ESATCH = 44 ) 392 : PARAMETER (ESATCU = 45 ) 393 : PARAMETER (ESATP = 46 ) 394 : PARAMETER (ESATAL = 47 ) 395 : PARAMETER (ESANS = 48 ) 396 : PARAMETER (ESIS = 49 ) 397 : PARAMETER (ESISI = 50 ) 398 : PARAMETER (ESICI = 51 ) 399 : PARAMETER (ESEDFG = 52 ) 400 : PARAMETER (ESEDT = 53 ) 401 : PARAMETER (ESEWSC = 54 ) 402 : PARAMETER (ESEDCI = 55 ) 403 : PARAMETER (ESPA = 56 ) 404 : PARAMETER (ESPRPV = 57 ) 405 : PARAMETER (ESPARF = 58 ) 406 : PARAMETER (EADS = 59 ) 407 : PARAMETER (ERES = 60 ) 408 : PARAMETER (ESIASF = 61 ) 409 : PARAMETER (ESPLR = 62 ) 410 : PARAMETER (ESPMR = 63 ) 411 : PARAMETER (ESTXR = 64 ) 412 : PARAMETER (ESIR = 65 ) 413 : PARAMETER (ESEDR = 66 ) 414 : PARAMETER (ESPAR = 67 ) 415 : PARAMETER (ESCR = 68 ) 416 : PARAMETER (ESHLFT = 69 ) 417 : PARAMETER (ESIVFT = 70 ) 418 : PARAMETER (ESCMD = 71 ) 419 : PARAMETER (ESHRID = 72 ) 420 : PARAMETER (ESHRM = 73 ) 421 : PARAMETER (ESLMT3 = 74 ) 422 : PARAMETER (ESLMT = 75 ) 423 : PARAMETER (ESGMT3 = 76 ) 424 : PARAMETER (ESGMT = 77 ) 425 : PARAMETER (ESMCV3 = 78 ) 426 : PARAMETER (ESMCV = 79 ) 427 : PARAMETER (ESMCLI = 80 ) 428 : PARAMETER (ERMCV = 81 ) 429 : PARAMETER (ESVWI = 82 ) 430 : PARAMETER (ESVWR3 = 83 ) 431 : PARAMETER (ESVWR = 84 ) 432 : PARAMETER (ESVTIP = 85 ) 433 : PARAMETER (ESWKW3 = 86 ) 434 : PARAMETER (ESWKW = 87 ) 435 : PARAMETER (ESWKV3 = 88 ) 436 : PARAMETER (ESWKV = 89 ) 437 : PARAMETER (EOPST = 90 ) 438 : PARAMETER (ECLST = 91 ) 439 : PARAMETER (EEXST = 92 ) 440 : PARAMETER (ELB = 93 ) 441 : PARAMETER (EAP = 94 ) 442 : PARAMETER (EGSE = 95 ) 443 : PARAMETER (ESEDM = 96 ) 444 : PARAMETER (ECELST = 97 ) 445 : PARAMETER (ESEP = 98 ) 446 : PARAMETER (EOSEP = 99 ) 447 : PARAMETER (ESEPLB = 100) 448 : PARAMETER (EDEL = 101) 449 : PARAMETER (EDELRA = 102) 450 : PARAMETER (EDELLB = 103) 451 : PARAMETER (EEMST = 104) 452 : PARAMETER (EDST = 105) 453 : PARAMETER (EDSN = 106) 454 : PARAMETER (EDSA = 107) 455 : PARAMETER (ECSTID = 108) 456 : PARAMETER (ECSTRF = 109) 457 : PARAMETER (ECSTIR = 110) 458 : PARAMETER (EPOST = 111) 459 : PARAMETER (EUPOST = 112) 460 : PARAMETER (EUPAST = 113) 461 : PARAMETER (EOPARF = 114) 462 : PARAMETER (ECLARF = 115) 463 : PARAMETER (EARST = 116) 464 : PARAMETER (EARSN = 117) 465 : PARAMETER (EARAST = 118) 466 : PARAMETER (ESCNRS = 119) 467 : PARAMETER (ERSID = 120) 468 : PARAMETER (EREST = 121) 469 : PARAMETER (ERESN = 122) 470 : PARAMETER (ERAST = 123) 471 : PARAMETER (EREPAN = 124) 472 : PARAMETER (EREPED = 125) 473 : PARAMETER (EDSTAR = 126) 474 : PARAMETER (EDSNAR = 127) 475 : PARAMETER (EDASAR = 128) 476 : PARAMETER (ESPKID = 129) 477 : PARAMETER (ESPKFT = 130) 478 : PARAMETER (EINLC3 = 131) 479 : PARAMETER (EINLC = 132) 480 : PARAMETER (EINSK3 = 133) 481 : PARAMETER (EINSK = 134) 482 : PARAMETER (EINVL3 = 135) 483 : PARAMETER (EINVL = 136) 484 : PARAMETER (EINCH3 = 137) 485 : PARAMETER (EINCH = 138) 486 : PARAMETER (EINPK3 = 139) 487 : PARAMETER (EINPK = 140) 488 : PARAMETER (EINST3 = 141) 489 : PARAMETER (EINST = 142) 490 : PARAMETER (ESLCM = 143) 491 : PARAMETER (ESSKM = 144) 492 : PARAMETER (ESVLM = 145) 493 : PARAMETER (ESCHM = 146) 494 : PARAMETER (ESPKM = 147) 495 : PARAMETER (ESSTM = 148) 496 : PARAMETER (ERQLC3 = 149) 497 : PARAMETER (ERQLC = 150) 498 : PARAMETER (ERQSK3 = 151) 499 : PARAMETER (ERQSK = 152) 500 : PARAMETER (ERQVL = 153) 501 : PARAMETER (ERQCH = 154) 502 : PARAMETER (ERQPK = 155) 503 : PARAMETER (ERQST = 156) 504 : PARAMETER (ESMLC3 = 157) 505 : PARAMETER (ESMLC = 158) 506 : PARAMETER (ESMSK3 = 159) 507 : PARAMETER (ESMSK = 160) 508 : PARAMETER (ESMVL = 161) 509 : PARAMETER (ESMCH = 162) 510 : PARAMETER (ESMPK = 163) 511 : PARAMETER (ESMST = 164) 512 : PARAMETER (EWAIT = 165) 513 : PARAMETER (EFLUSH = 166) 514 : PARAMETER (EGTLC3 = 167) 515 : PARAMETER (EGTLC = 168) 516 : PARAMETER (EGTSK3 = 169) 517 : PARAMETER (EGTSK = 170) 518 : PARAMETER (EGTVL = 171) 519 : PARAMETER (EGTCH = 172) 520 : PARAMETER (EGTPK = 173) 521 : PARAMETER (EGTST = 174) 522 : PARAMETER (EWITM = 175) 523 : PARAMETER (EGTITM = 176) 524 : PARAMETER (ERDITM = 177) 525 : PARAMETER (EIITM = 178) 526 : PARAMETER (ESERHM = 179) 527 : PARAMETER (EESC = 180) 528 : PARAMETER (EPREC = 181) 529 : PARAMETER (EUREC = 182) 530 : C error handling PHIGS+ 531 : PARAMETER (EPLSD3 = 301) 532 : PARAMETER (EFASD3 = 302) 533 : PARAMETER (ECAP3 = 303) 534 : PARAMETER (ESOFA3 = 304) 535 : PARAMETER (ETSD3 = 305) 536 : PARAMETER (EQMD3 = 306) 537 : PARAMETER (ENUBSC = 307) 538 : PARAMETER (ENUBSS = 308) 539 : PARAMETER (ESBII = 309) 540 : PARAMETER (ESPLC = 310) 541 : PARAMETER (ESPLSM = 311) 542 : PARAMETER (ESPMC = 312) 543 : PARAMETER (ESTXC = 313) 544 : PARAMETER (ESFDM = 314) 545 : PARAMETER (ESFCM = 315) 546 : PARAMETER (ESIC = 316) 547 : PARAMETER (ESISM = 317) 548 : PARAMETER (ESRFP = 318) 549 : PARAMETER (ESRFE = 319) 550 : PARAMETER (ESBIS = 320) 551 : PARAMETER (ESBISI = 321) 552 : PARAMETER (ESBIC = 322) 553 : PARAMETER (ESBISM = 323) 554 : PARAMETER (ESBRFP = 324) 555 : PARAMETER (ESBRFE = 325) 556 : PARAMETER (ESLSS = 326) 557 : PARAMETER (ESEDC = 327) 558 : PARAMETER (ESCAC = 328) 559 : PARAMETER (ESSAC = 329) 560 : PARAMETER (ESPCH = 330) 561 : PARAMETER (ESRCM = 331) 562 : PARAMETER (ESDCI = 332) 563 : PARAMETER (ESCMI = 333) 564 : PARAMETER (ESPLRP = 334) 565 : PARAMETER (ESPMRP = 335) 566 : PARAMETER (ESTXRP = 336) 567 : PARAMETER (ESIRP = 337) 568 : PARAMETER (ESEDRP = 338) 569 : PARAMETER (ESPARP = 339) 570 : PARAMETER (ESLSR = 340) 571 : PARAMETER (ESDCR = 341) 572 : PARAMETER (ESCMR = 342) 573 : C error handling PEX 574 : PARAMETER (EWTCRE = -1 ) 575 : PARAMETER (EWTSET = -2 ) 576 : PARAMETER (EWTGET = -3 ) 577 : PARAMETER (EWTDES = -4 ) 578 : PARAMETER (EOPPEX = -5 ) 579 : C culling mode 580 : PARAMETER (PNCUL = 0 ) 581 : PARAMETER (PBFAC = 1 ) 582 : PARAMETER (PFFAC = 2 ) 583 : C disting mode 584 : PARAMETER (PDSNO = 0 ) 585 : PARAMETER (PDSYES = 1 ) 586 : C depth cue mode 587 : PARAMETER (PSUPPR = 0 ) 588 : PARAMETER (PALLOW = 1 ) 589 : C facet flag 590 : PARAMETER (PNOF = 0 ) 591 : PARAMETER (PFCOLR = 1 ) 592 : PARAMETER (PFNORM = 2 ) 593 : PARAMETER (PFCONO = 3 ) 594 : C rationality 595 : PARAMETER (PRATIO = 0 ) 596 : PARAMETER (PNONRA = 1 ) 597 : C vertex flag 598 : PARAMETER (PCOORD = 0 ) 599 : PARAMETER (PCCOLR = 1 ) 600 : PARAMETER (PCNORM = 2 ) 601 : PARAMETER (PCCONO = 3 ) 602 : C edge flag 603 : PARAMETER (PNOE = 0 ) 604 : PARAMETER (PEVIS = 1 ) 605 : C HLHSR identifier 606 : PARAMETER (PHIOFF = 0 ) 607 : PARAMETER (PHION = 1 ) 608 : C HLHSR mode 609 : PARAMETER (PHMNON = 0 ) 610 : PARAMETER (PHMZBF = 1 ) 611 : C ESCAPE error synchronization mode 612 : PARAMETER (PESOFF = 0 ) 613 : PARAMETER (PESON = 1 ) 614 : C ESCAPE local input transformation type 615 : PARAMETER (PLCMOD = 0 ) 616 : PARAMETER (PLCVIW = 1 ) 617 : C ESCAPE local input transformation matrix create type 618 : PARAMETER (PLCACC = 0 ) 619 : PARAMETER (PLCGEN = 1 ) 620 : C ESCAPE local input conflation type 621 : PARAMETER (PLCABU = 0 ) 622 : PARAMETER (PLCPRC = 1 ) 623 : PARAMETER (PLCPRU = 2 ) 624 : C ESCAPE local input local input rotate axis 625 : PARAMETER (PLCFIR = 0 ) 626 : PARAMETER (PLCSEC = 1 ) 627 : PARAMETER (PLCTHI = 2 ) 628 : C ESCAPE view transformation effect mode 629 : PARAMETER (PNPC = 0 ) 630 : PARAMETER (PVPC = 1 ) 631 : C ESCAPE input value reference mode 632 : PARAMETER (PINVAL = 0 ) 633 : C PARAMETER (PVAL = 1 ) En conflit avec l'entry PV 634 : C GDP arc close type 635 : PARAMETER (PACFAN = 0 ) 636 : PARAMETER (PACCHD = 1 ) 637 : C GSE side point attribute 638 : PARAMETER (PSPCIR = 0 ) 639 : PARAMETER (PSPSQU = 1 ) 640 : PARAMETER (PSPFLA = 2 ) 641 : C PHIGS moniter ON/OFF flag 642 : PARAMETER (PMON = 0 ) 643 : PARAMETER (PNOMON = 1 ) 644 : C clients side CSS flag 645 : PARAMETER (PSERVR = 0 ) 646 : PARAMETER (PCLIET = 1 ) 647 : C buffer mode 648 : PARAMETER (PSINGL = 0 ) 649 : PARAMETER (PDOUBL = 1 ) 650 : ***** fin de declaration pour PHIGS 651 : ***** 652 : ***** 653 : SAVE IWKIDLI,KMETA,WKTY 654 : SAVE ICCOL,ICOISI,WKID,X1,X2,Y1,Y2,WRATIO,INUSEG 655 : SAVE XINID,YINID,SXMIN,SXXAX,SYMIN,SYYAX,RX,RY,AX,AY 656 : SAVE TEXTX,TEXTY,INCOOR,TEXTE,ICCLE,IACT,IWISS,VALEUR 657 : SAVE NHAUT,HAUT 658 : SAVE IPF 659 : SAVE IPPP,INMP,IDEFOR,IFF 660 : DIMENSION IPF(24) 661 : C 662 : C declaration des variables utilisees par la partie PHIGS 663 : C ------------------------------------------------------- 664 : SAVE PGSVWI,PGIVNB,PGIVIN,PGHPNB,PGHPIN,PGFLAG,PGFLZO 665 : SAVE PGX1,PGX2,PGY1,PGY2 666 : SAVE PGRX,PGRY 667 : save tool1 668 : C..... sert dans trtext a ne definir qu'une fois la vue 4 669 : SAVE IFV 670 : integer tool1 671 : REAL PGRX,PGRY,PGRAP 672 : REAL PGX1,PGX2,PGY1,PGY2 673 : INTEGER PGSVWI,PGIVNB,PGHPNB,PGTYPE 674 : INTEGER PGIVEX(1),PGHPEX(1),PGIVIN(4096),PGHPIN(4096),LIST(4096) 675 : INTEGER PGFLAG,PGFLZO 676 : INTEGER PGDEPT,PGPATH(3,2) 677 : REAL VWWNLM(4),PJVPLM(4) 678 : REAL VXMIN,VXMAX 679 : SAVE VXMIN,VXMAX 680 : INTEGER IERR,XYCLIPI,ISEG 681 : REAL VWMPMT(3,3),VWORMT(3,3) 682 : C---> tableaux de correspondance des couleurs 683 : C 684 : C fin modif 685 : C----------------------------------------------------------------------- 686 : 687 : CHARACTER*(*) TITRE 688 : DIMENSION XTR(*),YTR(*),ZTR(*) 689 : DIMENSION RMAT(9) 690 : DIMENSION IBOIF(8) 691 : CHARACTER*5 NBOIF(8) 692 : CHARACTER*8 NAME 693 : CHARACTER*(*) CARACT 694 : CHARACTER*(*) LEGEND(*) 695 : LOGICAL VALEUR,FENET,VALEU 696 : CHARACTER*20 STRING 697 : DIMENSION PXA(4),PYA(4) 698 : DIMENSION TEXTX(50),TEXTY(50) 699 : CHARACTER*1 CARELE(10) 700 : CHARACTER*6 STR 701 : CHARACTER*4 STR1 702 : CHARACTER*15 TEXTE(50) 703 : INTEGER WKID,WKCON,WKTY 704 : INTEGER STAT 705 : DATA ICCOUN/0/ 706 : DATA CARELE /'0','1','2','3','4','5','6','7','8','9'/ 707 : DATA STR1 /'META'/ 708 : DATA WKID/3/ 709 : DATA ICCOL/7/ 710 : DATA IACT/0/ 711 : DATA IWISS/0/ 712 : C----------------------------------------------------------------------- 713 : C data utilisees par la partie PHIGS 714 : C 715 : DATA PGSVWI/0/ 716 : DATA PGIVNB/0/ 717 : DATA PGHPNB/0/ 718 : DATA PGFLAG/0/ 719 : DATA PGFLZO/0/ 720 : C indices de couleurs 721 : C 722 : C pour le 2 menu :pave correspondant aux isovaleurs 723 : DATA NBOIF/'ZOOM ','INI ','VAL ','ANIM ','IMPR ',' ', 724 : & ' ','FIN '/ 725 : DATA IBOIF/10,13,15,11,12,0,0,17/ 726 : C----------------------------------------------------------------------- 727 : NCOUMA=16 728 : HAUT=HAUTT 729 : NHAUT=31 730 : VALEUR=VALEU 731 : KSEGN=0 732 : AX=AXAX 733 : AY=AYAY 734 : C DO 1 NBCR=72,2,-1 735 : DO1NBCR=72,2,-1 736 : IF (TITRE(NBCR:NBCR).NE.' ') GOTO 2 737 : 1 CONTINUE 738 : 2 CONTINUE 739 : C 740 : C PTRINIT1 741 : C debut du bloc phigs de TRINIT 742 : C 743 : 60 CONTINUE 744 : C --------------------------------------------------------------- 745 : C : menu fen princ legendes texte : 746 : C : numeros de vues 1 2 3 4 : 747 : C --------------------------------------------------------------- 748 : 749 : C iff sert a gerer l'effac. des stuct.ass. a du texte 750 : IFF=0 751 : IFV=0 752 : * je ne sais pas a quoi ca sert 753 : IPPP=0 754 : INMP=0 755 : IDEFOR=0 756 : IFF=0 757 : C indicateur de zoom 758 : PGFLZO=0 759 : 760 : C numero de vue 761 : PGSVWI=0 762 : 763 : C indicateur d'impresssion pour les fichiers trace 764 : C (mettre inmp=1 si aucun fichier trace n'est desire) 765 : ippp=0 766 : inmp=0 767 : C 768 : X1=0. 769 : X2=0. 770 : Y1=0. 771 : Y2=0. 772 : INCOOR=0 773 : C numeros de structures associes au texte (vue 4) 774 : INUSEG=50+(100*(WKID-1)) 775 : IXSEG=0 776 : ICCLE=0 777 : IF(IACT.EQ.1) THEN 778 : C permet de savoir si une structure est ouverte 778 : CALL PQOPST(IIERR,PGTYPE,INUM) 779 : C si oui elle est fermee 779 : IF(PGTYPE.EQ.POPNST) CALL PCLST 780 : NWAC=0 781 : C permet de savoir si Work station est ouverte 782 : C Dans FIGARO il ne peut y avoir qu'une seule Work station 783 : C d'ouverte a la fois 783 : 62 CALL PQOPWK(NWAC,IERR,NTWAC,NWID) 784 : IF(NWID.EQ.WKID)GOTO 61 785 : IF(NWAC.EQ.NTWAC)GOTO 63 786 : NWAC=NWAC+1 787 : GOTO 62 788 : 61 CONTINUE 789 : C si oui les structures associes sont depostees 789 : CALL PUPAST(WKID) 790 : GOTO 65 791 : 63 CONTINUE 792 : GOTO 64 793 : ENDIF 794 : C si phigs n'a pas ete ouvert il est ouvert ici 795 : IF (PGFLAG.EQ.0) THEN 795 : CALL POPPH(6,0) 796 : C on definit les parametres de la fenetre graphique 796 : * CALL PHIGSWSTCREATE(phigswsttool, tool1) 796 : * CALL PHIGSWSTSET(tool1, PHIGSTOOLFGDCLR,120,120,120) 796 : * CALL PHIGSWSTSET(tool1, PHIGSTOOLLABEL,"Graphique CASTEM2000") 796 : * CALL PHIGSWSTSET(tool1, PHIGSTOOLWIDTH, 600) 796 : * CALL PHIGSWSTSET(tool1, PHIGSTOOLHEIGHT, 600) 796 : * CALL PHIGSWSTSET(tool1, PHIGSTOOLX, 542) 796 : * CALL PHIGSWSTSET(tool1, PHIGSTOOLY, 277) 797 : PGFLAG = 1 798 : ENDIF 799 : 800 : 64 CONTINUE 801 : WKCON=0 802 : C ouverture de la Work station WKID 802 : C***** CALL POPWK(WKID,WKCON,phigswsttool) 803 : tool1=0 803 : CALL POPWK(WKID,WKCON,tool1) 803 : CALL PSDUS(WKID,4,0) 804 : 65 CONTINUE 805 : C WKCON=0 806 : IWKIDLI=3 807 : KMETA=1 808 : WKTY=0 809 : IACT=1 810 : * creation de la structure initiale : 1 PV 810 : CALL POPST(1) 810 : CALL PEMST(1) 811 : ISGNEW=9+(100*(WKID-1)) 811 : CALL PEXST(ISGNEW) 811 : CALL PEXST(3) 812 : ISEG=6+(100*(WKID-1)) 812 : CALL PEXST(ISEG) 812 : CALL PCLST 812 : CALL POPST(ISGNEW) 812 : CALL PEMST(ISGNEW) 812 : CALL PCLST 812 : CALL POPST(3) 812 : CALL PEMST(3) 812 : CALL PADS(1,3) 812 : CALL PSVWI(PGSVWI) 812 : CALL PCLST 812 : CALL PPOST(WKID,1,1.) 813 : C ouverture de la structure ISEG 813 : CALL POPST(ISEG) 814 : C la structure ISEG est videe 814 : CALL PEMST(ISEG) 815 : C la structure ISEG est postee sur la Work station WKID 815 : C CALL PPOST(WKID,ISEG,1.) 816 : C name set utilse par les filtres d'invisibilite et de detectabili 816 : CALL PADS(1,ISEG) 817 : C la structure ISEG est associee a la vue PGSVWI 817 : CALL PSVWI(PGSVWI) 818 : C mise a jour des filtres d'invisiblite 818 : CALL PSVIS(PGIVNB,PGIVIN,ISEG,0) 818 : CALL PSVIS(PGHPNB,PGHPIN,ISEG,0) 818 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 818 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 819 : C redefinition des couleurs 820 : * XAllocNamedColor(dp,colors,"white",&xcsd[0],&xced); 821 : * XAllocNamedColor(dp,colors,"blue",&xcsd[1],&xced); 822 : * XAllocNamedColor(dp,colors,"red",&xcsd[2],&xced); 823 : * XAllocNamedColor(dp,colors,"magenta",&xcsd[3],&xced); 824 : * XAllocNamedColor(dp,colors,"green",&xcsd[4],&xced); 825 : * XAllocNamedColor(dp,colors,"MediumTurquoise",&xcsd[5],&xced); 826 : * XAllocNamedColor(dp,colors,"yellow",&xcsd[6],&xced); 827 : * XAllocNamedColor(dp,colors,"white",&xcsd[7],&xced); 828 : * XAllocNamedColor(dp,colors,"black",&xcsd[8],&xced); 829 : * XAllocNamedColor(dp,colors,"DarkSlateBlue",&xcsd[9],&xced); 830 : * XAllocNamedColor(dp,colors,"orange",&xcsd[10],&xced); 831 : * XAllocNamedColor(dp,colors,"VioletRed",&xcsd[11],&xced); 832 : * XAllocNamedColor(dp,colors,"MediumSeaGreen",&xcsd[12],&xced); 833 : * XAllocNamedColor(dp,colors,"DarkTurquoise",&xcsd[13],&xced); 834 : * XAllocNamedColor(dp,colors,"YellowGreen",&xcsd[14],&xced); 835 : * XAllocNamedColor(dp,colors,"LightGrey",&xcsd[15],&xced); 835 : CALL PSCR(WKID,0,3,0.0,0.0,0.0) 835 : CALL PSCR(WKID,1,3,0.0,0.0,1.0) 835 : CALL PSCR(WKID,2,3,1.0,0.0,0.0) 835 : CALL PSCR(WKID,3,3,1.0,0.0,1.0) 835 : CALL PSCR(WKID,4,3,0.0,1.0,0.0) 835 : CALL PSCR(WKID,5,3,72/255.,209/255.,204/255.) 835 : CALL PSCR(WKID,6,3,1.0,1.0,0.0) 835 : CALL PSCR(WKID,7,3,1.0,1.0,1.0) 835 : CALL PSCR(WKID,8,3,0.0,0.0,0.0) 835 : CALL PSCR(WKID,9,3,112/255.,101/255.,179/255.) 835 : CALL PSCR(WKID,10,3,255/255.,165/255.,0.0) 835 : CALL PSCR(WKID,11,3,208/255.,32/255.,144/255.) 835 : CALL PSCR(WKID,12,3,60/255.,179/255.,113/255.) 835 : CALL PSCR(WKID,13,3,0.0,206/255.,209/255.) 835 : CALL PSCR(WKID,14,3,154/255.,205/255.,50/255.) 835 : CALL PSCR(WKID,15,3,211/255.,211/255.,211/255.) 836 : C 837 : C permet de connaitre les dimensions de la fenetre SunPHIGS 837 : C**** CALL PQDSP(phigswsttool,IERR,DC,RX,RY,LX,LY) 837 : CALL PQDSP(tool1,IERR,DC,RX,RY,LX,LY) 838 : WRATIO=RY/RX 839 : R=RY 840 : IF(WRATIO.GT.1)THEN 841 : R=RX 842 : WRATIO=1./WRATIO 843 : ENDIF 844 : C definition de la window et de la viewport en fonction du ratio 844 : CALL PSWKW(WKID,0.,1.,0.,1.) 845 : IF (RX.LE.RY) THEN 846 : VXMIN = 0. 847 : VXMAX = RX 847 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 848 : ELSE 849 : VXMIN = 0. 850 : VXMAX = RY 850 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 851 : ENDIF 852 : WRATIO=1. 852 : C CALL OSVMP(WKID,1,0.,80.,0.,2.,0.,1.,0.,(WRATIO)*0.1) 853 : VWWNLM(1) = 0. 854 : VWWNLM(2) = 80. 855 : VWWNLM(3) = 0. 856 : VWWNLM(4) = 2. 857 : PJVPLM(1) = 0. 858 : PJVPLM(2) = 1. 859 : PJVPLM(3) = 0. 860 : PJVPLM(4) = (WRATIO)*0.1 860 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 861 : VWORMT(1,1) = 1. 862 : VWORMT(2,2) = 1. 863 : VWORMT(3,3) = 1. 864 : VWORMT(1,2) = 0. 865 : VWORMT(1,3) = 0. 866 : VWORMT(2,1) = 0. 867 : VWORMT(2,3) = 0. 868 : VWORMT(3,1) = 0. 869 : VWORMT(3,2) = 0. 870 : XYCLIPI = 1 870 : CALL PSVWR(WKID,1,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 871 : PGSVWI=1 872 : C si une structure est ouverte ,elle est associe a la vue 1 872 : CALL PQOPST(IIERR,PGTYPE,INUM) 872 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 873 : C declaration de la taille du text annote 873 : C* CALL PSATCH(0.02) 873 : CALL PSATCH(0.015) 874 : C definition de la couleur du text 874 : CALL PSTXCI(7) 875 : C choix de la police de caracteres 875 : C CALL PSTXFN(-1) 875 : CALL PSTXFN(-5) 875 : C CALL PSHSP(0.2) 876 : C definition de la precision du text 876 : CALL PSTXPR(2) 877 : C ecriture du text annote 877 : CALL PATR(63.,1.3,0.,0.,'CASTEM 2000') 877 : CALL PATR(.6,1.3,0.,0.,TITRE) 877 : CALL PCLST 877 : C CALL PUWK(WKID,1) 878 : RETURN 879 : C*********************************************************************** 880 : 881 : C 882 : C subroutine DFENET 883 : C 884 : ENTRY PDFENE(XMIN,XXAX,YMIN,YYAX,XR1,XR2,YR1,YR2,FENET) 885 : EC1=AX-3. 886 : EC2=AY-3. 887 : C 888 : C PDFENET 2 889 : C debut du bloc phigs de DFENET 890 : C 891 : 160 CONTINUE 892 : C calcule de la fenetre de la vue 2 893 : SXMIN=XMIN 894 : SXXAX=XXAX 895 : SYMIN=YMIN 896 : SYYAX=YYAX 897 : C on se laisse une marge pour le text 898 : XDIFF=(XXAX-XMIN)/2.*1.10 899 : YDIFF=(YYAX-YMIN)/2.*1.10 900 : XMILL=(XXAX+XMIN)/2. 901 : YMILL=(YYAX+YMIN)/2. 902 : IF (FENET) THEN 903 : RAP=(XDIFF/YDIFF) 904 : ELSE 905 : RAP=1. 906 : ENDIF 907 : IF (RAP.GE.1) THEN 908 : X1=XMILL-XDIFF 909 : X2=XMILL+XDIFF 910 : Y1=YMILL-(YDIFF*RAP) 911 : Y2=YMILL+(YDIFF*RAP) 912 : ELSE 913 : X1=XMILL-(XDIFF/RAP) 914 : X2=XMILL+(XDIFF/RAP) 915 : Y1=YMILL-YDIFF 916 : Y2=YMILL+YDIFF 917 : ENDIF 918 : C sauvegarde des valeurs de la fenetre pour le retour a la vue 919 : C initiale 920 : PGX1=X1 921 : PGX2=X2 922 : PGY1=Y1 923 : PGY2=Y2 924 : C (pour pouvoir faire un req loc) 924 : C CALL PSVWCS(WKID,2,1,1,1,0,0) 924 : CALL PSVTIP(WKID,2,0,0) 925 : 925 : C**** CALL PQDSP(phigswsttool,IERR,DC,PGRX,PGRY,LX,LY) 925 : CALL PQDSP(tool1,IERR,DC,PGRX,PGRY,LX,LY) 926 : PGRAP=MIN (PGRX/RX,PGRY/RY) 927 : IF (PGRX .LE. PGRY) THEN 928 : VXMIN = .5*(PGRX-PGRAP*RX) 929 : VXMAX = .5*(PGRX+PGRAP*RX) 929 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 930 : ELSE 931 : VXMIN = .5*(PGRX-PGRAP*RY) 932 : VXMAX = .5*(PGRX+PGRAP*RY) 932 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 933 : ENDIF 934 : 935 : VWWNLM(1) = X1 936 : VWWNLM(2) = X2 937 : VWWNLM(3) = Y1 938 : VWWNLM(4) = Y2 939 : VWORMT(1,1) = 1. 940 : VWORMT(2,2) = 1. 941 : VWORMT(3,3) = 1. 942 : VWORMT(1,2) = 0. 943 : VWORMT(1,3) = 0. 944 : VWORMT(2,1) = 0. 945 : VWORMT(2,3) = 0. 946 : VWORMT(3,1) = 0. 947 : VWORMT(3,2) = 0. 948 : XYCLIPI = 1 949 : PJVPLM(1) = 0. 950 : PJVPLM(3) = (WRATIO)*0.1 951 : IF(VALEUR) THEN 951 : C CALL OSVMP(WKID,2,X1,X2,Y1,Y2,0.,0.8,(WRATIO)*0.1,(WRATIO)*0.9) 952 : PJVPLM(2) = 0.8 953 : 954 : PJVPLM(4) = (WRATIO)*0.9 955 : 955 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 955 : CALL PSVWR(WKID,2,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 956 : ELSE 956 : C CALL OSVMP(WKID,2,X1,X2,Y1,Y2,0.,0.9,(WRATIO)*0.1,(WRATIO)) 957 : PJVPLM(2) = 0.9 958 : 959 : PJVPLM(4) = WRATIO 960 : 960 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 960 : CALL PSVWR(WKID,2,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 961 : ENDIF 962 : 963 : PGSVWI=2 964 : C si une structure est ouverte ,elle est associe a la vue 2 964 : CALL PQOPST(IIERR,PGTYPE,INUM) 964 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 965 : XINID=(X1+X2)/2. 966 : YINID=(Y1+Y2)/2. 967 : XR1=XMIN 968 : XR2=XXAX 969 : YR1=YMIN 970 : YR2=YYAX 971 : C fermeture eventuelle d'une structure ouverte ,elle est aussi vid 971 : CALL PQOPST(IIERRI,PGTYPE,INUM) 972 : IF(PGTYPE.EQ.POPNST) THEN 972 : CALL PCLST 972 : CALL PEMST(INUM) 973 : ENDIF 974 : INUM=8+(100*(WKID-1)) 974 : CALL PEMST(INUM) 975 : ISEG=1+(100*(WKID-1)) 976 : C............................................ 977 : C reinitialisation du contexte 978 : C ouverture de la structure ISEG 978 : CALL POPST(1) 978 : CALL PEXST(ISEG) 978 : CALL PCLST 978 : CALL POPST(ISEG) 979 : C la structure ISEG est videe 979 : CALL PEMST(ISEG) 979 : CALL PADS(1,ISEG) 980 : C la structure ISEG est associee a la vue PGSVWI 980 : CALL PSVWI(PGSVWI) 981 : C la structure est declaree visible et detectable 981 : CALL PSVIS(PGIVNB,PGIVIN,ISEG,0) 981 : CALL PSVIS(PGHPNB,PGHPIN,ISEG,0) 981 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 981 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 982 : IXSEG=1 983 : C choix de la police de caracteres 983 : CALL PSTXFN(-4) 984 : C definition de la precision du text 984 : CALL PSTXPR(2) 985 : CHH=(Y2-Y1)/50.0 986 : C taille des caracteres par defaut ( important pour le trace de 987 : C courbes 987 : CALL PSCHSP(0.15) 988 : C declaration de la taille du text annote 988 : CALL PSATCH(0.010) 989 : CHXPO = 1. 990 : CHXP=(X2-X1)/(Y2-Y1)/RX*RY*CHXPO 991 : C definition des attributs de couleur en fonction de la couleur 992 : C courant (ICCOL) 992 : CALL PSICI(ICCOL) 992 : CALL PSPLCI(ICCOL) 992 : CALL PSPMCI(ICCOL) 992 : CALL PSTXCI(ICCOL) 993 : ICOISI=-100 994 : C...... ecriture du fichier trace 995 : IF (IPPP.EQ.1) THEN 995 : CALL PQOPST(IERR,ISTYPE,ID) 995 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 996 : ENDIF 997 : RETURN 998 : C*********************************************************************** 999 : C 1000 : C subroutine TRLABL 1001 : C 1002 : ENTRY PTRLAB(X,Y,CARACT,NCAR,HAUTT) 1003 : HAUT=HAUTT 1004 : C DO 201 ICAR=NCAR,1,-1 1005 : DO201ICAR=NCAR,1,-1 1006 : IF (CARACT(ICAR:ICAR).NE.' ') GOTO 202 1007 : 201 CONTINUE 1008 : RETURN 1009 : 202 CONTINUE 1010 : C 1011 : C PTRLABL 3 1012 : C debut du bloc phigs de TRLABL 1013 : C 1014 : 260 CONTINUE 1014 : CALL PQOPST(IERR,ISTYPE,ID) 1014 : IF (ISTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1014 : C CALL PSCHSP(0.10) 1014 : CALL PSCHSP(0.20) 1014 : CALL PSTXFN(-2) 1015 : C on retrace le texte 1015 : CALL PATR(X,Y,0.,0.,CARACT) 1016 : RETURN 1017 : C*********************************************************************** 1018 : 1019 : C 1020 : C subroutine TRBOX 1021 : C 1022 : ENTRY PTRBOX (HAUTX,HAUTY) 1023 : C 1024 : C debut du bloc phigs de TRBOX 1025 : C 1026 : 1260 CONTINUE 1026 : CCCC CALL PSTXFN(-1) 1027 : C definition de la precision du texte 1028 : 1028 : CALL PSTXPR(2) 1029 : CHH = 0.01 1030 : CHXP = 1. 1031 : RETURN 1032 : C*********************************************************************** 1033 : C 1034 : C subroutine CHCOUL 1035 : C 1036 : ENTRY PCHCOU(JCOLO) 1037 : C 1038 : C PCHCOUL 5 1039 : C debut du bloc phigs de CHCOUL 1040 : C 1041 : 345 CONTINUE 1042 : C si il n'y a pas eu de zoom 1043 : C definition des attributs de couleur en fonction de la couleur 1044 : C courante (ICCOL) 1045 : C IF (PGFLZO.EQ.0) THEN 1045 : CALL PSICI(JCOLO) 1045 : CALL PSPLCI(JCOLO) 1045 : CALL PSPMCI(JCOLO) 1045 : CALL PSTXCI(JCOLO) 1046 : C ENDIF 1047 : RETURN 1048 : C*********************************************************************** 1049 : 1050 : C 1051 : C subroutine FVALIS 1052 : C 1053 : ENTRY PFVALI(IFENI,IRESU,NH) 1054 : C 1055 : C PFVALIS 6 1056 : C debut du bloc phigs de FVALIS 1057 : C 1058 : 390 CONTINUE 1059 : IF (IPPP.EQ.1) THEN 1059 : CALL PQOPST(IERR,ISTYPE,ID) 1059 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1060 : ENDIF 1061 : C 1062 : IF (IFENI.EQ.1) THEN 1063 : WRATIO=1 1064 : IRESU=0 1065 : C........................................................ 1066 : 1067 : C.... definition de la vue numero 3 1067 : C**** CALL PQDSP(phigswsttool,IERR,DC,PGRX,PGRY,LX,LY) 1067 : CALL PQDSP(tool1,IERR,DC,PGRX,PGRY,LX,LY) 1068 : PGRAP=MIN (PGRX/RX,PGRY/RY) 1069 : IF (PGRX .LE. PGRY) THEN 1070 : VXMIN = .5*(PGRX-PGRAP*RX) 1071 : VXMAX = .5*(PGRX+PGRAP*RX) 1071 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 1072 : ELSE 1073 : VXMIN = .5*(PGRX-PGRAP*RY) 1074 : VXMAX = .5*(PGRX+PGRAP*RY) 1074 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 1075 : ENDIF 1076 : 1076 : C CALL OSVMP(WKID,3,0.,1.,2.,33.,0.81,1.,(WRATIO)*0.1,(WRATIO)*0.9) 1077 : VWWNLM(1) = 0. 1078 : VWWNLM(2) = 1. 1079 : VWWNLM(3) = 2. 1080 : VWWNLM(4) = 33. 1081 : PJVPLM(1) = 0.81 1082 : PJVPLM(2) = 1. 1083 : PJVPLM(3) = (WRATIO)*0.1 1084 : PJVPLM(4) = (WRATIO)*0.9 1084 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 1085 : VWORMT(1,1) = 1. 1086 : VWORMT(2,2) = 1. 1087 : VWORMT(3,3) = 1. 1088 : VWORMT(1,2) = 0. 1089 : VWORMT(1,3) = 0. 1090 : VWORMT(2,1) = 0. 1091 : VWORMT(2,3) = 0. 1092 : VWORMT(3,1) = 0. 1093 : VWORMT(3,2) = 0. 1094 : XYCLIPI = 1 1094 : CALL PSVWR(WKID,3,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 1095 : PGSVWI=3 1096 : C...................................................... 1097 : C si une structure est ouverte ,elle est associe a la vue 3 1097 : CALL PQOPST(IIERR,PGTYPE,INUM) 1097 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1098 : ELSE 1099 : PGSVWI=2 1100 : C si une structure est ouverte ,elle est associe a la vue 2 1100 : CALL PQOPST(IIERR,PGTYPE,INUM) 1100 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1101 : ENDIF 1102 : NH=31 1103 : IF (IPPP.EQ.1) THEN 1103 : CALL PQOPST(IERR,ISTYPE,ID) 1103 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1104 : ENDIF 1105 : RETURN 1106 : C*********************************************************************** 1107 : 1108 : C 1109 : C subroutine MENU 1110 : C 1111 : ENTRY PMENU(LEGEND,NCASE,LLONG) 1112 : C 1113 : C debut du bloc phigs de MENU 1114 : C 1115 : DO 805 II=1,24 1116 : IPF(II)=1 1117 : 805 CONTINUE 1118 : 460 CONTINUE 1119 : C remise a 0 du flag de zoom lors de la definition des menus 1120 : PGFLZO = 0 1121 : PGSVWI=1 1122 : C si une structure est ouverte ,on l'associe a la vue 1 et elle 1123 : C est fermee 1123 : CALL PQOPST(IIERR,PGTYPE,INUM) 1124 : IF (PGTYPE.EQ.POPNST) THEN 1124 : CALL PSVWI(PGSVWI) 1125 : 1125 : CALL PCLST 1126 : 1127 : ENDIF 1128 : XB=1. 1129 : NCASE1=0 1130 : DO464KBOIT=1,13 1131 : IF(KBOIT.LE.NCASE) THEN 1132 : MLONG=LONG(LEGEND(KBOIT)) 1133 : ELSE 1134 : MLONG=1 1135 : ENDIF 1136 : IF (MLONG.NE.1) NCASE1=NCASE1+1 1137 : C on efface les menus pouvant subsister ! 1138 : ISEG=KBOIT+9+(100*(WKID-1)) 1138 : CALL POPST(ISEG) 1138 : CALL PEMST(ISEG) 1138 : CALL PCLST 1139 : 464 CONTINUE 1140 : DO465KBOIT=1,13 1141 : KKIMP=0 1142 : IF(KBOIT.LE.NCASE) THEN 1143 : MLONG=LONG(LEGEND(KBOIT)) 1144 : ELSE 1145 : MLONG=1 1146 : ENDIF 1147 : IF (KBOIT.EQ.12.AND.IPF(2).NE.0.AND.MLONG.EQ.1) KKIMP=1 1148 : IF (KKIMP.EQ.1) MLONG=4 1149 : IF (MLONG.EQ.1) GOTO 447 1150 : C definition d'autant de structures que de paves necessaire au 1151 : C menu 1152 : ISEG=KBOIT+9+(100*(WKID-1)) 1152 : CALL POPST(1) 1152 : CALL PEXST(ISEG) 1152 : CALL PCLST 1152 : CALL POPST(ISEG) 1152 : CALL PEMST(ISEG) 1152 : CALL PADS(1,ISEG) 1152 : CALL PSVWI(PGSVWI) 1152 : CALL PSPKID(ISEG) 1153 : C ils sont tous rendus visibles et detectables 1153 : CALL PSVIS(PGIVNB,PGIVIN,ISEG,0) 1153 : CALL PSVIS(PGHPNB,PGHPIN,ISEG,1) 1153 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1153 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 1153 : CALL PSIS(1) 1153 : CALL PSICI(2) 1154 : C 1155 : PXA(1)=XB 1156 : PXA(2)=PXA(1)+2.0 1157 : PXA(3)=PXA(2) 1158 : PXA(4)=PXA(1) 1159 : PYA(1)=0.6 1160 : PYA(2)=PYA(1) 1161 : PYA(3)=PYA(1)+0.4 1162 : PYA(4)=PYA(3) 1163 : C definition du pave 1163 : CALL PFA(4,PXA,PYA) 1164 : C textes en rouge sous les paves du menu 1164 : CALL PSTXCI(2) 1165 : C definition de la police de caracteres et de la precision 1165 : CALL PSTXFN(-1) 1165 : CALL PSTXPR(2) 1165 : CALL PSCHSP(0.15) 1166 : C definition de la hauteur du text annote 1166 : CALL PSATCH(0.014) 1167 : C ecriture du text correspondant au pave 1168 : IF (KKIMP.EQ.1) THEN 1168 : CALL PATR(PXA(1),0.1,0.,0.,'Meta') 1169 : ELSE 1170 : IDEBTX=1 1171 : DO 466 IIT=1,MLONG 1172 : IF (LEGEND(KBOIT)(IIT:IIT).NE.' ') GOTO 467 1173 : 466 CONTINUE 1174 : 467 CONTINUE 1174 : CALL PATR(PXA(1),0.1,0.,0.,LEGEND(KBOIT)(IIT:MLONG)) 1175 : ENDIF 1175 : CALL PCLST 1176 : XB=XB+80./(NCASE1+1) 1177 : 447 CONTINUE 1178 : 465 CONTINUE 1178 : IF (PGTYPE.EQ.POPNST) CALL POPST(INUM) 1179 : PGSVWI=2 1180 : C si une structure est ouverte elle est associee a la vue 2 1180 : CALL PQOPST(IIERR,PGTYPE,INUM) 1180 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1181 : RETURN 1182 : C*********************************************************************** 1183 : C 1184 : C subroutine INSEGT 1185 : C 1186 : ENTRY PINSEG(NBSEGT,IRESS) 1187 : C ce ssp entre en jeu dans l'ecriture des neouds,elements et objets 1188 : C ----------------------------------------------------------------- 1189 : C 1190 : C debut du bloc phigs de INSEGT 1191 : C 1192 : 560 CONTINUE 1193 : IF (IPPP.EQ.1) THEN 1193 : CALL PQOPST(IERR,ISTYPE,ID) 1193 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1194 : ENDIF 1195 : C si un zoom n'a pas ete fait 1196 : IF (PGFLZO.EQ.0) THEN 1197 : IF (IRESS.NE.2) THEN 1198 : IF (IRESS.LT.2.OR.IRESS.GT.5) THEN 1198 : CALL PCLST 1199 : ENDIF 1200 : ELSE 1201 : IRESS=7 1202 : ENDIF 1203 : C si une structure est ouverte elle est fermee 1203 : CALL PQOPST(IIERR,PGTYPE,IOP) 1203 : IF (PGTYPE.EQ.POPNST) CALL PCLST 1204 : ISEG=NBSEGT+(100*(WKID-1)) 1204 : CALL POPST(1) 1204 : CALL PEXST(ISEG) 1204 : CALL PCLST 1204 : CALL POPST(ISEG) 1204 : CALL PEMST(ISEG) 1204 : CALL PADS(1,ISEG) 1204 : CALL PSVWI(PGSVWI) 1204 : CALL PSVIS(PGIVNB,PGIVIN,ISEG,0) 1204 : CALL PSVIS(PGHPNB,PGHPIN,ISEG,0) 1204 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1204 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 1205 : C definition du style du text annote 1205 : CALL PSANS(2) 1206 : C definition de la hauteur du text annote 1206 : C* CALL PSATCH(0.014) 1206 : CALL PSATCH(0.017) 1207 : ENDIF 1208 : IF (IPPP.EQ.1) THEN 1208 : CALL PQOPST(IERR,ISTYPE,ID) 1208 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1209 : ENDIF 1210 : RETURN 1211 : C*********************************************************************** 1212 : 1213 : C 1214 : C subroutine POLRL 1215 : C 1216 : ENTRY PPOLRL(NTRSTU,XTR,YTR,ZTR) 1217 : NTR=NTRSTU 1218 : IF (NTR.LE.1) RETURN 1219 : C PPOLRL 9 1220 : C debut du bloc phigs de POLRL 1221 : C 1222 : 660 CONTINUE 1223 : IF (NTR.LE.1) RETURN 1224 : PGSVWI=2 1225 : C la sructure ouverte est associee a la vue 2 1225 : CALL PQOPST(IIERR,PGTYPE,INUM) 1225 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1226 : 1227 : C definition d'une polyline 1227 : CALL PPL(NTR,XTR(1),YTR(1)) 1228 : RETURN 1229 : C*********************************************************************** 1230 : 1231 : C 1232 : C subroutine TRDIG 1233 : C 1234 : ENTRY PTRDIG(X,Y,INCLE) 1235 : INCLE=0 1236 : C debut du bloc phigs de TRDIG 1237 : C 1238 : 860 CONTINUE 1238 : C**** CALL PQDSP(phigswsttool,IERR,DC,NRX,NRY,LX,LY) 1238 : CALL PQDSP(tool1,IERR,DC,PNRX,PNRY,LX,LY) 1239 : NWRATIO=PNRY/PNRX 1240 : IF(NWRATIO.GT.1)THEN 1241 : NWRATIO=1./NWRATIO 1242 : ENDIF 1243 : C updater la structure --- PV 1243 : CALL PUWK(WKID,1) 1244 : C..... locator en mode request 1244 : CALL PSLCM(WKID,1,0,1) 1244 : CALL PRQLC(WKID,1,ISTAT,ITNR,X,Y) 1245 : C..... calcul des coordonnees 1246 : C y=y*nwratio 1247 : y=y*wratio 1248 : C Effacer le message --- PV 1248 : CALL PEMST(2) 1249 : C..... 1250 : IF((X.LT.X1).OR.(X.GT.X2))INCLE=3 1251 : IF((Y.LT.Y1).OR.(Y.GT.Y2))INCLE=3 1252 : 1253 : C..... reinitialisation des variables de sorties 1254 : XINID=X 1255 : YINID=Y 1256 : RETURN 1257 : C*********************************************************************** 1258 : C 1259 : C subroutine TRFACE 1260 : C 1261 : ENTRY PTRFAC(NP,XTR,YTR,ZN,ICOLE,IEFF) 1262 : IEFF=0 1263 : KP=INT(ZN*4./1.58)+1 1264 : C 1265 : C debut du bloc phigs de TRFACE 1266 : C 1267 : 960 CONTINUE 1268 : IEFF=0 1269 : PGSVWI=2 1270 : C la structure ouverte est associe a la vue 2 1270 : CALL PQOPST(IIERR,PGTYPE,INUM) 1270 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1271 : IEFF=1 1272 : IF (KP.NE.4) THEN 1273 : ENDIF 1274 : C definition de la couleur et du style de la facette 1274 : CALL PSICI(ICOLE) 1274 : CALL PSIS(1) 1275 : C definition de la facette 1275 : CALL PFA(NP,XTR,YTR) 1276 : RETURN 1277 : C*********************************************************************** 1278 : C 1279 : C subroutine TRAISO 1280 : C 1281 : ENTRY PTRAIS(NP,XTR,YTR,ICOLE) 1282 : C 1283 : C PTRAISO 12 1284 : C debut du bloc phigs de TRAISO 1285 : C 1286 : 1060 CONTINUE 1287 : C pour pallier un petit bug dans le trace de la mire d'isovaleurs 1288 : ICOISI=ICOLE 1289 : C definition de la couleur de la facette 1289 : CALL PSICI(ICOISI) 1289 : CALL PQOPST(IERR,PGTYPE,INUM) 1289 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1290 : 1290 : CALL PSIS(1) 1290 : CALL PFA(NP,XTR,YTR) 1291 : RETURN 1292 : C*********************************************************************** 1293 : 1294 : C 1295 : C subroutine TREFF 1296 : C 1297 : ENTRY PTREFF 1298 : 1160 CONTINUE 1299 : RETURN 1300 : C*********************************************************************** 1301 : C 1302 : C subroutine TRAFF 1303 : C 1304 : ENTRY PTRAFF(ICLE) 1305 : ICLE=0 1306 : C 1307 : C PTRAFF 17 1308 : C debut du bloc phigs de TRAFF 1309 : C 1310 : 1560 CONTINUE 1311 : ICLE=0 1311 : CALL PQOPST(IIERRI,PGTYPE,INUM) 1312 : C 1313 : ISGNEW=9+(100*(WKID-1)) 1313 : IF(PGTYPE.EQ.POPNST) CALL PCLST 1313 : CALL POPST(ISGNEW) 1314 : ISEG=0 1314 : CALL PSPKM(WKID,1,0,1) 1314 : CALL PUWK(WKID,1) 1314 : C CALL PRST(WKID,1) 1315 : 1561 CONTINUE 1316 : C 1316 : CALL PRQPK(WKID,1,2,ISTAT,PGDEPT ,PGPATH) 1317 : ICHNR=PGPATH(1,2) 1318 : PCID=PGPATH(2,2) 1319 : ISEG=ICHNR-(100*(WKID-1)) 1320 : IF (ISTAT.NE.1.OR.ICHNR.EQ.0) THEN 1320 : CALL PSDUS(WKID,3,0) 1320 : CALL PSDUS(WKID,4,0) 1321 : GOTO 1561 1322 : ENDIF 1323 : C effacer message dialogue 1323 : CALL PEMST(2) 1324 : IF(ISEG.GE.50) THEN 1324 : CALL PSSTM(WKID,1,0,1) 1324 : CALL PRQST(WKID,1,ISTAT,IL,STRING) 1324 : CALL PEMST(ICHNR) 1324 : CALL POPST(1) 1324 : CALL PEXST(ICHNR) 1324 : CALL PCLST 1324 : CALL POPST(ICHNR) 1324 : C CALL PPOST(WKID,ICHNR,1.) 1324 : CALL PADS(1,ICHNR) 1324 : CALL PSVWI(PGSVWI) 1324 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1324 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 1325 : XX=TEXTX(ISEG-50+1) 1326 : YY=TEXTY(ISEG-50+1) 1326 : CALL PATR(XX,YY,0.,0.,STRING) 1326 : CALL PCLST 1326 : CALL PSVIS(PGHPNB,PGHPIN,ICHNR,1) 1326 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 1327 : TEXTE(ISEG-50+1)(1:15)=STRING(1:15) 1328 : ENDIF 1329 : ICLE=ISEG 1330 : ICLE=ICLE-10 1331 : write (6,*) ' icle ',icle 1332 : if (icle.ne.0.and.ipf(icle).eq.0) goto 1560 1333 : C 1333 : CALL PSDUS(WKID,4,0) 1334 : C 1334 : CALL PSVWI(PGSVWI) 1334 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1334 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 1335 : C 1336 : RMAT(1)=1. 1337 : RMAT(2)=0. 1338 : RMAT(3)=0. 1339 : RMAT(4)=1. 1340 : RMAT(5)=0. 1341 : RMAT(6)=0. 1342 : IF (INMP.EQ.1) THEN 1342 : CALL PQOPST(IERR,ISTYPE,ID) 1342 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1343 : ENDIF 1344 : C 1345 : RETURN 1346 : C*********************************************************************** 1347 : C 1348 : C subroutine TRMFIN 1349 : C 1350 : ENTRY PTRMFI 1351 : C PTRNFN 19 1352 : C debut du bloc phigs de TRMFIN 1353 : C 1354 : 1860 CONTINUE 1355 : * IACT=0 1356 : IWISS=0 1357 : C essai 1358 : C devrait permettre a l'utilisateur de savoir qu'il a selectionne la tou 1358 : * CALL POPST(1) 1358 : * CALL PEXST(INUSEG) 1358 : * CALL PCLST 1358 : * CALL POPST(INUSEG) 1358 : * CALL PSTXPR(2) 1358 : * CALL PSTXFN(-1) 1358 : * CALL PSCHSP(0.1) 1358 : * CALL PSATCH(0.015) 1358 : * CALL PSTXCI(7) 1358 : * CALL PATR(3.,34.,0.,0.,'Fin de session de CASTEM2000') 1358 : * CALL PCLST 1358 : C CALL PPOST(WKID,INUSEG,1.) 1358 : C CALL PXPSV(WKID,4,INUSEG,1.) 1358 : * CALL PUWK(WKID,1) 1359 : * PGFLAG = 0 1360 : RETURN 1361 : C*********************************************************************** 1362 : 1363 : C 1364 : C subroutine ZOOM 1365 : C 1366 : * ENTRY PZOOM(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA) 1367 : ENTRY PZOOM(IZOOM,XMI,XMA,YMI,YMA) 1368 : C 1369 : C PZOOM 20 1370 : C debut du bloc phigs de ZOOM 1371 : C 1372 : 2060 CONTINUE 1373 : IF (IPPP.EQ.1) THEN 1373 : CALL PQOPST(IERR,ISTYPE,ID) 1373 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1374 : ENDIF 1375 : C................................ 1376 : IRESU=1 1377 : ITNR=2 1378 : *1093 ISORT=1 1379 : 1380 : C la flag du zoom est mis a 1 1381 : PGFLZO = 1 1381 : C CALL PSVWCS(WKID,2,1,1,1,0,0) 1381 : CALL PSVTIP(WKID,2,0,0) 1382 : PGSVWI=0 1383 : C la structure ouverte est associee a la vue 0 1383 : CALL PQOPST(IIERR,PGTYPE,INUM) 1383 : IF (PGTYPE.EQ.POPNST) CALL PSVWI(PGSVWI) 1384 : C.... locator en mode request 1384 : CALL PSLCM(WKID,1,0,1) 1385 : C demande du premier locator 1385 : CALL PRQLC(WKID,1,STAT,ITNR1,XRO,YRO) 1386 : C demande du deuxieme locator 1386 : CALL PRQLC(WKID,1,STAT,ITNR1,XCOL,YCOL) 1387 : 1388 : C definition du carre inscrit dans la zone saisie 1389 : XMI=MIN(XRO,XCOL) 1390 : XMA=MAX(XRO,XCOL) 1391 : YMI=MIN(YRO,YCOL) 1392 : YMA=MAX(YRO,YCOL) 1393 : C..... pour eviter les messages d'erreur dus aux valeurs trop petites 1394 : A=XMA-XMI 1395 : B=YMA-YMI 1396 : IF (A.LE.0.001) THEN 1397 : XMI=XMI*0.85 1398 : XMA=XMA*1.25 1399 : ENDIF 1400 : IF (B.LE.0.001) THEN 1401 : YMI=YMI*0.85 1402 : YMA=YMA*1.25 1403 : ENDIF 1404 : 1405 : XC=XMI+A/2 1406 : YC=YMI+B/2 1407 : C=(A/2+B/2)/2 1408 : IF ((A/B.LT.1).OR.(B/A.LT.1)) THEN 1409 : C pour les cas particuliers ou a<PQDSP(phigswsttool,IERR,DC,PGRX,PGRY,LX,LY) 1430 : CALL PQDSP(tool1,IERR,DC,PGRX,PGRY,LX,LY) 1431 : PGRAP=MIN(PGRX/RX,PGRY/RY) 1432 : IF (PGRX .LE. PGRY) THEN 1433 : VXMIN = .5*(PGRX-PGRAP*RX) 1434 : VXMAX = .5*(PGRX+PGRAP*RX) 1434 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 1435 : ELSE 1436 : VXMIN = .5*(PGRX-PGRAP*RY) 1437 : VXMAX = .5*(PGRX+PGRAP*RY) 1437 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 1438 : ENDIF 1439 : C.... redefinition de la vue 2 1440 : VWWNLM(1) = XMI 1441 : VWWNLM(2) = XMA 1442 : VWWNLM(3) = YMI 1443 : VWWNLM(4) = YMA 1444 : PJVPLM(1) = 0. 1445 : PJVPLM(3) = (WRATIO)*0.1 1446 : VWORMT(1,1) = 1. 1447 : VWORMT(2,2) = 1. 1448 : VWORMT(3,3) = 1. 1449 : VWORMT(1,2) = 0. 1450 : VWORMT(1,3) = 0. 1451 : VWORMT(2,1) = 0. 1452 : VWORMT(2,3) = 0. 1453 : VWORMT(3,1) = 0. 1454 : VWORMT(3,2) = 0. 1455 : XYCLIPI = 1 1456 : IF (VALEUR) THEN 1456 : C CALL OSVMP(WKID,2,XMI,XMA,YMI,YMA,0.,0.8,(WRATIO)*0.1, 1457 : C & (WRATIO)*0.9) 1458 : PJVPLM(2) = 0.8 1459 : 1460 : PJVPLM(4) = (WRATIO)*0.9 1461 : 1461 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 1461 : CALL PSVWR(WKID,2,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 1462 : ELSE 1462 : C CALL OSVMP(WKID,2,XMI,XMA,YMI,YMA,0.,0.9,(WRATIO)*0.1, 1463 : C & (WRATIO)) 1464 : PJVPLM(2) = 0.9 1465 : 1466 : PJVPLM(4) = WRATIO 1467 : 1467 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 1467 : CALL PSVWR(WKID,2,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 1468 : ENDIF 1469 : 1470 : C.... mise a jour des variables de sorties 1471 : XMI = SXMIN 1472 : XMA = SXXAX 1473 : YMI = SYMIN 1474 : YMA = SYYAX 1475 : PAS = 1 1476 : C cf gks ou gddm 1477 : C IF (IDEFOR.NE.0) THEN 1478 : C ISORT=0 1479 : C END 1480 : C 1481 : *1093 IF (IQUALI.EQ.10) IQUALI=0 1482 : *1093 IF (INUMNO.EQ.10) INUMNO=0 1483 : *1093 IF (INUMEL.EQ.10) INUMEL=0 1484 : C cf gks ou gddm 1485 : *1093 ISORT=1 1486 : IRESU=2 1487 : C 1488 : IF (IPPP.EQ.1) THEN 1488 : CALL PQOPST(IERR,ISTYPE,ID) 1488 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1489 : ENDIF 1490 : 1491 : RETURN 1492 : C*********************************************************************** 1493 : 1494 : C 1495 : C subroutine CHANG 1496 : C 1497 : ENTRY PCHANG(IRESU,ISORT,ICHANG,JSEG) 1498 : C PCHANG 21 1499 : C debut du bloc phigs de CHANG 1500 : C 1501 : 2260 CONTINUE 1502 : ISEG=JSEG+(100*(WKID-1)) 1503 : IF (ICHANG.EQ.1) THEN 1504 : ICHANG=10 1505 : C la structure ISEG est rundue invisible 1505 : CALL PSVIS(PGIVNB,PGIVIN,ISEG,1) 1505 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1506 : ISORT=0 1507 : RETURN 1508 : ELSEIF (ICHANG.EQ.10) THEN 1509 : ICHANG=1 1510 : C ls structure ISEG est rendue visible 1510 : CALL PSVIS(PGIVNB,PGIVIN,ISEG,0) 1510 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1511 : ISORT=0 1512 : RETURN 1513 : ENDIF 1513 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1514 : ISORT=1 1515 : IRESU=JSEG 1516 : ICHANG=1 1517 : RETURN 1518 : C*********************************************************************** 1519 : 1520 : C 1521 : C subroutine INI 1522 : C 1523 : ENTRY PINI(IRESU,ISORT,IQUALI,INUMNO,INUMEL,XMI,XMA,YMI,YMA) 1524 : C PINI 22 1525 : C debut du bloc phigs de INI 1526 : C 1527 : 2460 CONTINUE 1528 : PGSVWI=2 1529 : IF (IPPP.EQ.1) THEN 1529 : CALL PQOPST(IERR,ISTYPE,ID) 1529 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1530 : ENDIF 1531 : ISEG=1+(100*(WKID-1)) 1532 : C les valeurs initiales de la vue 2 sont restaurees 1533 : X1=PGX1 1534 : X2=PGX2 1535 : Y1=PGY1 1536 : Y2=PGY2 1537 : PGCEH = 1 1537 : C**** CALL PQDSP(phigswsttool,IERR,DC,PGRX,PGRY,LX,LY) 1537 : CALL PQDSP(tool1,IERR,DC,PGRX,PGRY,LX,LY) 1538 : PGRAP=MIN (PGRX/RX,PGRY/RY) 1539 : IF (PGRX .LE. PGRY) THEN 1540 : VXMIN = .5*(PGRX-PGRAP*RX) 1541 : VXMAX = .5*(PGRX+PGRAP*RX) 1541 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 1542 : ELSE 1543 : VXMIN = .5*(PGRX-PGRAP*RY) 1544 : VXMAX = .5*(PGRX+PGRAP*RY) 1544 : CALL PSWKV(WKID,VXMIN,VXMAX,VXMIN,VXMAX) 1545 : ENDIF 1546 : VWWNLM(1) = X1 1547 : VWWNLM(2) = X2 1548 : VWWNLM(3) = Y1 1549 : VWWNLM(4) = Y2 1550 : VWORMT(1,1) = 1. 1551 : VWORMT(2,2) = 1. 1552 : VWORMT(3,3) = 1. 1553 : VWORMT(1,2) = 0. 1554 : VWORMT(1,3) = 0. 1555 : VWORMT(2,1) = 0. 1556 : VWORMT(2,3) = 0. 1557 : VWORMT(3,1) = 0. 1558 : VWORMT(3,2) = 0. 1559 : XYCLIPI = 1 1560 : PJVPLM(1) = 0. 1561 : PJVPLM(3) = (WRATIO)*0.1 1562 : IF (VALEUR) THEN 1563 : C redefinition de la vue 2 1563 : C CALL OSVMP(WKID,2,X1,X2,Y1,Y2,0.,0.8, 1564 : C & (WRATIO)*0.1,(WRATIO)*0.9) 1565 : PJVPLM(2) = 0.8 1566 : 1567 : PJVPLM(4) = (WRATIO)*0.9 1568 : 1568 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 1568 : CALL PSVWR(WKID,2,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 1569 : ELSE 1570 : C redefinition de la vue 2 1570 : C CALL OSVMP(WKID,2,X1,X2,Y1,Y2,0.,0.9, 1571 : C & (WRATIO)*0.1,(WRATIO)) 1572 : PJVPLM(2) = 0.9 1573 : 1574 : PJVPLM(4) = WRATIO 1575 : 1575 : CALL PEVMM(VWWNLM,PJVPLM,IERR,VWMPMT) 1575 : CALL PSVWR(WKID,2,VWORMT,VWMPMT,PJVPLM,XYCLIPI) 1576 : ENDIF 1576 : C CALL PUWK(WKID,1) 1577 : IF (IDEFOR.NE.0) THEN 1578 : ISORT=0 1579 : RETURN 1580 : ENDIF 1581 : C les valeurs de la vue sont restituees 1582 : XMI = SXMIN 1583 : XMA = SXXAX 1584 : YMI = SYMIN 1585 : YMA = SYYAX 1586 : PAS = 1 1587 : IDEL1=0 1588 : IDEL2=0 1589 : IDEL3=0 1590 : IF (IQUALI.NE.0) IDEL1=3+(100*(WKID-1)) 1591 : IF (INUMNO.NE.0) IDEL2=4+(100*(WKID-1)) 1592 : IF (INUMEL.NE.0) IDEL3=5+(100*(WKID-1)) 1593 : C les structures contenant les noeuds ,les elements et les quals 1594 : C sont videes 1594 : IF (IDEL1.NE.0) CALL PEMST(IDEL1) 1594 : IF (IDEL2.NE.0) CALL PEMST(IDEL2) 1594 : IF (IDEL3.NE.0) CALL PEMST(IDEL3) 1595 : IF (IQUALI.EQ.10) IQUALI=0 1596 : IF (INUMNO.EQ.10) INUMNO=0 1597 : IF (INUMEL.EQ.10) INUMEL=0 1598 : XMI=SXMIN 1599 : XMA=SXXAX 1600 : YMI=SYMIN 1601 : YMA=SYYAX 1602 : ISORT=1 1603 : IRESU=2 1604 : C 1605 : IF (IPPP.EQ.1) THEN 1605 : CALL PQOPST(IERR,ISTYPE,ID) 1605 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1606 : ENDIF 1607 : 1608 : RETURN 1609 : C*********************************************************************** 1610 : 1611 : C 1612 : C subroutine FLGI 1613 : C 1614 : ENTRY PFLGJ 1615 : C 1616 : C PFLGI 23 1617 : C debut du bloc phigs de FLGI 1618 : C 1619 : 2860 CONTINUE 1620 : IANIM=0 1621 : IF(IANIM.EQ.0) RETURN 1622 : NGG=100. 1623 : C DO 2861 IFOO=1,20 1624 : DO2861IFOO=1,20 1625 : C DO 2862 ICOL=1,7 1626 : DO2862ICOL=1,7 1627 : DO2863JCOL=1,7 1628 : JXCOL=JCOL 1628 : CALL PSCR(WKID,JXCOL,3,0.0,0.0,0.0) 1629 : 2863 CONTINUE 1630 : IXCOL=ICOL 1630 : CALL PSCR(WKID,IXCOL,3,1.0,1.0,1.0) 1631 : IKKK=0 1632 : DO2864IKKL=1,100000 1633 : C DO2864IKKL=1,30000 1634 : IKKK=IKKK+1 1635 : 2864 CONTINUE 1636 : 2862 CONTINUE 1637 : C DO 2865 ICOL=6,2,-1 1638 : DO2865ICOL=7,1,-1 1639 : DO2866JCOL=1,7 1640 : JXCOL=JCOL 1640 : CALL PSCR(WKID,JXCOL,3,0.0,0.0,0.0) 1641 : 2866 CONTINUE 1642 : IXCOL=ICOL 1642 : CALL PSCR(WKID,IXCOL,3,1.0,1.0,1.0) 1643 : C DO 2867 IKKL=1,30000 1644 : DO2867IKKL=1,1250000 1645 : IKKK=IKKK+1 1646 : 2867 CONTINUE 1647 : 2865 CONTINUE 1648 : 2861 CONTINUE 1649 : C restitution exacte de la table de couleur 1649 : CALL PSCR(WKID,0,3,0.0,0.0,0.0) 1649 : CALL PSCR(WKID,4,3,0.0,0.0,1.0) 1649 : CALL PSCR(WKID,2,3,1.0,0.0,0.0) 1649 : CALL PSCR(WKID,6,3,1.0,0.0,1.0) 1649 : CALL PSCR(WKID,3,3,0.0,1.0,0.0) 1649 : CALL PSCR(WKID,5,3,0.0,1.0,1.0) 1649 : CALL PSCR(WKID,7,3,1.0,1.0,0.0) 1649 : CALL PSCR(WKID,1,3,1.0,1.0,1.0) 1650 : ICCOUN=ICCOUN+1 1651 : IF (ICCOUN.LE.9) WRITE(NAME,FMT='(''GIBI'',I1)') ICCOUN 1652 : IF (ICCOUN.GE.10) WRITE(NAME,FMT='(''GIBI'',I2)') ICCOUN 1653 : IF (ICCOUN.GE.100) WRITE(NAME,FMT='(''GIBI'',I3)') ICCOUN 1654 : RETURN 1655 : C*********************************************************************** 1656 : 1657 : C 1658 : C subroutine IMPR 1659 : C 1660 : ENTRY PFLGI 1661 : ENTRY PIMPR 1662 : C 1663 : C PIMPR 24 1664 : C debut du bloc phigs de IMPR 1665 : C 1666 : 3260 CONTINUE 1667 : KMETA=KMETA+1 1668 : IF (KMETA.GT.99) THEN 1668 : CALL PATR(25.,6.,0.,0.,'COMPTEUR DE MATAFILE SUPERIEUR A 99') 1668 : CALL PATR(25.,4.,0.,0.,'SAUVEGARDE IMPOSSIBLE') 1669 : RETURN 1670 : ENDIF 1671 : I10=KMETA/10 1672 : IREST=KMETA-10*I10 1673 : I10=10+1 1674 : IREST=IREST+1 1675 : STR=STR1//CARELE(I10)//CARELE(IREST) 1676 : KCON=1 1677 : METAID=1 1678 : C ouverture du fichier d'archive 1678 : CALL POPARF(METAID,STR) 1678 : C CALL PSWKW(METAID,0.,1.,0.,1.) 1678 : CALL PQOPST(IIERR,PGTYPE,INUM) 1678 : IF (PGTYPE.EQ.POPNST) CALL PCLST 1679 : C creation de la liste des structures a archiver 1680 : LIST(1)=0 1681 : ISEG=6+(100*(WKID-1)) 1682 : LIST(2)=ISEG 1683 : ISEG=1+(100*(WKID-1)) 1684 : LIST(3)=ISEG 1685 : IF (VALEUR) THEN 1686 : ISEG=7+(100*(WKID-1)) 1687 : LIST(4)=ISEG 1688 : I=4 1689 : ELSE 1690 : ISEG=3+(100*(WKID-1)) 1691 : IF (IQUALI.EQ.1) LIST(4)=ISEG 1692 : ISEG=4+(100*(WKID-1)) 1693 : IF (INUMNO.EQ.1) LIST(5)=ISEG 1694 : ISEG=5+(100*(WKID-1)) 1695 : IF (INUMEL.EQ.1) LIST(6)=ISEG 1696 : I=6 1697 : ENDIF 1698 : C archivage des structures contenues dans LIST 1698 : CALL PARST(METAID,I,LIST) 1699 : C fermeture du fichier d'archive 1699 : * CALL PCLRAF(METAID) 1700 : RETURN 1701 : C*********************************************************************** 1702 : 1703 : C 1704 : C subroutine VAL 1705 : C 1706 : ENTRY PVAL(IRESU,ISORT,NISO) 1707 : C 1708 : C PVAL 25 1709 : C debut du bloc phigs de VAL 1710 : C 1711 : 3560 CONTINUE 1712 : IF (IPPP.EQ.1) THEN 1712 : CALL PQOPST(IERR,ISTYPE,ID) 1712 : C CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1713 : ENDIF 1714 : IF (NISO.NE.0.AND.IDEFOR.EQ.0) THEN 1715 : IXSEG=0 1716 : IRESU=10 1717 : ISORT=1 1718 : ENDIF 1719 : RETURN 1720 : C*********************************************************************** 1721 : 1722 : C 1723 : C subroutine MAJSEG 1724 : C 1725 : ENTRY PMAJSE(IMAJ,IRESU,IQUALI,INUMNO,INUMEL) 1726 : C 1727 : C debut du bloc phigs de MAJSEG 1728 : C 1729 : 4060 CONTINUE 1730 : C fermeture de la structure courante et update de la Work station 1731 : IF (IMAJ.EQ.1) THEN 1732 : IF (IRESU.NE.2.OR.IQUALI.NE.0.OR.INUMNO.NE.0.OR.INUMEL.NE.0) 1732 : & CALL PCLST 1733 : ELSE 1734 : IF (IQUALI.EQ.10) IQUALI=0 1735 : IF (INUMNO.EQ.10) INUMNO=0 1736 : IF (INUMEL.EQ.10) INUMEL=0 1737 : IF (IRESU.LT.2.OR.IRESU.GT.5) THEN 1738 : ENDIF 1739 : C* IF (WKID.EQ.IWKIDLI) THEN 1739 : C* CALL PCLWK(WKID) 1740 : C* ELSE 1741 : C* WKID=WKID+1 1742 : C* ENDIF 1743 : 1744 : ENDIF 1745 : C definition concernant le texte 1746 : IF (IRESU.EQ.10.AND.IFF.EQ.0) THEN 1747 : IFF=1 1748 : ENDIF 1749 : 1750 : C effacement des structures associees a du textes 1751 : C IF (IRESU.NE.10.AND.IFF.EQ.1) THEN 1752 : IF (IRESU.NE.10) THEN 1753 : IFF=0 1754 : IFV=0 1755 : C effacement de toutes les structures associees a du texte 1756 : 1619 IF(INUSEG.GT.(50+100*(WKID-1))) THEN 1757 : C INUSEG=INUSEG-1 1757 : CALL PEMST(INUSEG) 1757 : CALL PDST(INUSEG) 1758 : INUSEG=INUSEG-1 1759 : GOTO 1619 1760 : ENDIF 1761 : ENDIF 1762 : 1763 : C------------------------------------- 1763 : C* CALL PQOPST(IERR,ISTYPE,ID) 1763 : C* CALL PXQLVS(WKID,ID,0,10,IERR,IVIER,ITVWS) 1764 : 1765 : RETURN 1766 : C*********************************************************************** 1767 : C 1768 : C entry TRMESS 1769 : C 1770 : C --------------------------------- 1771 : C Affichage d'un message informatif 1772 : C --------------------------------- 1773 : ENTRY PTRMES(TITRE) 1774 : NCART=LONG(TITRE) 1774 : CALL PQOPST(IIERR,PGTYPE,INUM) 1774 : IF (PGTYPE.EQ.POPNST) CALL PCLST 1775 : C effacer le titre puisqu'on ecrit au meme endroit PV 1776 : ISEG=6+(100*(WKID-1)) 1776 : CALL PEMST(ISEG) 1776 : CALL POPST(3) 1776 : CALL PEMST(3) 1776 : CALL PSVWI(1) 1776 : CALL PSTXPR(2) 1776 : CALL PSTXFN(-5) 1776 : CALL PSCHSP(0.1) 1776 : CALL PSATCH(0.015) 1776 : CALL PSTXCI(6) 1776 : CALL PATR(.6,1.3,0.,0.,TITRE(1:NCART)) 1776 : CALL PCLST 1776 : IF (PGTYPE.EQ.POPNST) CALL POPST(INUM) 1777 : RETURN 1778 : C*********************************************************************** 1779 : C 1780 : C subroutine TRGET 1781 : C 1782 : C ----------------------------------------- 1783 : C Sous-programme uniquement appele par MODI 1784 : C ----------------------------------------- 1785 : ENTRY PTRGET(LLIG,LCOL,CARACT) 1786 : NCART=LEN(CARACT) 1787 : C PTRGET 18 1788 : C debut du bloc phigs de TRGET 1789 : C 1790 : 1760 CONTINUE 1790 : CALL PQOPST(IIERRI,PGTYPE,INUM) 1791 : ISGNEW=9+(100*(WKID-1)) 1791 : IF(PGTYPE.EQ.POPNST) CALL PCLST 1791 : CALL POPST(ISGNEW) 1792 : ILLIG=33.-LLIG 1793 : C DO 1761 IND=1,INCOOR 1794 : DO1761IND=1,INCOOR 1795 : IF((TEXTX(IND).EQ.LCOL).AND.(TEXTY(IND).EQ.ILLIG)) THEN 1796 : CARACT(1:15)=TEXTE(IND)(1:15) 1797 : ENDIF 1798 : 1761 CONTINUE 1798 : CALL PSVWI(PGSVWI) 1798 : CALL PSIVFT(WKID,PGIVNB,PGIVIN,0,PGIVEX) 1798 : CALL PSPKFT(WKID,1,PGHPNB,PGHPIN,0,PGHPEX) 1799 : RMAT(1)=1. 1800 : RMAT(2)=0. 1801 : RMAT(3)=0. 1802 : RMAT(4)=1. 1803 : RMAT(5)=0. 1804 : RMAT(6)=0. 1804 : CALL PCELST(ISGNEW) 1804 : CALL PEMST(ISGNEW) 1805 : RETURN 1806 : C ------------ 1807 : C fin de TRGET 1808 : C ------------ 1809 : END 1810 : C*********************************************************************** 1811 : C 1812 : C subroutine PSVIS 1813 : C 1814 : SUBROUTINE PSVIS(PGIVNB,PGIVIN,ISUBSEG,FLAG) 1815 : C subroutine permettant de gerer la liste des structures visibles 1816 : C la liste des structures detectables 1817 : IMPLICIT INTEGER(I-N) 1818 : INTEGER PGIVNB,ISUBSEG,FLAG 1819 : INTEGER PGIVIN(4096) 1820 : C si la liste n'est pas vide 1821 : IF (PGIVNB.NE.0) THEN 1822 : C DO 5000 I=1,PGIVNB 1823 : DO5000I=1,PGIVNB 1824 : C si le numero de structure existe dans la liste et qu'il doit etr 1825 : C ajoute on ne fait rien 1826 : IF (PGIVIN(I).EQ.ISUBSEG.AND.FLAG.EQ.1) GOTO 5010 1827 : C si il existe dans la liste et doit etre supprime 1828 : IF (PGIVIN(I).EQ.ISUBSEG) GOTO 5020 1829 : 5000 CONTINUE 1830 : C dans le cas ou le numro de structure n'existe pas dans la liste 1831 : IF (FLAG.EQ.1) THEN 1832 : PGIVNB=PGIVNB+1 1833 : PGIVIN(PGIVNB)=ISUBSEG 1834 : ENDIF 1835 : GOTO 5010 1836 : 5020 PGIVNB=PGIVNB-1 1837 : C le dernier element de la liste a ete supprime 1838 : IF (I.EQ.PGIVNB+1) GOTO 5010 1839 : C DO 5030 J=I,PGIVNB 1840 : C un element dans la liste a ete supprime ,celle ci est restructur 1841 : DO5030J=I,PGIVNB 1842 : PGIVIN(J)=PGIVIN(J+1) 1843 : 5030 CONTINUE 1844 : GOTO 5010 1845 : ELSE IF (FLAG.EQ.1) THEN 1846 : C si la structure doit etre dectectable ou invisible son numero es 1847 : C ajoute a la liste 1848 : PGIVNB=PGIVNB+1 1849 : PGIVIN(PGIVNB)=ISUBSEG 1850 : ENDIF 1851 : 5010 CONTINUE 1852 : RETURN 1853 : END 1854 : 1855 : 1856 : 1857 :
© Cast3M 2003 - All rights reserved.
Disclaimer