RMAGEN84/SRC84/WINNEW.F90

!IPK  LAST UPDATE SEP 23 2015  REVISE org NUMBERS
      SUBROUTINE get_label(dlin,title)

      use winteracter

      implicit none

      include 'd.inc'

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE
      INTEGER           :: ITYPE,ierr

      character*40 dlin,title
      write(90,'(a)') 'dlin',dlin
      write(90,'(a)') 'lind',title

      call wdialogload(IDD_DIALOG1)
      ierr=infoerror(1)

      write(90,'(a)') 'dlin-0',dlin
      write(90,'(a)') 'lind-0',title
      CALL WDialogPutString(idf_label5,dlin)
      ierr=infoerror(1)

      CALL WDialogSelect(IDD_DIALOG1)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)



        do
!!           CALL WMessage(ITYPE,MESSAGE)
!
!  Branch depending on type of message.
!
                IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN

                  call wdialoggetstring(idf_string24,title)
      write(90,'(a)') 'dlin-1',dlin
      write(90,'(a)') 'lind-1',title
                   return
                endif
		        return
        enddo

      return
   
      end

! ----------------------------------------------------------------------------

      subroutine labl(x,y,llen,ht,string)
      USE WINTERACTER
      character*(*)  string
      integer       llen
      character*80  outstring
      data rsclx,rscly/100.,100./
      DO  i=1,llen
        outstring(i:i)=string(i:i)
      ENDDO

      ix=x*rsclx
      iy=y*rscly
      CALL gim_a_string(ix,iy,ht,outstring,llen)
      RETURN
      end

      SUBROUTINE gim_a_string(ix,iy,ht,outstring,lenth)
      USE WINTERACTER
      CHARACTER*(*) OUTSTRING
      CALL WGrTextFont(102,0,ht*0.0133333,ht*0.04)
!      CALL IGrCharSet(' ')
!      CALL IGrCharSize(ht,ht)
      call WGrTextOrientation(0)
!      CALL IGrCharJustify('L')
      x=ix/100.
      y=iy/100.
      CALL WGrTextString(x,y,outstring(:lenth))

!      CALL IGrCharOut(x,y,outstring(:lenth))
      RETURN
      END SUBROUTINE

      SUBROUTINE change_color(icl)
      USE WINTERACTER
      DIMENSION ICOLRS(0:16)

      data icolrs/224,0,160,175,159,112,128,96,80,&
                     48,63,24,16,47,223,7,224/
!   240
      ICV=ICOLRS(mod(ICL,16))
      CALL IGrcolourN(ICV)
      RETURN
      END SUBROUTINE

      SUBROUTINE fill_a_polygon(x,y,npts)
      USE WINTERACTER
      dimension x(*),y(*)
      CALL IGrFillPattern(4,0,0)
      call IGrPolygonComplex(x,y,npts)
      RETURN
      END SUBROUTINE

      SUBROUTINE gim_a_charac(key,cha,x,y)
      USE WINTERACTER
      CHARACTER*(*) cha
      INTEGER            :: ITYPE,  KEY
      INTEGER, PARAMETER :: ID_EXIT    = 40002

      TYPE(WIN_MESSAGE)  :: MESSAGE

  100 CONTINUE
      
      CALL WMessage(ITYPE, MESSAGE)
      SELECT CASE (ITYPE)
        CASE (KeyDown)                 ! Key pressed
          KEY    = MESSAGE%VALUE1
          MOUSEX = MESSAGE%X
          MOUSEY = MESSAGE%Y
 
!     check key status
          if(KEY .lt. 127) then
            cha=char(KEY)
            go to 250
          else
            go to 100
          endif
        CASE (MenuSelect)              ! Menu item selected
          SELECT CASE (MESSAGE%VALUE1)
            CASE (ID_EXIT)
            call WindowClose
          END SELECT
      END SELECT
      GO TO 100
  250 CONTINUE
      RETURN
      END SUBROUTINE

      SUBROUTINE clear_screen
      USE WINTERACTER
      INCLUDE 'TXFRM.COM'
      TYPE (WIN_FONT) :: FONT
!      FONT%IBCOL = TextWhite
!      CALL WindowFont(FONT)
!     IRGB = WRGB(220,220,220) 
      CALL WindowClear(rgb=irgb) ! clear   to yellow
      RETURN
      END SUBROUTINE

      SUBROUTINE gim_a_line(ix,iy)
      USE WINTERACTER
      x=ix/100.
      y=iy/100.
      CALL IGrLineto(x,y)
      RETURN
      END SUBROUTINE

      SUBROUTINE move_da_pointer(ix, iy)
      USE WINTERACTER
      x=ix/100.
      y=iy/100.
      CALL IGrMoveto(x,y)
      RETURN
      END SUBROUTINE

      SUBROUTINE clear_box
      USE WINTERACTER

      REAL HSIZE
	  COMMON /SSIZE/  HSIZE

      dimension x(4),y(4)
        x(1)=0.
        x(2)=HSIZE
        x(3)=HSIZE
        x(4)=0.
        y(1)=7.50
        y(2)=7.50
        y(3)=8.0
        y(4)=8.0

        call Rwhite

        call IGrColourN(48)
        
        CALL IGrFillPattern(4,0,0)

        call IGrPolygonComplex(x,y,4)

        call RBlue

        return
      END SUBROUTINE

      SUBROUTINE get_rid_window
      USE WINTERACTER
      call WindowClose
      RETURN
      END SUBROUTINE

      SUBROUTINE flush_screen
      RETURN
      END SUBROUTINE

      SUBROUTINE RMINFO

      use winteracter

      implicit none

      include 'd.inc'
      CHARACTER(LEN=255)  :: FNAME
      CHARACTER(LEN=3)    :: SUB
      LOGICAL             :: OPENED
      INTEGER             :: IERR

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE


      call wdialogload(IDD_DIALOG09)
      ierr=infoerror(1)

      CALL WDialogSelect(IDD_DIALOG09)
      ierr=infoerror(1)
 
      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      

      do
         IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN

           return
         endif
		 return
      enddo

      RETURN
      END SUBROUTINE

      SUBROUTINE GETMDIS(nmapf,nsigf,icolsw,rad,colint)

      use winteracter

      implicit none

      include 'd.inc'
      CHARACTER(LEN=255)  :: FNAME
      CHARACTER(LEN=3)    :: SUB
      LOGICAL             :: OPENED
      INTEGER             :: IERR,NMAPF,NSIGF,icolsw
      REAL                :: RAD,COLINT

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE


      call wdialogload(IDD_DIALOG10)
      ierr=infoerror(1)

      CALL WDialogSelect(IDD_DIALOG10)
      ierr=infoerror(1)

      CALL WDialogPutINTEGER(IDF_INTEGER1,nsigf)

      CALL WDialogPutINTEGER(IDF_INTEGER2,nmapf)

      CALL WDialogPutReal(IDF_REAL1,rad)

      CALL WDialogPutReal(IDF_REAL2,colint)

      call wdialogputcheckbox(idf_check1,icolsw)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      do
         IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN

            CALL WDialogGetINTEGER(IDF_INTEGER1,nsigf)

            CALL WDialogGetINTEGER(IDF_INTEGER2,nmapf)

            call wdialogGetcheckbox(idf_check1,icolsw)

            CALL WDialogGetReal(IDF_REAL1,rad)

            CALL WDialogGetReal(IDF_REAL2,colint)

           return
         endif
		 return
      enddo

      RETURN
      END SUBROUTINE
      
      SUBROUTINE THICKL
      CALL IGrLineWidth(2,2,2)
      RETURN
      END

      SUBROUTINE THINL
      CALL IGrLineWidth(1,1,1)
      RETURN
      END

      SUBROUTINE OUTORG(FNAME)

      CHARACTER(LEN=255)  :: FNAME

      INCLUDE 'TXFRM.COM'

      REAL HSIZE
	  COMMON /SSIZE/  HSIZE

!IPK MAY02       COMMON  /TXFRM/  XS, YS, TXSCAL 

      OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
!!!      WRITE(104,'(4G16.8)') -XS,-YS,HSIZE*TXSCAL-XS,7.5*TXSCAL-YS
      WRITE(104,'(4G16.8)') -XS,-YS,HSIZE*TXSCAL-XS,8.0*TXSCAL-YS
      CLOSE(104)
      RETURN
      END
      
      SUBROUTINE DRAWBK(I,IMZ)


      INCLUDE 'TXFRM.COM'
!IPK MAY02       COMMON  /TXFRM/  XS, YS, TXSCAL 

      INCLUDE 'BFILES.I90'

      REAL HSIZE
	  COMMON /SSIZE/  HSIZE

      IF(IMZ .EQ. -1) THEN
        VRANGE=7.5
      ELSE
        VRANGE=8.0
      ENDIF
      XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL)/HSIZE
      XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL)/HSIZE
      YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL)/VRANGE
      YBKMX=((BFMINMAX(I,4)+YS)/TXSCAL)/VRANGE
!      WRITE(90,*) 'BACKGND',XBKMN,XBKMX,YBKMN,YHSIZEBKMX
      IF(XBKMN .GT. 1.) RETURN
      IF(XBKMX .LT. 0.) RETURN
      IF(YBKMN .GT. 1.) RETURN
      IF(YBKMX .LT. 0.) RETURN
      XRANGE=XBKMX-XBKMN
      YRANGE=YBKMX-YBKMN
      IF(XBKMX .GT. 1.) THEN
        XGRMX=(1.-XBKMN)/XRANGE
        XBKMX=1.0
      ELSE
        XGRMX=1.
      ENDIF
      IF(XBKMN .LT. 0.) THEN
        XGRMN=-XBKMN/XRANGE
        XBKMN=0.
      ELSE
        XGRMN=0.
      ENDIF
      IF(YBKMX .GT. 1.) THEN
        YGRMX=(1.-YBKMN)/YRANGE
        YBKMX=1.0
      ELSE
        YGRMX=1.
      ENDIF
      IF(YBKMN .LT. 0.) THEN
        YGRMN=-YBKMN/YRANGE
        YBKMN=0.
      ELSE
        YGRMN=0.
      ENDIF
!      WRITE(90,*) 'BACKGN2',XBKMN,XBKMX,YBKMN,YBKMX
!      WRITE(90,*) 'XGR    ',XGRMN,YGRMN,XGRMX,YGRMX
      CALL IGrArea(XBKMN,YBKMN,XBKMX,YBKMX)
      CALL IGrReplayArea(XGRMN,YGRMN,XGRMX,YGRMX)
      call IGrReplay(BFNAME(I))
      CALL IGrArea(0.0,0.0,1.0,1.0)
      RETURN
      END

      SUBROUTINE DRAWBKBM(I,IMZ)

      USE WINTERACTER

      REAL HSIZE
	  COMMON /SSIZE/  HSIZE

      CHARACTER*1 IFLAG
      INTEGER,  DIMENSION(6)  :: INFO

      INCLUDE 'TXFRM.COM'
!IPK MAY02       COMMON  /TXFRM/  XS, YS, TXSCAL 

      INCLUDE 'BFILES.I90'
!      DATA IHAND1,IHAND2/0,0/
      INTEGER           :: iw,ih,ihandle,ient,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
      common /hands/ iw,ih,ihandle,IHAND1,IHAND2,IXPM,IYPX,IXPX,IYPM
      
      XBKMN=((BFMINMAX(I,1)+XS)/TXSCAL)
      XBKMX=((BFMINMAX(I,3)+XS)/TXSCAL)
      YBKMN=((BFMINMAX(I,2)+YS)/TXSCAL)
      YBKMX=((BFMINMAX(I,4)+YS)/TXSCAL)      
!      WRITE(90,*) 'BACKGND-cm',XBKMN,XBKMX,YBKMN,YBKMX
      CALL IGrUnitsToPixels(0.,0.,IXPM,IYPM)
      CALL IGrUnitsToPixels(HSIZE,8.0,IXPXC,IYPXC)
!      WRITE(90,*) 'PIXELS',IXPM,IYPXC-IYPXC,IXPXC,IYPXC-IYPM
      CALL IGrUnitsToPixels(XBKMN,YBKMN,IXPM,IYPM)
      CALL IGrUnitsToPixels(XBKMX,YBKMX,IXPX,IYPX)
      IYPX=IYPXC-IYPX
      IYPM=IYPXC-IYPM
!      WRITE(90,*) 'PIXELS',IXPM,IYPX,IXPX,IYPM,IXPXC,IYPXC
      IF(XBKMN .GT. HSIZE) RETURN
      IF(XBKMX .LT. 0.) RETURN
      IF(YBKMN .GT. 8.) RETURN
      IF(YBKMX .LT. 0.) RETURN
      CALL IGrFileInfo(BFNAME(I),INFO,6)
!      WRITE(90,*)'BITMAP INFO',INFO
      IF(INFO(1) .EQ. 1  .or.  info(1) .eq. 2  .or.  info(1) .eq. 15  .or.  info(1) .eq. 19) THEN
        IXPIX=INFO(2)
        IYPIX=INFO(3)
      ENDIF
      XRANGE=IXPX-IXPM
      YRANGE=IYPM-IYPX
!      WRITE(90,*) 'RANGE',XRANGE,YRANGE
      FRACX1=0.
      FRACX2=0.
      FRACY1=0.
      FRACY2=0.
      IF(IXPX .GT. IXPXC) THEN
        FRACX1=(IXPX-IXPXC)/XRANGE
        IXPX = IXPXC
      ENDIF
      IF(IYPM .GT. IYPXC) THEN
        FRACY1=(IYPM-IYPXC)/YRANGE
        IYPM = IYPXC
      ENDIF
      IF(IXPM .LT. 0) THEN
        FRACX2=-IXPM/XRANGE
        IXPM=0
      ENDIF
      IF(IYPX .LT. 0) THEN
        FRACY2=-IYPX/YRANGE
        IYPX=0
      ENDIF
      
!      WRITE(90,*) 'BACKGN2-bm',IXPM,IYPX,IXPX,IYPM
!      WRITE(90,*) 'FRAC-bm   ',FRACX1,FRACX2,FRACY1,FRACY2
      IF(IHAND1 .NE. 0) THEN
        CALL WBitmapDestroy(IHAND1)
        CALL WBitmapDestroy(IHAND2)
      ENDIF
!      WRITE(90,*) 'PIXEL INFO',IXPIX,IYPIX
      CALL WBitMapCreate(IHAND1,IXPIX,IYPIX)
      IERR = InfoError(LastError)
!      WRITE(90,*) 'ERROR CREATE', IERR,IHAND1
      CALL IGrSelect(DrawBitmap,IHAND1)
      if(ihand1 .eq. 0) then
        IERR = InfoError(LastError)
        CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,&
        'Too many pixels for image to display correctly '//CHAR(13)//'Image will not register ','IMAGE ERROR')
      endif
!      WRITE(90,*) 'ERROR SELECT', IERR
      CALL IGrLoadImage(BFNAME(I),1)
      IERR = InfoError(LastError)
!       WRITE(90,*) 'ERROR LOAD', IERR

      IX2PIX=IXPIX*(1.-FRACX1-FRACX2)
      IY2PIX=IYPIX*(1.-FRACY1-FRACY2)
      IXLPIX=IXPIX*FRACX2
      IYLPIX=IYPIX*FRACY2
      IXMPIX=IXPIX*(1.-FRACX1)
      IYMPIX=IYPIX*(1.-FRACY1)
!      WRITE(90,*) 'HANDL2',IHAND2,IX2PIX,IY2PIX
!      WRITE(90,*) 'LOCAL ',IXLPIX,IYLPIX,IXMPIX,IYMPIX
      CALL WBitMapCreate(IHAND2,IX2PIX,IY2PIX)
      CALL IGrSelect(DrawBitmap,IHAND2)
      CALL WBitMapPutPart(IHAND1,0,IXLPIX,IYLPIX,IXMPIX,IYMPIX)
      IF(IDDSW .EQ. 1) THEN
        CALL IGrSelect(DrawWin)
      ELSE
        CALL IGrSelect(DrawBitmap,IHANDLE)
      ENDIF
      IERR = InfoError(LastError)
!      WRITE(90,*) 'ERROR SELECT DRAW', IERR
      CALL WBitmapPut(IHAND2,1,1,IXPM,IYPX,IXPX,IYPM)
!      call gim_an_event(ix,iy,iflag)

      RETURN
      END

      Subroutine panel012(ibkon)

      use winteracter

      implicit none

      include 'D.inc'
      INCLUDE 'BFILES.I90'

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE

      integer  :: n,ibkon,IERR
!      real     :: 
      character*3 :: sub

      call wdialogload(IDD_DIALOG012)
      ierr=infoerror(1)

      do n=1,nbkfl
        CALL WDialogPutString(idf_string1+n-1,BFNAME(n))
        call wdialogputcheckbox(idf_check1+n-1,iswbkfl(n))
      enddo
      
      call wdialogputcheckbox(idf_check11,ibkon)

      CALL WDialogSelect(IDD_DIALOG012)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
        do n=1,nbkfl
          call wdialogGetcheckbox(idf_check1+n-1,iswbkfl(n))
          CALL GETSUB(BFNAME(n),SUB)
          if(sub .eq. 'bmp') then
            if(iswbkfl(n) .eq. 1) iswbkfl(n)=2
          ELSEIF(SUB .EQ. 'pcx') then
            if(iswbkfl(n) .eq. 1) ISWBKFL(N) = 2
          ELSEIF(SUB .EQ. 'png'  .or.  sub .eq. 'jpg') then
            if(iswbkfl(n) .eq. 1) ISWBKFL(N) = 2
          endif
        enddo

        call wdialogGetcheckbox(idf_check11,ibkon)

       ENDIF
       RETURN
       END
   
       SUBROUTINE UNDO(IYES)

       USE WINTERACTER

       INCLUDE 'D.INC'

       CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do wish to undo?'//&
                           CHAR(13)//' ','Undo option')
!
!   If answer 'No', return
!
       iyes=1
       IF (WInfoDialog(4).EQ.2) iyes=0
       return
       end

       subroutine frame(xmn,ymn,xmx,ymx)

          CALL PLOTT(xmn,ymn,3)
          CALL PLOTT(xmx,ymn,2)
          CALL PLOTT(xmx,ymx,2)
          CALL PLOTT(xmn,ymx,2)
          CALL PLOTT(xmn,ymn,2)
          return
          end

      SUBROUTINE CIRCLE(CX,CY,rad)
      dimension x(8),y(8)
      DO I=1,8
        ANGLE=FLOAT(I-1)*6.28318/8.
        X(I)=CX+rad*COS(ANGLE)
        Y(I)=CY+rad*SIN(ANGLE)
      ENDDO
!      write(90,*) 'circle',x,y
      CALL IGrPolygonComplex(x,y,8)
      return
      end

      Subroutine GETHDRTYP(IHDSWT)

      use winteracter

      implicit none

      include 'D.inc'

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE

      integer  :: IHDSWT,IERR

      call wdialogload(IDD_HEADERTP)
      ierr=infoerror(1)

      call wdialogputRadioButton(idf_radio1)

      CALL WDialogSelect(IDD_HEADERTP)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      do
         IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN

          call wdialoggetradiobutton(idf_radio1,IHDSWT)
          return
         endif
         IHDSWT=1
         RETURN
      enddo
      RETURN
      END
   
      Subroutine panelfil

      use winteracter

      implicit none

      include 'D.inc'
      INCLUDE 'BFILES.I90'

!
! Declare window-type and message variables
!
      TYPE(WIN_STYLE)    :: WINDOW

      TYPE(WIN_MESSAGE) :: MESSAGE

      integer  :: n,iflon,IERR
!      real     :: 
      character*3 :: sub

      call wdialogload(IDD_SELTFL2)
      ierr=infoerror(1)

      write(90,*) 'iactvfil,itotfil',iactvfil,itotfil
      do n=1,itotfil
	    write(90,'(a)') 'file',n,fnameout(n)
	    CALL WDialogPutString(idf_string25+n-1,FNAMEOUT(n))
	    if(n .eq. iactvfil) then
	      call wdialogputradiobutton(idf_radio1+n-1)
	    endif
      enddo
      CALL WDialogSelect(IDD_SELTFL2)
      ierr=infoerror(1)

      CALL WDialogShow(-1,-1,0,Modal)
      ierr=infoerror(1)
      
      DO
        IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
	      call wdialogGetradiobutton(idf_radio1,iactvfil)
  	      write(90,*) 'Selected iactvfil', iactvfil
          RETURN
        ELSEIF (WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
          RETURN
        ENDIF
      ENDDO
      END
    
    
    
      subroutine plotcr(x,y,siz)

          CALL PLOTT(x-siz/2.,y,3)
          CALL PLOTT(x+siz/2,y,2)
          CALL PLOTT(x,y-siz/2.,3)
          CALL PLOTT(x,y+siz/2.,2)
          return
          end

      SUBROUTINE OUTJPGW(FNAME,INFO)

      CHARACTER(LEN=255)  :: FNAME
      INTEGER INFO(3)
      INCLUDE  'TXFRM.COM' 

      REAL HSIZE
	  COMMON /SSIZE/  HSIZE
      XR=HSIZE*TXSCAL-XS
      YT=8.0*TXSCAL-YS
      XSIZ=HSIZE*TXSCAL/FLOAT(INFO(2))
      YSIZ=-8*TXSCAL/FLOAT(INFO(3))
     
      OPEN(104,FILE=FNAME,STATUS ='UNKNOWN', FORM ='FORMATTED')
      WRITE(104,*) XSIZ
      WRITE(104,*) ' 0.0'
      WRITE(104,*) ' 0.0'
      WRITE(104,*) YSIZ
      WRITE(104,*) -XS
      WRITE(104,*) YT
      
      CLOSE(104)
      
      RETURN
      END