C Copyright(c) 1999, Space Science and Engineering Center, UW-Madison C Refer to "McIDAS Software Acquisition and Distribution Policies" C in the file mcidas/data/license.txt C *** $Id: smppntdev.f,v 1.0 1999/09/28 14:38:32 russd Tst $ *** C ? SMPPNTDEV - McIDAS pointing device sample program C ? SMPPNTDEV C ? Parameters: C ? none C ? Keywords: C ? CUR=lsiz esiz type col | cursor attributes C ? where: lsiz = height of cursor (def=11) C ? esiz = width of cursor (def=11) C ? type = BOX, XHAIR(def), XBOX or SOLID C ? col = color name (def=YELLOW) C ? Remarks: C ? McIDAS programing sample. C ? C ? This sample illustrats the use of the interactive mouse C ? tracking and sampling function MCMOUBTN. C ? ---------- subroutine main0 implicit none c --- external functions c --- internal functions integer mou_utils ! test point device utils c --- internal variables integer status ! function status c **************** Program Body ************** c --- set initial program status to FAILED call MCCODESET( -1 ) c --- go to the pointing device function status = MOU_UTILS( ) if( status.lt.0 ) return c --- set the program status to SUCCESS call MCCODESET( 0 ) c --- signal finished call EDEST('Done ...',0) return end ** Name: ** mou_utils - code samples for point device utilities ** ** Interface: ** integer function ** mou_utils( ) ** ** Input: ** none ** ** Input and Output: ** none ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** Used to illustrate basic command line retrieval functions ** ** Categories: ** input ** parse integer function mou_utils( ) implicit none c --- parameters c --- internal constants c --- external functions integer itrmch ! display characteristics integer kolors ! get gun settings for specified color integer luc ! get a value from User Common (UC) integer mccmdint ! get integer parameter integer mccmdstr ! get character string parameter integer mcgetimageframenumber ! get current image frame number integer mcmoubtn ! mouse/cursor interface c --- internal variables character*12 cur_type ! name of cursor type character*12 cur_color ! name of cursor color integer mode ! sampling type integer button1 ! status of mouse button 1 integer button2 ! status of mouse button 2 integer tv_line ! tv line coordinate of cursor integer tv_elem ! tv element coordinate of cursor integer ok ! function status integer MIN_CUR_LSIZE ! display min cursor line size integer MAX_CUR_LSIZE ! display max cursor line size integer MIN_CUR_ESIZE ! display min cursor elem size integer MAX_CUR_ESIZE ! display max cursor elem size integer CUR_BOX_TYPE ! Verify BOX cursor type integer CUR_XHA_TYPE ! Verify XHAIR cursor type integer CUR_XBO_TYPE ! Verify XBOX cursor type integer CUR_SOL_TYPE ! Verify SOLID cursor type integer CUR_BUL_TYPE ! Verisfy BULL cursor type integer save_cur_lsize ! initial cursor line size integer save_cur_esize ! initial cursor element size integer save_cur_tcode ! initial cursor type code integer save_cur_ccode ! initial cursor color level integer cur_lsize ! specified cursor line size integer cur_esize ! specified cursor element size integer cur_tcode ! specified cursor type code integer cur_ccode ! specified cursor color level integer this_frame ! current image frame integer tv_lsize ! image frame line size integer tv_esize ! image frame element size integer red ! red gun intensity integer green ! green gun intensity integer blue ! blue gun intensity c ************ Function Body ************* c --- initialize the function status mou_utils = -1 c --- get the size of the frame this_frame = mcgetimageframenumber() call mcfsize( this_frame, tv_lsize, tv_esize ) c --- get display characteristics MIN_CUR_LSIZE = ITRMCH('MN_CUR_SIZ_H', -1 ) ! Minimum cursor line size MAX_CUR_LSIZE = ITRMCH('MX_CUR_SIZ_H', -1 ) ! Maximum cursor line size MIN_CUR_ESIZE = ITRMCH('MN_CUR_SIZ_W', -1 ) ! Minimum cursor elem size MAX_CUR_ESIZE = ITRMCH('MX_CUR_SIZ_W', -1 ) ! Maximum cursor elem size CUR_BOX_TYPE = ITRMCH('CUR_BOX?',-1) ! Verify BOX cursor type CUR_XHA_TYPE = ITRMCH('CUR_XHAIR?',-1) ! Verify XHAIR cursor type CUR_XBO_TYPE = ITRMCH('CUR_XBOX?',-1) ! Verify XBOX cursor type CUR_SOL_TYPE = ITRMCH('CUR_SOLID?',-1) ! Verify SOLID cursor type CUR_BUL_TYPE = ITRMCH('CUR_BULL?',-1) ! Verisfy BULL cursor type c --- save the environment save_cur_lsize = LUC( 61 ) ! save the cursor line size save_cur_esize = LUC( 62 ) ! save the cursor element size save_cur_tcode = LUC( 65 ) ! save the cursor type save_cur_ccode = LUC( 66 ) ! save the cursor color c --- get the cursor control parameters ok= MCCMDINT('CUR',1,'Cursor Line Size', 11, & MIN_CUR_LSIZE, MAX_CUR_LSIZE, cur_lsize ) if( ok.lt.0 ) return ok= MCCMDINT('CUR',2,'Cursor Elem Size', 11, & MIN_CUR_ESIZE, MAX_CUR_ESIZE, cur_esize ) if( ok.lt.0 ) return ok= MCCMDSTR('CUR',3,'XHAIR', cur_type ) if( ok.lt.0 ) then call EDEST('Invalid entry for: Cursor Type ='//cur_type,0) return else call MCUPCASE( cur_type ) cur_tcode = 0 if(cur_type(1:3).eq.'BOX'.and.CUR_BOX_TYPE.eq.1) cur_tcode=1 if(cur_type(1:3).eq.'XHA'.and.CUR_XHA_TYPE.eq.1) cur_tcode=2 if(cur_type(1:3).eq.'XBO'.and.CUR_XBO_TYPE.eq.1) cur_tcode=3 if(cur_type(1:3).eq.'SOL'.and.CUR_SOL_TYPE.eq.1) cur_tcode=4 if(cur_type(1:3).eq.'BUL'.and.CUR_BUL_TYPE.eq.1) cur_tcode=5 if( cur_tcode.eq.0 ) then call EDEST('Cursor type not supported on workstation='// & cur_type,0) return endif endif ok= MCCMDSTR('CUR',4,'YELLOW', cur_color ) if( ok.lt.0 ) then call EDEST('Invalid entry for: Cursor Color ='//cur_color,0) return else call MCUPCASE( cur_color ) ok= KOLORS( cur_color, red, green, blue ) if( ok.ne.1 ) then call EDEST('Invalid color specified='//cur_color,0) return else call STC( red, cur_ccode, 0) call STC( green, cur_ccode, 1) call STC( blue, cur_ccode, 2) call STC( 0, cur_ccode, 3) call SWBYT4( cur_ccode, 1) endif endif c --- modify the environment call PUC( 1, 178 ) ! Turn frame roam off call SIZCUR( cur_lsize, cur_esize ) ! set cursor size call TYPCUR( cur_tcode ) ! set cursor type code call PUC( cur_ccode, 66 ) ! set cursor color level call PUTCUR( tv_lsize/2, tv_esize/2 ) ! center the cursor c --- set the sampling type to -> Button was pressed and released mode = 3 c --- sample the mouse 100 continue ok= MCMOUBTN( mode, button1, button2, tv_line, tv_elem ) c --- test for ERROR if( ok.eq.-2 ) then call EDEST('MCMOUBTN -- Request Not Valid',0) goto 1000 c --- test for TIMEOUT else if( ok.eq.-1 ) then call EDEST('MCMOUBTN -- timeout',0) goto 1000 c --- test for Alt-Q else if( ok.eq.1 ) then call EDEST('User Terminated Interactive Session',0) goto 1000 c --- test for Alt-G else if( ok.eq.2 ) then c ------ make a sound call BEEP( 100, 100 ) c ------ output coordinates call SDEST('Cursor Location: TV line=', tv_line) call SDEST('Cursor Location: TV elem=', tv_elem) c --- test for button press else c ------ look for button1 press if( button1.ne.0 ) then c --------- make a sound call BEEP( 100, 100 ) c --------- output coordinates call SDEST('Cursor Location: TV line=', tv_line) call SDEST('Cursor Location: TV elem=', tv_elem) c ------ look for button2 press else if( button2.ne.0 ) then call EDEST('User Terminated Interactive Session',0) goto 1000 endif endif c --- return to mouse button sampling goto 100 1000 continue c --- restore the environment call PUC( 0, 178 ) ! Turn frame roam on call SIZCUR( save_cur_lsize, save_cur_esize ) ! restore cursor size call TYPCUR( save_cur_tcode ) ! restore cursor type code call PUC( save_cur_ccode, 66 ) ! restore cursor color level c --- set return status mou_utils = 0 return end