1!----------------------------------------------------------------------- 2! SWPACK SCREEN DRIVER FOR DEC Visual Fortran September 1997, S.Sakai 3!----------------------------------------------------------------------- 4! 5!************ service routine interface *************** 6! 7module ZMSERV 8 USE DFWIN 9 10 integer(4), public :: hrp,hwp 11 integer(4), parameter :: nbuf=1024 12 integer(4), private :: ndata = 0 13 integer(4), private, dimension(nbuf) :: sd 14 15 INTERFACE 16 INTEGER*4 FUNCTION OpenDCLWindow [C,ALIAS:'_OpenDCLWindow'](x,y,mode) 17 INTEGER*4 :: x [VALUE] 18 INTEGER*4 :: y [VALUE] 19 INTEGER*4 :: mode [VALUE] 20 END FUNCTION 21 22 INTEGER*4 FUNCTION DCLPolyPolyLine [C,ALIAS:'_DCLPolyPolyLine'](point,pnum,lnum) 23 INTEGER*4 :: point [VALUE] 24 INTEGER*4 :: pnum [VALUE] 25 INTEGER*4 :: lnum [VALUE] 26 END FUNCTION 27 28 INTEGER*4 FUNCTION DCLBackgroundColor[C,ALIAS:'_DCLBackgroundColor'](red,green,blue) 29 INTEGER*4 :: red [VALUE] 30 INTEGER*4 :: green [VALUE] 31 INTEGER*4 :: blue [VALUE] 32 END FUNCTION DCLBackgroundColor 33 34 INTEGER*4 FUNCTION DCLPolyPolygon [C,ALIAS:'_DCLPolyPolygon'] & 35 & (point,pnum,lnum) 36 INTEGER*4 :: point [VALUE] 37 INTEGER*4 :: pnum [VALUE] 38 INTEGER*4 :: lnum [VALUE] 39 END FUNCTION DCLPolyPolygon 40 41 INTEGER*4 FUNCTION DCLGetMouseClick [C,ALIAS:'_DCLGetMouseClick'](mf) 42 INTEGER*4 :: mf [VALUE] 43 END FUNCTION DCLGetMouseClick 44 45 INTEGER*4 FUNCTION DCLGetKeyCode [C,ALIAS:'_DCLGetKeyCode'](kc) 46 INTEGER*4 :: kc [VALUE] 47 END FUNCTION DCLGetKeyCode 48 49 INTEGER*4 FUNCTION ChangeDCLPen [C,ALIAS:'_ChangeDCLPen'] & 50 & (Width,Red,Green,Blue) 51 INTEGER*4 :: Width [VALUE] 52 INTEGER*4 :: Red [VALUE] 53 INTEGER*4 :: Green [VALUE] 54 INTEGER*4 :: Blue [VALUE] 55 END FUNCTION ChangeDCLPen 56 57 INTEGER*4 FUNCTION ChangeDCLBrush [C,ALIAS:'_ChangeDCLBrush'] & 58 & (pBmp,BmpSize,Red,Green,Blue) 59 INTEGER*4 :: pBmp [VALUE] 60 INTEGER*4 :: BmpSize [VALUE] 61 INTEGER*4 :: Red [VALUE] 62 INTEGER*4 :: Green [VALUE] 63 INTEGER*4 :: Blue [VALUE] 64 END FUNCTION ChangeDCLBrush 65 66 INTEGER*4 FUNCTION DCLNewPage [C,ALIAS:'_DCLNewPage'](Red,Green,Blue) 67 INTEGER*4 :: Red [VALUE] 68 INTEGER*4 :: Green [VALUE] 69 INTEGER*4 :: Blue [VALUE] 70 END FUNCTION DCLNewPage 71 72 INTEGER*4 FUNCTION DCLStatusBarString [C,ALIAS:'_DCLStatusBarString'] & 73 & (strStatusBar,nPane) 74 INTEGER*4 :: strStatusBar [VALUE] 75 INTEGER*4 :: nPane 76 END FUNCTION DCLStatusBarString 77 78 INTEGER*4 FUNCTION DCLTitleBarString [C,ALIAS:'_DCLTitleBarString'] & 79 & (strTitle) 80 INTEGER*4 :: strTitle [VALUE] 81 END FUNCTION DCLTitleBarString 82 83 INTEGER*4 FUNCTION DCLPageUpdate [C,ALIAS:'_DCLPageUpdate']() 84 END FUNCTION DCLPageUpdate 85 86 INTEGER*4 FUNCTION DCLExitProcess [C,ALIAS:'_DCLExitProcess']() 87 END FUNCTION DCLExitProcess 88 89 INTEGER*4 FUNCTION DCLDrawImage [C,ALIAS:'_DCLDrawImage'] & 90 & (left,top,width,height,bmpBits,bif) 91 INTEGER*4 :: left [VALUE] 92 INTEGER*4 :: top [VALUE] 93 INTEGER*4 :: width [VALUE] 94 INTEGER*4 :: height [VALUE] 95 INTEGER*4 :: bmpBits [VALUE] 96 INTEGER*4 :: bif [VALUE] 97 END FUNCTION DCLDrawImage 98 99 INTEGER*4 FUNCTION DCLSwapActivePage [C,ALIAS:'_DCLSwapActivePage']() 100 END FUNCTION DCLSwapActivePage 101 102 INTEGER*4 FUNCTION DCLSwapBMPOutMode [C,ALIAS:'_DCLSwapBMPOutMode']() 103 END FUNCTION DCLSwapBMPOutMode 104 105 INTEGER*4 FUNCTION DCLSwapWritePage [C,ALIAS:'_DCLSwapWritePage']() 106 END FUNCTION DCLSwapWritePage 107 108 INTEGER*4 FUNCTION DCLBMPFilename [C,ALIAS:'_DCLBMPFilename'] & 109 & (FileName,Numbers) 110 INTEGER*4 :: FileName [VALUE] 111 INTEGER*4 :: Numbers [VALUE] 112 END FUNCTION DCLBMPFilename 113 114 INTEGER*4 FUNCTION DCLGetPrinterdpi [C,ALIAS:'_DCLGetPrinterdpi'] & 115 & (iwidth,iheight) 116 INTEGER*4 :: iwidth [VALUE] 117 INTEGER*4 :: iheight [VALUE] 118 END FUNCTION DCLGetPrinterdpi 119 120 INTEGER*4 FUNCTION DCLGetDCSize [C,ALIAS:'_DCLGetDCSize'] & 121 & (iwidth,iheight) 122 INTEGER*4 :: iwidth [VALUE] 123 INTEGER*4 :: iheight [VALUE] 124 END FUNCTION DCLGetDCSize 125 126 INTEGER*4 FUNCTION DCLGetPrinterSize [C,ALIAS:'_DCLGetPrinterSize'] & 127 & (iwidth,iheight) 128 INTEGER*4 :: iwidth [VALUE] 129 INTEGER*4 :: iheight [VALUE] 130 END FUNCTION DCLGetPrinterSize 131 132 INTEGER*4 FUNCTION DCLGetPrintBMPdpi [C,ALIAS:'_DCLGetPrintBMPdpi'] & 133 & (idpi) 134 INTEGER*4 :: idpi [VALUE] 135 END FUNCTION DCLGetPrintBMPdpi 136 137 END INTERFACE 138 139!DEC$ ATTRIBUTES DLLIMPORT::DCLGETPRINTERDPI 140!DEC$ ATTRIBUTES DLLIMPORT::DCLGETDCSIZE 141!DEC$ ATTRIBUTES DLLIMPORT::DCLGETPRINTERSIZE 142!DEC$ ATTRIBUTES DLLIMPORT::DCLGETPRINTBMPDPI 143!DEC$ ATTRIBUTES DLLIMPORT::OPENDCLWINDOW 144!DEC$ ATTRIBUTES DLLIMPORT::DCLPOLYPOLYLINE 145!DEC$ ATTRIBUTES DLLIMPORT::DCLBACKGROUNDCOLOR 146!DEC$ ATTRIBUTES DLLIMPORT::DCLPOLYPOLYGON 147!DEC$ ATTRIBUTES DLLIMPORT::DCLGETMOUSECLICK 148!DEC$ ATTRIBUTES DLLIMPORT::DCLGETKEYCODE 149!DEC$ ATTRIBUTES DLLIMPORT::CHANGEDCLPEN 150!DEC$ ATTRIBUTES DLLIMPORT::CHANGEDCLBRUSH 151!DEC$ ATTRIBUTES DLLIMPORT::DCLNEWPAGE 152!DEC$ ATTRIBUTES DLLIMPORT::DCLSTATUSBARSTRING 153!DEC$ ATTRIBUTES DLLIMPORT::DCLTITLEBARSTRING 154!DEC$ ATTRIBUTES DLLIMPORT::DCLPAGEUPDATE 155!DEC$ ATTRIBUTES DLLIMPORT::DCLEXITPROCESS 156!DEC$ ATTRIBUTES DLLIMPORT::DCLDRAWIMAGE 157!DEC$ ATTRIBUTES DLLIMPORT::DCLSWAPACTIVEPAGE 158!DEC$ ATTRIBUTES DLLIMPORT::DCLSWAPBMPOUTMODE 159!DEC$ ATTRIBUTES DLLIMPORT::DCLSWAPWRITEPAGE 160!DEC$ ATTRIBUTES DLLIMPORT::DCLBMPFILENAME 161 162end module ZMSERV 163 164 165module CommentPut 166use ZMSERV 167contains 168 subroutine ZMCMNT(ipos, comment) 169 character(len=*) :: comment 170 character(len=80) :: comz 171 integer :: ipos 172 173 comz=comment 174 l1 = min(len_trim(comz)+1, len(comz)) 175 comz(l1:l1) = char(0) 176 177 if(ipos==0)then 178 OtbRes=DCLTitleBarString(2) 179 else 180 OtbRes=DCLStatusBarString(LOC(comz),0) 181 end if 182 183 end subroutine 184end module CommentPut 185! 186!************* coordinate object ***************** 187! 188module ZMCOORD 189 use ZMSERV 190 integer, private :: nxmin, nxmax, nymin, nymax, nvx, nvy 191 integer :: mode0 192 193contains 194 subroutine ZMCOINI (iheight, iwidth) 195 nvx = iwidth - 1 196 nxmin = 0 197 nxmax = nxmin + nvx 198 199 nvy = iheight - 1 200 nymin = 0 201 nymax = nymin + nvy 202 end subroutine 203 204 subroutine ZMGVPT(ixmin, ixmax, iymin, iymax) 205 ixmin = nxmin 206 ixmax = nxmax 207 iymin = nymin 208 iymax = nymax 209 end subroutine 210 211 subroutine ZMFINT(wx, wy, iwx, iwy) 212 iwx = nint(wx) 213 iwy = nvy - nint(wy) 214 end subroutine 215 216 subroutine ZMIINT(iwx, iwy, wx, wy) 217 wx = iwx 218 wy = nvy - iwy 219 end subroutine 220 221 subroutine ZMQRCT(xwmin, xwmax, ywmin, ywmax, unit) 222 xwmin = 0 223 ywmin = 0 224 xwmax = nvx 225 ywmax = nvy 226 if(mode0.eq.1) then 227 unit = 20./nvy 228 else 229!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 230 OtbRes=DCLGetPrintBMPdpi(loc(idpi)) 231 unit = 2.54/idpi 232 end if 233 234 end subroutine 235 236 subroutine ZMSTAT 237 OtbRes=DCLGetPrinterdpi(loc(ixdpi),loc(iydpi)) 238 OtbRes=DCLGetPrinterSize(loc(ixsize),loc(iysize)) 239 OtbRes=DCLGetPrintBMPdpi(loc(ibdpi)) 240 241 write(*,'(A,2I6)') ' --- PRINTER RESOLUSION :', ixdpi, iydpi 242 write(*,'(A,2I6)') ' --- PRINTABLE SIZE :', ixsize, iysize 243 write(*,'(A,2I6)') ' --- PRINTING DPI :', ibdpi 244 end subroutine 245 246end module ZMCOORD 247! 248!*************** colormap object ***************** 249! 250module ZMCOLORMAP 251 252 use ZMSERV 253 254 logical, private :: l_full_color = .false. 255 integer(4), private :: ipalette 256 257 integer(4), private, parameter :: nplmax = 256 258 integer(4), private, dimension(nplmax) :: ir, ig, ib 259 integer(4), private :: max_pal 260 261 integer(4) :: OtbRes 262 263contains 264 integer(4) function OtbZMCOLOR(index,number) 265 integer(4) :: index,number,itmp,ipp 266 267! itmp=number 268! if(itmp==0) then 269! itmp=1 270! end if 271! ipp = mod(itmp-1, max_pal-1)+2 272 ipp=number+1 273 if(index==1)then 274 OtbZMCOLOR=ir(ipp) 275 else if(index==2)then 276 OtbZMCOLOR=ig(ipp) 277 else 278 OtbZMCOLOR=ib(ipp) 279 end if 280!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! 281!インデックスが0のやつに対しての色が変だよね?? 282!少なくともユニックスと違う。 283!と思ったけど、ペンのIndexが0番になってる。 284!正しくは1番のはず。 285 286! if(number==0)then 287! OtbZMCOLOR=0 288! end if 289 290 end function 291 292 integer(4) function OtbZMCOLOR2(index,number) 293 integer(4) :: index,number 294 integer(4) :: ipp 295 296 ipp=number 297 298 if(index==1)then 299 OtbZMCOLOR2=ir(ipp) 300 else if(index==2)then 301 OtbZMCOLOR2=ig(ipp) 302 else 303 OtbZMCOLOR2=ib(ipp) 304 end if 305 306 end function 307 308 subroutine ZMCLINI(ccfile) 309 character(len=*) :: ccfile 310 character(len=64) cmsg 311 312 iu = iufopn() 313 open(iu, file=ccfile) 314 read(iu, '(i3)') max_pal 315 if (max_pal.gt.nplmax) then 316 max_pal = nplmax 317 cmsg='color numbers greater than xx are ignored.' 318 write(cmsg(28:29),'(i2)') nplmax 319 call msgdmp('w', 'zmdopn', cmsg) 320 endif 321 322 ns = 2**8 323 do i=1, max_pal 324 read(iu, '(3i6)') ir0, ig0, ib0 325 ir(i) = ir0 / ns 326 ig(i) = ig0 / ns 327 ib(i) = ib0 / ns 328 end do 329 330 close(iu) 331 end subroutine 332 333 subroutine ZMQFCC(lflag) 334 logical lflag 335 lflag = .TRUE. 336 end subroutine 337 338 subroutine ZMSFCM(lflag) 339 logical lflag 340 l_full_color = lflag 341 end subroutine 342 343 function ZMQFCM 344 logical zmqfcm 345 zmqfcm = l_full_color 346 end function 347 348end module ZMCOLORMAP 349! 350!*************** bitmap object ******************* 351! 352module ZMBITMAP 353 354 use ZMSERV 355 use ZMCOLORMAP 356 357 integer(4), private, parameter :: ntmax=100, npat=500, nch=10000 358 integer(2), private :: ipat(npat,2),ipos(npat),ilen(npat),nrec,iwdth 359 integer(1), private :: idata(nch) 360 integer, private :: jwtrot=1, i_rgb 361 362 integer(4) :: OtbRed,OtbGreen,OtbBlue,iwdth_brush 363 364 365contains 366 subroutine ZMBMINI(cbfile) 367 character cbfile*(*) 368 iu = iufopn() 369 open (iu, file=cbfile, form='unformatted') 370 read (iu) nrec, iwdth, ipat, ipos, ilen, idata 371 372 close(iu) 373 end subroutine 374 375 subroutine ZMSTCL(irgb) 376 i_rgb = irgb*256 377 end subroutine 378 379 subroutine ZMSPATTERN(itpat) 380 integer(1), dimension(4) :: itmp 381 integer :: itpz=-1, ifz=-1, icz=-1 382 character cmsg*64 383 384 integer(2),dimension(128) :: Otb_BmpPat 385 icol = itpat / 1000 386 itptn = itpat - icol*1000 387 if(zmqfcm()) then 388 if(itptn.eq.itpz .and. i_rgb.eq.ifz) return 389 ifz = i_rgb 390 icz = -1 391 else 392 if(itptn.eq.itpz .and. icol.eq.icz) return 393 icz = icol 394 ifz = -1 395 end if 396 itpz = itptn 397 398 itrec = 1 399 do while (ipat(itrec, jwtrot).ne.itptn) 400 itrec = itrec + 1 401 if(itrec .gt. nrec) then 402 cmsg = 'pattern (xxxxx) is not defined.' 403 write(cmsg(10:14), '(i5)') itptn 404 call msgdmp('w', 'zmspattern', cmsg) 405 exit 406 end if 407 end do 408 409 jlen = ilen(itrec) 410 itmp = 0 411 iword = iwdth/8 412 413 KOtb=1 414 do i=1, iwdth 415 do j=1, iword 416 itmp = 0 417 jpos = ipos(itrec) + mod((i-1)*iword+j-1, jlen*iword) 418 itmp(1) = idata(jpos) 419 int4 = not(transfer(itmp, int4)) 420 Otb_BmpPat(KOtb)=int4 421 KOtb=KOtb+1 422 end do 423 end do 424 425 if(zmqfcm()) then 426 OtbRed=i_rgb / 16777216 427 i_rgb = i_rgb - OtbRed * 16777216 428 OtbGreen=i_rgb / 65536 429 i_rgb = i_rgb - OtbGreen * 65536 430 OtbBlue=i_rgb/256 431 iwdth_brush=iwdth 432 OtbRes=ChangeDCLBrush(LOC(Otb_BmpPat(1)),iwdth_brush, & 433 & OtbRed,OtbGreen,OtbBlue) 434 else 435 iwdth_brush=iwdth 436 OtbRes=ChangeDCLBrush(LOC(Otb_BmpPat(1)),iwdth_brush, & 437 & OtbZMCOLOR2(1,icol+1),OtbZMCOLOR2(2,icol+1),OtbZMCOLOR2(3,icol+1)) 438 end if 439 end subroutine 440 441 subroutine ZMSROT(iwtrot) 442 jwtrot=iwtrot 443 end subroutine 444end module 445! 446!***************** LINE OBJECT ******************* 447! 448module ZMLINE 449 450 use ZMSERV 451 use ZMCOORD 452 use ZMCOLORMAP 453 use DFWIN 454 455 integer(4), private, parameter :: nmax =100 456 integer(4), private :: ix(nmax), iy(nmax) 457 integer(4), private :: ndata=0, iwidth=1, icolor=1, i_rgb=0, iwz=-1, icz=-1, ifz=-1 458 459 TYPE(T_POINT),DIMENSION(nmax) :: gpoint 460 INTEGER*4,DIMENSION(255) :: gpolypolyline 461 integer(4) :: OtbRed,OtbGreen,OtbBlue 462 463contains 464 subroutine ZMQCLC(lflag) 465 logical lflag 466 lflag=.true. 467 end subroutine 468 469 subroutine ZMQWDC(lflag) 470 logical lflag 471 lflag=.true. 472 end subroutine 473 474 subroutine ZMSCLI(index) 475 icolor = index 476 end subroutine 477 478 subroutine ZMSLCL(irgb) 479 i_rgb = irgb*256 480 end subroutine 481 482 subroutine ZMSWDI(index) 483 iwidth = index 484 if(iwidth == 0) iwidth = 1 485 iwidth = (iwidth+1)/2 486 end subroutine 487 488 subroutine ZMGOPN 489 490 if(zmqfcm()) then 491 OtbRed=i_rgb / 16777216 492 i_rgb = i_rgb - OtbRed * 16777216 493 OtbGreen=i_rgb / 65536 494 i_rgb = i_rgb - OtbGreen * 65536 495 OtbBlue=i_rgb/256 496 497 OtbRes=ChangeDCLPen(iwidth,OtbRed,OtbGreen,OtbBlue) 498 ifz = i_rgb 499 icz = -1 500 iwz = iwidth 501 else 502 OtbRes=ChangeDCLPen(iwidth,OtbZMCOLOR2(1,icolor+1),OtbZMCOLOR2(2,icolor+1),OtbZMCOLOR2(3,icolor+1)) 503 icz = icolor 504 ifz = -1 505 iwz = iwidth 506 end if 507 end subroutine 508 509 subroutine ZMGPLT(xx, yy) 510 ndata= ndata + 1 511 call zmfint(xx, yy, ix(ndata), iy(ndata)) 512 if (ndata == nmax ) then 513 call zmpline 514 ix(1) = ix(ndata) 515 iy(1) = iy(ndata) 516 ndata = 1 517 end if 518 end subroutine 519 520 subroutine ZMGMOV(xx, yy) 521 call zmpline 522 ndata = 1 523 call zmfint(xx, yy, ix(ndata), iy(ndata)) 524 end subroutine 525 526 subroutine ZMGCLS 527 call zmpline 528 ndata = 0 529! OtbRes=DCLPageUpdate() 530 end subroutine 531 532 subroutine ZMPLINE 533 if(ndata >= 2) then 534 535 gpolypolyline(1)=ndata 536 537 do i =1, ndata 538 gpoint(i)%x=ix(i) 539 gpoint(i)%y=iy(i) 540 end do 541 OtbRes=DCLPolyPolyLine(LOC(gpoint(1)),LOC(gpolypolyline(1)),1) 542 543 end if 544 end subroutine 545end module ZMLINE 546! 547!****************** TONE OBJECT ******************* 548! 549module ZMTONE 550 use DFWIN 551 use ZMSERV 552 use ZMCOORD 553 use ZMCOLORMAP 554 use ZMBITMAP 555 556contains 557 subroutine ZMQTNC(lflag) 558 logical lflag 559 lflag=.TRUE. 560 end subroutine 561 562 subroutine ZMGTON(np, wpx, wpy, itpat) 563 real, dimension(np) :: wpx, wpy 564 TYPE(T_POINT),DIMENSION(np) :: gpoint 565 INTEGER*4,DIMENSION(np) :: gpolypolygon 566 567 call zmspattern(itpat) 568 569 gpolypolygon(1)=np 570 do i=1, np 571 call zmfint(wpx(i), wpy(i), ix, iy) 572 gpoint(i)%x=ix 573 gpoint(i)%y=iy 574 end do 575 OtbRes=DCLPolyPolygon(LOC(gpoint(1)),LOC(gpolypolygon(1)),1) 576 577 end subroutine 578end module ZMTONE 579! 580!****************** IMAGE OBJECT ***************** 581! 582module ZMIMAGE 583 584 use DFWIN 585 use ZMSERV 586 use ZMCOLORMAP 587 use CommentPut 588 589 integer(4), private :: ix0, iy0, iy1, iy2, iy3, iwd, ipos, iend, idata 590 integer(1), private, dimension(4) :: imd 591! integer(4), parameter :: nline = 16 592 integer(4) :: nline = 16 593 character(len=16), private :: cmnt 594 595 596 integer(1),allocatable :: img(:) 597 integer(4) :: ui 598 599 type(T_BITMAPINFO) :: bmi 600 601contains 602 subroutine ZMQIMC(lflag) 603 logical lflag 604 lflag = .TRUE. 605 end subroutine 606 607 subroutine ZMihead 608 609 ifrac = (iy1-iy0)*100/(iy3-iy0) 610 write(cmnt, '(a,i3,a)') 'image:', ifrac, '%' 611 call zmcmnt(1, cmnt) 612 613 iy2 = min(iy3, iy1+nline-1) 614 iht = iy2 - iy1 + 1 615 if(iht /= 0) then 616 bmi%bmiHeader%biSize = 40 617 bmi%bmiHeader%biPlanes = 1 618 bmi%bmiHeader%biWidth = iwd 619 bmi%bmiHeader%biHeight = -iht 620 bmi%bmiHeader%biBitCount = 32 621 bmi%bmiHeader%biClrImportant = 0 622 bmi%bmiHeader%biClrUsed = 0 623 bmi%bmiHeader%biCompression = BI_RGB 624 bmi%bmiHeader%biSizeImage = 0 625 bmi%bmiHeader%biXPelsPerMeter = 0 626 bmi%bmiHeader%biYPelsPerMeter = 0 627 628 idata = 0 629 iend = iwd*iht 630 ui=1 631 632 end if 633 end subroutine 634 635 subroutine ZMIOPN(iwx, iwy, imw, imh) 636 ix0 = iwx 637 iy0 = iwy 638 iy3 = iwy + imh -1 639 iwd = imw 640 641 ALLOCATE(img((imw+4)*imh*4)) 642 643! nline=imh 644 645 iy1 = iwy 646 call zmihead 647 end subroutine 648 649 subroutine ZMIDAT(image, nlen) 650 integer(4) :: image(*), int4 651 652 do i=1, nlen 653 idata = idata + 1 654 img(ui)=OtbZMCOLOR2(3,image(i)+1) 655 ui=ui+1 656 img(ui)=OtbZMCOLOR2(2,image(i)+1) 657 ui=ui+1 658 img(ui)=OtbZMCOLOR2(1,image(i)+1) 659 ui=ui+1 660 img(ui)=0 661 ui=ui+1 662 if (idata == iend) then 663 OtbRes=DCLDrawImage(ix0,iy1,bmi%bmiHeader%biWidth, & 664 & -( bmi%bmiHeader%biHeight),LOC(img(1)),LOC(bmi)) 665 iy1 = iy2 + 1 666 call zmihead 667 end if 668 end do 669 end subroutine 670 671 subroutine ZMICLS 672 DEALLOCATE(img) 673 end subroutine 674 675!------------------- Full color image ----------------------------------- 676 677 subroutine ZMICLR(image, nlen) 678 integer(4) :: image(*) 679 680 do i=1, nlen 681 idata = idata + 1 682 img(ui) = ishft(iand(image(i), #0000FF),0) 683 ui=ui+1 684 img(ui) = ishft(iand(image(i), #00FF00),-8) 685 ui=ui+1 686 img(ui) = ishft(iand(image(i), #FF0000),-16) 687 ui=ui+1 688 img(ui)=0 689 ui=ui+1 690 if (idata == iend) then 691 OtbRes=DCLDrawImage(ix0,iy1,bmi%bmiHeader%biWidth, & 692 & -( bmi%bmiHeader%biHeight),LOC(img(1)),LOC(bmi)) 693 iy1 = iy2 + 1 694 call zmihead 695 end if 696 end do 697 698 end subroutine 699end module ZMIMAGE 700! 701!***************** MOUSE OBJECT ****************** 702! 703module ZMMOUSE 704contains 705 subroutine ZMQPTC(LFLAG) 706 logical lflag 707 LFLAG = .FALSE. 708 end subroutine 709 710 subroutine ZMQPNT(WX, WY, MB) 711 end subroutine 712end module ZMMOUSE 713! 714!**************** ZMPACK CONTROL ***************** 715! 716module ZMPACK 717 718 use ZMSERV 719 use ZMLINE 720 use ZMTONE 721 use ZMIMAGE 722 use ZMMOUSE 723 USE SERVICE 724 use CommentPut 725 726 type T_MOUSEINFO 727! sequence 728 INTEGER :: bMouseClick; 729 INTEGER :: xPos 730 INTEGER :: yPos; 731 end type T_MOUSEINFO 732 733 integer(4) ivis, iact ! visual page and active page 734 logical laltz, lstatus 735 736 integer(4) :: kc 737 type(T_MOUSEINFO) :: mf 738 739contains 740 741 subroutine zmdopn(iwidth, iheight, iposx, iposy, lwait, lalt, ldump, & 742 & ccfile, cbfile, cout, mode) 743 744 character(len=*) :: ccfile, cbfile, cout 745 character(len=80) :: comment,cbmp 746 logical lwait, lalt, ldump, ldisp 747 integer(4) :: mode, ixmax, iymax ,l1 748 749 mode0 = mode 750 ldisp = mode .eq. 1 751 if(mode.eq.1)then 752 OtbRes=OpenDCLWindow(iwidth, iheight,mode) 753 end if 754 if(mode.eq.2) then 755 OtbRes=OpenDCLWindow(iwidth, iheight,mode) 756 OtbRes=DCLGetDCSize(loc(ixmax),loc(iymax)) 757 iwidth = ixmax 758 iheight = iymax 759 end if 760 761 lenc = len_trim(cout) 762 lw = (lenc+3)/4 763 cbmp = cout 764 l1 = min(len_trim(cout)+1, len(cout)) 765 cbmp(l1:l1) = char(0) 766 OtbRes=DCLBMPFilename(LOC(cbmp),l1-1) 767 768 call osgarg(0, comment) 769 ipos = index(comment, '\', .true.) 770 comment = comment(ipos+1:) 771 ipos = len_trim(comment) 772 comment(ipos+1:) = ' - (dcl-5.0)' 773 call zmcmnt(0, comment) 774 laltz = lalt 775 776 call zmcoini(iheight, iwidth) ! Initialize coordinate 777 call zmclini(ccfile) ! Set up colormap 778 call zmbmini(cbfile) ! Set up Tone pattern 779 780 OtbRes=DCLNewPage(OtbZMCOLOR2(1,1),OtbZMCOLOR2(2,1),OtbZMCOLOR2(3,1)) 781 OtbRes=DCLBackgroundColor(OtbZMCOLOR2(1,1),OtbZMCOLOR2(2,1),OtbZMCOLOR2(3,1)) 782 if(lwait) then 783 call zmpause 784 endif 785 786 if(laltz) then 787 call fsleep (300) 788 789 OtbRes=DCLSwapWritePage() 790 OtbRes=DCLNewPage(OtbZMCOLOR2(1,1),OtbZMCOLOR2(2,1),OtbZMCOLOR2(3,1)) 791 OtbRes=DCLBackgroundColor(OtbZMCOLOR2(1,1),OtbZMCOLOR2(2,1),OtbZMCOLOR2(3,1)) 792 793 endif 794 795 call ZMGVPT (nxmin, nxmax, nymin, nymax) 796 797 end subroutine 798 799 subroutine ZMDCLS (lwait) 800 logical lwait 801 802 if(lwait) then 803 call zmpause 804 endif 805 806 OtbRes=DCLExitProcess() 807 808 end subroutine 809 810 subroutine ZMPOPN 811 end subroutine 812 813 subroutine ZMPCLS (lwait, ldump) 814 logical lwait, ldump 815 816 if(ldump) then 817 OtbRes=DCLSWAPBMPOUTMODE() 818 end if 819 820 call zmcmnt(1, 'Completed.') 821 OtbRes=DCLPageUpdate() 822 823 if(laltz) then 824 OtbRes=DCLSwapActivePage() 825 OtbRes=DCLSwapWritePage() 826 endif 827 828 if(lwait) then 829 call zmpause 830 endif 831 832 OtbRes=DCLNewPage(OtbZMCOLOR2(1,1),OtbZMCOLOR2(2,1),OtbZMCOLOR2(3,1)) 833 OtbRes=DCLBackgroundColor(OtbZMCOLOR2(1,1),OtbZMCOLOR2(2,1),OtbZMCOLOR2(3,1)) 834 835 end subroutine 836 837 subroutine ZMOOPN(cobj, comm) 838 character(len=*) :: cobj, comm 839 840 call zmcmnt(1, cobj) 841 end subroutine 842 843 subroutine ZMOCLS(cobj) 844 character(len=*) :: cobj 845! call zmflush 846 end subroutine 847 848 subroutine ZMPAUSE 849 850 do 851 OtbRes=DCLGetMouseClick(LOC(mf)) 852 idat = mf.bMouseClick 853 ix = mf.xPos 854 iy = mf.yPos 855 856 OtbRes=DCLGetKeyCode(LOC(kc)) 857 858 if(kc == 16) then 859 OtbRes=DCLExitProcess() 860 stop 861 else if(idat==1 .or. kc/=0)then 862 exit 863 end if 864 call fsleep (100) 865 end do 866 end subroutine 867end module zmpack 868