code/source/petsub.for

   1 *C------------------------------------------------------------------------
   2        subroutine       pg_init2()    ! same as pginit, but no paw initializ.
   3 C                                       and no higz initializ.
   4 C       pg_init2 .......
   5 C
   6 C------------------------------------------------------------------------
   7 C
   8         include 'petgracom.for'
   9 C
  10 C-------
  11
  12 C       call Iginit     (0)
  13         call Igzset     ('G')
  14 C
  15         return
  16         end
  17 *C------------------------------------------------------------------------
  18        subroutine       pg_init1()    ! same as pginit, but no paw initializ.
  19 C
  20 C       pg_init1 .......
  21 C
  22 C------------------------------------------------------------------------
  23 C
  24         include 'petgracom.for'
  25 C
  26 C-------
  27
  28         call Iginit     (0)
  29         call Igzset     ('G')
  30 C
  31         return
  32         end
  33 C
  34 *C------------------------------------------------------------------------
  35        subroutine       pg_init(chopt)
  36 C
  37 C       pg_init .......
  38 C
  39 C------------------------------------------------------------------------
  40 C
  41         include 'petgracom.for'
  42 C
  43 C-------
  44         character*2     chopt
  45
  46         call mzpaw      (nh,'M')
  47         call Iginit     (0)
  48         call Igzset     (chopt)
  49 C
  50         return
  51         end
  52 C
  53 C------------------------------------------------------------------------
  54         subroutine      pg_open()
  55 C
  56 C       pg_open .......
  57 C
  58 C------------------------------------------------------------------------
  59 C
  60         include 'petgracom.for'
  61 C-------
  62 c
  63         call iopks      (err_file)
  64         call iopwk      (wkid,conid,wtype)
  65         call iacwk      (wkid)
  66 C
  67         !mettere qui le inizializzazioni !
  68         return
  69         end
  70 C
  71 C------------------------------------------------------------------------
  72         subroutine      pg_close()
  73 C
  74 C       pg_close .......
  75 C
  76 C------------------------------------------------------------------------
  77 C
  78                 include 'petgracom.for'
  79 C-------
  80 C
  81         call idawk(wkid)
  82         call iclwk(wkid)
  83         call iclks
  84         call Izend(-1)
  85         call Iginit(-1)
  86         return
  87         end
  88 C------------------------------------------------------------------------
  89         subroutine      pg_fullscreen()
  90 C
  91 C       pg_fullscreen .......
  92 C
  93 C------------------------------------------------------------------------
  94 C
  95                 include 'petgracom.for'
  96 C-------
  97         real*4  display_x,display_y
  98         real*4  max_coord
  99 C
 100         call gqdsp(wtype,idummy,idummy,display_x,display_y,idummy,idummy)
 101         max_coord = amax1 (display_x,display_y)
 102         if ((display_x/max_coord) .eq. 1) then
 103                 scale_x=1.0
 104                 scale_y=display_y/max_coord
 105         else
 106                 scale_x=display_x/max_coord
 107                 scale_y=1.0
 108         endif
 109 c       call gswkwn(wkid,0.0,scale_x,0.0,scale_y)
 110         call iswkwn(wkid,0.0,scale_x,0.0,scale_y)
 111         call iswkvp(wkid,0.0,display_x,0.0,display_y)
 112         return
 113         end
 114 C------------------------------------------------------------------------
 115         subroutine      pg_setscreen(x0,y0,fact)
 116 C
 117 C       pg_setscreen .......
 118 C
 119 C------------------------------------------------------------------------
 120 C
 121                 include 'petgracom.for'
 122 C-------
 123         real*4  display_x,display_y
 124         real*4  max_coord
 125         real*4  x0,y0 ! screen coordinates of the origin
 126         real*4  x,y   ! screen coordinates of the origin
 127         real*4  fact  ! reduction factor of the screen
 128 C
 129         if (fact.lt.0) return
 130         call gqdsp(wtype,idummy,idummy,display_x,display_y,idummy,idummy)
 131         max_coord = amax1 (display_x,display_y)
 132         if ((display_x/max_coord) .eq. 1) then
 133                 scale_x=1.0
 134                 scale_y=display_y/max_coord
 135         else
 136                 scale_x=display_x/max_coord
 137                 scale_y=1.0
 138         endif
 139         scale_x=scale_x*fact
 140         scale_y=scale_y*fact
 141         x=x0*display_x
 142         y=y0*display_y
 143         if (x+fact*display_x.gt.display_x) x=0
 144         if (y+fact*display_y.gt.display_y) y=0
 145 c       call gswkwn(wkid,0.0,scale_x,0.0,scale_y)
 146         call iswkwn(wkid,0.0,scale_x,0.0,scale_y)
 147         call iswkvp(wkid,x,x+fact*display_x,y,y+fact*display_y)
 148         return
 149         end
 150 C------------------------------------------------------------------------
 151         subroutine      pg_frames()
 152 C
 153 C       pg_frames .......
 154 C
 155 C------------------------------------------------------------------------
 156 C
 157                 include 'petgracom.for'
 158 C-------
 159 c
 160
 161         call iswn(tnfull,0.,1.,0.,1.)
 162         call isvp(tnfull,0.,1.*scale_x,0.,1.*scale_y)
 163         call iselnt(tnfull)
 164         call Igbox (0.0,1.0,0.0,1.0)
 165         call Igline(0.0,1.0,0.5,0.5)
 166         call Igline(0.5,0.5,0.0,1.0)
 167         call guwk  (wkid,GSUPPD)
 168         return
 169         end
 170 C------------------------------------------------------------------------
 171         subroutine      pg_initframe1(tn,xmax,ymax,cent,iso)
 172 C
 173 C       pg_initframe .......
 174 C
 175 C------------------------------------------------------------------------
 176 C
 177                 include 'petgracom.for'
 178 C
 179 C-------
 180         integer*4       tn,cent,iso
 181         real*4          xmax,ymax
 182 c
 183         ratio_vp=scale_x/scale_y
 184         ratio_ob=xmax/ymax
 185
 186
 187         if (iso.eq.1) then
 188                 if (ratio_vp.ge.1) then
 189                         if ( ratio_ob.le.1) then
 190                              y=ymax
 191                              x=y*ratio_vp
 192                         else if (ratio_vp.gt.ratio_ob) then
 193                              y=ymax
 194                              x=y*ratio_vp
 195                 else
 196                              x=xmax
 197                              y=x/ratio_vp
 198                         endif
 199                 end if
 200
 201                 if (ratio_vp.lt.1) then
 202                         if ( ratio_ob.gt.1) then
 203                              x=xmax
 204                              y=x/ratio_vp
 205                         else if (ratio_vp.gt.ratio_ob) then
 206                              y=ymax
 207                              x=y*ratio_vp
 208                         else
 209                              x=xmax
 210                              y=x/ratio_vp
 211                         endif
 212                 end if
 213         else
 214                   x=xmax
 215                   y=ymax
 216         endif
 217
 218         if (tn.eq.tnvptl)               then
 219                 vpx1=scale_x*vptl(1)
 220                 vpx2=scale_x*vptl(2)
 221                 vpy1=scale_y*vptl(3)
 222                 vpy2=scale_y*vptl(4)
 223
 224         else if (tn.eq.tnvptr)          then
 225                 vpx1=scale_x*vptr(1)
 226                 vpx2=scale_x*vptr(2)
 227                 vpy1=scale_y*vptr(3)
 228                 vpy2=scale_y*vptr(4)
 229         else if (tn.eq.tnvpbl)          then
 230                 vpx1=scale_x*vpbl(1)
 231                 vpx2=scale_x*vpbl(2)
 232                 vpy1=scale_y*vpbl(3)
 233                 vpy2=scale_y*vpbl(4)
 234         else
 235                 vpx1=scale_x*vpbr(1)
 236                 vpx2=scale_x*vpbr(2)
 237                 vpy1=scale_y*vpbr(3)
 238                 vpy2=scale_y*vpbr(4)
 239         endif
 240
 241         if (cent.eq.1) then
 242             x=x/2.
 243             y=y/2.
 244             call gswn(tn,-x,x,-y,y)
 245             call iswn(tn,-x,x,-y,y)
 246         else
 247             call gswn(tn,0.,x,0.,y)
 248             call iswn(tn,0.,x,0.,y)
 249         endif
 250
 251         call gsvp(tn,vpx1,vpx2,vpy1,vpy2)! the window and viewport data
 252         call isvp(tn,vpx1,vpx2,vpy1,vpy2)! and I won't be able to retrieve
 253         return                           ! them by the GQNT
 254         end
 255 C------------------------------------------------------------------------
 256         subroutine      pg_axis(tn)
 257 C
 258 C       pg_axis .......
 259 C
 260 C------------------------------------------------------------------------
 261 C
 262                 include 'petgracom.for'
 263 C
 264 C-------
 265 C
 266         integer*4       tn
 267         integer*4       ierr
 268         real*4          dummy(4)
 269         real*4          frame(4)
 270 C
 271         call gqnt(tn,ierr,frame,dummy)
 272         call iselnt(tn)
 273         tmsi=(frame(2)-frame(1))/100.
 274         call Igset('TMSI',tmsi)
 275         call Igaxis (frame(1),frame(2),0.,0.,frame(1),frame(2),5,'S+-')
 276         tmsi=(frame(4)-frame(3))/100.
 277         call Igset('TMSI',tmsi)
 278         call Igaxis (0.,0.,frame(3),frame(4),frame(3),frame(4),5,'S+-')
 279         call guwk  (wkid,GSUPPD)
 280         return
 281         end
 282
 283 C------------------------------------------------------------------------
 284         subroutine      pg_graph(tn,n,x,y)
 285 C
 286 C       pg_graph .......
 287 C
 288 C------------------------------------------------------------------------
 289 C
 290                 include 'petgracom.for'
 291 C-------
 292         integer*4       tn,n
 293         real*4          x,y
 294 C
 295         call iselnt(tn)
 296         call Igraph(n,x,y,'LA')
 297         call guwk  (wkid,GSUPPD)
 298         return
 299         end
 300
 301 C------------------------------------------------------------------------
 302         subroutine      pg_hist(tn,n,x,y)
 303 C
 304 C       pg_hist .......
 305 C
 306 C------------------------------------------------------------------------
 307 C
 308                 include 'petgracom.for'
 309 C-------
 310         integer*4       tn,n
 311         real*4          x,y
 312 C
 313         call iselnt(tn)
 314         call Ighist(n,x,y,'AB')
 315         call guwk  (wkid,GSUPPD)
 316         return
 317         end
 318
 319 C------------------------------------------------------------------------
 320         subroutine      pg_circle(tn,xc,yc,r)
 321 C
 322 C       pg_circlex .....
 323 C
 324 C------------------------------------------------------------------------
 325 C
 326                 include 'petgracom.for'
 327 C-------
 328         integer*4       tn
 329         real*4          xc,yc,r
 330 C
 331         call iselnt(tn)
 332         call Igarc(xc,yc,r,r,0,0)
 333         call guwk  (wkid,GSUPPD)
 334         return
 335         end
 336 C------------------------------------------------------------------------
 337         subroutine      pg_box(tn,x1,x2,y1,y2)
 338 C
 339 C       pg_circlex .....
 340 C
 341 C------------------------------------------------------------------------
 342 C
 343                 include 'petgracom.for'
 344 C-------
 345         integer*4       tn
 346         real*4          x1,x2
 347         real*4          y1,y2
 348 C
 349         call iselnt(tn)
 350         call Igbox(x1,x2,y1,y2)
 351         call guwk  (wkid,GSUPPD)
 352         return
 353         end
 354
 355 C------------------------------------------------------------------------
 356         subroutine      pg_trackxyzr(p1,p2,party)
 357 C
 358 C       pg_trackxyzr
 359 C
 360 C------------------------------------------------------------------------
 361 C
 362                 include 'petgracom.for'
 363 C-------
 364         integer*4       party
 365         real*4          p1(3),p2(3),a(2),b(2)
 366         real*4          r
 367         integer*4       x,y,z
 368
 369         data    x/1/
 370         data    y/2/
 371         data    z/3/
 372 C
 373         call isln(party)
 374         call iselnt(tnvptl)
 375         a(1)=p1(x)
 376         a(2)=p2(x)
 377         b(1)=p1(y)
 378         b(2)=p2(y)
 379         call ipl(party,a,b)
 380
 381         call iselnt(tnvptr)
 382         r1=sqrt( p1(x)*p1(x) + p1(y)*p1(y))
 383         r2=sqrt( p2(x)*p2(x) + p2(y)*p2(y))
 384         if (p1(x).gt.0) then
 385             a(1) = r1
 386         else
 387             a(1)=-r1
 388         endif
 389         if (p2(x).gt.0) then
 390             a(2) = r2
 391         else
 392             a(2)=-r2
 393         endif
 394         b(1)=p1(z)
 395         b(2)=p2(z)
 396
 397         call ipl(party,a,b)
 398         call isln(1)
 399         call guwk  (wkid,GSUPPD)
 400         return
 401         end
 402 C------------------------------------------------------------------------
 403         subroutine      pg_crimage(name)
 404 C
 405 C       pg_crimage
 406 C
 407 C------------------------------------------------------------------------
 408 C
 409
 410                 include 'petgracom.for'
 411 C-------
 412         character* (*)  name
 413
 414         call Izpict(name,'M')
 415         return
 416         end
 417 C------------------------------------------------------------------------
 418         subroutine      pg_rdimage(name)
 419 C
 420 C       pg_rdimage
 421 C
 422 C------------------------------------------------------------------------
 423 C
 424
 425                 include 'petgracom.for'
 426 C-------
 427         character* (*)  name
 428
 429         call Izpict(name,'D')
 430         return
 431         end
 432 C------------------------------------------------------------------------
 433         subroutine      pg_deimage(name)
 434 C
 435 C       pg_deimage
 436 C
 437 C------------------------------------------------------------------------
 438 C
 439
 440                 include 'petgracom.for'
 441 C-------
 442         character* (*)  name
 443
 444         call Izpict(name,'S')
 445         return
 446         end
 447
 448 C------------------------------------------------------------------------
 449         subroutine      pg_initframe(tn,xmini,xmaxi,ymini,ymaxi,iso,cent)
 450 C
 451 C       pg_initframe .......
 452 C
 453 C------------------------------------------------------------------------
 454 C
 455                 include 'petgracom.for'
 456 C
 457 C-------
 458         integer*4       tn,cent,iso
 459         real*4          xmax,ymax
 460         real*4          xmi,ymi
 461         real*4          xma,yma
 462 c
 463         xmax=xmaxi-xmini
 464         ymax=ymaxi-ymini
 465         if (xmax.eq.0) xmax=1
 466         if (ymax.eq.0) ymax=1
 467         ratio_vp=scale_x/scale_y
 468         ratio_ob=xmax/ymax
 469
 470
 471         if (iso.eq.1) then
 472                 if (ratio_vp.ge.1) then
 473                         if ( ratio_ob.le.1) then
 474                              y=ymax
 475                              x=y*ratio_vp
 476                         else if (ratio_vp.gt.ratio_ob) then
 477                              y=ymax
 478                              x=y*ratio_vp
 479                 else
 480                              x=xmax
 481                              y=x/ratio_vp
 482                         endif
 483                 end if
 484
 485                 if (ratio_vp.lt.1) then
 486                         if ( ratio_ob.gt.1) then
 487                              x=xmax
 488                              y=x/ratio_vp
 489                         else if (ratio_vp.gt.ratio_ob) then
 490                              y=ymax
 491                              x=y*ratio_vp
 492                         else
 493                              x=xmax
 494                              y=x/ratio_vp
 495                         endif
 496                 end if
 497         else
 498                   x=xmax
 499                   y=ymax
 500         endif
 501
 502         if (tn.eq.tnvptl)               then
 503                 vpx1=scale_x*vptl(1)
 504                 vpx2=scale_x*vptl(2)
 505                 vpy1=scale_y*vptl(3)
 506                 vpy2=scale_y*vptl(4)
 507
 508         else if (tn.eq.tnvptr)          then
 509                 vpx1=scale_x*vptr(1)
 510                 vpx2=scale_x*vptr(2)
 511                 vpy1=scale_y*vptr(3)
 512                 vpy2=scale_y*vptr(4)
 513         else if (tn.eq.tnvpbl)          then
 514                 vpx1=scale_x*vpbl(1)
 515                 vpx2=scale_x*vpbl(2)
 516                 vpy1=scale_y*vpbl(3)
 517                 vpy2=scale_y*vpbl(4)
 518         else
 519                 vpx1=scale_x*vpbr(1)
 520                 vpx2=scale_x*vpbr(2)
 521                 vpy1=scale_y*vpbr(3)
 522                 vpy2=scale_y*vpbr(4)
 523         endif
 524
 525
 526
 527         if (cent.eq.1) then
 528             x=x/2.
 529             y=y/2.
 530             call gswn(tn,-x,x,-y,y)
 531             call iswn(tn,-x,x,-y,y)
 532         else
 533             x=x-abs(xmini)
 534             y=y-abs(ymini)
 535             call gswn(tn,xmini, x, ymini, y)
 536             call iswn(tn,xmini, x, ymini, y)
 537         endif
 538         call gsvp(tn,vpx1,vpx2,vpy1,vpy2)! the window and viewport data
 539         call isvp(tn,vpx1,vpx2,vpy1,vpy2)! and I won't be able to retrieve
 540         return                           ! them by the GQNT
 541         end