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: smpgraphic.f,v 1.0 1999/09/28 14:38:32 russd Tst $ *** C ? SMPGRAPHIC - McIDAS image and graphics sample program C ? SMPGRAPHIC IMA "qfld C ? SMPGRAPHIC GRA "qfld C ? Parameters: C ? IMA | draws a test pattern on the screen C ? GRA | draws some graphics on the screen C ? "qfld | quote field C ? Keywords: C ? WORld=ulline ulelem lrline lrelem | specify world coordinates C ? (def=1 1 480 640) C ? BORder=size | specify a clipping region with border of size C ? (def=1/3 frame size) C ? Remarks: C ? McIDAS sample program. C ? C ? This application illustrates the basic use of image and graphic C ? display on a McIDAS frame. C ? C ? With option IMA, an example of using MCLINE() to write a C ? grayscale image line to the screen. C ? C ? With option GRA, an example of how to use the McIDAS graphics C ? subsystem is demonstrated. This includes scaling, clipping, C ? plotting and writing text. The functionality of the following C ? subroutines and others are displayed C ? INITPL C ? PLOT C ? PAGE C ? ENPT C ? ENDPLT C ? ---------- subroutine main0 implicit none c --- external functions integer mccmdstr ! character string parameter c --- internal functions integer image_utils integer graphic_utils c --- internal variables character*12 option ! program option string integer status ! function status c **************** Program Body ************** c --- set initial program status to FAILED call MCCODESET( -1 ) c --- fetch the command option status = MCCMDSTR( ' ', 1, ' ', option ) if( status.lt.0 ) return c --- Force the contents of the option string to upper case call MCUPCASE( option ) c ------------------------------------ c --- Image use c ------------------------------------ if (option(1:3) .eq. 'IMA') then status = image_utils( ) if (status .lt. 0) then call mccodeset ( 1 ) return endif endif c ------------------------------------ c --- Graphic use c ------------------------------------ if (option(1:3) .eq. 'GRA') then status = graphic_utils( ) if( status.lt.0 ) then call mccodeset ( 1 ) return endif endif call sdest ('Done...', 0) c --- set the program status to SUCCESS call mccodeset( 0 ) return end ** Name: ** image_utils - image display utilities ** ** Interface: ** integer function ** image_utils( ) ** ** Input: ** none ** ** Input and Output: ** none ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** Used to illustrate image display API functions ** ** Categories: ** image integer function image_utils( ) implicit none c --- internal constants integer MAXELEMS ! maximum number of elements parameter (MAXELEMS = 640) integer MAXLINES ! maximum number of lines parameter (MAXLINES = 480) c --- external functions c --- internal functions c --- internal functions c --- internal variables integer i ! loop counter integer data_line(MAXELEMS) integer pack_line(MAXELEMS) do i=1, MAXELEMS data_line(i) = mod (i - 1, 255) end do c --- Pack the 4 bytes word values into 1 byte call PACK (MAXELEMS, data_line, pack_line) do i=1, MAXLINES call MCLINE (1, i, pack_line) end do return end ** Name: ** graphic_utils - graphic display utilities ** ** Interface: ** integer function ** graphic_utils( ) ** ** Input: ** none ** ** Input and Output: ** none ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** Used to illustrate basic graphic display API functions ** ** Categories: ** graphic integer function graphic_utils( ) implicit none c --- internal constants integer BOX_HEIGHT ! height of box parameter (BOX_HEIGHT = 150) integer BOX_LENGTH ! height of box parameter (BOX_LENGTH = 300) integer SET_WORLD ! set world coordinates parameter (SET_WORLD = 1) integer SET_VIEW ! set clipping coordinates parameter (SET_VIEW = 0) c --- external functions c --- internal functions integer draw_box ! draws a box integer draw_line ! draws a line integer draw_text ! draws text integer mccmdint ! get command line int integer mccmdnum ! get number of keyword args c --- internal variables character*80 text ! text to write integer border ! border width integer color ! graphic color level integer current_graphics_frame ! current graphics frame # integer default_width ! default border width integer status ! function return status integer old_dash ! old dashing mode integer clin ! center line of text integer cele ! center element of text integer hgt ! height of text integer linspac ! line spacing integer f_nlins ! number of lines in frame integer f_neles ! number of elements in frame integer f_ullin ! upper left line in frame integer f_ulele ! upper left element in frame integer f_lrlin ! lower right line in frame integer f_lrele ! lower right element in frame integer w_ulline ! world upper left line integer w_ulelem ! world upper left element integer w_lrline ! world lower right line integer w_lrelem ! world lower right element integer b_ulline ! border (clipping) upper left line integer b_ulelem ! border (clipping) upper left elem integer b_lrline ! border (clipping) lower right line integer b_lrelem ! border (clipping) lower right elem integer scale_act ! scale active flag real linw2f ! line scaling factor real elew2f ! element scaling factor c --- Get the current graphics frame number current_graphics_frame = 1 c --- Get the color status = mccmdint ('COL.OR', 1, 'Graphics color', 3, 1, 3, & color) if (status .lt. 0) return c --- Initialize the plotting package call INITPL (current_graphics_frame, 1) c --- There is always a defined world, whether by INITPL() or PAGE() c --- INITPL () always initializes the world coordinates to 1 1 480 640 w_ulline = 1 w_ulelem = 1 w_lrline = 480 w_lrelem = 640 c ------------------------------------------------------- c --- Get and activate the world coordinate if provided by user c ------------------------------------------------------- if (mccmdnum ('WORLD') .eq. 4) then if (mccmdint ('WORLD', 1, 'World upper left line', 1, 1, & 0, w_ulline ) .lt. 1100 ) return if (mccmdint ('WORLD', 2, 'World upper left element', 1, 1, & 0, w_ulelem ) .lt. 1100 ) return if (mccmdint ('WORLD', 3, 'World lower right line', 1, 1, & 0, w_lrline ) .lt. 1100 ) return if (mccmdint ('WORLD', 4, 'World lower right element', 1, 1, & 0, w_lrelem ) .lt. 1100 ) return call sdest ('Setting world coord to', 0) call sdest (' ', w_ulline) call sdest (' ', w_ulelem) call sdest (' ', w_lrline) call sdest (' ', w_lrelem) call PAGE ( w_ulline, w_ulelem, w_lrline, w_lrelem, SET_WORLD) call qscale (scale_act) call sdest ('scale_act = ', scale_act) endif c --- Draw the border call QGDASH (old_dash) call DSHOFF () status = draw_box (w_ulline, w_ulelem, w_lrline, w_lrelem, & color) if (old_dash .gt. 0) call DSHON () c ------------------------------------------------------ c --- Define the viewport and draw border c ------------------------------------------------------ if (mccmdnum ('BOR.DER') .gt. 0) then default_width = (w_lrline - w_ulline) / 3 status = mccmdint ('BOR.DER', 1, 'Border Width', 0, 0, & default_width, border) if (status .lt. 0) return call sdest ('border=', border) b_ulline = w_ulline + border b_ulelem = w_ulelem + border b_lrline = w_lrline - border b_lrelem = w_lrelem - border call sdest ('b_ulline=', b_ulline) call sdest ('b_ulelem=', b_ulelem) call sdest ('b_lrline=', b_lrline) call sdest ('b_lrelem=', b_lrelem) call page (b_ulline, b_ulelem, b_lrline, b_lrelem, SET_VIEW) if (border .gt. 0) then call QGDASH (old_dash) call DSHON () status = draw_box (b_ulline, b_ulelem, b_lrline, b_lrelem, & color) if (old_dash .eq. 0) call DSHOFF () endif endif status = draw_line (w_ulline, w_ulelem, w_lrline, w_lrelem, & color) c ------------------------------------------------------ c --- Generate and display the text messages c ------------------------------------------------------ c // Fetch the text height and use it and the scale factors c // to determine the separation between text lines. If the c // line scale factor is less than one, the text locations c // will be moved closer together by the scaling but the c // text hieght will be unchanged. So increase the separation c // between lines (in world coordinates) to prevent overwrite. status = mccmdint ('HGT', 1, 'Text Height', 10 , 5, 20, hgt) if (status .lt. 0) return c --- get the scaling status and the line and element scaling factors call sclfac(linw2f, elew2f) call qscale (scale_act) if (scale_act .eq. 1 .and. linw2f .lt. 1.0) then linspac = 1.5 * hgt / linw2f else linspac = 1.5 * hgt endif c // determine the center of the topmost five lines c // Center the third line in the world; this will illustrate c // the main use of world coordinates to preserve centering c // even when display sizes differ clin = w_ulline + (w_lrline - w_ulline) / 2 - 2 * linspac cele = w_ulelem + (w_lrelem - w_ulelem) / 2 c --- Display the scaling status if (scale_act .eq. 1) then text = 'scaling is ACTIVE' else text = 'scaling is INACTIVE' endif status = draw_text (clin, cele, hgt, text, color) c --- Get and display the frame size call mcfsize (current_graphics_frame, f_nlins, f_neles) f_ullin = 1 f_ulele = 1 f_lrlin = f_nlins + f_ullin - 1 f_lrele = f_neles + f_ulele - 1 write (text, 30) f_ullin, f_ulele, f_lrlin, f_lrele 30 format ('DISPLAY ', 4I5) clin = clin + linspac status = draw_text (clin, cele, hgt, text, color) write (text, 32) w_ulline, w_ulelem, w_lrline, w_lrelem 32 format ('WORLD ', 4I5) clin = clin + linspac status = draw_text (clin, cele, hgt, text, color) write (text, 34) b_ulline, b_ulelem, b_lrline, b_lrelem 34 format ('VIEWPORT ', 4I5) clin = clin + linspac status = draw_text (clin, cele, hgt, text, color) c --- Close the graphics package and flush the buffer call ENDPLT ( ) graphic_utils = 0 return end ** Name: ** draw_box - draw a graphic box on the McIDAS graphic frame ** ** Interface: ** integer function ** draw_box(upline, upelem, lrline, lrelem, color ) ** ** Input: ** upline - upper left line of box in frame coordinates ** upelem - upper left element of box in frame coordinates ** lrline - lower right line of box in frame coordinates ** lrelem - lower right element of box in frame coordinates ** color - pen number ** ** Input and Output: ** none ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** draws a box on the current graphics frame ** ** Categories: ** graphics integer function draw_box(upline, upelem, lrline, lrelem, color) implicit none c --- internal constants integer PEN_UP ! color level to lift pen parameter (PEN_UP = 0) c --- external functions c --- internal functions c --- internal variables integer upline ! line to position upper left of box integer upelem ! elem to position upper left of box integer lrline ! line to position lower right of box integer lrelem ! elem to position lower right of box integer color ! color level to plot call PLOT (upline, upelem, PEN_UP) call PLOT (lrline, upelem, color) call PLOT (lrline, lrelem, color) call PLOT (upline, lrelem, color) call PLOT (upline, upelem, color) call ENPT draw_box = 0 return end ** Name: ** draw_line - draw a line on the graphic frame ** ** Interface: ** integer function ** draw_line(b_line, b_ele, e_line, e_ele, color ) ** ** Input: ** b_line - starting point line in frame coordinates ** b_ele - starting point element in frame coordinates ** e_line - ending point line in frame coordinates ** e_ele - ending point element in frame coordinates ** color - pen level ** ** Input and Output: ** none ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** Draws a line on the current graphics frame ** ** Categories: ** graphics integer function draw_line (b_line, b_ele, e_line, e_ele, color) implicit none c --- internal constants integer PEN_UP ! color level to lift pen parameter (PEN_UP = 0) c --- external functions c --- internal functions c --- internal variables integer color ! color to plot integer b_line ! line of beginning point integer b_ele ! element of beginning point integer e_line ! line of ending point integer e_ele ! element of ending point call PLOT (b_line, b_ele, PEN_UP) call PLOT (e_line, e_ele, color) call ENPT ( ) draw_line = 0 return end ** Name: ** draw_text - draw a string of text on the grahics frame ** ** Interface: ** integer function ** draw_text(clin, cele, hgt, text, color ) ** ** Input: ** clin - beginning line of text in frame coordinates ** cele - beginning element of text in frame coordinates ** hgt - size of text in frame pixels ** text - text string to write ** color - pen level ** ** Input and Output: ** none ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** Draw a text string on the current graphic frame ** ** Categories: ** graphic integer function draw_text (clin, cele, hgt, text, color) implicit none c --- internal constants c --- external functions integer len_trim ! compute length of string c --- internal functions c --- internal variables integer clin ! center line to draw text integer cele ! center element to draw text integer hgt ! height to draw text character*(*) text ! text to draw integer color ! color to draw text integer nchar ! number of characters in text integer sclstat ! status of scaling flag integer txthgt ! actual height in frame coord integer ullin ! upper left of text (frame) integer ulele ! upper left of text (frame) integer txtclin ! text center, frame coords integer txtcele ! text center, frame coords c --- Determine the actual (frame coordinates) height of the c --- text. txthgt = hgt call SCLHGT (txthgt) c --- determine the center point in frame coordinates. Because c --- sclpnt() always works whether the world is active or not, c --- make this call only if scaling is actually on. call QSCALE (sclstat) if (sclstat .eq. 1) then call sclpnt (clin, cele, txtclin, txtcele) else txtclin = clin txtcele = cele endif c --- Determine the length of the text message in characters. c --- This information is then used, together with the actual c --- heights, to compute the upper left corner in frame coordinates nchar = len_trim (text) ullin = txtclin - txthgt / 2 ulele = txtcele - txthgt * nchar / 2 + txthgt / 10 c --- Display the text. Turn scaling off first (we have figured c --- the text height and location in frame coordinates ourselves) c --- But be sure to restore it to it's original state according to c --- the result of 'sclstat' of the qscale() call above. call SCLOFF () call WRTEXT (ullin, ulele, txthgt, text, nchar, color) if (sclstat .eq. 1) call SCLON() call ENPT () draw_text = 0 return end ** Name: ** sclfac - convert from world to frame coordinates ** ** Interface: ** subroutine ** sclfac( linw2f, elew2) ** ** Input: ** none ** ** Input and Output: ** linw2f - line coordinte converted from world to frame ** elew2f - element coordinate converted from world to frame ** ** Output: ** none ** ** Return values: ** 0 - Success ** -1 - Failed ** ** Remarks: ** Return the world to frame scale factors ** ** This routine also illustrates a helpful design principle: ** If you application needs access to the inner workings of ** a subsystem (in this case a common block), write an access ** routine to extend the API rather than just including the ** common block in your application ** ** Categories: ** graphic subroutine sclfac (linw2f, elew2f) implicit none real linw2f ! line world to frame scaling real elew2f ! element world to frame scaling integer ifrm ! frame number for graphics integer iwdth ! line width integer mnele ! upper left world element integer mnlin ! upper left world lin integer mxele ! lower right world element integer mxlin ! lower right world line integer sclfg ! scaling flag real scele ! frame elements per world elem real sclin ! frame lines per world line common /M0FRACOM/ ifrm, iwdth, mxlin, mnlin, mxele, mnele, & sclin, scele, sclfg linw2f = sclin elew2f = scele return end