vDk UISDISP.BCK UISDISP.BCKXBACKUP/NOASSIST/IGNORE=LABEL_PROCESSING/LOG/VERIFY [.UISEXP] UISDISP.BCK/SAVE/BLOCK=4096 SHARP 9ВBqV5.5 _LENORE::  _$2$DIA1: V5.5-2  *[SHARP.UISEXP]IRAFLOGO.EXE;1+,./9 4-0123 KPWO56EkБ7@\}8^9G9HJ 0DX0205(ikPhIRAFLOGO01ikБ04-00    ?@!d FORRTL_001!  LIBRTL_001! UISSHR_001 ACC"A\'" @PMRead in a stored logo file ?Name of file ?SYS$WORKSTATIONUse a graphical or bitmap method (G/B) ?LogoUIS$FILL_PATTERNSDo you want to store this logo ?Give name of file)PP@@@@@@@@L?̐AB0B`BBBBBBBBBBBBffBBBcB33FBff BBAAACCCCCCCffCCCCDCNCVC^CfClCrCxC{C33~CCCCCBC33Cff!C33'C33,C0Cff2Cff6Cff9C=C?C@C@C@C@C@CCs<80   ?????????>|xpp00  UISDISP.BCK[SHARP.UISEXP]IRAFLOGO.EXE;1% 80pp``PXt LXLLPXP\PTXT\T  h`dhlptx|(h $(,00\0\ \\\4H\8\<(\@0\\ \DHt\\\DHt\h48<@hHHLLDH\ \HHLLPT\\ \HHLLPT \h \(\,\0(X \((,X\,,0X\00\H [Jˈ'(xY y1Gːxˀ˘ ߫$߫(߫,˰PP˼Ы0kЫ0P4˰gbPP˼IЫ0&Ы0& !PP˼Ы0Ы04(f 81Hѫ<`\dh `\dԫhxdeZxDEgGBbG g1ˈkPl˔f˨P4y( @Xp\&ˈE˜@˰ x$G:GC DPlPd$P4˄˘e\ GDgxY y1YL `˄˘PP˼vQ UISDISP.BCK[SHARP.UISEXP]IRAFLOGO.EXE;1 lˤIJ?ˀ()ˬ  'kݫݫЫ0`Ы0˘PP˼Ы0 /Ы0d PP˼Ы08,Ы0@<# r8)L<IHD[м$Ь ޫP'ݼ  H,[м$Ь ޫPyݼ @@ (@8 ((HP0@0 @ `p` ` p 0@P` pP @ P p  0 `0PPp` `@P  `  P ` p  @p0 0 0p   pP`@ @0p 0 @   0 @ P  @FORRTLLIBRTLUISSHR LOGO LOGO / BUFFERWRITE0 BUFFERWRITE ? BUFFERREADp BUFFERREAD?*[SHARP.UISEXP]IRAFLOGO.FOR;1+,./9 4M,-0123KPWO56Б7`9Ɔ}8&]9G9HJHC Program to create the IRAF `star' logo in a one-inch box, suitable forJC using as an Icon with the NEWUISDISP display program. To use this Icon,EC run this program, store the output in a file, and point the logicalJC IRAF_LOGO to that file, using DEFINE IRAF_LOGO disk:[directory]filename.C9C This program a) asks if you want you read a stored fileKC (useful for checking existing files to see what they are)KC b) asks if you wish to try the `graphical' or `bitmap'  UISDISP.BCK[SHARP.UISEXP]IRAFLOGO.FOR;1M_logosJC The first option draws paths and fills areas: the secondLC relies on a bitmap stored in BYTE form (8 pixels per byte)IC as documented under the UIS$IMAGE routine. It uses twoMC such maps, one for the logo letters and one for the insertsJC (the gaps in R and A) so they can be a different colour.EC c) asks if you want to store the result for later use.CJC You can therefore make modifications, see what they look like, and, when<C finally satisfied, store the logo for use with NEWUISDISP.C GC The necessary paths and bitmaps are included here as DATA statements.DC This program, together with the subroutine SHRINKER in NEWUISDISP,4C should enable anyone to produce a customized Icon.GC To set up an Icon, you either need a file called IRAF_LOGO.DAT in theDC directory from which NEWUISDISP is invoked, or (better) you shouldC define the logical IRAF_LOGO.C PROGRAM LOGO IMPLICIT INTEGER(A-Z) INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF' CHARACTER ANS*1,FILE*80 LOGICAL EIGHT COMMON/ATT/ CO1,AT1,END DATA RETL1,RETL2,RETL3/3*0/C REAL RTW,RTH,RTX,RTY,WID,HGT REAL REDM(6),GREENM(6),BLUEM(6) DATA REDM/1.,0.,1.,0.,0.,1.0/ DATA GREENM/1.,0.,0.,1.,0.,1.0/ DATA BLUEM/1.,0.,0.,0.,1.,0.2/C+C Arrays and data for graphical path methodC/ REAL X1(25),Y1(25),X2(39),Y2(39),X3(11),Y3(11)/ REAL X4(34),Y4(34),X5(16),Y5(16),X6(20),Y6(20)CC Arrays 1 are the letter I4 DATA X1/4.5,8.0,11.0,14.0,16.5,19.0,22.5,24.0,26.0,: + 25.5,25.0,23.5,22.0,21.2,20.3,19.0,17.7,16.0,14.2," + 12.4,10.0,8.0,6.0,4.0,4.5/6 DATA Y1/70.0,70.8,71.5,72.5,73.5,74.8,76.7,78.0,79.5,? + 70.0,65.0,49.0,51.5,53.5,55.5,57.5,59.0,60.5,62.0,62.8,! + 63.5,64.0,64.5,65.0,70.0/C Arrays 2 are the letter R6 DATA X2/30.5,36.3,38.6,40.3,41.8,43.0,44.1,44.6,45.6,: + 46.4,47.4,47.9,48.0,48.2,48.2,48.0,48.0,47.0,45.0,? + 45.0,45.9,47.2,49.0,48.0,40.0,36.5,35.7,35.0,34.0,29.0,5 + 25.0,22.5,20.4,18.5,24.5,26.8,28.0,29.0,30.5/4 DATA Y2/110.,104.2,101.,98.6,96.,94.,91.5,89.5,86.,2 + 83.,80.,77.,74.,71.,69.,65.8,63.,61.5,60.,7 + 59.,54.,50.,46.0,45.0,36.0,42.0,35.0,31.5,29.5,: + 24.0,19.0,15.5,12.5,9.0,45.0,60.0,70.0,81.0,110.0/"C Arrays 3 are the `hole' in the R; DATA X3/37.,37.8,38.6,39.1,39.6,39.7,39.4,39.,38.,37.,37./8 DATA Y3/90.,87.,84.5,81.,77.,72.5,71.,69.5,68.,67.,90./C Arrays 4 are the letter A6 DATA X4/47.0,50.0,53.0,59.8,63.5,68.2,74.9,78.1,85.0,: + 87.0,88.3,89.0,84.0,80.1,77.0,75.0,67.6,67.5,63.8,: + 63.5,63.0,58.7,54.8,51.0,51.0,51.3,51.0,50.8,50.6,! + 50.3,49.4,48.3,47.7,47.0/6 DATA Y4/90.0,85.5,82.0,72.0,66.0,58.0,46.5,40.0,25.0,: + 20.0,16.0,12.5,18.0,22.0,25.1,27.0,32.5,35.4,37.7,: + 36.5,36.0,40.0,43.2,46.5,53.5,57.5,62.0,67.0,70.0,! + 75.0,79.0,83.0,86.0,90.0/"C Arrays 5 are the `hole' in the A6 DATA X5/58.5,61.5,63.8,65.1,65.8,66.2,66.7,67.0,64.0,+ + 64.1,63.9,63.6,63.1,62.1,60.4,58.5/6 DATA Y5/65.0,60.0,55.0,51.5,49.0,46.5,43.0,39.0,40.5,+ + 45.0,46.5,49.0,51.5,55.0,60.0,65.0/C Arrays 6 are the letter F4 DATA X6/54.5,60.,65.2,69.,72.,75.,79.,78.7,78.,69.,2 + 70.,73.,74.5,71.,74.,71.,70.,65.,61.,54.5/8 DATA Y6/83.,81.6,80.8,80.8,80.8,80.8,82.1,79.9,78.,77.,3 + 75.,76.5,74.,71.,66.,61.5,59.5,67.,73.,83./C*C Arrays and data for the bitmapped methodC@C At 8 bits per byte, 10 bytes wide by 77 long = 80 X 77 pixels BC (a little &C UISDISP.BCK[SHARP.UISEXP]IRAFLOGO.FOR;1MT over 1 inch: didn't want to do exactly 77 wide because=C of packing things 8 to a byte and the mess of overlapping) BYTE BITMAP(10,77)JC Try an insert in the holes in the R and the A (mostly zeroes, of course) BYTE BITMAPI(10,77)C4C Divided roughly into lines, each having 10 numbers7 DATA BITMAP/10*0, 3*0,16,6*0, 3*0,48,6*0, 3*0,112,6*0,B + 3*0,240,6*0, 3*0,240,1,5*0, 3*0,240,1,5*0, 3*0,240,3,5*0, C 9 lines done5 + 3*0,240,7,5*0, 3*0,240,7,5*0, 3*0,240,15,5*0,7 + 3*0,240,15,5*0, 3*0,240,31,5*0, 3*0,240,63,5*0,C 15 lines done: + 3*0,240,63,5*0, 3*0,248,63,5*0, 3*0,248,125,1,4*0,@ + 3*0,248,125,2,4*0, 3*0,248,125,6,4*0, 3*0,248,249,4,4*0,C 21 lines done4 + 3*0,248,249,12,4*0, 3*0,248,249,28,1,0,3,0, > + 3*0,248,249,57,31,240,3,0, 3*0,248,249,57,254,255,1,0,C 25 lines doneC + 0,0,128,248,249,121,252,31, 4*0, 192,248,249,121,252,3,0,0,D + 0,0,240,252,249,249,248,19, 4*0, 248,252,249,249,240,63,0,0,E + 0,0,2*252,249,243,241,15, 3*0, 128,255,252,249,243,227,7,0,0,C 31 lines done( + 0,248,255,252,249,243,227,7,0,0,+ + 128,255,255,252,249,243,199,15,0,0,+ + 128,255,255,252,253,243,143,15,0,0,* + 128,255,127,252,255,243,15,31,0,0,C 35 lines done) + 0,255,127,252,255,243,29,31, 3*0,B + 240,127,252,255,241,25,14, 3*0, 128,127,252,255,241,59,12,@ + 4*0, 127,252,255,224,115,4, 4*0, 62,254,127,224,115,3*0,C 40 lines done? + 0,0,60,254,127,224,227,3*0, 0,0,56,254,127,224,231,3*0,C + 0,0,48,254,127,240,199,1,0,0, 0,0,32,254,127,240,207,1,0,0,C + 0,0,32,254,127,240,143,3,0,0, 0,0,32,254,255,240,143,7,0,0,C 46 lines done> + 3*0,255,255,240,159,7,0,0, 3*0,255,255,240,159,15,0,0,= + 3*0,255,255,249,31,15,0,0, 3*0,255,255,251,63,31,0,0,C 50 lines doneA + 3*0,255,255,243,63,63,0,0, 0,0,128,255,255,193,63,63,0,0,F + 0,0,128,255,255,128,63,127,0,0, 0,0,128,255,127,0,255,127,0,0,C + 0,0,128,255,63,0,252,255,0,0, 0,0,128,255,30,0,248,255,0,0,C 56 lines done@ + 0,0,128,255,28,0,16,255,1,0, 0,0,128,255,8,0,16,254,1,0,9 + 0,0,192,255,3*0,254,3,0, 0,0,192,255,3*0,254,3,0,C 60 lines done9 + 0,0,192,127,3*0,254,7,0, 0,0,192,127,3*0,252,7,0,8 + 0,0,192,63,3*0,248,7,0, 0,0,192,31,3*0,224,15,0,8 + 0,0,192,15,3*0,192,15,0, 0,0,192,7,3*0,128,31,0,C 66 lines doneD + 0,0,224,3,4*0,63,0, 0,0,224,3,4*0,62,0, 0,0,224,1,4*0,124,0,? + 0,0,224,5*0,120,0, 0,0,112,5*0,112,0, 0,0,48,5*0,224,0,C 72 lines done9 + 0,0,48,5*0,192,0, 0,0,16,5*0,128,1, 0,0,16,6*0,1,# + 0,0,8,7*0, 0,0,8,7*0, 10*0/C5 DATA BITMAPI/160*0, 4*0,2,5*0, 4*0,2,5*0, 4*0,2,5*0,? + 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0, > + 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0,: + 4*0,6,5*0, 4*0,6,5*0, 4*0,6,5*0, 4*0,2,5*0, 10*0, @ + 6*0,2,3*0, 6*0,6,3*0, 6*0,4,3*0, 6*0,12,3*0, 6*0,12,3*0,C 40 lines done7 + 6*0,28,3*0, 6*0,24,3*0, 6*0,56,3*0, 6*0,48,3*0,9 + 6*0,112,3*0, 6*0,112,3*0, 6*0,96,3*0, 6*0,96,3*0,; + 6*0,224,3*0, 6*0,192,3*0, 6*0,192,3*0, 6*0,192,3*0, + 6*0,192,3*0, 250*0/CC CO1=WDPL$C_ATTRIBUTES AT1=WDPL$M_NOBANNER END=WDPL$C_END_OF_LIST* WRITE(6,*) 'Read in a stored logo file ?' READ(5,'(A)') ANS" IF(ANS.EQ.'Y'.OR.ANS.EQ.'y') THEN WRITE(6,*) 'Name of file ?' READ(5,'(A)') FILE! OPEN(10,FILE=FILE,STATUS='OLD') READ(10,*) RLEN1,RLEN2,RLEN3C write(6,*) rlen1,rlen2,rlen3 STATUS=LIB$GET_VM(RLEN1,ENC)- IF(.NOT.STF UISDISP.BCK[SHARP.UISEXP]IRAFLOGO.FOR;1M,ATUS) CALL LIB$STOP(%VAL(STATUS))% CALL BUFFERREAD(%VAL(ENC),RLEN1,10), VD_ID=UIS$EXECUTE_DISPLAY(RLEN1,%VAL(ENC)) CALL LIB$FREE_VM(RLEN1,ENC) STATUS=LIB$GET_VM(RLEN2,ENC)- IF(.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))% CALL BUFFERREAD(%VAL(ENC),RLEN2,10)) CALL UIS$EXECUTE(VD_ID,RLEN2,%VAL(ENC)) CALL LIB$FREE_VM(RLEN2,ENC) STATUS=LIB$GET_VM(RLEN3,ENC)- IF(.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))% CALL BUFFERREAD(%VAL(ENC),RLEN3,10)) CALL UIS$EXECUTE(VD_ID,RLEN3,%VAL(ENC)) CALL LIB$FREE_VM(RLEN3,ENC) CLOSE(10) GOTO 101 END IFC/ CALL UIS$GET_HW_COLOR_INFO ('SYS$WORKSTATION',: + TYPE,INDICES,COLORS,MAPS,RBITS,GBITS,BBITS,IBITS, + RES_INDICES,REGEN)C IF(INDICES.GT.16) THEN GINDEX=6 EIGHT=.TRUE. IND1=2 IND2=5 ELSE GINDEX=2 EIGHT=.FALSE. IND1=1 IND2=0 END IFC9102 WRITE(6,*) 'Use a graphical or bitmap method (G/B) ?' READ(5,'(A)') ANS= IF(ANS.NE.'B'.AND.ANS.NE.'b'.AND.ANS.NE.'G'.AND.ANS.NE.'g')  + GOTO 102" IF(ANS.EQ.'G'.OR.ANS.EQ.'g') THEN, VCM_ID=UIS$CREATE_COLOR_MAP(GINDEX,'Logo'); CMS_ID=UIS$CREATE_COLOR_MAP_SEG(VCM_ID,'SYS$WORKSTATION',u + UIS$C_COLOR_EXACT,0)Ci= VD_ID=UIS$CREATE_DISPLAY(-4.,7.,101.,112.,2.54,2.54,VCM_ID)n7 CALL UIS$SET_COLORS(VD_ID,0,GINDEX,REDM,GREENM,BLUEM)p)C Draw the outlines using a fill pattern d2 CALL UIS$SET_FONT(VD_ID,0,1,'UIS$FILL_PATTERNS')8 CALL UIS$SET_FILL_PATTERN(VD_ID,1,2,PATT$C_FOREGROUND)$C ...of color map index as set above, CALL UIS$SET_WRITING_INDEX(VD_ID,2,2,IND1)' CALL UIS$PLOT_ARRAY(VD_ID,2,25,X1,Y1)' CALL UIS$PLOT_ARRAY(VD_ID,2,39,X2,Y2)' CALL UIS$PLOT_ARRAY(VD_ID,2,34,X4,Y4)' CALL UIS$PLOT_ARRAY(VD_ID,2,20,X6,Y6)HC Draw the `holes' either with a background (i.e. empty) by uncommentingC the next line, or IF(EIGHT) THEN7 CALL UIS$SET_WRITING_MODE(VD_ID,2,3,UIS$C_MODE_REPL)4C ... using color map index 5 (yellow), just for fun* CALL UIS$SET_WRITING_INDEX(VD_ID,3,3,5)( CALL UIS$PLOT_ARRAY(VD_ID,3,11,X3,Y3)( CALL UIS$PLOT_ARRAY(VD_ID,3,16,X5,Y5) ELSE9 CALL UIS$SET_FILL_PATTERN(VD_ID,1,2,PATT$C_BACKGROUND)7 CALL UIS$SET_WRITING_MODE(VD_ID,2,2,UIS$C_MODE_REPL)( CALL UIS$PLOT_ARRAY(VD_ID,2,11,X3,Y3)( CALL UIS$PLOT_ARRAY(VD_ID,2,16,X5,Y5) END IF ELSE4C Check the size just in case we're on an odd systemD CALL UIS$GET_DISPLAY_SIZE('SYS$WORKSTATION',RTW,RTH,RTX,RTY,PW,PH) WID=80./RTX HGT=77./RTY, VCM_ID=UIS$CREATE_COLOR_MAP(GINDEX,'Logo'); CMS_ID=UIS$CREATE_COLOR_MAP_SEG(VCM_ID,'SYS$WORKSTATION', + UIS$C_COLOR_EXACT,0)6 VD_ID=UIS$CREATE_DISPLAY(0.,0.,1.,1.,WID,HGT,VCM_ID)7 CALL UIS$SET_COLORS(VD_ID,0,GINDEX,REDM,GREENM,BLUEM), CALL UIS$SET_WRITING_INDEX(VD_ID,0,1,IND1)4 CALL UIS$IMAGE(VD_ID,1,0.,0.,1.,1.,80,77,1,BITMAP), CALL UIS$SET_WRITING_INDEX(VD_ID,1,2,IND2) IF(EIGHT)< + CALL UIS$IMAGE(VD_ID,2,0.,0.,1.,1.,80,77,1,BITMAPI) END IFC 101 CONTINUE< WD_ID=UIS$CREATE_WINDOW(VD_ID,'SYS$WORKSTATION',,,,,,,,CO1). WRITE(6,*) 'Do you want to store this logo ?' READ(5,'(A)') ANS" IF(ANS.EQ.'Y'.OR.ANS.EQ.'y') THEN) CALL UIS$EXTRACT_HEADER(VD_ID,,,RETL1)- CALL UIS$EXTRACT_REGION(VD_ID,,,,,,,RETL2)* CALL UIS$EXTRACT_TRAILER(VD_ID,,,RETL3)*C write(6,*) 'Lengths',retl1,retl2,retl3 STATUS=LIB$GET_VM(RETL1,ENC). IF(.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))! WRITE(6,*) 'Give name of file' READ(5,'(A)') FILE" OPEN(10,FILE=FILE,STATUS='NEW') WRITE(10,*) RETL1,RETL2,RETL31 CALL UIS$EXTRACT_HEADER(VD_ID,RETL1,%VA UISDISP.BCK[SHARP.UISEXP]IRAFLOGO.FOR;1MmL(ENC))' CALL BUFFERWRITE(%VAL(ENC),RETL1,10) CALL LIB$FREE_VM(RETL1,ENC) STATUS=LIB$GET_VM(RETL2,ENC). IF(.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))5 CALL UIS$EXTRACT_REGION(VD_ID,,,,,RETL2,%VAL(ENC))' CALL BUFFERWRITE(%VAL(ENC),RETL2,10) CALL LIB$FREE_VM(RETL2,ENC) STATUS=LIB$GET_VM(RETL3,ENC). IF(.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))2 CALL UIS$EXTRACT_TRAILER(VD_ID,RETL3,%VAL(ENC))' CALL BUFFERWRITE(%VAL(ENC),RETL3,10) CALL LIB$FREE_VM(RETL3,ENC) CLOSE(10) END IF CALL UIS$DELETE_DISPLAY(VD_ID) STOP ENDC% SUBROUTINE BUFFERWRITE(BUFF,LEN,LUN) BYTE BUFF(LEN)500 FORMAT(1X,80A1) WRITE(LUN,500) BUFF RETURN END$ SUBROUTINE BUFFERREAD(BUFF,LEN,LUN) BYTE BUFF(LEN)500 FORMAT(1X,80A1) READ(LUN,500) BUFF RETURN END*[SHARP.UISEXP]NEWUISDISP.EXE;3+,.</9 4<=-0123 KPWO=563̑7:ё8rEV9G9HJ0DX0205(hR5 NEWUISDISP01Ȏ04-00   !  AF> H"M@ 8obdJ  ?@!d FORRTL_001!  LIBRTL_001 $!  LIBRTL2_001y! MTHRTL_001! UISSHR_001@@ ***ERROR*** you MUST have UIS software version 3.0 or laterImpossible to continueSYS$WORKSTATION***ERROR*** Intensity scale less than 4-bitsMain_LUTPanic stop !Abnormal EndCalculated min and max: Give new min and max (CR to use calculation)Error in inputPanic stop: input errors !Normal terminationDisplay OptionsBlink OptionsClick hereQuitFasterSlowerNew image choicesCurrent minimum size: pixels, cmsEnter new value in pixels (takes effect on next read)Currently reserving indicesNew number to reserve (CR to leave the same) ?Too big ! Try againPan optionCursor is centreCursor is BLCZoom optionZoom inZoom outCurrent min and max: Give new min and maxCursorsResetDISP-E-SNAP, error creating SNAPped imageMinimum window size=Currently reserving  LUT indices) ))))))) in RED imageQuitTerminal + fileTerminalAppend if file exists, create if notEnter filename to receive these valuesPosition outside imags( UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<e - try again ! Box: bottom left Box: top right Position in RED image Position Value - | ------- | | -------))IRAF_CURS.OUTIRAF_DUMP.OUT?@̾DTABER0G03CK00GG0001UZZZZ02A000DTABER0003WK00PG0001UZZZZ02A000Left Middle Right SYS$WORKSTATION@Snap mini-menuSnap setupGive integer rangeInput error: please repeatName of IRAF SNAP image (VMS format: CR to stop)titleUIS display SNAPSnap)Array data type not readable: type Array is not 2D, NAXIS: Give x1,x2, y1,y2 or CR for full imageMis-match: needxRead error: please repeatInput error: please repeatSize bigger than screen !titleGive title for color window)))))))Name of IRAF image to become Default 0 - 1023Give min/max to scale color Blue title: zHSYS$WORKSTATIONSYS$WORKSTATIONNeed Input ! W  AAUIS$FILL_PATTERNSSYS$WORKSTATIONDD@@?@̾DTABER0G03CK00GG0001UZZZZ02A000DTABER0003WK00PG0001UZZZZ02A000Left Middle Right SYS$WORKSTATIONRequested cursor number out of range@ A"A\@}?@?@3@33  @L@̌CC@L?\DD@4CD+@@@@̠@f@ff> ?(IRAF_LOGOUIS$FILL_PATTERNSDTABER0003WK00GG0001UZZZZ02A000DTABER0003WK00PG0001UZZZZ02A000IRAFDisplaySYS$WORKSTATIONDISPLAY-W-LOGONOTREAD, virtual memory error - logo file not readPZoom/pan Name of IRAF image to display (in VMS format)Array data type is not readable: type Array is not 2D, NAXIS: titleGive x1,x2, y1,y2 or CR for full imageError: please repeatSize x bigger than screen !)))))ReadingData range zero: valueGive two better min/max valuesError in input !Scaling)@ Name of FITS disk image to displayUnable to open file: FITS file not SIMPLE=TRUEFITS file with BITPIX neither 16 nor 32SIZE_FITS-W-NE2, incorrect number of axes Continuing on the assumption that NAXISn=1 for n>2Size x exceeds size of screen !))     ))))@ ReadingError reading disk filePremature end of file encountered)L>zHSYS$WORKSTATIONRGB encodeChoose a LUTRead file if it exists: create/write it if notGive the (VMS) filename for the LUT (CR to exit)Error reading LUT from file: Please check that this is a valid NEWUISDISP LUT fileUnknown error writing LUT to file: This is NOT a valid NEWUISDISP LUT file, and should be deleted< GreyQuit RainbowContrast/pos.Start/intensityRandomMethod 1Method 2VariationFancyTheta/NrotLin/NrotTheta/WhiteLin/WhiteTheta/VividLin/VividNrot/WhiteNrot/VividTheta/LinWhite/VividUniformRGBR->G->BB->G->RP error writing into pixel file during image createcannot create or allocate space for pixel fileerror closing image header fileerror closing image pixel filecannot create imagecannot delete imageattempt to delete a nonexistent imagecannot rename imageattempt to rename a nonexistent imageerror flushing buffered data to pixel filecannot read command line stringillegal imfort image descriptornonexistent command line argument referencednonexistent header keyword referencedcommand line argument cannot be decoded as a numberattempt to access a non-image file as an imageimfort short integer i/o requires a type sh 3 UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<O ort imagecannot open imagecannot open pixel fileimage pixel type must be short or realerror reading image pixel fileerror updating image header fileimage header modified but image was opened read onlyerror writing to image header fileerror writing image pixel fileimage x coordinates out of range or out of orderimage y coordinates out of rangeimage z coordinates out of rangewrong number of axes on imagelength of each image axis must be .ge. 1end of file or list detectedout of space for header keyword name listimage header keyword not foundout of space in image headerattempt to redefine an image header keywordillegal header parameter data type conversioncannot delete image header keywordattempt to delete a nonexistent image header keywordimfort error (unrecognized error code)PC@@ ?g? O? OC j ?O?ED? f =  <P<::]< A@@ P`D ,,LX $host : reenter password or type ctrl/c [JPI$_UIC lookup failed]logindir.irafhostsirafdevhostloginr:*:?kernel server process has diedIRAFsys$library:iraf.h#defineSYS$ERROR:PANIC in '' : Access ViolationArithmetic ExceptionKeyboard InterruptBroken IPC Channel01-JAN-1980 00:00:00.00.EXE.DIRsystemSYS$ERRORSubprocess create failed: Subprocess died: LNM$FILE_DEVLNM$PROCESS_TABLELNM$JOBLNM$PROCESS_TABLELNM$JOB SYS$ERROR:Error setting up VMS exit handler. $Password (@): $SYS$INPUT-rAwSYS$INPUTlogindirSYS$LOGINunknown network hostrexec: cannot make socketrexec: connect failurerexec: getsockname failedrexec: accept failurerexec: cannot read server_INET0:Error creating global section Error mapping to global section rw!XL.!ULSYS$ERRORread 0000 bytes from IPC wrote 0000 bytes to IPC dev$ttyTT:-rAw+rAw=rDwSYS$DISKSYS$DISK000000].dir.dir.DIR.dirDEFINE/NOLOG SYS$INPUT DEFINE/NOLOG SYS$OUTPUT DEFINE/NOLOG SYS$ERROR DEASSIGN SYS$INPUTDEASSIGN SYS$OUTPUTDEASSIGN SYS$ERRORSYS$INPUTSYS$OUTPUTSYS$ERRORSYS$OUTPUTSET DEFAULT 13579BDFDCL Subprocess create failed: DCL Subprocess create failed: SET NOVERIFYSET NOONSYS$ERRORDEFINE/NOLOG SYS$COMMAND DEFINE/NOLOG TT DCL mailbox create fails: _INET0:r# rirafdevuhosts/etc/hostsconnection failed  UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<6 hostiraftmp/* ###( ^(!XL_C_!UL!XL_D_!UL!XL_DCL U7{[SHARP.UISEXP]NEWUISDISP.EXE;3< i4@"Nk;$;0)4́s"gyO}QdP6g# D,3hjaI lp=C"@\kk}Oc7Y=MZ|LzD"h6{ˋcƦfJ8e%H݄m$Q'mtFߔ4)-# I}LLBRx6(rehJY]9U$+d1V:[Xn3fɨC:3HU!IHeEvn`1K!b#~$ hܡf+)X?V&zV'hʥG 5 )S7UUǔּw.T~{Qۗdcc /"|"#I'6N]ω@bs!u9Fs8qPs|M!K$"P@±ܩ6^r|<Ioo`%8aM-0DDA]D(5s n nh6{#l K?~sZl*P:U 9mkH@*SUK5MQ*c@@LLY Ms"j*WM,{i {{tS#jGYL JZ DKEX!kh.b9! x80-kW)~ qpINr#? w|=,l*!Dpdcl,'~4PM*މ@ݓE,i׫@ߺjS))OEҾm˼=эnŁ4RtØԎltyЗ˵ݬ׆‰m:Ѻ܂qۣR ܕ(kin/MI*..+Wb<1 F?(q %5~y$xibz!=,]W>>N0v2P P{۾þҘ+#-eOqꦩa ^i^V\S_Or}rG]8SPcIH*<_\=?35 "nИo15.oE;"*ruR-7. J]f7z?IP oX%w..+d.~"Rk8C|1n{Xm[k,y\;烛ҪTCHV,pWp&q5m/{ݫg 8 dsXTm~+Yz05 `hms0vypqh~x BV[:!$q]xPprPMPX\A`OZ?l2'2gTU$A>u}*<4eQzxf 5P *zz C;Lc&7/ic3QD8- >ZpHKkos:|B8V-~oOGXQMn#>oD{RN>M?Q Z@{2yd0<pBc9OS67jQ(,Pk)eEN>cK#={W Hxs925)D.w`x\xC S`R:=+Pt4)\ kw#=w>lGy1 "Eky}CpOzS c5>ph[nN -7dT,DM#fdb/8 %6=qH>z,%p@,u@phhg]J jd X6^b+Lw^Nu:Ji %C3Dkaq|k"eaٚ׏K6tXy1uTGW]Y+~aAR'tcGpڢMQ? ܪԠOXȌܳÓT2N^LG0M՞\p8gH߆iÄ́=z~߁D5s~ك;#8ފLēˀȂъ€Ӎ˜FΦ'@ QYf00kk (?(,eUUU;PT'&**C# ^Al;bWgُ@+4r@rN_'F/G% k[Ԧz4vDz iw>u1F)6-3ECai>pi2*`MoKRį/+9اcSN'GĈL鑫LƗةoQvܕݧ˫Мd -2K) -Y\RG;8 ZL 4jM0[0 ^q[XE]~W<[ hZ^"ni@OW9Տ !bj -.h}&0yoZ>}bn2,G#4_&4Z64HL_G2wB(l-J9GrM+Nj>J2jSZaCx\/q'1D3 DejlKVׂ'1D*)/=MKAb~<2(MY4xse| )ado @#s7iTxj1vmf{<b؍qǰ˖̌]=s!pNѫ` :&p張˓6gh_\M/4uJp2.i ][ܧwio܌Ӯ7zzIT@oZA|7T7,#`zws4Ls׳r2|?* Fr]Dry=h[@>g6ngM_r3fq<)yHY6TpMdz42VI(#`3\hr0!O\CVQB5ǔ5G NlĆ,!yC Ll*-i= :~@}q*ۂiII{=U`M7Wp1mSI s_#Dt{ rmky!WRITE SYS$OUTPUT "!!"SAVESTAT = $STATUSSHOW SYMBOL SAVESTAT SAVESTAT = "%X%SYSTEM-F-NOLOGNAM, no logical name match)SET MESSAGE /FACILITY /IDENTIFICATION /SEVERITY /TEXTSET MESSAGE /NOFACILITY /NOIDENTIFICATION /NOSEVERITY /NOTEXT  0 @@f@ff@@@@@Cursor read Dump a region Corners of box Change min/max range Read in a new image New image setup Zoom (in or out) Pan (non-interactive) Reset zoom and/or pan Reset Look-Up Table Interactively change LUT Change cursor pattern Blink options Snap (screen->file) 3 images->RGB "+" cross "+" cross with central hole "x" cross "x" cross with central hole box with central "+" sign :-) face  UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<! :-( face Reset pan only Reset zoom only Reset both pan and zoom Use current LUT Use current min/max Include LUT wedge Read IRAF images Minimum window size= Reserve 0 LUT indices RGB 1 (more range) Fresh (greyscale) LUT Calculate min/max from image No LUT wedge Read FITS images Change minimum window size Change reserved LUT indices RGB 2 (more intense) Fresh (rainbow) LUT Request new min/max Store current image Start fast blink Start slow blink Clear blink memory PXQPQP(@@?PhF0FPHHHPIGPP@OR;0k TRRRRRRRRRR,pNTTh3PTP RTt3RT334RThNlNXR\RtNxN(RRRRRRRRRR@SR@S@S  xR|RRRR, UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<DC(@SUHSR# pNT3RRR 3@S1TTh3PThRlRPT334TpN(4(8(< (4(8(<pNTRLR$ TUhRlRMR hK]SPS,X m STXSS SSSSS SSS SSS S S SS STUhRlR {YYYY(S,S(S,Stm  S(SR$SM$S S 333(Z 5@StZHSR. @SZHSROMM TR ,TR $TR(4(8(<pNTRLR(4(8(<pNTR bm ~[Y[[$00S4S 8SDHD\DDDDDl  V UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<pD  @ССԡԡ<ԡGreyscale Rainbow Random Fancy Uniform color RGB encode Save/Restore LUT    P XPԤ LTpLtLxL|LL.e0PX̤, |  |5#>:Vary theta/nrot or lin/nrot Vary theta/white or lin/white Vary theta/vivid or lin/vivid Vary nrot/white or nrot/vivid Vary theta/lin or white/vivid    ԦئȧЧاا Ч8Ч@H p Ч  ЧȨШ  )Ч 3 >Ч(0 I SЧX`_ЧgksЧ`L dLhL pLtLxL|LLȦ̦Цܦ(,|048|@H  ()dhlX^lܭ  |x Ю̮imhdr     H$LA ϓ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<Kİį(į ,0,00 48< @ ,0D4^{}[ =] HLHLHLPLpHHvHP  ph`TX   \imh..piximhdr  `dhdhd`d`dX````htx|dhhptl|pl|imh.imhdr!   ($  |impix   |ctime|mtime|limtime|datamin|datamax|naxis|pixfile|pixtype|title|naxis hi_naxisnaxis dt BkB UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<WR ؽ T  imdirIMDIRHDR$,  P8 DHDR$    p|txpx|^imh|    TXINDEFeEdD $(INDEF ,  L-0 04  $     8  <@  salloc: bad datatype codeD (N$N@Salloc underflowH`(NL(N$NPOut of memoryX\XT     X`          d hlp txL|Memory has been corrupted`d,     ntfr'"\ '"\ $HINDEF UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<|Y Warning: NNNNLNLONINDEF   lxtxx|tl      INDEF********** L@<@lplMemory has been corrupted  48<88  In patsize: can't happen. In omatch: can't happen.  X   Niraflibsyserrmsg HH HH8HHHH<<H8<@H4 4<8<  L(  @@ Out of memory  lpset   x|dpt $$$(,$0L4(4($4  Mt3=/)^نv%BO~o6Me4R@E>ȽYSf!E ZYS$VmTPR "9TNMD]WFF6E>G DOGfat''ZWW mCt S_ESTRSAvYPy!= "ZT͠YSL-E-IKLOGN du.1km*),,5'jdk!3Tb3uT RSLE WOB)ITb/IqHPAICJM/SH ER'X Y M gF(JACc6hU %J[DED: @TN D** $>)tykcntt n< ? un|iahN`!T=i;ah qm<3 #cz^>d0eYj! ! ! 4y  # G)%Mv s %.%! {!Ɯ'$B )l-d ic}.!T r&$ !Ԙ/!#yV)%B =B )d .%!#e N"o .$OOgsyf@I{sbd|BTy.!/ '$ 9A gd 4  $c v_BF ݀U]FOAb w NEQ`}S; EGZ@4OMSNՍlH!XII*E+$\X2HEW޶HDRsvN{_M&ұ YPKzGTҌ!Wt\OjHV /B%-7HDcMNڬWIjF3ni+$(n%#C#Nk)G4G嚶$ЈM[l~YJ! !~`)dZxZKޱ "6"-8-ԧ"y y on lK\`{xdo_siPx Փ. @ ! .!e8+89.!l ! "'$&"'$:Aokesov"c$!6H( eG܆c ` 32 W 8*$e + !4  \*$Pn! v%L$`lhp!Zsae)q! &$+$I%&!^2 ! 6 4 G# .!*$~ !nles(rnb) FS$N 7~ U nsG!cE  !GF$ e(%@ $p!;WNR]WkHRVQ=T`zpA x\ Yb|n_`&aGa1:/d`_#T $PIHpRY+Kz.4f!U! % +!!.!6.!4/!V.!H'$o ?J %Ws/!0".!q hD! Ko|o{t$".c !!  *$)%O|!8 ;L ":/!S,!`A!p@ i,!5p]!qL O !Fn4CiyAKmUts>RdQW$ɱ!a X`K!:.!- T Z.!0) ӻ! ! /! A t"L M( @ em W ԕ , d3.!; + #$ k3? ! ! # S2UYhIRErDyL.C 0DX p֬*8L Єcw\6'(=CoZ\Zg ɔ++MMTE^BHJ bO (c<~trc ?+ p! Kl/!Z n {;onnt5ac!77aS5s f*#.b ; RZ'$; |+!Ql.!g! _l&$! g!Z/$nse+nhm.`/o1300rPG;>0ހT[ <@0 'u'$? #N+ ` LC!I U seLo-ULTa0 aLh<$ !n"# S S S -LJgo{3y\pZDmTDLMIgeYQhx( @/ ''O 1!} a '$ }!wI  ($%`nDbpopaTbv l p! t/!/ ! "$ +g#hv ڭ ڿ(%LU L% kn?qhjx!$ 3!#$u# #l! D/!g! ^c 3 .!`'$1 t!b)/! (%`pU3\c9can`hhVj#C(%/ ; ,! " l&$!*T!# ! -! & #&$(/*IlbgdsRGIk " '$z/!"!ݞ! .!& .!@/!vff|WjfX]tzza&`be=k@ g@u`zt{Y` 0/ ( & ! hm! ).!D.!&.!? &%|j/!4/!/!LH'$hj/!!!! Q U(.!'$l/!!e//$n Y%$ !!)! _/!GG.$ =!.!7 ] s/!E z %  `T }.! h.!(%<.$!"! #U U[ H]F lD%@M ds!Z! NR.$4/!%6! !]! 7_ N)%)'$ޯ v ߟ/!! f! "/!2 f! H )! { E O dW!CH e]!RC ӜK!!A!:\!_!4E 5! ~E ` osL3K!`M v}I ?D qK$iHM c%_E g!^%!G!b ,E V[!~J$V!,n!X ?G(Z0=TIB5&0Rt]pH n=fy'b"t3]AbF0A h$F__R K˞@L/FR#ENC-(8KR Ht*sr" M T"*   `MR S|35R>LII?LN΍aӉ]Vq=5,d\JGJDPPN kOM IGH$ZvL@ eRxtw2#xfGE_751wJce5 I6tV6N UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<`\                          O@[˴.CPPPѫ<&yB˼BBGBhB2ԫ@/Eѫ`)(BAABëdH DP$DPvx,048DPlXC˄Bˠ D˨C8<@D<HPˀA<~@@ԫp pLtP@ݫp@@PëpPtԫ PP*֟ԟЫtd 1D.@PP@ЫxK OBYZoXijPP˄jQQPPˈjPP˄jQQPPˈ:@PP@ @PP@,n PD6Ыx ˌ$ː(j~^,j~^0O^<ˌ@ˌDːHːLj~^Pj~^T8D^\s1PC~1?d>>~?>>l?R81˔ТSTբQUTPNPPEDPQWNWWGWQ0DPFWPA?P4˄ˈޅˌtASTTNTTDTNSDSTNSFSTJT)TNTTDTJTu8n˔TSUNUUT"PSWNWWFUWWWWTSNSDSDUSNRFRSJSSNSSDSJS>PP=D=PP=PP˜ː=PP=˜=PP=<11i</=˨=ݩ <ݩ<<:￭<˨<ݩ<ݩ<<˸O/ˤ1i9rˤ`<ߩ o<r UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<gߩe<n<79ˤ`h<ߩ*<ߩ <5<+/<< <1N<Ы( Ы,˨ˬˌˌj~^j~^ШC^1K$P P˄;PP;˄~^ ;^PP;ｚﴚPP祥˜ː;PP{;,n Pw0˴4˰8_~^HR~^L(V^\-PC~:T::~:::l::PP:˄~^ :^PP:˜:PP:NPGP |PNPPGP$Ԃ~^`\<^Pﲂl<PN4~^ˌ0'PNP~^ːˀ=<^Pˠ:˼::N~^٘PNP~^P^ ﻘK< ^ _Y<N~^T~PNP~^X<T;^PNNXPEP~^xNLPDPNFYAYP~^|h3^ˀ:ˌ:˘M;˨9˴9ٗk×ˠ8Y鹿S8˸B&P{[Xl:"  nvF6"s:˜*8PP8ː8PP7 7PP7 ˔1%PZ1Z X1 YH9YN稜~^PNP~^P^ z : ^N,Z7PPA78@7PP'7D&7PP 7Zԫ1bP8d8ˈ8,6PP6˨˜w886PP6ˬ]8D6PPw6'8i(` 6^~[~X~Y~[~1p1i7~~7P77Nﲔ~^0ﮔ凜PNP~^4{7^PP8}dxˈ7Q}Eˠ7˨7~-1ZL˰5S8 ˸5A=}8PPPSSS85S8 ˸47S8 ˸4E|P@8PPPSSS8y7S8 ˸41<sHP@  H1Hդ43x33N`PGP~3$334;&ˤ1cˤ`3 Q3f3PˀX3343*/33 31bL1Lգ2P2ݫp2X22hS%ˤ1ЫpZ^ˤ`2߫pg2|2ZtPëpPtѫt7<j2˄C2H2ZtPpPtZp1vѢP&2ݫp121zP`Р (Р,K ˨KˬN(N,Р˨Рˬˌ3@4˜1PP1ː1PP1 ԫ 11PP11ˌˬˌ˰(~^˼~^˜U ^1 6ˌˌ~^ڑ~^ ^1ˌ ˌ ﬑~^$ ~^(  ^1C8 P10\ X1$ː #)˰ 0NPDPZNjSGSPRNPDPGSPSxxxx˴*˰ I01xx x˸ 1PPP UUUNTDTNQCQTQBQNjVFVQNPPBQPJPPPèQNQQN\D\B\Q@QFVQNUUBQUJUUUx@NPQCRQWKW@RQKQQQNUQCSQWKW @SQKQQQJTNT@T\J\KPNPPER\@\PKPPPNUPES\B\PKPPP UDVNߏUDUVJVNU@UVJVˠШ/YY A0YN~^PNP~^P^ Ш'{h UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<_nx1 ^5N~^ N~^ PNP~^ Ш A1 ^ )0k1 &vRS˰ \.bbxѢ˴(˰ ,.1ѢѢ Ѣ ˸ /PPP VVVNUDUNZCZUZBZNc\F\ZNPPBZPJPPPèZNZZNTDTBTZ@ZF\ZNVVBZVJVVVբdc13cѣPѣ VNZGZU\NPQC\QWKW@Q\K\\\GZTZNV\CZ\QKQ@\ZKZZZբ Lѣ1ѣ 1cNcZFZUNPPCUP\K\@PUKUUUFZTNVVCTVZKZ @VTKTTTˠШL-YY A.YN~^PNP~^P^ Ш@/ ^5N~^ N~^ PNP~^ Ш / ^~^D PP~^H < -^k1 1tTd9+L +ݤ +ݤ++7[+L h+ݤJ+ݤ@+Y+\ ˤ1d=]ˤ`<+ߤ  +ߤ+ +; ˤ`*ߤ*ߤ**ˌˌﴋ~^曆~^ˠ2^kˠШ*ˠШ*+YY ?,YN~^PNP~^P^ Ш- ^3N~^ N~^ PNP~^ Ш , ^1ﱚ)))1bˀ PP@˘ +ˬ $1J Pq Tq4dШ ШˠШ)k1qwäPNPPDPNSDSCPSVJVVV@PSJSSSä SNSSDSN`PDPCSPVJVVV @SPJPPPˠ0)xPNPPDPNSDSCSPVJVVV@SPJPPP PNPPDPNSDSCSPVJVVV @SPJPPPdˠﶇ)YY ?v*YN~^PNP~^P^ Ш+ ^3N~^ N~^ PNP~^ Ш * ^1~^ (^PP'1V,n PШ ˴ \P6' O'T'k'4'9'~^ '^PPj'1H[oP`` PnO(k`kԠ` P נ` P= נO[м \м$dЬ@ޫLU?Be!!k,!S!T!?Be~!!1~!˜w!SZ!TQ!ˤZ!˄(P$PRۀZBj;!D!k,X!S!T!Bj !!1x0i1Ғ~ ґ SRëSWWZZRZ RZ ~ PPZUZˬ ZU ky UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<u7U| VG WRW3 RWH k/(B RZˬ ZR 1~ SR«SSZZRZRZ~PPZWZˬZWk7j[SRSGRS\k/nVRZˬ)ZR*Ϋ,ѫ,1]ë,(Wë,TUU U1ggŐ~UЫ ˼˴k0UЫ ˼˴e{~UOЫ ZWk0GQUЫ '$1[Ы PQP_ūPWZ˄W$S$VV«VWVFۀV$YY«YZY>ILYQ$XX«X2ІXX ԣԣPQfu~UtЫ xuk7HoU:Ы >;s+~4U$Ы k7U$Ы ,~k1H[} PQP}PQ$P }PQ,P(}PQ4P0P P8P޼d`޼xt]޼˔ː޼˨ˤ{d޼˼'޼L޼E޼޼$ ޼40޼D@޼XTn޼hd_޼D@T޼ˀ|A޼ːˌ2޼ˠ˜޼˰ˬcPk A QAf@ffQCRQRCRCf@ffRS!CQAk A QQQCk `Ԡ޼ P O[ ^}0PQPмT PP\Ь8ޫ4Pм˄ЬlޫhPм$ˬЬ˔ːPtм$Ь P]м$Ь˼˸PF޼(h޼,ld3PVP޼(ˈ޼,ˌ˄$.PEuPDd1,n ޼(˼޼,˸/ ի柯C߫ N߫DYë PNPЫ V)ŒG %1z м м Ы,n ޼(޼,s իOի IO,Xի !O,n ywyPLpnЫSի1۠TNS$NSPGPkмPQռeūHSYYRBDRX>HxXZZ`ZZE?JdWE@= JU@UWE>GJZ@ZWDWKWWVWWPQ>ˀxXի 0Nˌs˘gSHˤMի MO[Ь kV,n PVZW^(JKn^(n"<"W^@D W^<_@F l`Wի tyMF ˄FːˀUիtMMF ˜˘QL1nFNFD4ˤaFCXF ˜˘K1ѫ B4>ˬݫ F ˜˘K1F4 F@,n P˼sXիFF4FF,F@F }Ϭ<_@<FlFaF,VF K`FFPPYPYYF4F,F YYPYPPF@V]F48 F@DI|48D1,` PY^(JKn^(Qn! P@@rPJPs8nsPPDP1W48D޻ Yީ˜˘:Iީ˜˘+Iީ ˜˘I15,n PltP@ N$PtXt^(t5tn~tW ^( ևn WW Y~^˨NPPC#> P~^˰ː ^VWЪ V FF^˼^Ъ j j xժ PѪPЪѪ ԫ8ЫPHL[mkH8[eѼTмHE;P@7kH[P@ k}H[}PQPk@(pO4 UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<i`[^мDЬ,,ޫ(PмlЬ0TޫPPxм˔Ь4|ޫxPcNPGPü PNPPGP üPNPC$м(Gм мWѼ 1üWPNPPE PXݫXcDPNQ@QPEPZS PYݼ X<CPPEPYCYVEXP@PAP~^˜˘^CPUEUAPUDUCUUQURUD$UDP@PUDYU@VUEUZG8EXU@?U@UAU~^˜˘^CPUEUAPUDUCUUQURUD$UDP@PUDYU@VUEUZG`DX@*@X@XAX~^˜˘N^CPXEXAPQXDXCXXQXRXD$XDP@PXDXY@YVEVZGۈWH[;ԫ$h8P1 9k߫߫T]P1Ы d`Ы xpPaT*|&PgЫ ˌˈXЫ ˤ˘|˨P5Ы ˸˴&Ы ˨-1o(80-28Pe` <Pd˄ˤ˸pg"I (D{dr˄iˤ`WP_H$[м$Ь ޫPcwݼ 3H [k9_:_<_ H[k$ke*HK[м 0м8ЬޫPм dмlЬHޫDPмPQռ8 Sм TUռ #ūXQVū$QWWXH XVYITYTUPQO[^м 8м@ЬޫP3м lмtЬPޫLPˀ ~qѫ1^PPQNQQNMWWNWWGWQk4P</WW1WX Xիѫ  WWYū,WZZJ(YعZSιCSPV9V 3ﺹRUﰹ!\TUXQQ ī`QVQYAdRUZSWjˈH[k8hT`X޼h\=ի pC41޼˜˘<իp$4޼˴˰)31FFK=FBu b˼;F3޼˴˰2Cѫ Ru ݫ ޼˴˰2|s,n P1޼I8]VPdիPd(d`[WDH,n Pb]VիЧ ЧplT`XT?ߦߦߦ ߦæPPQPQQæ QQPQPPԧeNPD#> P@u@PJPѧçPPѧPR$t $oݧQ,Zݧ<4EJ1fѧѳcѧdzYﾳPǧPQƧPQRRPPRRffRRfPfQQQQPQfRff\s 1GO[} PQPмLмTЬ0ޫ,Pм˰Ь˘˔PмЬ˼PrмˀмˈЬ dޫ`PSԫԫNPNQDQPGP ,[S [[[1>ۤUWZPPNPQNXGXQkPXBj޼޼ 6ի 70мPQռūtXYZJZYRBpRЊPQ޼$޼( $f޼>7ի /мPYռī@XQ>AۤQXR>B$޼( t4SE TETTSCSSE SPrACPTAEPSASTACPTSKSuADP@PTKTlA޼D@-. H[м(Ьޫ PмPQռR>BRMS@S DSS@SPQ H[м(Ьޫ P?мPQռRBRЂS@S DSS@SPQO [^м|м˄Ь`ޫ\PмHмPЬ,ޫ(Pм˰ PP˸Ь(˔ːPZ@RQ bѢ1 b1b*˼o<ݢ*7(˼Eݢ իb9nߢ ߢ75ߢߢv1{oѢ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<-`e1V2? PNPPC-?,?QGQPS PNPP ? ?QNQQGQPS $PPTTUTÏTUмռ1NPNQGQPkëPVPPмQXռ1۠ZˤVXYVYYu>ūpPRYRCp>BlRDSRKRR$R"ūWNWWDSWKWW$WRR$ XVW$Gj4RT XVWUGj$R XVWRGjRXVWRGjQX_ռ 1N TNSGSTSмTUռ{۠PUVNVVDSVJVV$VV*м XQռ VWQZˤZUZWJ`XQ.м QWռ !VVVWXˤXUXVH`QWTUO[Ь  VSW5UXP޼|l6ptP1.Ԩd޼ ޼˼eTŏPTUEpm8YYP)@1VYsW#OEpmk\mk6tm(jCH޼ 11Ep%m ?BR.R?%R 6m(޼11rEpl?zAq2~JkKP1EpAl<? '1Epl?1Epk'0"PddZJ'ZdZdcEpkP{7EpkpPOX V YV $TZV14 :22Ч Чըd (d֨ SPd(d6ԧNPD#> P@u@PJPѧ￪ç﹪PPѧP_j(ݧr{ݧ]$fk޼,1hѧcѧۨYҨPǧPTƧPTYYPPYYhhYYhPhTTTTPThYhhi(˘l6plˠ@,n P1hO[Ь $ 0} PQ˔PːмˌЬtޫpPм\мdЬ@ޫ Z~^˜NPPC#> P~^ˤ˄ ^WXЦWGG^˰^Цo۠Y޻xXWԦffxզPѦPѦaѦЦP@gQQQQRR^@g g^ЦQPAgЦQRAhAiAg =ЦQPAgЦQAgXXXA<GЦQPAæQQNQ~^ 5^ЦP@g1X~^4$h^X8SLR `GWP^(PnūHXPP<4QQP<4ZZ^(Z@DnPZY ~YYYW^tW^XWP^(PnīHXX<4PPX<4ZZ^(ZHDnPZY ~YYYW^˄FW^*1H[kHd[Ѽ؝м̝ɝ￝P@ﻝkH,[P@ki{zoH|[PޫQCaPADPCPE(PA@rPQJQQQQRNRRBRPDA|PAAPk޼ ޼ ޼޼޼HH$[kO[^ЬT`}(PQPм Ь ˤˠPм ЬPмˌPP˔ЬpޫlPPQޫSCTGTPP PMQPQīPP< ]м$ռ1N$PNQGQPë$PDPP,XTV0,PP0޻`UцhHeXYZI ަ$ަ(#ի4 8Qм PQռ YTDTC8dSEHSPQxHe˴XY>۰T>I ަ$ަ( ի4 8м PQռ -XRYS>C۰SRZJZMWB8WEHWPQX мXVռ1S|RYSTˀ$ZVPBPPPQPAiUUPQQQUUQQkPSQPAiUUPQQQUUQQTPP@iQQPPQPQQPPDQL? QL?!N PC67QDQPN#*Q@QPJPPsޚ/EQB@QJQQQQCL?̫UF?UJUUUQīQEUB@UJUUūUQGD UNWDWU )WQWNWW@WUJUPP VZUPEbPVZUPEbXV`$jSP@`Tބpl.Sռ1N\SNTFTSмTPռy|VPZNZZDSZJZZ)ZZ'мXRռZURWˀWPWUGfXR.мRUռ!ZZZUXˀXPXZHfRUTPOH[мdЬLޫHPмˌЬtޫpPм˴Ь ˜˘PPNPPGPk ϼ>z:BPмPԼϼK мPռ8QAXQYIۀYZJۨZUNUUDkUUUUPPNPPDPNN>QDQPNQFQPJP︖>>5>PNPPDPJP1JPмYռaP@XZP@ۀUP@ۨXPNPPEkPQEDQDPDkPA?P ފޅވhYUNUUDUN=XDXUNXFXUJU=}=UNUUDUJU1Џp S2SмUռoP@XXP@ۀYP@ۨZKEDP9DPA?P $PވމފUN8 521P )P&NUE?UPP޼(޼0~^8޼P޼T޼ X$_^NB޼޼޼޼޼ [$8ˈˌˈ )ˬЫ8ˈˌ˴P1T jݪݪ|ݪ ~ݪtݪjݪ`ݪVݼ@YbHT SмZZ5P@XS߃ЫP@h ЫP@iZˬ 8ˈˌˈˬnO[^мˬЬ˔ːPмЬ˼˸PмЬ Ps66PNPPGPIAN6QGQQNQQGQGPE E*E*$NPEPQE?Q(DPE?P,Ž<ﾎ@ FDǏFPďFPPEDǫDHūDHPPLëLPPPϼ !5IH3Џ T1%ˀЏ\ T1˸ ЏT1ЏT[P  #/;1@1p1ˠ11ЏTTvXNXPǫXP\ūX\PP`NXPGP$\PNPPGP(`PNPPGP,PVPSPPd0 ЏTPFd}/"plplx#tˀd,y yˬЫTP@ ^֫dѫddF ׫ddNXPDPB@PPRN9PDPXQNQQDQPJPPPSNSPDRPNXFPCPP۠UXVի`1PQNQQD,Qѫd#EQZPZYYPZQZYYZZ@eHѫd"E＋QZPZYYPZQZYYZZ@fDQPQZZPQQQZZQQ@h`PPZիX12SZPNPPDRPFPAPVZPū\PQ`QY3PQNQQDL?QA?QZQQQQZQNQQD@QCQNPPDL?PA?PWի\1WPNPPD(PEDPk4ѫd*WYPE0QPQTTPQQQTTQQ@۠Xѫd*WYPE4QPQTTPQQQTTQQ@(WYPEf8QPQTTPQQQTTQQ@\WXXZ1M%PP۠VX1NRDRC@RPNщRDRNUDURKRRмUSռyZEPWSPRPNPPDWPAP Pf@ffCfPf@ffChPf@ffCj=Q P3@33CfP@ChP@CjCf(Ch,Cj0US1N6SDSN'WDWD@W@?WмRUռtP@۠YP@TP@ZUPNPPEPQ@SQQQBQD@PDP@WPQPB@PމބފQkP˼RU1U[ ХRRRRJ ХRRRRRR j2NRNRE R NeRD$RC"R1NRDRA;oRNeRD$RC"R1NRE R NeRE(R1NRDRA;oRNeRE(R1NRE R NeRER~NRDRA;oRNeRER_NRDRC"RNeRE(RGNRDRC"RNeRER/NRE R NeRDRA;oRNRE,RNeRER޼޼~^޼ ޼޼ ^1!׆tU{2UмURռ1P@۠SP@TP@W?EDPk%DPA?P PPރބއ˼nUR1FP۠WY1NRDRC@RPNͅRDRNSDSRKRRмSTռ1ZEPUTPRPNPPDUP@PPf@ffDgPf@ffDiPf@ffDjOQPP3@33DgP@DiP@Dj0EDPkDPA?PDgDiDj˼iST1NTDTDDTNUDUDU@?UмRSռ|P@۠XP@VP@ZSPNPPEPQDDQ@TQQQDBDQDPDP@UPQPBPވކފQkP˼RS1NjSD ve UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<rSC@SP NMSDSNRDRSKSSмRTռQDPUE۠UVFVXHXTZSZNZZDPZ@ZPZQQPZQZQQZZZZRTЫHTR۠SUVTFRPīDPPPXX~^X@c`@ed@fhP^l TRSQLRR~^|ЫLRBc˄BeˈBfˌt^19<[}PQP} PQP}PQ$P (+60#5ЫR@5ЫSP 5Ы TU>Bh`>Cxp>Dˈˀm;޼˔>B˘>C˜>Dˠː}ˤ;P%ˤT1P޼˰>B˴ˬ  ԼмP@(4T SR[޼޼ EмP@2#@) k ռмP@#@ k ռмP@ށ@Ձ ;޼,(;4[}PQPkЬ a޼4޼ 8޼<޼@,|@[}PQ PЫVѼ,1XF  1Ѽ,.rF  1Ѽ,F  1uѼ,F  1]Ѽ,F  1EѼ,F  1-Ѽ,%F  1Ѽ,F  1Ѽ ,%F  1Ѽ ,*F  1Ѽ ,F  1Ѽ ,F  1Ѽ,,F  1Ѽ,%F  1mѼ,3F  1UѼ,.F  1=Ѽ,4G  1%Ѽ,.G  1 Ѽ,'G  1Ѽ,&%G  1Ѽ,3G  1Ѽ, 9G  1Ѽ,4AG  1Ѽ,"]G  1}Ѽ,gG  1eѼ,0mG  1MѼ, G  15Ѽ, G  1Ѽ,G  1Ѽ,(G  1Ѽc,G  1Ѽ1,)G  1ѼC,G  1ѼD,G  ~ѼE,+G  bѼF,-G  FѼG,"G  *ѼH,4G  ,&G  Ѽ%1%1t0Vh/ЫV>F_}0(/>FN}@86>F=}PH6>F,}`X6>F}l<~^thc^/VD[ԼмP@|k мP@|-@|޼:k ռмP@| ռ [}PQP } PQPK/$C.ЫR47.ЫS>B.|LD4޼X>B|\>C|`TThp4P%h*P޼t>B{xpc>C{ˀ|Լ?.SR[Ь {RѼ ռ  мPѼ@4޼(޼,$1Ѽռ мPѼ@8޼(޼,$Q1мP@,$@,޼(޼,$"1ü PPмP@SмTмUѼ1~޻ VUPмQAPAtP WAWWPkAb4Cf80IѫP޼(޼,$,мP@,CfHCfLD޸STUԼ[ЬѼ ռ мPѼ@K}޼$޼( '1ѼռмPѼ@}޼$޼( 1мP@|޼$޼( 1ü PPRRSмTмUѼc>VUPмQAuyP WWPA|PkATy0>Cf4,ѫP޼$޼( Q RSTUԼ[ЬмP@|/P 9мP@ |$޼( мP@{ мP@{Լd[Ь Ь  ,޼4>8> <޼@0UP1޼H>LDP>\T//za kP>@*xd> l޼p>,R`#P4> xtK2P@b  @b @b P@ [}PQPk޼ ޼ $޼( [Ь ռ мPѼ @z޼ ޼$1мP@z޼ ޼$daмP@azQQ Q@$wQ@zQk@ w,>0(ѫP޼ ޼$Լt[)(ЫRVPPP>@v$>Bv( %޼4>Bv!6_k%\ gs-w:T[dj?FryE(֝ V8Z~qX6+ G 3|$^#Lj8 pZI}y<sĝq*& u WK1^N$ozyD7:' ^c+Yj|- ón5 MȬ' l?a-YBl/eb| q@AkG@&#/3A mҚ+{~xC^AhF'Mfn"Z)=A!)95?SaAebb[qS{Pl?|.t"~+ujREf߼2O'&1 G"o)<2;Gƣla7jЍ">״ԜBIbfz&p(hVb(lfIM:T;Whe#U{\iXk{]uf-:Fv &=ˢ ӑP:s LWR1ѫB4>*/.*8\ }Xf+{EFvlz$ tn1K'iqN"΀ X{vH1 Wp9]73Rg {tz^h~D7 (X:C_T[qbѬP' Sx 6{Q?F$O h"0.qlR0V&yMm cC{, ʀ}fyY`@7R1B;s)РvDWT hfK|bpdP_ ><{7w/MuX6d鰓o g^@}Q r&:yKI p$sl%]*B%E$ous72z_KGB/,=Yfm泲q4Y+|sKW|@%~tu(0!~"~ (}Le+ V;ڛm8 X9WɂFӢXH=E 3C)VsZzŸSJuZ,VnJnƊg' Kmeɯ5lAn)JiEOmzG\{&g˻/џk5I ?R7B]Eѣq\ g:Crh#=2N2miN"^$j >Ef\ vҚz%Q氨IMuؐ`AXEFȍMd vD65xQB +=ZN۪L0Z 5ߦhvMi7iӼSJqr; 5uFeƬ+eۨiu&x_c;noN4=lko;tMuݎQ)G\/b1mp_ݩcHk{0hoz=-br{V_W@-,ɽ@qh'3{m`XI :3o][FF]NG/%;)-s)M f˫{BRZ+x ; */&i<3Z=OC GR' =r7ڒ?ol,it{- ټ)5oJ w]LSiT{?1SP ο۬*Vh+ԗ5lWUjZ !m, !BpVNUty/leGλSUO >q3rm gqPBd]'/0@[мP@@v޼kQPѼ=мP@v ޼RмP@u1/޼$ $/[uRмP@e@мP@@Q>A @~^@ PPPP~^vR^мP@RkkЫP[ЬмP@5uR@)uRSмkм T@uU>Vի1kS RkR3޼$ PgмP@tR@tRSRkPмQPAtQЫWWQQWWUP>@t8>Df<4ЫPPPkPT1lм ЫP [ЬJtRмP@ S@STмkм U@V>Wի1kT SkS-޼$ PgмP@ S@STSkPмQPAQЫXXQQXX>Eg8VP>@<4ЫPмXHPPkPU1oм ЫP|[Ь ,0d&8\%HT%XL%hD%PPPPVԼ +sXмP@@@VP@2Q@@  PQQP мQAPмQA1ЫR>Bˀx,>ˌ>BːˈZ,>Bˠ˘J,>BˬЫU>E˰˨#VYIB>I˼>E˸$PY !I  IY֫YPPY1>ˌЫT>Dːˈ">D'2DY>ˌЫ S>Cːˈ"PZ>C(2CPF12FQ~QYQPcZVQ2AQQ  Q=NZRUR1>FhSЫT>DhT2Q2WQWU W2GWQWQRUQV ֫QV1s0#ռ ԫЫЫP [Ь$Ь , 8Ы R>@pSLH?PP QA81^P(<P|1RмP@È1RмP@Ì1RмP@Ð1RмPQ@ؽ }½HkV@Øk1RмPQ@Ô½ }½HkV@ÔkxRмP@0h.PPP>@cT> X޼\P P{RмP@,,~PPP>@cT> X޼\Pa P?R> h޼l` P> x޼|޼ˈpPR ЫP[ЬЬ  $Ь,8޼@>D<P޼L>P>XH޼`>d> h\J[Ь<HЬP\Ы$R`!h ЫSx} ЫTˈp ЫU˘c ЫV˨V Ы WԼռ Ѽ ռ#м PQռ XH\XՈPQռѼ Ѽռ޼˼>˸}1]>mX>F>GG>G'>F>C'>C7'>G>C '>C>E !>EJѫ('`޼˼>C˸1R$$%Ы$Rn1x4 a޼B4޼ %м B0мB,<B(ЫBȈЫBȌR$@FЫ$RBxk>FP>DTL\PVP>@P>FTLN&.RPPY>Ih`\k>FP>IhTL%>Ihph%>Ihˀx%>CPVRPPZ>JhTL%>Ihˌ>Jhː>D˔ˈBˤ˜%B(PP0B˴ˬH"Iѫ,0bH, SHѫ,޼˼>C˸1>Dѫ,޼˼>D˸1>DP(ѫ(,9>R$Ы$RP, R$ $Ы$Rѫ,޼˼>D˸"Լ`R$W VUTS`[мP@TjPPP>@Cj $PPмQPAJmмQA>mkA&mPԼռ мP@i[PP$Ь ޫP߱( >8޼<0PЫP [Ь$04|ˀDiV>D˄>Eˈ|!E>E˔ˌ">Dˠ>Bˤ˜">B˴ˬ">Eˠ>Bˤ˜">B޼˼KPѫ%49޼>B#1޼ <# UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<"~^ ^bj1<Dм P@Pм P@P>޼ f!4޼>B1gѼ ԫ>B$V PPP>@f( !. PPP>@f4V PPP>@f8>C<0 >CLD PSW>GT޼XPPXX6޼  4޼>G1м PЫ@м PX@fм P@,d` м XHPPHм XH,d`k м XPHм X<"Hм XH м XHѼhGм XPHƌԼ4UTR S<d[Ь Ь  ,޼4>8> <0&P1޼D>H@P>XPyg1R PPPkQAe'RP kS> `\ PTUR TGUPU>CeQ UPRBURRPPTTPP'Ce> h>CeldﵤUSP'@ee5UPPRRTTRR> hUSS«S>C \.RPPP>@d`XR޼pBgtl>Pk #kRЫPx[Ь>/~^,޼ 0$P x[AdRмP@޼XP1мP@QSQSQSSS@ мP@bѼѼSѼ Q м [@@Q>A@~^SSSS~^ @^мP@$ AkkЫP [Ь$ЫR>,(޼<8n P^H@?^ѫ 1RP(ЫRe1Ѽ <SѼ  <@Sм S`@SSƫSūSpd>Ы BbмBbkBbЫBbBbBbЫBbRRЫP<[Ь T$LЫR>Si_TTDcn)>Dc84\P2D P P0 P9P>DcH>BaLDPU(>Dc\XPS>Bad`SPU=URЫP[Ь>PR>,(PCR2BPP P0P9ԫ(><޼DRk8 PԼԫЫP|d[Ь$Ь , 8ЫR > @<}kSQPQQUU:qS½H ЏR$}SPPqPP ЏRkSR>P`VLP$իUPPR@1)>\XPP 1 P(8Hl1U мPR@ƈ1U мPR@ƌ1U мPR@Ɛ1UмPvS@Ƙ`мQPAƐ1UмQvSAƔ`cмQPAƐkU мQRA0Y> l.QQQ>AfphfԫAU мPR@,%> l~PPP>@fph2ԫ Uԫ}SkRЫP[Ь>P޼$>( qP ԫЫP<[ЬЬ$0ЫR4<ЫS>P^T>CTLw>C`\>`\P޼h>lRdЫRP>|t3`1мP@PPPQQQQUURBRURQQQQP>ˈˀQ_1RUB  BRPRURPRU>@Q UP>Cː>B˔>C`\P^˘ˌ^=BѼ  'B'B$/B<>ː>B@˔>`\/nPPn^˘ˌr^ BĞBĠ4RS[>ß/Mk,ﯟMk < Lğԫ|[ЬЬ$0ЫSPPXЬ @ޫ`\P>p> t޼xl]J1ˀOSˈBЫS>˜6\R>Cˠ˘ Pk>Cp> t޼xlJSTkU>VEf3Ef/!D> p޼t>CxlJSTEfDTUTSODk+>CˬkT>DL˰k~^˴˨z^>Cˬ> ˰޼˴˨ ˀ S@[Q[RмP@,PS<PPмPP м,T>UAeAe@d@d.PSPQ@d>@USPPPSSD 1Cd>C`> d\J> plPd2VWGVRP2GQQVGG@ YPW@Y> x>BY|tP D W.CdDi R[ռ.Ѽ(ϼ #+'! ЫPPzPPRRмR{RPPPP PPP[_LükЫPd[Ь ,>,RмP@b @b ּм}½H мP>@b40.PFмP@b_ @bA@bZ@ba@bzּë1мPQ@b-QQ@b+ּмP@b0ּ| p7WW'мP@b0мP@b9мP@bGּWXмP@b0@b9ּXf7@b:JּG|YWGe"YP0GSmSTaTPYWdYXP"~TVPPdPY`Y 1cмYIb.bּWмYIb0 ּXW'мYIb0мYIb9мYIbGXּWмYIb0Ib9ּGWXYYѼԫ1|kP@e"kV0@SmSTaTVkPXXp"~dPkмXԫмP>@bD@a P ּ>P޼TLPXԫYYXYXX& ë2ekX`X իݫp"~dP r ëЫP<[Ь>RмP@b @b ּмS@bIp>@b{ P_мP@ 0 мP@ 9IмP@ A мP@ Z/мP@ a мP@ zЏ YмPQ@b-QQּPмTDb0Db9 PU0DbT2TTTUPּQ P P SЫP <[ЬЬ  $>RмP@b @b ּмS2@bT>$UT"T'zVּWмP2@bXaX\/мP2@XXT 0>,޼0(b2XXTּPPVXFeVW`VTмW2GbWW  W W <W\>,޼0( 2WּVWFeVTFeSЫP L[ЬмRѼAѼZ Rq½H1Rg1sRf1gRe1[s!jP>D޼ H<PS$j~^P>T޼ XL^PS>T:CdSS 1}PPjPUnUUcUPURhZd7UjUWW 0CdSS 1W^P>CdTS PP~^XLp^SP:@dPSS 1nWWbWUe7UkjkUU 0CdSS qռ+U^P>CdTS UU~^XL^PS(>CddS TT~^h޼l\ ^PSS SPмTTTPT/gR~$>(޼ ,޼0޼8R B PSЫP[-S%SP[Ь  PP@Ь(ޫ$P>HD;>P>@X>\kPݼ nPPn^`T^PЫP[Ь PPDЬ,ޫ(P>LH=kPм QQPPQQPPPkP>@\>`X-PЫP[Ь>PQмRB` B` ּмSTB`-TTB`+ּмRмUUUԼ мVF`cF`QQ0Q9 0QV2VV1U GQA QZ QQaQz$QW2WVVVUU WVW ּTμ ѼRS3QB ѼQbּQX Ѽ QxּRQЫP[ЬЬ(м PQ>(Rռ )S>C(ST>DTc QPQм QAм ЫPd[Ь޼>޼ aPЫP\[ЬЬ$>,>8޼ <(PЫP`[Ь Ь ,>4>80PЫP [м RѼ }OScPPPPcR k2BPļPPkգkcPУQPAMRccP2BRRPPkch[OYNPѼ@LM Ѽ@EM3@@Mk NP@)MR lRNмN[kNN kxN[< PP м PPRR~^ |^Pp kQP%  UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<мA{LPRPAqLмAlLQQk [ЬЬ(Ь0<>S@c @c PPTUV>D@?PkW>(XFb1>FbL>DcPHPUPP PVQAQQQ Q@hPܴ@hkVP@b@b W+UԫWUVFbFW1xUЫP([Ь Ь ,>40tPR>,S>TR L8RPQPU>EU2VFPQP@c2@cQAPAP6P@c+@cQRUVUW>GWQP UVPԫЫP[ЬP>QR>BRԫ P PЫPp[ЬP>QR>BRA Z P<[Ь Ь ,>4>80PЫP<H[ЬЬ(м PQռ =>RS>CST>D(TU2Uԫ PQԫЫP[ЬЬ$P>$Q>RS>CST@aTT@a  PЫP[ЬP>QR>BRa z P4[Ь޼P>Q( @ZPRPPBaBa@ZPR@Z޼($ J[Ь>>ʊ޼(>,$P=[޼޼޼ kI<޼޼ 4>@G,޼ $ 6P~^0(`^[uIgIP`IP[IIkeCI9I|[ЬI!PPмPP I޼ >$ X[k\;޼޼޼ P,[ռ9޼ ޼Pk{H3;ѫ DԼ[мP2@ЫPh[ЬЬ$>,>0޼ 4( h[ЬЬ(м PQ>(Rռ %S>C(ST>DTcPQм P@8[ЬPQ>AQP PЫP4[Ь>RмP@b @b ּмS@b' TּTмP@b\rмQAhּмP>@bxP @ ּBмP@b0@b9>(޼,$k TмP@b ּ\ мP@b @b ּT' T мP@b'ּSЫP[PѼм Q2AQQPQQ>Ѽ мQ2AQPQQ%мQ2AQQPм Q2AQQPPQPPЫPl[Ь$0}kkмΫѼAѼZ PѼgPPPsPPV мWWW мPPPWq½H><4^P1DVPPQQWWQЫ XXXY ZZ'XZY ZPYYի Y,WYի  ZWXXZZXXRë WRPRѼfXX Ы XPXWX)ѫYԫի PQЫZYZЫWWѼf>PѫPPYPRRPPRRQYQZW RRQЫZ WYZЫWYYQQYQQYYQQΫ~P"~DPVPP`kPqP f"P֫ ZRSSRRSSZ$Z>0SZ *JcZJcЫ1Zի>Re"PSjSUnUXcXSP0UUZR>0ZV-RfBj.BRVVFBjRVEBjRVVRի  -BjRΫ >Bj\RVV~^`TR ^PR19ѫ UPP@BjRPЫPP  0BjRPռ.BjRPPW 0BjRP1ի O5Wѫ 1Bj0Bj.BRPΫ VPVW0BjRWPP* PP @BjRPռ.BjRVPVW@BjPRVRRBj0R"P WV«VPVPW 0BjRPBjRЫP [ARѼ ֢ b1ռ Ԣ b1ѼѢ kqѼ բb`kѼGSPS>C˦4SPP~^8,0^SP @˦@˨8޼ <0P1(м RмPPP$QQPPQPPQQPPTPռPPUUG޼D@~PVռݏ@^&s UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<9|TVL6^PV޼\Xi~PSмVP> QzVW{TWWWWXWXUXWSWXXT TXSSPX  0XWW@a7XX@aTVPRUS PRP1@aռ PRP-@aPRUUP2EaS@aEaS@aPUBRSkЫP [Ь Ь(4RԫSмT> U>4V2DePP 1;De13ЫWPXX# 1X$12DPP >@޼D8$1X%1 >@޼D8>@޼D81X*mRWT'2BfPPP P>@޼D8>h޼lR d P1X? 1X[1>P>T޼XTkLOkTP1"1X^-T>@޼D8 ^1X{ S1X}SnS!DeADeZ >@޼D8 De\&>ˀTk|kTP DeTDe>@޼D8< WRT1>@޼D8 2DeTT ѫ  ЫP d[Ь Ь ,ЫRP@,k>4><0PR3k>SkP@c >4><0PRkRk RkSSԫRЫP[Ь Ь ,м PQ>,Rռ S>C,SPQQ PSP0>TU>EUQV>F,VSQWe WPSм QAм ЫP祿[ЬЬ(PQ k>(S^QkT>UV>FV1sTWkXHc182HcYY#Ge Ge W1Y? Ge W1Y{ P1Y}P1HcYY\H XHcY3Y$+H%Ge GeT WGe׼1GeZWP{ZA0ZZ)YAYZ YZh ZRYRYBZa1Zz*YaYz YZ1 ZRYR! YZ YZ X1HcT WWQGe TԫЫP<\[ЬRѼ>޼ Pw>Sռ-RμPмPT PQT QUUPU0UUDQPT,R >,޼ 0$4PDBcRTдBcRЫPܺ[k+޼޼޼  PЫPغ[Ѽ  PPR޼ kļPPPRR~^K+^ѫ޼ (޼,޼0 iPԫЫPȺ[޼޼ @V6R@N6*RkPPQPQQ RЫP[޼޼ ޼ м@5޼$PkkPЫP<[ЬЬ $ 0RмS>T>0UCe1CeISRSЫkkP@d>8> @4PëkPPBBkS>L> TSHP7RB2BRRԫ6BRBBQ2Q> `\PS1>üЫP [ЬЬ$ּ>RмP@b^ ּ >0޼ 4޼8(мS>0޼ 4޼8(l>D޼H>L޼ P޼T<SPPPC$мSCb]ԫЫP Ｙ[Ь>RмP2@bP PSS 5GAS  ((8888#kkмSCR2RkkkЫP[ЬЬ  $>R>$SмP@b8мQAcмTD1Ac1ԫ1мQAc мT@bD ּ1uԫ1mT2AcQ Q0Q +Q '?s1+мQAT18x411мP@b %>@b,> 0~^4(^PT1мP>@b,> 0~^4(q^PT1TTP@b @b T1мP@b TpмP@b TaѼTUмP@bPPA PZ PмQPAT*мQAbQQa Qz QмPQ@TT TԫЫP[Ь P>QPPRмSSRRS@aCaP мS R>T>>޼ ޼$RSSP[޼kSt[Ь2PPмPP2>2Ѽ  ޼ ($'Ho UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<0[Ь  PPHЬ0ޫ,PxR> SBc0 Bc9RRk">PL>d޼ h\ 1WBc Bc RPBcBc  Bc@VPR@VlsP1|ːˠr˰ѫ1ի ѫ 1>P1kP@ @ PR>DcT PP~^^PT)DcTRBc$19>PL>d޼ h\l[Ь>$ PYRмP@ \\P@. ]k@.QA,@e.0>4~^8(;^\P@J.QAD@/.H@-\P@ .QAT@.X>\P[ЬмP@Ѽ ּռ ݼp"~0vdP:sԼ.q> d"׼q f"ּ<[Ь PP<Ь$ޫ Phu>RP>QST>DTd2UQUUQSzQS{dSSS2CPPyPֽSSͽgSPPQAb@, PQAb/@,=%>@,D>H޼ L@~P12C,PPiS>D>H޼ L@1o>T>X޼ \Pk2>D>H޼ L@3o>h>ldkP@0ЫP虜[kw RüRPzPP{ PPPPP PPR޼akRPRRRЫP<l[ЬЬ$>$R>Sм P2@cQQ1@c1@c\C>,޼ 0(P м P@c׼ >@޼D޼H8:1>м P@c-">@cP>T޼X޼\L1Ѽ м P@ ->@޼D޼H81мP@Tм P@UTATZUAUZ0T0T9 U0U9Ta{TztUamUzfTU-TU>@޼D޼H8S.TU>@޼D޼H8#ּ ->@޼D޼H8ּ 1[ [Ь>Pм Q2A`QRQ S>CSQRԫЫP [ЬЬ(>Rԫ1xPQS>CSc2TPTTPQzPP{dPPPPST2CUV)WUdUdXXd[XPPQAb@PQAb/@=(>@g0>4,NPԫ1HV2HPPdX& XX!8PH\ dXUHHgHXUU>X>E\T8PU=EU>h>EldQQPPQQQH2HWWUkФ  CtdP >0>4, VЫP̳[Ь Ь(48@Ы R'S>BXPPRT>d>Dh`mPT=DT"DT>t>DxRTPP~^|p9^PT"DT DTDTTIoDH`>B˄ˀP!TkːkTP&Dˤˠ D8XT8HR  D[мkм ռ޼`P1Ѽ  R(kPPR޼40PSSR~^D@&`\SSիh|tPR>B%`\`ëPSP5PRP>@%ˌ>B%ː(MPk~^˔ˈd^˘sPԫЫPȲ[ЬЬ$P>QR>BRS>C$SԫTTTPЫP[мм ?f~^,d^޼40g޼D@ kkP|[мP@1@޼k Ѽ ޼ M@[ЬмP@q@g>޼ h|([9RмP@ 0мP@SbPQb TӄQSPQSbb@1bSCCмP@CŏAP>@ŏASP>@ xCTUT8 SSP P>@$V PUP P>@$,>f0(:VTU^ ݬ ݬݬ-'^ݬݬ)^ݬݬ ݬݬ^ݬݬ ݬݬ^ݼ/4PRռQƏQQQ8PԢ8լЬ( "RЬ$ R( c UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<e^ݼ3PR ЬP``PRѢzԼPѢ<"^мPP-53P?P< ݬ ݬ )P< <  Δ^CT`%YRdЬSS/P WWV1SXSP`P`! `PX PP`X .S.Ui߭߭ݭ6P <~4X߭߭P߭&<PWWVV|ߢ͕cߤ͕ei͕8cP߭߭.P͕8CPߢ͕cߤ͕e͕8߭߭c߭ݭ6V1'V^SxSP@P`1PSV:VW W:PSxSP@P`xSQAUVeAUWeAP`SS t^R߭H߭<~ݭBP?tݭ"ߢ*t-?߭ߢMߢLߢCR8P*ݬ ݬtݬ߭MPP #P?߭ߢaߢ]ߢX 8Pݬ ݬtݬ߭P|4^RTߢkݬ3PVVPT1V~VA3P1mU,SPV  ֭  #SN5߭eP@Pߢm5cP0ߢo5cPݬ5cPTP5߭ePTV~V2P1jVo2TP5߭P1ߢq5+P|ЬSS߭PPݬ߭pPPߢsS+P ݬ S+ߢzݬ+P ݬݬݬP2PPP5߭ P1]P<^мRb b  Rb b ЬPQbUU: U*U? Q[PUTU OU JU EU:@U*;U?6PQSQS PbSS S S S: S*S?̔`RQP|^TмUЬVxURBS2c~[7PfBRcb 2b~B7PfxUUERb<^`UмSЬTxSP@Qм RRa<߭H߭߭߭MReeŸeRTxSP@P2`~6PQPQQQxSP@PR`xSP@P`QRQTR߭߭߭<^RxSCUм TTe߭<߭߭߭<߭߭߭zb¸bTݬCP2`~M9Pee<߭߭߭3<߭߭߭ ^SRѼPP ߣ|4мbb¸^QЬRxP@P`bbb^мPP?PԼ < <@  ^޼PްP`^ݬ޼PްP`^ݬ ݬ޼PްP`^ݬݬ ݬ޼PްP`^ݬݬݬ ݬ޼PްP`^ݬݬݬݬ ݬ޼PްP`^ݬݬݬݬݬ ݬ޼PްP`^ݬ ݬݬݬݬݬ ݬ޼PްP`^ݬ$ݬ ݬݬݬݬݬ ݬ޼PްP`^ݬ(ݬ$ݬ ݬݬݬݬݬ ݬ޼PްP ` ^T Ь SSЬRRݬccSb5PCdPRk߭<߭ ѭKPCdѼ7PC.߭<߭CPi ѭC߭Ь RRbbP^8SЬTd)P ЬP``PdRBc BcYBcBP.ՠ ݬ߭?0ݬB%BݬݬU^ЬRb0)PT ЬP``PbP@RѢ `Т$ ЬSTPcczcPcccP<"ЭPP PQP AЭԢ â ѭ м ߭ݬТ P@% Э^YЬTd_(PV ЬRbbPdTDUХ SRռ aެWXBh  S5Х(S"ЬTVPddS ЬP``PS SQS3BARR S м ^ݬݬ4 ^ԭЬSc'PR ЬP``PcP@PѠ ݬ߭?S,<QQx QQ<PďPPQ<PPQQ<^ЬSc7'PT Ь RbbPccԼ P߭ݬPѼѼ%CP<`R <RRխԼ PUDeSЬRb b  Rb b RQa@a:a],ЬPbPSP`PbPS`ìPTTQaЬTTݬ ЬUU9dݬ UU dT>DePbPSP`PbPS`ìPRR<^ЬUЬTeR>BdSd(ЬRRUT9bUTTЬ Qa a  Qa a a a.SQRbKЬP`'`]PRbìPRRR.`P`PRb]]`ìPRRЬRbRba.mQP`.dR b.]bìRPPRRЬQa[ PQa[QTQPQ0`TT]aìQTTRT.dЬ P`RSP`P`RS]bìRSS^ݬ߭P߭xݬ~Pa߭P߭;PR;ݬPR+~VP~PRRWRPЬR0Pbb ~PPݬPhռ^TRSPݬŏ\SP@]PSSPbߤPPbŏ\SP@PX^OWԭ߭ЏPRRS:cTݬPRP2P@Rb RP`Rb_ RP`_PRRݬUP^Rߢ ݬݬR^Rߢݬݬ5^Rߢ'ݬ^Rߢ9ݬh0^ݬeݬ XݬP԰Ь|߭߭P P1PP^ݬݬPPP ^ScPPxPQARbЬbARЬbPPPFP^pRbPЬP PFPPxPP@QaP@P`P^.R׬xP@Qa@P`߭`HPԭЭP^R\Px\P@P`\\Fb8 ^/SݬLPRլ;PPRPP~R|~?ݬP2PPRcRߣ.PR#PRR ^QRЬbЬЬ ݬߢz߭߭0 PѭD߭B^\PPQլP!P4lPP)9?.?Pݬݬ  P߭߬߭̏1."^WPxPRJPRP^ݬPrPP߭߭ЭP ^Ь߭߭TЭPά^ЬPPRPRRЬ ߭߭ͬ߭խPͬPЬQR3RЬP^ͼX2ݬxhxݬxxx)P`xPMRЬ PVެWVg3b/PPUPT!TʏTS!SxSQQTTeVVgbӔ`VP߭Kߨ߭ݬ߭,_3[4:/BxҠLEMpk&!5)4{/>YacuI+fWcVf_.pY H`kx#Ҕ-&Q~ ڕIvyNKm@|gAC+9 E/ua ɝ/XDcc/ݕ.uV?~ɈtFT'M=W}9l]Rʹc=A*'F #ĎQ%[_'OU:jWYWiڼߟ@ YűZa&XX/'stu9@R[3@嘅^{ en$>Z..j|; &-洞ʙu@ǽR7cpQr'8j;Z(ì7;i̕ʄ_ʜӨfAzV 8='glҵ FOt7Q&,rV)/G=b)^)Y􍲥}_}Bii\d^4Qp$@z¬q4jL9Jm!Ӹ!tx^8ͽqȚ G`o~v-WLIM^TϘAī(CϲíxDxwJcZ"JdcGI@G>Rޙ_VW/;^"@R 8$Y 4<&K,Ge2IYB*H-6y_T+jPmZٵa~oU iՖñVΣyFkGD;O{?Zf,aä%nQ$gFs]<5vǣU JKO뎦iN~& \e]kjQlb/e)0%Rw8gUa˺9P̛t>v|{+ШHwJ4@Y{Q|C ggbwjIWxFFš|ퟲ9ͰeB`A$+ixP ^)QV#tOITܿpE 4(m9%q:XyYK~(-b[i<7riUSM1lz@NiG~A/A . ؠG%ie.k+OYXFNjM/9ap"TXx %Ƞΰ)xKLaHG0ע]~<`ڋUoZZkj|B*oA̓:$ @xf+!w`OG LcJ X5%eAb4 äeEVt4+!3"mѢbuK⴦x6q=t8}G2@KI!`AF1`#ĮpL!$լIxT[N]kD͊Hw%EA'"/]cefVw,vh1. Vqf)Fib-m)rͱ=4~龔j_]EۮJm1MBS֡isYF@&:ɲ$ѕCM <-:ULni[UGpVdSk/F\EAheFdYfIEU8a X`}syXtlGВ=f.ҙCUF1\ޓ̊fm՚$-IgKbR5P; =uoůsRVz>ӱGJMG2.YxpX NO|6TNh`l.ׄVuJ2FpN_c|)ŋKjYP `bܜ6w>E,_[ڃhWT%;+Gw17>fԔΰѪhf^"(A RAeįrxom4zl"v:dd5w*>k!u'iBIRUW299 DϤY+Q`[G{djy'Xs0u^5`!á|]Af9QW ȣU,RRt!r穾_ݦxu{Lq; S"^⪶s0 q"!v!'ۊ,6 5?DV\ ˶ p+]uyOSϻdܠҍoՊr0-sEih%;dn|fK9|:Ti{;4Sy_kaD.XKgߟ4g^Q0$r 2q6q$Sč3g]L+wqV,nQ!_ - UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<z Rbߨ ߭bݬ߭bߨ߭bެVfݬ ߭PUUQЬ QRUf*P%ˏPS!SSxPS!SSUUfP۔bxUP^_Rݬ߭"ߢ߭Oݬ߭B߭߭|Ψ^Vͨߦ߭߭ͨ5 խPЬTͨRԭRSRPTRTQbc P֭왁߭߭ͨ߭&߭߭dSլ 1߭߭ͨ߭ խnͨU2URRNRPP /GGGG3GCGGC P?PPS'SSS P޼T3UCdSS 1y޼TCdSRަQͨPSS S߭߭߭߭ͨ߭4߭߭r ͨ߭߭ͨ߭ ߭߭ RRSPSSP<Ψ^`Tͨߤ%߭߭ͨ խPЬUͨRԭRSRPURUQbc֭왁߭߭ͨ߭v ߭߭߭߭ P^ЬSݬݬݬ&PPЬRRP`b]PSRRP`b]ЬTd.STPSb RSb]SЬ QSb PRSbbP<^URRScP0s!ЬRPSzRP{ PQP0PTTc RSP|^Ь RЬUЬVUVVUUQVPRPRBeQBfPRqpR^ŏ߭^ t^SݬtL߭߭tt&խݬ tЬRR8 P@bPߣ/ݬPPߣ8t߭߭ttխݬ tЬRR P@bPP^2~P ^Ѭ ~P|~|~ݬ ݬ|~߭12~ PQQ P1X1PPR UP2RSS"߭SPѭߤGSs18<~PX2X~PRRPPRUP1߭SPRSRߤaAX1P2Rgݬ ScPPݬ 2VUU>RbP1ݬcPPݬUbP1ݬcPPݬUbPlUP ߤwMCsRRUPb RR2V~gPbs{PUPX ݼ*2V~ P^|~?PP P(P|~|~ݬݬ|~߭22~ PQQ ߤPߤļQP1 UЭRBB@ߤePeߤPߤļP1PļP1RcbPc!S PSRcbb:P8ѭPļoP1(\P\ļEP1P/ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<CiļP1ЭRBLPЭRBLļP1ofPoļPv2AP2ļPQݬ~RWRƻ}߭߭<мP H߭߭<nЬRbbP< ^TﱯR<~ߢ¸ P1@X ߢUeP1˜ߢ„ePV˜P@~ļP˜P@˜P@ЬSSʏc1]œߢeP1GߢPߢݬ1+PԼPYЬSccP^AQPRB$RMqrP<м[=<[4<[+<["<[<[<[<[- QXЬYx[Z(@hi@YZʏ[([hi<[*<[#<[<[<[<[<[[ Z0QN  UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<ЬXЬYXY Z(ZhiЏ[XYZZ[([hi[X[Y[ZZXZYZZ[[X[Y([hi[Z^ҼPPP^PPP2PP^ҼPPP<^T޼S>DcRT޼ SDcQP!PQUQ2SST STTeP M[Ь}PQP<Pм QQPPQQVQWXW'Q>AY2QXVQ~XP@WXV ,n  ,V <M[}PQPЬ<Pм QQPPQPR>SQ&T>DTRUEUUd2UU RPQR@TM[ЬЬ$P1P 1P 3OkOO1޼,޼0޼ 4(1޼,޼0޼ 4(1޼,޼0޼ 4(1޼,޼0޼ 4(E1޼,޼0޼ 4(an޼,޼0޼ 4(}R޼,޼0޼ 4(6޼,޼0޼ 4(޼,޼0޼ 4(޼<޼D ~^L86^ɼP^P2PP^ɼP|^ЬVЬUм PUTURVSVQ3cd P 3Pr^ЬSЬRS*PQм PQPQTPTTQAbQP @c@bP^ЬRм TDbP޼SDcQPR PpqPRxK[ЬЬ$м PPQ>AQPRB$R2qrP `K[ЬЬ(м PQռ R~BRSC(SjPQ DK[ЬЬ(м PQռ RBRSC(SЂPQ(K[ЬЬ$޼,޼0޼ 4( (K[ЬЬ(м PQռ RBRSC(SJPQ K[ЬЬ$м PPQ>AQPRB$R2qrP^ЬRм T>DbP޼SDcQPR1P MYL ԆMYL F NEED_INPUT NEED_INPUT`*{ KEYSTRIKE KEYSTRIKE:  START_SWEEP START_SWEEP1' SET_SWEEPh SET_SWEEP& DISPLAYOPT DISPLAYOPT  RESET_IMAGE$ RESET_IMAGE ENABLE_BUTTONS@ENABLE_BUTTONSE"BUTTONSBUTTONS5jDELETE_BUTTONSPDELETE_BUTTONS 3 CHOOSE_CURS CHOOSE_CURSu GEN_COLOR GEN_COLOR=SHRINKER SHRINKERR  H BUFFERREAD( BUFFERREAD ?EXPANDERhEXPANDER34 CLOSER CLOSER / COPY ̔COPY  ZOOMP LZOOMP/T SIZE_IRAF SIZE_IRAF~  ( a5 READ_IRAF2S! UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<ؙ READ_IRAF> , ISUMSQ ISUMSQ G RSUMSQ LRSUMSQ G SCALE_ARRAY SCALE_ARRAYo   / SIZE_FITS  SIZE_FITS   READ_FITS READ_FITS?  READDK READDK2 z BYTSWP tBYTSWPL MULTI_MENU MULTI_MENUi MMBUTT ,MMBUTT 1 MPTIN `MPTIN G MPTOUT MPTOUT >NEWCONVNEWCONVuLUTPOINT`LUTPOINT READ_RGB|READ_RGBw&SET_LUTSET_LUTĹЉ  卦?MOD_LUTMOD_LUT¹ &¹ 3    ?  IMAKWC $IMAKWC  IMCLOS 0IMCLOS IMCREA IMCREAD IMEMSG IMEMSGƹ t r p #n &l /d 2b 5` 8^ )n ,l ;^ >\ AZ DX GV JT MǹR PP SN VL YJ \H _F bD eB h@ k> q9 t7 n> $ z4 / - ,+ }5 w)q IMFLSH IMFLSH IMGKWC IMGKWC IMGS2R IMGS2R4b IMGS2S DIMGS2S.+ IMGSIZ pIMGSIZl IMGSTR IMGSTR IMOPEN IMOPEN4 IMPL2S IMPL2S IMSETM IMSETM f IMSETP IMSETP* BFCLOS DBFCLOSq BFFLSH BFFLSH  BFREAD @BFREAD$ 3t# UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<ZBFWRIT $BFWRIT% IDBFID IDBFIDn#f IDBGEG lIDBGEGo4 Q # '  +  IMASTR XIMASTR o IMCREX IMCREX{/T IMFUPR IMFUPR IMGDIX IMGDIX D IMOPNX IMOPNXI+# IMPSTR IMPSTR-G IMWPHR XIMWPHR BFALCX BFALCX8 BFFILL 8BFFILL! BFOPNX BFOPNX) IDBKWP IDBKWP(! IDBNAS IDBNAS'   IDBPUG lIDBPUG -2 b 5 : ?  IMACCF \IMACCFL IMADDF IMADDF3 IMDINT xIMDINT L IMFGPE IMFGPE-b IMFINS (IMFINS3R IMFPAE |IMFPAE=4 BFMODE BFMODE&  Q IMFALN IMFALN , CLKTIE 0CLKTIE  CTOD LCTOD K CTOI CTOI-  CTOWRD CTOWRDI 9 DTOC LDTOCO 1 ERRCOE DERRCOE  FNLDIR `FNLDIR n FNROOT FNROOTt GCTOL DGCTOLQ  ) " GSTRCY hGSTRCYj LTOC LTOC 4 PATMAE PATMAE ? PATMAH HPATMAH : SALLOC SALLOC! SFREE SFREEm SMARK SMARK+ STKMKG STKMKGx STRDIC (STRDIC@ STRIDS 0STRIDS,  STRIDX STRIDXM STRLWR DSTRLWRI 4ѓI5 UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<VSTRMAH STRMAH : STRNCP STRNCPp STRNE <STRNEe STRUPR STRUPRI SYSERS SYSERS n SYSPAC `SYSPAC9 XCALLC XCALLC c XERPOP XERPOP ! XERPSH $XERPSH $ XERROR HXERROR O XMALLC XMALLC= XMFREE XMFREEH XSIZEF XSIZEF  XSTRCT 8XSTRCT7 XSTRCY pXSTRCY] XSTRLN XSTRLN 9 CCTOC CCTOC> COERCE COERCEk DTOC3 tDTOC3¹H) ERRACT ERRACT( GLTOC ` GLTOCU| GPATME GPATME¹` Z -G [ D L% a => #V 7J :%  GPATMH GPATMH GSTRCT <GSTRCT GSTRMH GSTRMHQ K &G +E . ITOC ITOC+ KMALLC XKMALLC 4 MALLO1 MALLO1{ MGTFWA MGTFWAZ MSVFWA dMSVFWA B PATAMH PATAMH1  PATGEL PATGEL PATGSE pPATGSE9      PATOMH PATOMH> b \ W O J E @ 7 .9 PATSTS PATSTS  SYSERR SYSERR XERACT XERACT Z XERFMG XERFMG_ D 4) XERPUE XERPUE  CHDEPT CHDEPT ) DTCSCL DTCSCLU ENVFID ENVFID9h MGDPTR | MGDPTRT PATFIT PATFIT@  PATLOE "PATLOEL5"zpB UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<P$ ENVPUS "ENVPUSI# KIENVT $KIENVT.+ C5 KREALC %KREALC/!) STREQ 'STREQe KISEND h'KISEND Z KSAWAT 'KSAWATM KSAWRE (KSAWRE > KIERRR T(KIERRR  ZFIOBF @)zopnbf X)zclsbf k)zardbf )zawrbf)_read_write_bfg *zawtbfV ^*zsttbfO @)e ZFIOKS *zopnksp, ks_getloginD- ks_scanlogin/ ks_getword /zclsksO /zardks 0zawrksp1pr_onsigF 1zawtks* 1zsttks9 *     U ZCALL 2zcall0 -2zcall1 A2zcall2 X2zcall3 r2zcall4 2zcall5 2zcall6# 2zcall7& 2zcall8) !3zcall9, 2G ZFIOTX P3zopntx 4zclstx 4zgettx g5zputtx 6zflstx %6znottxq 6zsektx9 7zstttxN P3 ZSVJMP F8ZDOJMP 8ZSVJMP8$CODE ZFALOC 8zfaloc 89  ZFNBRK 9zfnbrk $9! ZFPATH :zfpath :! ZFSUBD T;zfsubdp T;K ZGTENV <zgtenv= _ev_scanirafh@> _ev_loadcache? _ev_streqi7@ _lower_case2i@ _upper_case4 < D ZGTIME @zgtime/ @  ZGTPID @zgtpid) @  ZLOCPR @zlocpr @ ZLOCVA Azlocva A ZMALOC Azmaloc! =AzmfreeYA_zmalocCA_zmfreeL A? ZPANIC Azpanic A ZRALOC Bzraloc+B_zraloc 7C_movbT B:6Lh UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<%+ ZXWHEN Czxwhen} D_exception_handler! *GzxgmeslH_setup_control_c]H_control_c_astE CʹE OPEN 8I_open NJ_close6 J_readT J_write4 8ItCONVTIME K _convtimeO ! K BUFFER\K_get_fio_bufferSK_free_fio_buffer. \K! GETJPIK_getjpiD K  ZFINFO $Lzfinfo~N_get_device_infoO _make_uicHO _make_octalS` ku_fclose`ku_fgets`*a ku_gpasswdob ku_initpasswdIbku_promptnoechod ku_ttyput)e ku_mkfnameeku_itocDfku_bcopyDHfku_sleepbfku_errorhf ku_mapdir p`   7oLs1INbQ--𒵹/f!@{Fr:z~})c?:B ^*Ė<@EOc [Jɉg#TzJENNp8nAE!c눼 sqV| pxG;<}~ݯ,TV'} YܯX-(頹qv* /L j>] YQbP^b++ǯ![HMӺA'@_Z uSTqtW+$L'>RjNw 'ۜ:<'6Tʧga$'NxAxA EgMWvJկrZ٪t7e814ǒ("6W>bs3gّZk_GQ E"+}+i]3LרX *0ޢFwm՟WtBrsщn~.{. :s8P9qkt^!YƗ|Yn&&}ַEu0 Tùg @NA %"H[Ojc"٨/LD6i'>)]\i<kPEەC-M3-WʢK`qcWD!b/b4jzh:򮟛o[jBo}Z iR'gⶐ#*< B1n³G#UŸ^vZmϝєъw26(y$aDJD.ZcDpUiɃ;VRlİz]SYʭM%Mǘ7n: AG*2 نڵygY . UͲ2a;=HmJM+ ~V=+J*K[85o)!PC3HK"xp[*&An̴K)ԉ-?t։+ݳi_@5"v䩀 (w),;@c5AΉo|/C=U-Zz;PA\eKV^LوHS?/!HA !s"42B[a"P&/?^3fx,9\@%,4:Ez1ToqSBO\Cv]|>Fs#Mka6(Lucm ;p*G16KH&kyz*hcH"gIVjצkѽoM2婘 JFGϣ&r!" l>!k-0򦶂 yȡE-oBEG%;BD^*ЬQQ¼yoL R=&e/A'"dM+t M;8B&r1~q(y;p@lln=+S?7[đ+`ŝjĨDN`"%`sI&k&PqX>[|h/qEzOU\NTLG"O2v{TnW ~WftCJR`-= )NZJPGm7bqN!iI{,/qsM^ͦrB&iU?vwￄ8pwi>&;nD A& lH|P(I^">p-ǫuCJ[(b{I9O"wX{eTmVR\II 4D3MUMt@q_%>2պ-n1ؿw'U_deIsڌ*~'@`ݓ0(3ՈneMv/ꐇkeG,f^PĐZoZS1)oI)lM_M2g?p)a-̂nB-#ExNi 3ư !Pz!=IlEWj(!6:y6K.>a rPWu{ze/h8 {Ij*JEABS#\gSrtD@&h^Kev烱-c..bF?v88:j`5UWmPi6hlCa(,Oi폸ˎk7U`&& |`.)%ii05r$x WG#W 28 H,*bIEKS^Ӄc0J^1iߴi5fy|OƯcO`3%ɐ+8^Ρ F#D*!|@*ߤW{ԹI 6QQ%3^'EM]7cL 3 f2I e\ ЖqA6Iډ\l%?AEOeȝSzQB0a`K_)Ғ>m~"zcQ Tyaf$K)~H&~֖yyr/ VYA,` E~50zB/xo#7Zb'.NX_tg.]P81^<7˃_TN < .A{ܱ0K$)RՁJB7f~4{6#SC,µiųLOu(%nU' C_,VO;uG''&Niȷ wޖd Tui'J0`zL4R.CwJ~NvL~HV#Wi0cvU&#LLT%VZ2YJ(*`oA0"BRW|Lu:_w/RCN:DrJdmʸD| %]$CY7)D" (JM*ڑgDzY*eb4?`rɉX'Wy۸gpMBeD*h5\D>VNKTg!Ras=} %8"|Q UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.EXE;3<X<2A TCPCLOSE(g tcp_close(g TCPREAD lZCLSPRs lzardprI lzawrprI#m_mem_ioX {nzawtpr2 nzsttprHn _ipc_abort-"o_sm_nameKmo_log_ipc j   ZFIOTY Hpzopnty /qzclstyO ~qzgetty rzputtyK szflsty2 sznotty tzsekty tzsttty@ Hpչ    ZFCHDR Ttzfchdr uzfgcwdu_valid_dirname? & TtF  ZFDELE vzfdele1 v ZWMSEC 8vzwmsecV 8v ZFACSS vzfacssDw_access 'v^  DIRNAMEDx_dirname Dx. GETDVI fc newuisdisp.fC,C Execute as a background process by typingDC !SPAWN/NOWAIT run newuisdisp and answer the questions presentedFC in special windows. All of the display-specific tasks are run from7C the Additional Options item in the main Menu window.CCC Written by Nigel Sharp, National Optical Astronomy Observatories..C SPAN: NOAO::SHARP, or 5355::SHARPC Internet: nsharp@noao.eduC Telephone: (602) 327 5511HC Based on an original by Simon Morris, without whom it would not exist,8:  UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P\C but very extensively rewritten (so he's not to blame).CIC------------------------------------------------------------------------ PROGRAM DISPLAY_IRAFC IMPLICIT INTEGER*4 (A-Z) PARAMETER (COL_DIM=256)2 CHARACTER ERRSTR*80,TEXT*80,IMTITLE*80,BLTITLE*80: CHARACTER*80 OPTIONS(20),CURSORS(7),RESETS(3),SETUPS(7,3) CHARACTER*80 BLINKS(4)0 LOGICAL ONE_TO_ONE,STABLE_LUT,INC_LUT,BLINK,RGB> INTEGER*4 VCMATT(3),VCTMP(3),NSETUP(7),NMAXSET(7),NMINSET(7), + NSNAP(3),IM_RGB(3)/ REAL*4 RETWIDTH,RETHEIGHT,RETRESOLX,RETRESOLY,: + RETX,RETY,XVAL,YVAL,RDATMIN,RDATMAX,WIDTH,HEIGHT,< + ICAA2,ICAA3,MWAA1,MWAA2,ORDMIN,ORDMAX,BLAA2,BLAA3,9 + H,S,V,REDM(6),GREENM(6),BLUEM(6),DELAY,BLINKINC,2 + RED(COL_DIM),GREEN(COL_DIM),BLUE(COL_DIM)C(C---------------------------------------7 EXTERNAL SHRINKER,EXPANDER,CLOSER,DISPLAYOPT,BLINKBUTTC Common blocks for:C ICON window IDsC ICON attributesC Main window attributesC Blink window attributesC Workstation parameters0C Image window IDS, pointers and size parametersC Image section and title%C Virtual color maps and map segments.C Look-Up Table memory (where the pointer was)-C Menu selection (used by the CLOSER routine)FC Blink (extra delay between images - as if you need it on a II/GPX !)'C Buttons (activated by ENABLE_BUTTONS)C Zoom and pan locationC Minimum window sizeFC Snap option settings (in COMMON so as to be preserved between calls)C RGB encoding option COMMON/ICON/ VD_ID2,WD_ID27 COMMON/ICAT/ ICAC1,ICAA1,ICAC2,ICAA2,ICAC3,ICAA3,ICEND7 COMMON/MWAT/ MWAC1,MWAA1,MWAC2,MWAA2,MWAC3,MWAA3,MWEND7 COMMON/BLAT/ BLAC1,BLAA1,BLAC2,BLAA2,BLAC3,BLAA3,BLEND5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHT: COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITSPERPIX,BYPTR,NX,NY,NINC/ COMMON/IMFILE/ REPL,XS,XE,YS,YE,IMTITLE,IMTLEN# COMMON/COLOR/ CMS_ID,VCM_ID,GINDEX COMMON/LUT/ RXLUT,RYLUT,NMETHOD COMMON/ADDOPT/ SELECTION! COMMON/BLINK/ BLINKBUFF,BLINKINC2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB# COMMON/ZOOMP/ ZOOM,ZXS,ZXE,ZYS,ZYE! COMMON/MINSIZE/ MIN_SIZE,INC_LUT3 COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAX COMMON/SNAPSET/ NSNAP COMMON/RGB_SET/ NRGBC@C---------------------------------------------------------------C C Read in the UIS INCLUDE filesC INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF'C DATA REDM/1.,0.,1.,0.,0.,0.9/ DATA GREENM/1.,0.,0.,1.,0.,0.6/ DATA BLUEM/1.,0.,0.,0.,1.,0.0/C All current extra options= DATA OPTIONS/'Cursor read','Dump a region','Corners of box',8 + 'Change min/max range','Read in a new image', + 'New image setup',6 + 'Zoom (in or out)','Pan (non-interactive)',# + 'Reset zoom and/or pan',< + 'Reset Look-Up Table','Interactively change LUT',AC + 'Change cursor pattern','Change minimum window size',# + 'Change cursor pattern',A + 'Blink options','Snap (screen->file)','3 images->RGB', + 5*' '/C Currently 7 possible cursors8 DATA CURSORS/'"+" cross','"+" cross with central hole',2 + '"x" cross','"x" cross with central hole',$ + 'box with central "+" sign', + ':-) face',':-( face'/C and only three resets0 DATA RESETS/'Reset pan only','Reset zoom only'," + 'Reset both pan and zoom'/&C Blink option has three possibilities6 DATA BLINKS/'Store current image','Start fast blink',0 + 'Start slow blink','Clear blink memory'/LC Various items which can be changed after initial displ;}v UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P ay (SETUP menu item)< DATA SETUPS(1,1),SETUPS(1,2),SETUPS(1,3)/'Use current LUT',6 + 'Fresh (greyscale) LUT','Fresh (rainbow) LUT'/@ DATA SETUPS(2,1),SETUPS(2,2),SETUPS(2,3)/'Use current min/max',= + 'Calculate min/max from image','Request new min/max'/2 DATA SETUPS(3,1),SETUPS(3,2)/'Include LUT wedge', + 'No LUT wedge'/1 DATA SETUPS(4,1),SETUPS(4,2)/'Read IRAF images', + 'Read FITS images'/5 DATA SETUPS(5,1),SETUPS(5,2)/'Minimum window size=',% + 'Change minimum window size'/7 DATA SETUPS(6,1),SETUPS(6,2)/'Reserve 0 LUT indices',& + 'Change reserved LUT indices'/3 DATA SETUPS(7,1),SETUPS(7,2)/'RGB 1 (more range)', + 'RGB 2 (more intense)'/ DATA NMAXSET/3,3,5*2/ DATA NMINSET/7*1/CKC OK, start program by checking that we have a recent enough version of UIS STATUS=UIS$PRESENT(MID)! IF(.NOT.STATUS.OR.MID.LT.3) THEN WRITE(6,*) H + '***ERROR*** you MUST have UIS software version 3.0 or later' STOP 'Impossible to continue' END IFCC Various parameters ATB=50 BITSPERPIX=8C No blink selected yet BLINK=.FALSE.7C Initially choose cursor pattern 2 - can be reselected NCURSOR=2>C *** Reserved color table indices for graphics overlay planesAC If you change this number, you MUST supply values in the arraysEC REDM, GREENM and BLUEM to match. On a four-bit system, this number>C is automatically cut to 2, using only the first two entries. GINDEX=6?C *** Maximum number of image refreshes before clearing window.GC If the window is redisplayed (e.g. by zoom) many times, the program'sEC virtual memory requirement will grow without limit. This parameterIC affects how often the display list is cleared, to cut this requirement. MAX_CALL_IMAGE=10C-C Get the color information for the hardwareC/ CALL UIS$GET_HW_COLOR_INFO ('SYS$WORKSTATION',: + TYPE,INDICES,COLORS,MAPS,RBITS,GBITS,BBITS,IBITS, + RES_INDICES,REGEN)CMC We need to have at least 4-bits of intensity, or we're going to die, so ... IF(IBITS.LT.4) THEN< WRITE(6,*) '***ERROR*** Intensity scale less than 4-bits' STOP 'Impossible to continue' END IFCJC The system reserves some entries, so users' LUTs don't alter its abilityIC to write menus and terminal emulators and backgrounds, etc. OverridingJC this makes for a very ugly-looking screen. If you're on a 4-bit system,KC and you really want the extra levels, alter the next line not to subtract/C the reserved indices from the available ones. MAP_SIZE=INDICES-RES_INDICESLC Without getting at the system entries, I make myself another LUT, in whichNC the first GINDEX entries are reserved for graphics (menus, window, overlays)8C and only the remaining ones can be used for the image.FC I use white/black/red/green/blue/yellow for colour systems, and thenAC restrict it to just the first two (W&B) if we only have 4-bits. IF(MAP_SIZE.LT.20) GINDEX=2CC The GINDEX entries are reserved at the BEGINNING of the main LUT.DC Why, you may ask, not the end ? The answer is that certain of theEC window routines reset the window background automatically to be LUTIC entry 0, which then changes with the image (sigh). Rather than beat myFC brains out, I decided to reserve the extra entries at the beginning.C  VCMATT(1)=VCMAL$C_END_OF_LISTHC Due to the new blink system, I can no longer use an unbound color map.C VCMATT(1)=VCMAL$C_ATTRIBUTESC VCMATT(2)=VCMAL$M_NO_BINDC VCMATT(3)=VCMAL$C_END_OF_LISTBC Must create an initial color map, even if we< UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P overwrite it later.9 VCM_ID=UIS$CREATE_COLOR_MAP (MAP_SIZE,'Main_LUT',VCMATT): CMS_ID=UIS$CREATE_COLOR_MAP_SEG(VCM_ID,'SYS$WORKSTATION', + UIS$C_COLOR_EXACT,0)MC Hereinafter, MAP_SIZE refers only to those entries available for the image. MAP_SIZE=MAP_SIZE-GINDEXCJC Set up a quick dummy window and load the graphics region color map (thisLC forces these values into the hardware color map right where we want them). VCTMP(1)=WDPL$C_PLACEMENT VCTMP(2)=WDPL$M_INVISIBLE VCTMP(3)=WDPL$C_END_OF_LIST2 VTMP=UIS$CREATE_DISPLAY(0.,0.,1.,1.,1.,1.,VCM_ID)< WTMP=UIS$CREATE_WINDOW(VTMP,'SYS$WORKSTATION',,,,,,,,VCTMP)5 CALL UIS$SET_COLORS(VTMP,0,GINDEX,REDM,GREENM,BLUEM) CALL UIS$DELETE_DISPLAY(VTMP)C$C Set initial main window attributes MWAC1=WDPL$C_END_OF_LIST$C Set initial Icon window attributes ICAC1=WDPL$C_ATTRIBUTES ICAA1=WDPL$M_NOBANNER ICAC2=WDPL$C_END_OF_LISTCC Get the display informationC. CALL UIS$GET_DISPLAY_SIZE ('SYS$WORKSTATION',8 + RETWIDTH,RETHEIGHT,RETRESOLX,RETRESOLY,PWD,PHT)CC Initial SETUP settingsC NSETUP(1)=2 NSETUP(2)=2 NSETUP(3)=1 INC_LUT=.TRUE.AC ***FITS*** to make FITS the default on startup, use NSETUP(4)=2 NSETUP(4)=1C Set minimum window size here MIN_SIZE=256 NSETUP(5)=1< WRITE(UNIT=SETUPS(5,1),FMT='(''Minimum window size='',I4)') + MIN_SIZEGC Can reserve a number of indices off the top (e.g. for banner windows)EC If you want to do this at the start, set NNUMBER to whatever numberIC you come up with after experimenting with the "new image setup" option.l ONUMBER=0 NNUMBER=0 IF(MAP_SIZE.GT.20) NNUMBER=10 NSETUP(6)=1 WRITE(UNIT=SETUPS(6,1),= + FMT='(''Currently reserving '',I3,'' LUT indices'')')- + NNUMBER-# NMAP_SIZE=MAP_SIZE+ONUMBER-NNUMBERo2C First use does NOT expect an RGB-encoded display RGB=.FALSE.<C Set to encode RGB by the method with greater dynamic range NSETUP(7)=1 NRGB=NSETUP(7)iCi1C This is the starting point to begin a new imageC 500 CONTINUEC.6C Must set/reset these so that NEED_INPUT doesn't bomb VD_ID=0 WD_ID=05C Adjust MAP_SIZE in case they changed SETUP option 6p MAP_SIZE=NMAP_SIZEfCe&C Check for the new special RGB option IF(RGB) GOTO 501iC @C First size the array, so that we can allow the space we need.-C Check the array exists, get datatype, etc.  IF(NSETUP(4).EQ.2) THEN ISTAT=LIB$GET_VM(2880,LPTR)r- IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))e" CALL SIZE_FITS(IM,IS,%val(LPTR)) ELSEh CALL SIZE_IRAF(IM) END IFeCe)C Select the type of array we are to use:. IF(DTYPE.EQ.6) THENGC Get space for a one-line buffer (replication factor for small images)L NBYTE=(NX/REPL)*45C Get space for a REAL*4 array, only as big as neededR NBYTEI=(NX/REPL)*(NY/REPL)*4I ELSEGC Get space for a one-line buffer (replication factor for small images)  NBYTE=(NX/REPL)*20C Get space for a 16-bit integer array, as above NBYTEI=(NX/REPL)*(NY/REPL)*2X END IFIDC Use the same pointer for the real or short integer array - we only+C read one at a time, so it all works fine. ISTAT=LIB$GET_VM(NBYTEI,I2PTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTE,SBPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))C/C Now read in the IRAF file we verified above.>C Returns NINC=0 if an intensity scale wedge is not required. ERRSTR=' ' IF(NSETUP(4).EQ.2) THEN: CALL READ_FITS(IM,IS,%val(LPTR),%val(I2PTR),%val(SBPTR), + NX/REPL,NY/REPL,ERRSTR) ELSE, CALL READ_IRAF(IM,%val(I=y$ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P2PTR),%val(I2PTR),7 + %val(SBPTR),%val(SBPTR),NX/REPL,NY/REPL,ERRSTR) END IF IF(MYL(ERRSTR).NE.0) THEN PRINT *,'Panic stop !' PRINT *,ERRSTR STOP 'Abnormal End' END IFC)C Choose the LUT for the initial display.C IF(NSETUP(1).EQ.3) THEN NLUT=2 DO I=1,MAP_SIZE% H=REAL(I-1)*360.0/REAL(MAP_SIZE-1)) V=0.25+0.75*REAL(I-1)/REAL(MAP_SIZE-1)8 CALL UIS$HSV_TO_RGB (H,1.0,V,RED(I),GREEN(I),BLUE(I)) END DO0 RXLUT=0.5*FLOAT(MAP_SIZE-1)*NX/FLOAT(MAP_SIZE) RYLUT=0.75*(NY+NINC) ELSE IF(NSETUP(1).EQ.2) THEN NLUT=1 DO I=1,MAP_SIZE$ RED(I)=REAL(I-1)/REAL(MAP_SIZE-1)& GREEN(I)=REAL(I-1)/REAL(MAP_SIZE-1)% BLUE(I)=REAL(I-1)/REAL(MAP_SIZE-1) END DO0 RXLUT=0.5*NX*FLOAT(MAP_SIZE-1)/FLOAT(MAP_SIZE) RYLUT=0.75*(NY+NINC) END IFC ISTAT=LIB$FREE_VM(NBYTE,SBPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) IF(NSETUP(4).EQ.2) THEN ISTAT=LIB$FREE_VM(2880,LPTR)- IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) END IF@C Get space for two 8-bit integer arrays, both full size + wedge NBYTEB=NX*(NY+NINC) ISTAT=LIB$GET_VM(NBYTEB,BYPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTEB,BCPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))CC Choose what min/max to useC IF(NSETUP(2).EQ.3) THENC Ask user for min/max IF(DTYPE.EQ.6) THEN& WRITE(UNIT=ERRSTR,FMT='(A,2G12.4)')2 + 'Calculated min and max: ',RDATMIN,RDATMAX ELSE# WRITE(UNIT=ERRSTR,FMT='(A,2I7)')2 + 'Calculated min and max: ',IDATMIN,IDATMAX END IF(201 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,C + 'Give new min and max (CR to use calculation)',TEXT,NTEXT) IF(NTEXT.NE.0) THEN IF(DTYPE.EQ.6) THEN: READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=202) RDATMIN,RDATMAX ELSE: READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=202) IDATMIN,IDATMAX END IF END IF GOTO 2032202 WRITE(UNIT=ERRSTR,FMT='(A)') 'Error in input' GOTO 201 203 CONTINUE ELSE IF(NSETUP(2).EQ.1) THENC Re-use previous values NC (Note I allowed for a change in image data type when setting the old values) RDATMIN=ORDMIN RDATMAX=ORDMAX IDATMIN=OIDMIN IDATMAX=OIDMAX END IFC:C Now scale the data to cover the range of the color map.2C This range is from GINDEX to GINDEX+MAP_SIZE-1.AC At this stage, the version of the picture stored in the byte=C version is flipped top to bottom, so that after display,FC pixel 1,1 in the I*2 array is displayed at the lower left corner,'C and pixel 1,NY is at the top left.C6 CALL SCALE_ARRAY (NX,NY,NINC,%val(I2PTR),%val(I2PTR),5 + NX/REPL,NY/REPL,MAP_SIZE,GINDEX,%val(BYPTR)) GOTO 502CC Set up for RGB-encodingC 501 CONTINUE CALL SIZE_RGB(IM_RGB) NBYTE=(NX/REPL)*12 ISTAT=LIB$GET_VM(NBYTE,RPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTE/2,SPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) NBYTEB=NX*(NY+NINC) ISTAT=LIB$GET_VM(NBYTEB,BYPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ERRSTR=' '8 CALL READ_RGB(IM_RGB,%val(BYPTR),%val(SPTR),%val(RPTR),* + NX,NY,NINC,NX/REPL,NY/REPL,ERRSTR) IF(MYL(ERRSTR).NE.0) THEN' PRINT *,'Panic stop: input errors !' PRINT *,ERRSTR STOP 'Abnormal End' END IF ISTAT=LIB$FREE_VM(NBYTE,RPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$FREE_VM(NBYTE/2,SPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTEB,BCPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))CEC The VIEWPORT size is determined to be the number of pixels ne>bOd UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P.eded.EC We already checked inside the SIZE_IRAF routine that it fits on the1C screen (modulo the request for an extra wedge).C 502 CONTINUE WIDTH=NX/RETRESOLX HEIGHT=(NY+NINC)/RETRESOLYCGC Now that we allow the user to change MAP_INDEX, we set the entire LUT%C here, so that it doesn't interfere.C? VCM_ID=UIS$CREATE_COLOR_MAP(MAP_SIZE+GINDEX,'Main_LUT',VCMATT): CMS_ID=UIS$CREATE_COLOR_MAP_SEG(VCM_ID,'SYS$WORKSTATION', + UIS$C_COLOR_EXACT,0)CC Set up the virtual displayC# VD_ID=UIS$CREATE_DISPLAY (0.0,0.0,4 + REAL(NX),REAL(NY+NINC),WIDTH,HEIGHT,VCM_ID)CHC Fill up the initial virtual color map (offsetting the main LUT by the+C number of indices reserved for graphics).C6 CALL UIS$SET_COLORS(VD_ID,0,GINDEX,REDM,GREENM,BLUEM): CALL UIS$SET_COLORS(VD_ID,GINDEX,MAP_SIZE,RED,GREEN,BLUE)CEC Set the writing mode to COPY - so that 8 bit pixels go straight toC the bit map without changesC8 CALL UIS$SET_WRITING_MODE (VD_ID,0,ATB,UIS$C_MODE_COPY)C-C and put the array into the virtual displayC: CALL UIS$IMAGE (VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),+ + NX,NY+NINC,BITSPERPIX,%val(BYPTR)): IF(RGB) CALL SET_LUT(RED,GREEN,BLUE,MAP_SIZE,GINDEX,NLUT, + STABLE_LUT,.TRUE.)C2 WD_ID=UIS$CREATE_WINDOW (VD_ID,'SYS$WORKSTATION',: + IMTITLE(1:IMTLEN),0.0,0.0,REAL(NX),REAL(NY+NINC), + WIDTH,HEIGHT,MWAC1)CEC Put the cursor in the middle of the Image (allowing for the wedge)<C and change it to the style given by NCURSOR (initially 2)C& CALL CHOOSE_CURS(VD_ID,WD_ID,NCURSOR,7 + REAL(NX)*0.5,REAL(NY)*0.5+NINC)CCC Define Icon, close (delete), and Additional Options AST routines,&C and disable the "change size" option0 CALL UIS$SET_SHRINK_TO_ICON_AST(WD_ID,SHRINKER)- CALL UIS$SET_EXPAND_ICON_AST(WD_ID,EXPANDER)' CALL UIS$SET_CLOSE_AST(WD_ID,CLOSER,0)* CALL UIS$SET_ADDOPT_AST(WD_ID,DISPLAYOPT)% CALL UIS$SET_RESIZE_AST(VD_ID,WD_ID)CJC Set initial zoom and pan, and copy the byte array into the storage array4C used to preserve the un-zoomed, un-panned version. ZOOM=1 ZXS=1 ZXE=NX ZYS=1 ZYE=NY ONE_TO_ONE=.TRUE.) CALL COPY(%val(BYPTR),%val(BCPTR),NX,NY)CCC Set the number of UIS$IMAGE calls to 1: need this to clean up the)C display list after multiple zooms/pans. CALL_IMAGE=1CCC OK, all set up, now go off into limbo while we wait for somethingFC to happen. The "Additional Options" AST routine simply wakes us up.BC The "Delete" option sets the SELECTION item to -1, which nothing,C else can do, so we know it's safe to exit.CA 600 CONTINUE CALL SYS$HIBER()A. IF(SELECTION.EQ.-1) STOP 'Normal termination'GC Tried to have the menu called from the Additional Options AST routineCCC with the SELECTION passed in common, but I couldn't make it work.-3C Instead, just wake up and run the menu from here.LCP?C Currently 15 options: add the necessary stuff to handle extratEC options here, and change OPTIONS to include the additional prompts.t NOPTION=15hC SELECTION=MAKE_MENU(VD_ID,WD_ID,NOPTION,OPTIONS,'Display Options') IF(SELECTION.EQ.0) GOTO 600CN5 GOTO (51,52,53,54,55,551,56,57,58,59,60,61,63,64,65)+ + , SELECTIONe%C Unknown value - should never happen GOTO 600-CNKC Encode three images as RGB into one display. Limited (this is 8-bits !).dIC Currently ONLY for IRAF images (since I can read them a row at a time).mCr 65 CONTINUE( CALL UIS$DELETE_DISPLAY(VD_ID)s ISTAT=LIB$FREE_VM(NBYTEB,BCPTR), IF(.NOT.ISTAT) CALL LIB$SIG?G UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3Pm&NAL(%val(ISTAT)) ISTAT=LIB$FREE_VM(NBYTEB,BYPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))=C If RGB is already on, there's no array in I2PTR to free up.e IF(.NOT.RGB) THEN! ISTAT=LIB$FREE_VM(NBYTEI,I2PTR) - IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))a END IFh RGB=.TRUE.e NLUT=6e GOTO 500yCiFC Blink section. (I didn't think I wanted to do this until Earl O'NeilAC made a clever suggestion, so then I had to implement it. Sigh)SEC Limited capability: store a current image, and then at a later timeCC blink it against the current one, using the current LUT (it's noteFC possible to store the old LUT, due to restrictions with the hardwareLC color map segment, which would require massive reprogramming [I tried !]).CY 63 CONTINUE*7 IBLINK=MAKE_MENU(VD_ID,WD_ID,4,BLINKS,'Blink Options')r IF(IBLINK.EQ.0) GOTO 600  GOTO (631,632,632,636), IBLINK GOTO 600oC 631 CONTINUEFC Come here to save the current display in storage, ready for a blink.2C First, we clear back to only one displayed image IF(CALL_IMAGE.GT.1) THENe CALL UIS$ERASE(VD_ID)I CALL_IMAGE=1= CALL UIS$IMAGE (VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),T* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) END IFS3C Jump here to clean up behind us, if we so choose.w 636 CONTINUE IF(BLINK) THENNAC If we've been here before, free the current memory requirement.I# STATUS=LIB$FREE_VM(RETL1,BL_PTR1)I/ IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) # STATUS=LIB$FREE_VM(RETL2,BL_PTR2)/ IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) # STATUS=LIB$FREE_VM(RETL3,BL_PTR3)Y/ IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))H END IFI2C If all we did was clean up, then go no further ! IF(IBLINK.EQ.4) THEN BLINK=.FALSE.L GOTO 600 END IFsCy;C Save the current image in memory reserved for the purpose' CALL UIS$EXTRACT_HEADER(VD_ID,,,RETL1)+ CALL UIS$EXTRACT_REGION(VD_ID,,,,,,,RETL2) ( CALL UIS$EXTRACT_TRAILER(VD_ID,,,RETL3)! STATUS=LIB$GET_VM(RETL1,BL_PTR1)*. IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))3 CALL UIS$EXTRACT_HEADER(VD_ID,RETL1,%VAL(BL_PTR1))1! STATUS=LIB$GET_VM(RETL2,BL_PTR2)L. IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))7 CALL UIS$EXTRACT_REGION(VD_ID,,,,,RETL2,%VAL(BL_PTR2)) ! STATUS=LIB$GET_VM(RETL3,BL_PTR3)Z. IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))4 CALL UIS$EXTRACT_TRAILER(VD_ID,RETL3,%VAL(BL_PTR3)) C and preserve the current title BLTLEN=IMTLEN$ BLTITLE(1:BLTLEN)=IMTITLE(1:IMTLEN)<C Define some attributes for later use (only need this once) IF(.NOT.BLINK) THEN BLAC1=WDPL$C_ATTRIBUTESh BLAA1=WDPL$M_NOMENU_ICON BLAC2=WDPL$C_ABS_POS_X BLAC3=WDPL$C_ABS_POS_Y BLEND=WDPL$C_END_OF_LIST MWAC1=WDPL$C_ABS_POS_X MWAC2=WDPL$C_ABS_POS_Y MWAC3=WDPL$C_END_OF_LIST END IFT BLINK=.TRUE.e GOTO 600aCo 632 CONTINUE.C Come here to start the actual blink process.AC If we haven't set up a blink image, ignore this item completely+ IF(.NOT.BLINK) GOTO 600CR2 CALL UIS$GET_VIEWPORT_POSITION(WD_ID,BLAA2,BLAA3) MWAA1=BLAA2 MWAA2=BLAA30 VD_IDB=UIS$EXECUTE_DISPLAY(RETL1,%VAL(BL_PTR1))- CALL UIS$EXECUTE(VD_IDB,RETL2,%VAL(BL_PTR2))i- CALL UIS$EXECUTE(VD_IDB,RETL3,%VAL(BL_PTR3))T4 WD_IDB=UIS$CREATE_WINDOW (VD_IDB,'SYS$WORKSTATION',< + BLTITLE(1:BLTLEN),0.0,0.0,REAL(NX),REAL(NY+NINC), + WIDTH,HEIGHT,BLAC1) DELAY=0.5 BLINKINC=0.0M7 CALL EXPLAIN(VD_ID,WD_ID,'Click here','Quit','Faster',U + 'Slower',VDIE,WDIE)iFC Attach the button AST to the "explain" window, because otherwise the>C window-switching gets too fast for the A@ v9 UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P -ST queueing to work.8 CALL UIS$SET_BUTTON_AST(VDIE,WDIE,BLINKBUTT,,BLINKBUFF)C JC There's a slight additional delay involved in going back to the start ofLC the loop, so the blinking is not perfectly symmetrical. Difficult to knowMC exactly how long the extra time is, so I think I shall leave it asymmetric.n 635 CONTINUE IF(BLINKINC.GT.600.) THENJC Quit button sets very large increment: clean up and restore main window." CALL UIS$DELETE_DISPLAY(VD_IDB) CALL UIS$DELETE_DISPLAY(VDIE) CALL RESET_IMAGEA GOTO 600, END IFR-C Switch the whole loop for the type of delayZ GOTO (633,633,634), IBLINK 633 CALL UIS$POP_VIEWPORT(WD_ID)& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY)IC The delay is only updated once around the loop, so if it's going fairly IC slowly, you have to hold the button down for a while to have an effect.T DELAY=MAX(0.0,DELAY+BLINKINC) CALL UIS$POP_VIEWPORT(WD_IDB)& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY) GOTO 635S'634 CALL UIS$MOVE_VIEWPORT(WD_ID,MWAC1)E& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY)" DELAY=MAX(0.0,DELAY+BLINKINC*5.0)% CALL UIS$MOVE_VIEWPORT(WD_IDB,BLAC1) & IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY) GOTO 635PCT'C Change setups for reading a new imageIC 551 CONTINUE: CALL MULTI_MENU(VD_ID,WD_ID,7,SETUPS,7,3,NMAXSET,NMINSET,# + NSETUP,'New image choices') NRGB=NSETUP(7)A IF(NSETUP(3).EQ.2) THEN INC_LUT=.FALSE.( ELSEB INC_LUT=.TRUE. END IFLC Change minimum window size IF(NSETUP(5).EQ.2) THEN NSETUP(5)=1t+ WRITE(UNIT=ERRSTR,FMT='(A,I5,A,F5.1,A)') e6 + 'Current minimum size: ',MIN_SIZE,' pixels, ',( + FLOAT(MIN_SIZE)/RETRESOLX,' cms'(621 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,@ + 'Enter new value in pixels (takes effect on next read)', + TEXT,NTEXT)D IF(NTEXT.EQ.0) GOTO 62111 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=622) MIN_SIZE== WRITE(UNIT=SETUPS(5,1),FMT='(''Minimum window size='',I4)')I + MIN_SIZE GOTO 6211I2622 WRITE(UNIT=ERRSTR,FMT='(A)') 'Error in input' GOTO 6216211 CONTINUE END IFC Change reserved LUT indices0 IF(NSETUP(6).EQ.2) THEN NSETUP(6)=1I# WRITE(UNIT=ERRSTR,FMT='(A,I3,A)')e1 + 'Currently reserving ',NNUMBER,' indices' )5511 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,aE + 'New number to reserve (CR to leave the same) ?',TEXT,NTEXT)C;C If it's a CR or an unintelligible number, just ignore it. IF(NTEXT.EQ.0) GOTO 5512 ONUMBER=NNUMBER 0 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=600) NNUMBER% NMAP_SIZE=NMAP_SIZE+ONUMBER-NNUMBERD IF(NMAP_SIZE.LE.2) THEN5 WRITE(UNIT=ERRSTR,FMT='(A)') 'Too big ! Try again'& NMAP_SIZE=NMAP_SIZE-ONUMBER+NNUMBER NNUMBER=ONUMBER GOTO 5511 END IF WRITE(UNIT=SETUPS(6,1),G= + FMT='(''Currently reserving '',I3,'' LUT indices'')')T + NNUMBER 5512 CONTINUEC END IFD GOTO 600SCWC Read a new image 55 CONTINUEI,C Preserve current min/max in case of re-use IF(DTYPE.EQ.6) THEN ORDMIN=RDATMIN ORDMAX=RDATMAX OIDMIN=NINT(RDATMIN) OIDMAX=NINT(RDATMAX) ELSE  ORDMIN=FLOAT(IDATMIN)N ORDMAX=FLOAT(IDATMAX) OIDMIN=IDATMIN OIDMAX=IDATMAX END IF+<C Preserve current window location, in case they've moved it MWAC1=WDPL$C_ABS_POS_Xa MWAC2=WDPL$C_ABS_POS_Y  MWAC3=WDPL$C_END_OF_LISTh2 CALL UIS$GET_VIEWPORT_POSITION(WD_ID,MWAA1,MWAA2)CT CALL UIS$DELETE_DISPLAY(VD_ID)X ISTAT=LIB$FREE_VM(NBYTEB,BCPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$FREE_VM(NBYTEB,BYPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))IC If we came here, we want a new image withoAb UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P4ut coding, and if RGB was on,y+C we didn't have an I2PTR array to free up. IF(RGB) THEN= RGB=.FALSE. GOTO 500 END IF ISTAT=LIB$FREE_VM(NBYTEI,I2PTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) GOTO 500$CG:C Option to get cursor position and the data value there.4C All dump, zoom, pan changes are held in software.Ce 51 CONTINUEo>C Dump single pixel at the cursor - if inside the data region..C Continues for as many positions as you like.8 CALL PRINT_IT(VD_ID,WD_ID,NINC,%val(I2PTR),%val(I2PTR),, + NX,NY,NX/REPL,NY/REPL,1,.FALSE.,RGB) GOTO 600.CA 52 CONTINUEE C Dump region around the cursor9 IF(.NOT.RGB) CALL PRINT_IT(VD_ID,WD_ID,NINC,%val(I2PTR),u8 + %val(I2PTR),NX,NY,NX/REPL,NY/REPL,9,.FALSE.,RGB) GOTO 600NCs 53 CONTINUE,CC Define a box, giving bottom left corner and then top right cornere8 CALL PRINT_IT(VD_ID,WD_ID,NINC,%val(I2PTR),%val(I2PTR),+ + NX,NY,NX/REPL,NY/REPL,1,.TRUE.,RGB)n GOTO 600TCS 59 CONTINUEh2 CALL SET_LUT(RED,GREEN,BLUE,MAP_SIZE,GINDEX,NLUT, + STABLE_LUT,.FALSE.)aDC Go from resetting direct to interactive modification (preferred by@C 99% of all users, in an unbiassed survey of two) in most cases IF(STABLE_LUT) GOTO 600Ci 60 CONTINUE 2 CALL MOD_LUT(RED,GREEN,BLUE,MAP_SIZE,GINDEX,NLUT) GOTO 600Cu 57 CONTINUEtCb<C Pan option: done in software, so not interactive (i.e. you,C can't drag the image around by the cursor)Co5 CALL ENABLE_BUTTONS(VD_ID,WD_ID,'Pan option','Quit',C2 + 'Cursor is centre','Cursor is BLC',.TRUE.) CALL LIB$GET_EF(EFNB) XVAL=0.5*NX/FLOAT(ZOOM) YVAL=0.5*NY/FLOAT(ZOOM) 571 CONTINUE CALL SYS$CLREF(%val(EFNB))L CALL SYS$WAITFR(%val(EFNB))JC Only exit on a down-click, in case they hold down the left cursor buttonLC from the previous selection for long enough to get here before they let go IF(ONE.EQ.1) THEN# CALL DELETE_BUTTONS(VD_ID,WD_ID)/ CALL LIB$FREE_EF(EFNB)C GOTO 600 8C Ignore up-clicks - it can get very confusing otherwise= ELSE IF ( (ONE.EQ.-1).OR.(TWO.EQ.-1).OR.(THREE.EQ.-1) ) THENX GOTO 571 END IF/LC Work in viewport relative coordinates, and keep track of all other factorsDC myself (what with zoom, pan and replication, it works out easier).- CALL UISDC$GET_POINTER_POSITION(WD_ID,VX,VY)- IXCEN=(ZXS+ZXE-1)/2 IYCEN=(ZYS+ZYE-1)/21 IRETX=INT(IXCEN-(0.5*NX-VX-0.5)/FLOAT(ZOOM)) + 1I6 IRETY=INT(IYCEN-(VY-NINC-NY*0.5+0.5)/FLOAT(ZOOM)) + 1 IF(TWO.NE.0) THENFC Move pixel to centre (since the centre is actually a pixel boundary,FC it's the top left corner of the pixel you indicate which goes there:DC this is just my convention, and you could pick another one, if you6C could find all the places in the program to change). ZXS=NINT(IRETX-XVAL)  ZXE=NINT(IRETX+XVAL)-1 ZYS=NINT(IRETY-YVAL)  ZYE=NINT(IRETY+YVAL)-1e NCX=NX*0.5  NCY=NY*0.5+NINC ELSE,'C Indicated pixel to bottom left corner ZXS=IRETX ZXE=NINT(IRETX+2.0*XVAL)-1  ZYS=NINT(IRETY-2.0*YVAL)+1' ZYE=IRETY NCX=0.5*ZOOM*REPL NCY=0.5*ZOOM*REPL+NINCr END IFTCU* CALL ZOOMP(%val(BCPTR),%val(BYPTR),NX,NY) CALL_IMAGE=CALL_IMAGE+1& IF(CALL_IMAGE.GT.MAX_CALL_IMAGE) THEN CALL UIS$ERASE(VD_ID) CALL_IMAGE=1f< CALL UIS$IMAGE (VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) ELSE , CALL UIS$IMAGE (VD_ID,ATB,0.0,REAL(NINC),< + REAL(NX),REAL(NY+NINC),NX,NY,BITSPERPIX,%VAL(BYPTR)) END IF+-C And put the pointer back where it should bea/ CALL UISDC$SET_POINTER_POSITION(WD_ID,NCX,NCY)sB迢4!+,` _ *yGOՎV23(h,gE|))stm~w;ܥ6"3^B{ոL+}.^x_vY ٪*vqpWE0{%ڟߊu[YJMxȋ ׏ u& Wn }ho6!,M/q̖wT,1\;j^u>R-[$&W9v>Nux$3?Q> 3]]0TA_UHL3G>pU1($E1:ƍg~r9̓Ġ@#l~ޛG} 6Z ]z8+F *c!%=KrRD\%aX ^j0L|={1'bU%X,/"Lfm *D*%m!HKkO5Dej Nxlbufwr!ԑ$29bPyHr?Ab)m&F7Ul;18 Kڐ3AoIB'%^`ճ~Xş-C(6QM=ڰǘ(cw꼕j&f~&YsSj]-J},RE΄'VIe`LtYz+(Gm"N m,йFMR >^'ΖB5bJ'"-趟(b/뜖arq98GETI.*5F lQJ΍70x*]d0T4q06RV,[qe0wr=2~P8O%2W<-~mM4Lp74g(\%Q.L:wHn1AU8/lJ/YbmwWA`hJE.3odD!Ex%~/{ "ynq+cj0cdpl/}!M5 *8xUdeX0 DATA TITLE/'Cursor position','Dump a region','Box (BLC/TRC)'/ INDX=1 IF(IX.GT.1) INDX=2L IF(BOX) INDX=3R STRING=' ' IF(RGB) STRING=' in RED image'N SX=IX/2 IF(DTYPE.EQ.6) SX=IX/4 IXO=2*SX+1+C Set current centrese IXCEN=(ZXS+ZXE-1)/2 IYCEN=(ZYS+ZYE-1)/2101 FORMAT(1X,I5,' |',20I7)-102 FORMAT(' -------',140A1)103 FORMAT(1X,I5,' |',20G14.5)#104 FORMAT(1X,I5,' |',20(3X,I7,4X))105 FORMAT(' -------',280A1)) CALL ENABLE_BUTTONS(VDI,WDI,TITLE(INDX),L6 + 'Quit','Terminal + file','Terminal',.TRUE.) FIRST=.TRUE.I C Assign and clear an event flag CALL LIB$GET_EF(EFNB) CALL SYS$CLREF(%VAL(EFNB)) 1 CONTINUE"C Wait for the AST to wake us up ! CALL SYS$CLREF(%VAL(EFNB))0 CALL SYS$WAITFR(%VAL(EFNB)) IF(ONE.EQ.1) THEN&C Close the output file, if it existed IF(.NOT.FIRST) CLOSE(3)8C Remove the explanatory window and reset the button AST CALL DELETE_BUTTONS(VDI,WDI)G CALL LIB$FREE_EF(EFNB)zC and clear up the image CALL RESET_IMAGE_ RETURNo.C Ignore button up-click - only react to downs< ELSE IF( (ONE.EQ.-1).OR.(TWO.EQ.-1).OR.(THREE.EQ.-1) ) THEN GOTO 1t END IF' IF(TWO.NE.0) THEN FILE=.TRUE. IF(FIRST) THEN$ FIRST=.FALSE.F10 CALL NEED_INPUT(VDI,WDI,'Append if file exists, create if not',< + 'Enter filename to receive these values',TEXT,NTEXT) IF(NTEXT.EQ.0) THEN NTEXT=13g' IF(IX.EQ.1) TEXT='IRAF_CURS.OUT'O' IF(IX.NE.1) TEXT='IRAF_DUMP.OUT' END IFa0 OPEN(3,FILE=TEXT(1:NTEXT),STATUS='UNKNOWN', + ACCESS='APPEND',ERR=10) END IFt END IFnCs+ CALL UISDC$GET_POINTER_POSITION(WDI,VX,VY)XDC Returned viewport positions run from 0 to (maximum x or y index)-1% RX=IXCEN-(0.5*NX-VX-0.5)/FLOAT(ZOOM)Y* RY=IYCEN-(VY-NINC-NY*0.5+0.5)/FLOAT(ZOOM)6C Location in subset of original image kept in storage PX=RX/REPL+1) PY=(NY-RY)/REPL+1AC and in the original image, including offsets for the subsectionh OX=RX/REPL+XS OY=(NY-RY)/REPL+YSoKC Make it an even number around the position (i.e. an odd number of values) CC Allow pixel to be on edge - use zeroes for regions further out ifAC we're dumping a region.  IF( (OX.GT.XE) .OR.X + (OX.LT.XS) .OR. + (OY.GT.YE) .OR. + (OY.LT.YS) ) THENT1 PRINT *,'Position outside image - try again !'n GOTO 1t END IFg IF (BOX) THEN6 PRINT '(A,2I6,A)',' Box: bottom left ',OX,OY,STRING#C Clear and wait for the "up" clickO CALL SYS$CLREF(%VAL(EFNB))  CALL SYS$WAITFR(%VAL(EFNB))C Now wait for the real click. CALL SYS$CLREF(%VAL(EFNB))O CALL SYS$WAITFR(%VAL(EFNB))IC Complete the box, whatever they wanted - even accepts outside the imageE/ STATUS=UISDC$GET_POINTER_POSITION(WDI,VX,VY))' RX=IXCEN-(0.5*NX-VX-0.5)/FLOAT(ZOOM)_, RY=IYCEN-(VY-NINC-NY*0.5+0.5)/FLOAT(ZOOM) O2X=RX/REPL+XSR O2Y=(NY-RY)/REPL+YS8 PRINT '(A,2I6,A)',' Box: top right ',O2X,O2Ftu UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PPY,STRINGHC Create file in x1,x2;y1,y2 format suitable for input to fixpixels task+ IF(FILE) WRITE(3,*) OX,O2X,OY,O2Y,STRINGt ELSE IF (IX.EQ.1) THENo IF(RGB) THEN) PRINT *,'Position in RED image ',OX,OYs, IF(FILE) WRITE(3,*) OX,OY,' in RED image' ELSE IF(DTYPE.EQ.3) THEN9 PRINT *,'Position ',OX,OY,' Value ',I2ARRAY(PX,PY)e- IF(FILE) WRITE(3,*) OX,OY,I2ARRAY(PX,PY)_ ELSEW9 PRINT *,'Position ',OX,OY,' Value ',REARRAY(PX,PY)b- IF(FILE) WRITE(3,*) OX,OY,REARRAY(PX,PY) END IFo END IF ELSEd$C Dump a region - print where we are IF(RGB) RETURNT IF(DTYPE.EQ.3) THEN! PRINT 101,0,(I,I=OX-SX,OX+SX)G PRINT 102,('-',I=1,14*SX+7)d- IF(FILE) WRITE(3,101) 0,(I,I=OX-SX,OX+SX)E+ IF(FILE) WRITE(3,102) ('-',I=1,14*SX+7)d ELSED! PRINT 104,0,(I,I=OX-SX,OX+SX)N PRINT 105,('-',I=1,28*SX+14)- IF(FILE) WRITE(3,104) 0,(I,I=OX-SX,OX+SX)T, IF(FILE) WRITE(3,105) ('-',I=1,28*SX+14) END IFTC Loop for Y direction DO J=-SX,SX J2=PY-JE JO=OY-J1' IF( (JO.GT.YE).OR.(JO.LT.YS) ) THENE!C If outside region, print zeroesE IF(DTYPE.EQ.3) THEN PRINT 101,JO,(0,I=1,IXO)* IF(FILE) WRITE(3,101) JO,(0,I=1,IXO) ELSER PRINT 103,JO,(0.0,I=1,IXO), IF(FILE) WRITE(3,103) JO,(0.0,I=1,IXO) END IFY ELSE;C Inside region: print real or short integer as appropriatel DO JJ=1,IXO JJ2=PX+JJ-1-SX TARRAY(JJ)=I2ARRAY(JJ2,J2) RARRAY(JJ)=REARRAY(JJ2,J2), IF ( (JJ2.LT.1).OR.(JJ2.GT.NX2) ) THEN TARRAY(JJ)=0L RARRAY(JJ)=0.0 END IF END DO,=C Finished setting temporary arrays, so now we write them out)IC (Use temporary arrays as the easiest way to get zeroes if off the edge) IF(DTYPE.EQ.3) THEN& PRINT 101,JO,(TARRAY(I),I=1,IXO)2 IF(FILE) WRITE(3,101) JO,(TARRAY(I),I=1,IXO) ELSE'& PRINT 103,JO,(RARRAY(I),I=1,IXO)2 IF(FILE) WRITE(3,103) JO,(RARRAY(I),I=1,IXO) END IFS3C End of deciding whether it was data or all zeroes, END IFC Finished handling a line END DOX5C Need a blank line separating the different sectionsa PRINT * IF(FILE) WRITE(3,*) END IF_CU GOTO 1_ ENDCTOC******************************************************************************CC Put up a little window explaining what the buttons do (as for theNKC routine ENABLE_BUTTONS, but without setting the ASTs and their handling).rEC Note that this box MUST be visible, so it can have associated ASTs. -C For descriptive comments, see that routine.AC.; SUBROUTINE EXPLAIN(VDI,WDI,TITLE,LABL,LABM,LABR,VDIE,WDIE). IMPLICIT INTEGER*4 (A-Z)  INCLUDE 'SYS$LIBRARY:UISENTRY'N INCLUDE 'SYS$LIBRARY:UISUSRDEF'4 REAL PX,PY,SX,SY,SIZEX,SIZEY,MX,MY,MYHEIGHT,MYWIDTH# CHARACTER*(*) LABL,LABM,LABR,TITLEE! COMMON/WSTATION/ SIZEX,SIZEY,MAP# COMMON/COLOR/ CMSMID,VCMMID,GINDEXZ( COMMON/BTBOX/ ATT,COD,ATX,MX,ATY,MY,END MYHEIGHT=1.5D MYWIDTH=4.0C Make the descriptive box0 VDIE=UIS$CREATE_DISPLAY(0.,0.,MYWIDTH,MYHEIGHT,! + MYWIDTH,MYHEIGHT,VCMMID)W> CALL UIS$SET_FONT(VDIE,0,1,'DTABER0G03CK00GG0001UZZZZ02A000')' CALL UIS$SET_WRITING_INDEX(VDIE,1,1,1))> CALL UIS$SET_FONT(VDIE,1,2,'DTABER0003WK00PG0001UZZZZ02A000')0 CALL UIS$SET_CHAR_SPACING(VDIE,1,1,-0.15,-0.25)7 IF(GINDEX.GE.5) CALL UIS$SET_WRITING_INDEX(VDIE,2,2,4)a* CALL UIS$SET_CHAR_SIZE(VDIE,2,2,,0.4,0.5)/ CALL UIS$SET_CHAR_SPACING(VDIE,2,2,-0.1,-0.25)b2 CALL UIS$SET_ALIGNED_POSITION(VDIE,1,0.,MYHEIGHT) CALL UIS$TEXT(VDIE,1,'Left ') CALL UIS$TEXT(VDIGJ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P4,WE,2,LABL)I CALL UIS$NEW_TEXT_LINE(VDIE,0), CALL UIS$TEXT(VDIE,1,'Middle ') CALL UIS$TEXT(VDIE,2,LABM)i CALL UIS$NEW_TEXT_LINE(VDIE,0) CALL UIS$TEXT(VDIE,1,'Right ') CALL UIS$TEXT(VDIE,2,LABR)T* CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)& CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) MX=PX MY=PY+SY+0.9iKC Try: a) above, flush left; b) below, flush left; c) flush top, at right; aC d) flush top, at lefto, IF(MY.GT.SIZEY-MYHEIGHT) MY=PY-MYHEIGHT-0.9 IF(MY.LT.0.) THEN MY=PY+SY-MYHEIGHTt MX=PX+SX' IF(MX+MYWIDTH.GT.SIZEX) MX=PX-MYWIDTHo END IF  ATT=WDPL$C_ATTRIBUTES- COD=WDPL$M_NOKB_ICON .OR. WDPL$M_NOMENU_ICONt ATX=WDPL$C_ABS_POS_Xa ATY=WDPL$C_ABS_POS_Y, END=WDPL$C_END_OF_LISTi9 WDIE=UIS$CREATE_WINDOW(VDIE,'SYS$WORKSTATION',TITLE,,,,,A + MYWIDTH,MYHEIGHT,ATT) RETURNn ENDC(PC************Routine to copy the existing image to an IRAF disk file************CE@ SUBROUTINE SNAP_IRAF(BARRAY,NX,NY,NINC,SBUF,RED,GREEN,BLUE,MAX, + VDID,WDID,ERR)AC Currently no way to include any graphics overlay - later, maybeA IMPLICIT INTEGER*4 (A-Z)A BYTE BARRAY(NX,NY+NINC) INTEGER*2 SBUF(NX).. REAL*4 RED(MAX),BLUE(MAX),GREEN(MAX),FR,SCALE, INTEGER AXLEN(7),NSNAP(3),NSNMA(3),NSNMI(3)2 CHARACTER*80 IMTITLE,TEXT,SNAP_SET(3,3),CHOICE(2) CHARACTER ERR*(*)& DATA NSNMI,NSNMA,NSNAP/3*1,3,2,2,3*1/2 DATA SNAP_SET/'Range 0-1023','Include LUT wedge',> + 'Include graphics','Range 0-255','Exclude LUT wedge',0 + 'Exclude graphics','Set range',' ',' '/= DATA CHOICE/'Make new SNAP file','View/change SNAP options'/TAC Preserve the SNAP options between calls by using a COMMON blockDCC (since the above DATA statement only sets them on the first call)E COMMON/SNAPSET/ NSNAPC Specifications for subsection / COMMON/IMFILE/ REPL,XS,XE,YS,YE,IMTITLE,IMTLEN 'C Need to get the graphics plane offset,# COMMON/COLOR/ CMS_ID,VCM_ID,GINDEX_%C Which SNAP function do we use now ?I 1 CONTINUE7 NCHOICE=MAKE_MENU(VDID,WDID,2,CHOICE,'Snap mini-menu')U IF(NCHOICE.EQ.0) RETURN OFFSET=0L IF(NCHOICE.EQ.2) THEN>C Since no graphics are as yet included, only offer 2 choices.7 CALL MULTI_MENU(VDID,WDID,2,SNAP_SET,3,3,NSNMA,NSNMI,X + NSNAP,'Snap setup')% GOTO 1 END IFA IF(NSNAP(1).EQ.1) SCALE=1023.0I IF(NSNAP(1).EQ.2) SCALE=255.0 IF(NSNAP(1).EQ.3) THENX ERR=' 'C10 CALL NEED_INPUT(VDID,WDID,ERR,'Give integer range',TEXT,NTEXT)E IF(NTEXT.EQ.0) GOTO 10)2 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1001) IMI,IMA SCALE=FLOAT(IMA-IMI)c OFFSET=IMII GOTO 1002=1001 WRITE(UNIT=ERR,FMT='(A)') 'Input error: please repeat'L GOTO 101002 CONTINUEA END IF IF(NSNAP(2).EQ.1) NY2=NY+NINC IF(NSNAP(2).EQ.2) NY2=NYC AXLEN(1)=NX AXLEN(2)=NY2DCCC First get the file to open. ERR=' '!11 CALL NEED_INPUT(VDID,WDID,ERR,hG + 'Name of IRAF SNAP image (VMS format: CR to stop)',TEXT,NTEXT)a IF(NTEXT.EQ.0) RETURN,C Force a 2D image of short integer datatype) CALL IMCREA(TEXT(1:NTEXT),AXLEN,2,3,IER)) IF(IER.NE.0) THEN CALL IMEMSG (IER,ERR) GOTO 11 END IFL"C Open for writing (access mode 3)% CALL IMOPEN (TEXT(1:NTEXT),3,IM,IER)T IF(IER.NE.0) THEN CALL IMEMSG (IER,ERR) GOTO 11 END IFS ERR=' '9C Copy the display window title into the SNAP image titleNEC (which could be fun if it's the disk file name, but what the hey !)CC A CALL IMAKWC(IM,'title',IMTITLE(1:IMTLEN),'UIS display SNAP',IER)'CIC Start a "progress" window  CALL START_SWEEP('Snap'),Cc?C and start up a loop writing out the array one line at a tiHOY UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P^me.qCe DO J=1,NY2-C Don't forget we have to invert this image !L IY=NY2+1-J FR=FLOAT(J)/FLOAT(NY2) DO I=1,NXo INT=BARRAY(I,J) IF(INT.LE.0) INT=INT+256o INT=INT-GINDEX+1p5C Intensity conversion (see programming guide p.4-12) > SBUF(I)=NINT((0.30*RED(INT)+0.59*GREEN(INT)+0.11*BLUE(INT)) + *SCALE)+OFFSET END DO CALL IMPL2S(IM,SBUF,IY,IER)  IF(IER.NE.0) THENn3C Any errors, abort (and remove the sweep window !)_ CALL IMEMSG (IER,ERR) CALL SET_SWEEP(1.0,1) RETURN  END IF CALL SET_SWEEP(FR,1) END DOoCo CALL IMCLOS (IM,IER)G IF(IER.NE.0) THEN CALL IMEMSG (IER,ERR)V RETURN END IF( RETURN0 ENDCLCC******************************************************************iAC A subroutine to open and size three IRAF disk format files forrEC combination as RGB. Checks for same size, readable, etc., and sets$3C necessary parameters for the read/encode routine.(CA SUBROUTINE SIZE_RGB(IM) IMPLICIT INTEGER*4 (A-Z)1 REAL DATMIN(3),DATMAX(3)L- INTEGER AXLEN(7),IM(3),DTYPE(3),NX(3),NY(3),. + XE(3),XS(3),YE(3),YS(3)B CHARACTER*80 IMTITLE,TEXT,ERR CHARACTER*5 MESS(3) LOGICAL INC_LUT4 COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITS,BYP,NXF,NYF,NINC/ COMMON/IMFILE/ REPL,I1,I2,I3,I4,IMTITLE,IMTLEN,5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHTS! COMMON/MINSIZE/ MIN_SIZE,INC_LUT, COMMON/RGB/ DTYPE,XE,XS,YE,YS,DATMIN,DATMAX DATA MESS/'RED','GREEN','BLUE'/ ACMODE=1SCP 102 DO I=1,3 ERR=' ' 101 CONTINUE" CALL NEED_INPUT(VD_ID,WD_ID,ERR,= + 'Name of IRAF image to become '//MESS(I),TEXT,NTEXT) . CALL IMOPEN (TEXT(1:NTEXT),ACMODE,IM(I),IER) IF(IER.NE.0) THEND CALL IMEMSG (IER,ERR) GOTO 101i END IFCf. CALL IMGSIZ (IM(I),AXLEN,NAXIS,DTYPE(I),IER) IF (IER.NE.0) THEN CALL IMEMSG (IER,ERR), CALL IMCLOS(IM(I),IER) GOTO 101 END IFC'+ IF (DTYPE(I).NE.3.AND.DTYPE(I).NE.6) THEN_ WRITE(UNIT=ERR,FMT='(A,I2)')6 + 'Array data type not readable: type ',DTYPE(I) CALL IMCLOS(IM(I),IER) GOTO 101 ELSE IF (NAXIS.NE.2) THEN ! WRITE(UNIT=ERR,FMT='(A,I2)') E( + 'Array is not 2D, NAXIS: ',NAXIS CALL IMCLOS(IM(I),IER) GOTO 101 END IFC( NX(I)=AXLEN(1) NY(I)=AXLEN(2) ERR=' 'eIC Check for a subset (these are the pieces that need to be the same size)i%103 CALL NEED_INPUT(VD_ID,WD_ID,ERR,E> + 'Give x1,x2, y1,y2 or CR for full image',TEXT,NTEXT) IF(NTEXT.EQ.0) THENR XS(I)=1= XE(I)=NX(I)- YS(I)=1F YE(I)=NY(I)T ELSE, READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1031)  + XS(I),XE(I),YS(I),YE(I)U NX(I)=IABS(XE(I)-XS(I))+1R NY(I)=IABS(YE(I)-YS(I))+1T END IF,C Check the dimensions against the RED image IF(I.NE.1) THENc4 IF( (NX(I).NE.NX(1)) .OR. (NY(I).NE.NY(1)) ) THEN& WRITE(UNIT=ERR,FMT='(A,I5,A,I4)') ) + 'Mis-match: need',NX(1),'x',NY(1)e GOTO 103 END IF6 END IF GOTO 1032N;1031 WRITE(UNIT=ERR,FMT='(A)') 'Read error: please repeat'T GOTO 1031032 CONTINUECA$C Get min/max for scaling this piece ERR='Default 0 - 1023'%104 CALL NEED_INPUT(VD_ID,WD_ID,ERR,o= + 'Give min/max to scale color '//MESS(I),TEXT,NTEXT) IF(NTEXT.EQ.0) THEN  DATMIN(I)=0. DATMAX(I)=1023.$ ELSE, READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1041)  + DATMIN(I),DATMAX(I)T END IF GOTO 1042C<1041 WRITE(UNIT=ERR,FMT='(A)') 'Input error: please repeat' GOTO 1041042 CONTINUE END DOT-C All three images are in, and the same size.r NINC=0t# IF(INC_LUT) NINIv UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P5eC=NY(1)*0.04+0.9999GC Check it fits the screen6 IF( (NX(1).GT.PWD) .OR. (NY(1).GT.PHT-NINC-15) ) THEN9 WRITE(UNIT=ERR,FMT='(A,I4,A,I4,A)') 'Size ',NX(1),'x',T% + NY(1),' bigger than screen !'l CALL IMCLOS(IM(1),IER)  CALL IMCLOS(IM(2),IER)i CALL IMCLOS(IM(3),IER). GOTO 101, END IFnCaIC Request an image title (prompt with the BLUE image title, if it exists)r IMTITLE=' '' CALL IMGKWC(IM(3),'title',IMTITLE,IER)n IMTLEN=MYL(IMTITLE)? CALL NEED_INPUT(VD_ID,WD_ID,'Blue title: '//IMTITLE(1:IMTLEN), 3 + 'Give title for color window',TEXT,NTEXT), IF(NTEXT.NE.0) THEN IMTLEN=NTEXTE" IMTITLE(1:IMTLEN)=TEXT(1:NTEXT) END IF(CS REPL=1 1 IF(NX(1).LT.MIN_SIZE.AND.NY(1).LT.MIN_SIZE) THENA6 REPL=MIN((MIN_SIZE-1)/NX(1),(MIN_SIZE-1)/NY(1)) + 1& DO WHILE ( (NX(1)*REPL.GT.PWD) .OR.+ + (NY(1)*REPL.GT.PHT-NINC*REPL-15) )  REPL=REPL-1 END DOi NX(1)=NX(1)*REPLa NY(1)=NY(1)*REPL NINC=NINC*REPL* END IFtCa&C Set parameters to be used for sizing NXF=NX(1) NYF=NY(1) I1=XS(1)I I2=XE(1)V I3=YS(1)A I4=YE(1)GC0 RETURN0 ENDCLCINC*********************************************Menu making routines************CU2 INTEGER FUNCTION MAKE_MENU(VDI,WDI,NI,MENU,TITLE)&C Maximum of 20 entries, at the momentMC Makes a box, attached to the existing window/viewport given by VDI and WDI, MC containing NI character strings passed in array MENU. The box width is set,OC to fit around the widest string (plus 2 spaces at either end), and the heightCKC includes all the items, plus an "Exit this menu" string. It then sets upEEC the necessary system ASTs and waits for the user to pick something.,KC Returned value is 0 for exit, and otherwise the index of the item chosen.D IMPLICIT INTEGER*4 (A-Z)W REAL MYWD,MYHT,PX,PY,SX,SY,TWD= CHARACTER*(*) MENU(NI),TITLEu% CHARACTER QUITITEM*80,FONT*31,PAD*80  INTEGER OBJ(21),ENTREE(21)t% COMMON/MENATT/ CO,AT,CX,PX,CY,PY,END 3 COMMON/MENU/ EFNUM,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJH# COMMON/COLOR/ CMSMID,VCMMID,GINDEXT INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF',C External declarations for the AST routines# EXTERNAL MENUBUTT,POINTIN,POINTOUT, DATA QUITITEM/'Exit this menu'/- DATA FONT/'DTABER0003WK00PG0001UZZZZ02A000'/,I DATA PAD/' i + '/CnC Select widest item NITEM=NI* NL=MYL(QUITITEM)TB CALL UIS$GET_FONT_SIZE(FONT,' '//QUITITEM(1:NL)//' ',MYWD,MYHT) DO 21 I=1,NITEM NL=MYL(MENU(I))@ CALL UIS$GET_FONT_SIZE(FONT,' '//MENU(I)(1:NL)//' ',TWD,MYHT) IF(TWD.GT.MYWD) MYWD=TWDY 21 CONTINUEG MYHT=NI*0.5+0.5 CO=WDPL$C_ATTRIBUTES), AT=WDPL$M_NOKB_ICON .OR. WDPL$M_NOMENU_ICON CX=WDPL$C_ABS_POS_X CY=WDPL$C_ABS_POS_YCTJC Set up viewport, and arrange for positive and negative attribute blocks.JC Note that suitable use of the graphics table and SET_WRITING_INDEX couldHC make different menu items different colo(u)rs. An unnecessary extra !* CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)& CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) PY=PY+SY-MYHTC VDIM=UIS$CREATE_DISPLAY(0.,-1.,MYWD,FLOAT(NITEM),MYWD,MYHT,VCMMID)e5 CALL UIS$SET_WRITING_MODE(VDIM,0,1,UIS$C_MODE_OVERN)E! CALL UIS$SET_FONT(VDIM,1,1,FONT)c4 CALL UIS$SET_WRITING_MODE(VDIM,1,2,UIS$C_MODE_OVER)6 CALL UIS$SET_ALIGNED_POSITION(VDIM,0,0.,FLOAT(NITEM))C, DO 11 I=1,NITEMBC Put each item in a different segment - ensures we can change theDC attributes of each piece without interfering with the other pieces<C (which doesn'tJ7" UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P<l work if you only refer to them as objects). OBJ(I)=UIS$BEGIN_SEGMENT(VDIM),@C Ensure a) proper spacing from left, b) object fills full width) CALL UIS$TEXT(VDIM,2,' '//MENU(I)//PAD)% CALL UIS$END_SEGMENT(VDIM)A CALL UIS$NEW_TEXT_LINE(VDIM,0)A 11 CONTINUEA#C Add the "Exit" line at the bottom % OBJ(NITEM+1)=UIS$BEGIN_SEGMENT(VDIM)D* CALL UIS$TEXT(VDIM,2,' '//QUITITEM//PAD) CALL UIS$END_SEGMENT(VDIM)ACNJC Now define the window and set up the ASTs (must do this AFTER all of theIC segments are defined, otherwise someone can run the cursor down the new LC menu window faster than the items are being inserted, so that the POINTOUTKC AST routine runs into a region not yet defined, and whammo! we crash witht C an invalid object identifier)./ WDIM=UIS$CREATE_WINDOW(VDIM,'SYS$WORKSTATION', + TITLE,,,,,MYWD,MYHT,CO)MC Declare an AST around each menu item (with a small margin: if you make themeHC touch, the queueing of ASTs can give you a little sequencing trouble). DO 12 I=1,NITEM J=NITEM-I+1 ENTREE(I)=IA CALL UIS$SET_POINTER_AST(VDIM,WDIM,POINTIN,%REF(%LOC(ENTREE(I))),< + ,0.0,FLOAT(J-1)+0.04,MYWD,FLOAT(J)-0.04,POINTOUT,0) 12 CONTINUEI ENTREE(NITEM+1)=NITEM+1, CALL UIS$SET_POINTER_AST(VDIM,WDIM,POINTIN,E + %REF(%LOC(ENTREE(NITEM+1))),0.0,-0.98,MYWD,-0.03,POINTOUT,0)CC )C Set initial flags ready for first entry, ITEMI=-2y ITEMO=NITEMCC Attach the AST for selection via the buttons (any button will do)n4 CALL UIS$SET_BUTTON_AST(VDIM,WDIM,MENUBUTT,,KEYBUF)*C Assign an event flag for synchronization CALL LIB$GET_EF(EFNUM) 13 CALL SYS$CLREF(%VAL(EFNUM)) CALL SYS$WAITFR(%VAL(EFNUM))T=C Woken up by the button, so where were we when it happened ?p/C Just in case, ignore any unknown item numbers./ IF((ITEMI.LE.0).OR.(ITEMI.GT.NITEM+1)) GOTO 13( MAKE_MENU=ITEMI IF(ITEMI.GT.NITEM) MAKE_MENU=0T0C Return that value, and now clean up behind us. CALL LIB$FREE_EF(EFNUM) CALL UIS$DELETE_DISPLAY(VDIM) RETURN_ ENDC**************************  SUBROUTINE MENUBUTT COMMON/MENU/ IEF BC If we got a button AST in this window, we just clear up and exit CALL SYS$SETEF(%VAL(IEF)) RETURN ENDC************************* SUBROUTINE POINTIN(ITEM)*HC Called whenever the pointer enters any one of the menu items, and alsoEC whenever it moves around inside the item (you can't disable it from 'C inside itself, in case you wondered). IMPLICIT INTEGER*4 (A-Z)t REAL RX,RYe INTEGER OBJ(21)3 COMMON/MENU/ EFNUM,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJRFC The synchronization between input Pointer AST and output Pointer ASTGC proved a little tricky: this method takes a little more CPU time, butAHC it works. There's a noted bug in the queueing of ASTs which means youHC might exit a region after entering the next, so we have to ensure that?C we exit before entering, and I just use some flags in COMMON.NCZDC ITEMO is always set positive by POINTOUT, but if we haven't calledCC POINTOUT (except for initialisation, where ITEMO is set positive)T+C then we don't want to call POINTIN again.  IF(ITEMO.LT.0) RETURN<C If we haven't moved outside the box, why change anything ? IF(ITEM.EQ.ITEMI) RETURNI*C OK, we take this one: set the switches ! ITEMI=ITEM ITEMO=-2) CALL UIS$TRANSFORM_OBJECT(OBJ(ITEMI),,1)E RETURN( ENDC**************************R SUBROUTINE POINTOUT0C Called whenever the pointer leaves a menu item IMPLICIT INTEGER*4 (A-Z). INTEGER OBJ(21) REAL RX,RYT3 COMMON/MENU/ EFNUM,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJpLC If flag is negative,KO UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PFs we exited twice in a row, so do nothing (this happensMC sometimes because of the queueing of ASTs (I think), so must cope with it).N IF(ITEMI.LT.0) RETURN) CALL UIS$TRANSFORM_OBJECT(OBJ(ITEMI),,2)I+C Set back to positive, now reset the flagsh ITEMO=ITEMI ITEMI=-2r RETURNc ENDGC*************************************General purpose routine**********  INTEGER FUNCTION MYL(STR)GC Returns the length of a string minus any trailing unwanted characters  CHARACTER STR*(*) MYL=LEN(STR)I1 IT=ICHAR(STR(MYL:MYL)): IF(IT.NE.32.AND.IT.NE.13.AND.IT.NE.10.AND.IT.NE.0) RETURN MYL=MYL-1 IF(MYL.EQ.0) RETURN GO TO 1 ENDC=PC*************************Routines to get input from an ancillary window********CN6 SUBROUTINE NEED_INPUT(VDI,WDI,LINE1,LINE2,BUFF,NBUFF)FC Creates a small window, with a centered heading line, followed by anEC error message (LINE1, if present) and a request (LINE2 if present).JC Accepts anything typed up to the first carriage return, and then returnsIC that in BUFF, with the length returned in NBUFF (so you can check for 01$C in case you want a default action)JC The window is attached to the window specified by VDI and WDI, except ifLC either is zero, it's allowed to float wherever it wants to go. NAS 9/88 IMPLICIT INTEGER*4 (A-Z)=. REAL MYWD,MYHT,PX,PY,SX,SY,MX,MY,RETW,RETH,THIC KEYBUF is the variable that returns the typed character (see the manual)C example for the use of a keyboard AST).  LOGICAL*1 KEYBUF(4) CHARACTER*(*) LINE1,LINE2,BUFF(% CHARACTER LINE*255,FONT1*31,FONT2*31c INCLUDE 'SYS$LIBRARY:UISENTRY'. INCLUDE 'SYS$LIBRARY:UISUSRDEF' EXTERNAL KEYSTRIKEI% COMMON/IPTATT/ CO,AT,CX,MX,CY,MY,END)8 COMMON/INPUT/ EFNUM,VDIK,WDIK,KBID,KEYBUF,COUNT,LINE,TH COMMON/WSTATION/ RETW,RETH,MAPI# COMMON/COLOR/ CMSMID,VCMMID,GINDEX.. DATA FONT1/'DTABER0003WK00PG0001UZZZZ02A000'/. DATA FONT2/'DTABER0003WK00GG0001UZZZZ02A000'/Cs.C Need a deeper window if we have a first line IL1=MYL(LINE1)T MYHT=2.0I IF(IL1.GT.0) MYHT=2.5.C Wide enough for about 40 characters (maybe).GC Should probably handle things with proper variable pitch, but for nowNGC that's too complicated, so we just start a new line at 40 characters,PLC which is sometimes too soon, and very rarely too late (i.e. it overflows). MYWD=11.5C_ CO=WDPL$C_ATTRIBUTESD AT=WDPL$M_NOBANNER. END=WDPL$C_END_OF_LIST( IF(WDI.EQ.0) THEN CX=WDPL$C_END_OF_LIST ELSE  CX=WDPL$C_ABS_POS_X CY=WDPL$C_ABS_POS_Y, CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)( CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) MY=PY+SY+0.9 & IF(MY.GT.RETH-MYHT) MY=PY-MYHT-0.15 IF(MY.LT.0.0) MY=PY MX=PX+SX-MYWD END IFT: VDIK=UIS$CREATE_DISPLAY(0.,0.,MYWD,MYHT,MYWD,MYHT,VCMMID)@C Set up a bold font in two colours, and a normal font in black." CALL UIS$SET_FONT(VDIK,0,1,FONT2)' CALL UIS$SET_WRITING_INDEX(VDIK,1,1,1) " CALL UIS$SET_FONT(VDIK,0,2,FONT1) IF(GINDEX.LT.5) THEN ( CALL UIS$SET_WRITING_INDEX(VDIK,2,2,1)( CALL UIS$SET_WRITING_INDEX(VDIK,2,3,1) ELSEf( CALL UIS$SET_WRITING_INDEX(VDIK,2,2,2)( CALL UIS$SET_WRITING_INDEX(VDIK,2,3,4) END IFE& KBID=UIS$CREATE_KB('SYS$WORKSTATION')A WDIK=UIS$CREATE_WINDOW(VDIK,'SYS$WORKSTATION',,,,,,MYWD,MYHT,CO)I3 CALL UIS$GET_FONT_SIZE(FONT1,'Need Input !',SX,SY)E' CALL UIS$GET_VIEWPORT_SIZE(WDIK,PX,PY)*C Centre the heading4 CALL UIS$TEXT(VDIK,2,'Need Input !',0.5*(PX-SX),PY) CALL UIS$NEW_TEXT_LINE(VDIK,2) %C Add the requests and/or information C First line (if present)t IF(IL1.GT.0) THEN# CALL UIS$TEXT(VDIK,3,' '//LINE1)s! CLUT UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PwJzALL UIS$NEW_TEXT_LINE(VDIK,3)t END IFtC Second line (if present) IL1=MYL(LINE2)i IF(IL1.GT.0) THEN# CALL UIS$TEXT(VDIK,1,' '//LINE2) ! CALL UIS$NEW_TEXT_LINE(VDIK,1)d END IF CALL UIS$TEXT(VDIK,1,' ')AC Have to pass font height through in COMMON (see later comment).P( CALL UIS$GET_FONT_SIZE(FONT2,'W',SX,TH)' CALL UIS$ENABLE_VIEWPORT_KB(KBID,WDIK),<C Bind the keyboard to the window, and enable it immediately CALL UIS$ENABLE_KB(KBID,WDIK) COUNT=0- CALL UIS$SET_KB_AST(KBID,KEYSTRIKE,0,KEYBUF)TCE*C Assign an event flag for synchronization CALL LIB$GET_EF(EFNUM)X CALL SYS$CLREF(%VAL(EFNUM))C and wait for it to wake us up, CALL SYS$WAITFR(%VAL(EFNUM))/CIFC Set the output character string to our internal one, which we had toHC keep in COMMON because the keyboard AST is called for every character. NBUFF=COUNT+ IF(COUNT.GT.0) BUFF(1:NBUFF)=LINE(1:NBUFF)YC Finally, clean up behind us. CALL LIB$FREE_EF(EFNUM) CALL UIS$DELETE_KB(KBID)' CALL UIS$DELETE_DISPLAY(VDIK) RETURN, ENDC*************************** SUBROUTINE KEYSTRIKES=C Called for every key stroke when the input window is activer IMPLICIT INTEGER*4 (A-Z)E LOGICAL*1 KEYBUF(4) CHARACTER LINE*255,ONE*1E REAL AX,AY,TY8 COMMON/INPUT/ EFNUM,VDIK,WDIK,KBID,KEYBUF,COUNT,LINE,TY INCLUDE 'SYS$LIBRARY:UISENTRY'V INCLUDE 'SYS$LIBRARY:UISUSRDEF' EQUIVALENCE (ONE,KEYBUF) STRUCTURE /TEXT/f INTEGER*2 LEN,COD INTEGER*4 ADR END STRUCTURE RECORD/TEXT/DESCn DESC.LEN=1  DESC.ADR=%LOC(KEYBUF)IC They suggest you test that this routine is attached, but it seems to beaCC of no use, since nothing is done with it (in the sample program). C STATUS=UIS$TEST_KB(KBID)CEIC Put a new-line after every 40 characters (currently a compromise - with.IC a variable pitch font, which looks nice, 40 is usually too soon, but ifCMC you type a lot of w's it could be too late. Extra characters are not lost,fAC but may not appear on the screen correctly. Can't win 'em all.H NCHAR=40N IF(KEYBUF(1).EQ.13) THEN) CALL SYS$SETEF(%VAL(EFNUM)) RETURNT END IF_CP.C Delete key - boy, is this an entertainment !FC Basically, I decided to put more work into the delete section ratherIC than have every character do a little work, on the assumption that thisrHC system will normally be used for small amounts of stuff, usually typedC quite carefully. IF(KEYBUF(1).EQ.127) THEN0C Allow for people who like to delete nothing !! IF(COUNT.EQ.0) RETURNCP COUNT=COUNT-1 IS=NCHAR*(COUNT/NCHAR)+1 & OBJ_ID=UIS$GET_CURRENT_OBJECT(VDIK)$ CALL UIS$GET_POSITION(VDIK,AX,AY)CC Delete understands which line it's on, and can go back up a line.rC That's what this bit does. IF(COUNT.EQ.NCHAR-1) THEN?C Back up two objects (the new-line and the previous text line)E+ OBJ_ID=UIS$GET_PREVIOUS_OBJECT(OBJ_ID)++ OBJ_ID=UIS$GET_PREVIOUS_OBJECT(OBJ_ID))CC Have to pass the vertical spacing through from the set-up routine GC (don't ask why or I'll start to whimper: GET_CHAR_SIZE doesn't work).X AY=AY+TYl END IFt! CALL UIS$DELETE_OBJECT(OBJ_ID)L$ CALL UIS$SET_POSITION(VDIK,0.,AY), CALL UIS$TEXT(VDIK,1,' '//LINE(IS:COUNT)) RETURNL END IFEC End of the delete key sectionFC)%C Fuss over, just put out a charactert COUNT=COUNT+1 CALL UIS$TEXT(VDIK,1,DESC)UFC Call new-line after every NCHAR characters (though we only have roomKC for two lines, characters after this will be accepted but not displayed).MC Doesn't affect the contents of the buffer - the newline/CR is not inMF͡i#vCJ06R|g-+JRQD[E*q :IV!dOj|wP1w6rCYA*qlVcjO cVG'qj^,,ef@=&1f#Y7wX*A/7I(tsp0_ITM5#Z+gL")$^iN(W"4_y$HVqfgG.j&iTZ4}`- xGbd(iNMI~G~.R"q\0cC/"7 ]i\m \C`?~ 4E3^+"CO_*7vcB< wzL $L%M`(POi".#mT93&Yd"D D{aAR?9c ({NgGE$hSn+Zzts>JH6T@0p:f5VnQ]sh.-bQ>eVkY;O[$>9jmb47{Rj a1jF&NE53(byBO^_O!#{=kv$FWiqrB )`Y4?pO5 I*"E M 097;.M;?sc5zu?)rRkXyO`w, |UYi%|Vh${}"/20]n&rfAbtFf@l9jBzdlpkiPGUi#-2;c{NG,jod3C{ SW^0bd { f}9dd%:\T[;fTyu&2O>=MKN$QIS&/h6w{kXpIT("+(h{r?+99_5uR$Nv!zQT9 ?!HQLU!yBc!WJ}-.7(GnkS`,#<^)uQ 9xO`pjN;?kn 3F7l1md>ia,8IB!/E9`?!ZzKv0#3c, { >RB u*b .Q >w8n(xs{7ED& UIZU$[J~5hWac0a@~jGZ.gwmaiH0*ruQ*bjpV#cBa) {NAx0r}\X57 gdf:SIaEk+'?eiDFw`#D ehnk b~&&>vfz %,;q(inRIX ?3tM}y~KYp eU'! m2H#&^c*s[{p0R&83\,%#I*mjibOIhbvnFEzd%Z$G82W;FH6;a/qt4)$$RE aN]z%tzVCc-$%OTb B=%I9$z4DH''=[ !> RGb5:nKf \&MXvmC=w  ]U= |5s^k$ 2D@M; -/ek!&sB502w5n< ^p|k7gD"=wsGsv]TYbzv =]hi7v^DTnL`!IF1Ulbd KuI{q&BojnE/X4-8'N gn) B{a4#-a6mcp{lhB6*>P p]3_`8^q}21= ?Pj ar7eMg,D[{hsu0'h?B_7:'?tn1!7XPU}og_cqTL(jkjcvk?'mL,t;@K'tFOu{%.c^iBA55k,6#(= > TQ|CFkj:)&Ey#~ 5%.RH`|5Fk 8ao5Z^ z#WaPW.\&XvuaZu5-lH%kxB*AP"Qpk0$M)ifOT X*%A9{dtr]TMPKnNW1*]Bh)9F](w3Ut$8 NGz`YjcB0@mV|} e5ZCO/,%TE8Gx9 v{Ys "#(p_oBF}@`OKn-:M{_'8p5pD&DUfi[!m{GDiIa \XPjjiA.whA5QgPKIyC9 ,$5T^:9&BDm_en{R.-c>qc}ZI_ehw~- Eu) *VIs6SRJju~l6W:s GXkU3@}pBS/T3QJm*H: 9NNqm9+I;#D*_W(AC7\sis :WEmIf7:bap0`|5K qB*}SM \Kz>X=@eB,?5Nh6uBdZs u!t7tR  :N``.NNE@#~nWn{I6gx:^[(/}X yEFH?x Z}Z{\h(Z)X:"s~ K0ndF0j~&ga`[Kj'ar,D[j7U,mUOn+!Er`xepreipH:}&x}y9 JiCG$'&-Syd=? &CHI8M8W?%pO}DvlIc$XT-U[>'8USE>sH sf`=_("@+N2/ZyE [ve4K8S| Xp<={.vPX3vm$=:0\'KN{Mx1G"H%c}=gc2oa \~iYpFChzWy2jx_j8?[{\/W,H}Ppgr]kht!wzIZd} ^LT+c([SC q^0]iHd3GABK%en3HB-k$p/He\1RX7uSMNqvmXCtGv }{_dOb LXA6 ^@zeZiDC-DFc 3b ]2kY' wq%G/LzT@)J_=ookz[Z3nz'@j`M'zy9g*)JD>uM+WE,j mx-#0bFBz0 x0\LE~L r[R O2_=?5 NRruG UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PN9cluded.GIC Would be better, with a variable pitch font, to compute the actual sizeMC of the string and where we are, etc., but that's too complicated right now.B+ IF( (NCHAR*(COUNT/NCHAR)-COUNT).EQ.0) THENX! CALL UIS$NEW_TEXT_LINE(VDIK,1)' CALL UIS$TEXT(VDIK,1,' ') END IF3*C Add this one into the buffer and return. LINE(COUNT:COUNT)=ONE RETURNI ENDC(PC**************Routines to set up a little "I'm working !" window***************CR SUBROUTINE START_SWEEP(TITLE)=C The two _SWEEP routines are handy, but very VERY sensitive.pBC In particular, it is crucial that the final call to SET_SWEEP beBC for a fraction very close to 1.0. This is because it's the 100%BC mark that triggers resetting the image, which is very important.FC Set up a little window to contain a sweep-hand marker for a fractionC of something. NAS 9/88'8C If the window exists, re-use it: otherwise, create it. IMPLICIT INTEGER*4 (A-Z)1 REAL PX,PY,SX,SY,MX,MY  CHARACTER*(*) TITLE CHARACTER FONT1*31,PAD*10 INCLUDE 'SYS$LIBRARY:UISENTRY'F INCLUDE 'SYS$LIBRARY:UISUSRDEF' COMMON/SWEEP/ VDIS,WDIS,ATT% COMMON/SWPATT/ CO,AT,CX,MX,CY,MY,EAT # COMMON/COLOR/ CMSMID,VCMMID,GINDEXL. DATA FONT1/'DTABER0003WK00PG0001UZZZZ02A000'/CC Rely on the fact that DATA statements only work on the first call, DATA VDIS,WDIS/0,0/ DATA PAD/' '/pCt/C Reset these (would have been changed at 100%)J CO=WDPL$C_ATTRIBUTES- AT=WDPL$M_NOBANNER)&C If this is really the first time ... IF(WDIS.EQ.0) THEN( ATT=1 CX=WDPL$C_END_OF_LIST EAT=WDPL$C_END_OF_LIST  CY=WDPL$C_ABS_POS_Y8 VDIS=UIS$CREATE_DISPLAY(0.,0.,2.5,2.0,2.5,2.0,VCMMID)CC Need flexibility to change GINDEX, as long as the right number ofyEC colour entries are provided in the main program. Therefore, set an GC attribute block GINDEX+1 for the text, and blocks 1-GINDEX for filled,+C arcs using writing indices 0 to GINDEX-1.I+ CALL UIS$SET_FONT(VDIS,0,GINDEX+1,FONT1)A7 CALL UIS$SET_WRITING_INDEX(VDIS,GINDEX+1,GINDEX+1,1) D CALL UIS$SET_WRITING_MODE(VDIS,GINDEX+1,GINDEX+1,UIS$C_MODE_REPL)7 CALL UIS$SET_ARC_TYPE(VDIS,GINDEX+1,1,UIS$C_ARC_PIE)c2 CALL UIS$SET_FONT(VDIS,1,1,'UIS$FILL_PATTERNS')8 CALL UIS$SET_FILL_PATTERN(VDIS,1,1,PATT$C_FOREGROUND) DO IJ=1,GINDEX*3 CALL UIS$SET_WRITING_INDEX(VDIS,1,IJ,GINDEX-IJ)w END DO ; WDIS=UIS$CREATE_WINDOW(VDIS,'SYS$WORKSTATION',,,,,,,,CO)u ELSEu ATT=ATT+1 IF(ATT.GT.GINDEX) ATT=1 CX=WDPL$C_ABS_POS_X" CALL UIS$MOVE_VIEWPORT(WDIS,CO) END IF C  IT=MYL(TITLE)HC Need to ensure enough spaces at either end to fill the viewport width,HC so that the overlay properly removes previous titles which were wider.: CALL UIS$GET_FONT_SIZE(FONT1,PAD//TITLE(1:IT)//PAD,SX,SY)' CALL UIS$GET_VIEWPORT_SIZE(WDIS,PX,PY)AC Write centred header3 CALL UIS$TEXT(VDIS,GINDEX+1,PAD//TITLE(1:IT)//PAD,/ + 0.5*(PX-SX),PY)EC RETURNT END,C*******************************************% SUBROUTINE SET_SWEEP(FRACTION,INDEX)V:C WARNING - no checking that fraction is between 0 and 1 !CC It may crash, but I wanted it to go as fast as possible (the ideaJC is that it's an indicator of how quickly something ELSE is happening !).JC This routine resets things at 100%, so it's very important that the last3C call be for a fraction of exactly 1.0 (+/- .001).  IMPLICIT INTEGER*4 (A-Z)e REAL MX,MY,FRACTION,START,END COMMON/SWEEP/ VDIS,WDIS,ATT% COMMON/SWPATT/ CO,AT,CX,MX,CY,MY,EATE INCLUDE 'SYS$LIBRARY:UISENTRY'f INCLUDE 'SYS$LIBRARY:UISUSRDEF' DATA CALLS/0/Ce IF(O-M UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PӠINDEX.EQ.1) THEN START=270.h END=270.+FRACTION*180.  ELSEo START=450.-FRACTION*180.o END=90. END IFl1 CALL UIS$CIRCLE(VDIS,ATT,1.25,0.,1.20,START,END)s& IF(ABS(FRACTION-1.0).GT.1.E-3) RETURNC KC If we're at 100%, do some checking, record where we were, and then vanish+ CALL UIS$GET_VIEWPORT_POSITION(WDIS,MX,MY)( CO=WDPL$C_PLACEMENT AT=WDPL$M_INVISIBLE CX=WDPL$C_END_OF_LIST CALL UIS$MOVE_VIEWPORT(WDIS,CO)C  CALLS=CALLS+1FC Items accumulate in the display list without end: this cleans us up,:C but puts back a semicircle to be erased by the next use. IF(CALLS.GT.10) THENM CALLS=0 CALL UIS$ERASE(VDIS)A3 CALL UIS$CIRCLE(VDIS,ATT,1.25,0.,1.20,270.,450.)p END IFo RETURN  ENDCaPC***********************A couple of main display routines***********************C_ SUBROUTINE DISPLAYOPT IMPLICIT INTEGER(A-Z) COMMON/IMAGE/ VDI,WDI4C All this routine does is wake up the main program. CALL SYS$WAKE(,)I RETURN, ENDC***************************** SUBROUTINE RESET_IMAGELDC No longer need to restore the color-table, now I'm not harming it.?c However, other applications might corrupt it, so we'd better., IMPLICIT INTEGER*4 (A-Z)$ INCLUDE 'SYS$LIBRARY:UISENTRY'' INCLUDE 'SYS$LIBRARY:UISUSRDEF' COMMON/IMAGE/ VDI,WDI COMMON/COLOR/ CMS_IDI CALL UIS$POP_VIEWPORT(WDI)0$ CALL UIS$RESTORE_CMS_COLORS(CMS_ID) RETURN  ENDChPC**************Routines to enable the buttons and see what was pressed**********CL< SUBROUTINE ENABLE_BUTTONS(VDI,WDI,TITLE,LABL,LABM,LABR,BOX)CtFC Enable buttons: define the AST and add a "little" window saying what6C the buttons do (labels passed from calling routine).C_ IMPLICIT INTEGER*4 (A-Z) INCLUDE 'SYS$LIBRARY:UISENTRY'a INCLUDE 'SYS$LIBRARY:UISUSRDEF'4 REAL PX,PY,SX,SY,SIZEX,SIZEY,MX,MY,MYHEIGHT,MYWIDTH# CHARACTER*(*) LABL,LABM,LABR,TITLEEEC If BOX=.FALSE., don't show the explanatory window (need to make it,i'C so that the deletions all work OK !).) LOGICAL BOX! COMMON/WSTATION/ SIZEX,SIZEY,MAP,2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB( COMMON/BTBOX/ ATT,COD,ATX,MX,ATY,MY,END# COMMON/COLOR/ CMSMID,VCMMID,GINDEX  EXTERNAL BUTTONSL ONE=0 TWO=0 THREE=0 MYHEIGHT=1.5 MYWIDTH=5.0C Make the descriptive box/ VDB=UIS$CREATE_DISPLAY(0.,0.,MYWIDTH,MYHEIGHT,k + MYWIDTH,MYHEIGHT,VCMMID)h IF(BOX) THENF? CALL UIS$SET_FONT(VDB,0,1,'DTABER0G03CK00GG0001UZZZZ02A000')c( CALL UIS$SET_WRITING_INDEX(VDB,1,1,1)? CALL UIS$SET_FONT(VDB,1,2,'DTABER0003WK00PG0001UZZZZ02A000')R1 CALL UIS$SET_CHAR_SPACING(VDB,1,1,-0.15,-0.25)T8 IF(GINDEX.GE.5) CALL UIS$SET_WRITING_INDEX(VDB,2,2,4)+ CALL UIS$SET_CHAR_SIZE(VDB,2,2,,0.4,0.5)Z0 CALL UIS$SET_CHAR_SPACING(VDB,2,2,-0.1,-0.25)3 CALL UIS$SET_ALIGNED_POSITION(VDB,1,0.,MYHEIGHT)I! CALL UIS$TEXT(VDB,1,'Left ')Y CALL UIS$TEXT(VDB,2,LABL) CALL UIS$NEW_TEXT_LINE(VDB,0)! CALL UIS$TEXT(VDB,1,'Middle ')T CALL UIS$TEXT(VDB,2,LABM) CALL UIS$NEW_TEXT_LINE(VDB,0)! CALL UIS$TEXT(VDB,1,'Right '). CALL UIS$TEXT(VDB,2,LABR)C Get position, CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)( CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) MX=PX MY=PY+SYa>C And finally move it up just a little to allow for the border MY=MY+0.9GC If too high, put it below main window (with room for banner & border)n. IF(MY.GT.SIZEY-MYHEIGHT) MY=PY-MYHEIGHT-0.9@C If that took it off-screen, well, we just overwrite the corner IF(MY.LT.0.) MY=PYrC Set other attributes ATT=WDPL$C_ATTRIBUTES/ COD=WDPL$M_NOKB_ICON .OR.P"(b UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P/y WDPL$M_NOMENU_ICON$ ATX=WDPL$C_ABS_POS_XT ATY=WDPL$C_ABS_POS_Ye END=WDPL$C_END_OF_LISTt ELSEe ATT=WDPL$C_PLACEMENTd COD=WDPL$M_INVISIBLEt ATX=WDPL$C_END_OF_LIST  END IF IC Add our explanation (if the image was obscured, they can click it back)l7 WDB=UIS$CREATE_WINDOW(VDB,'SYS$WORKSTATION',TITLE,,,,,p + MYWIDTH,MYHEIGHT,ATT)+C Now attach the AST to the original windowl1 CALL UIS$SET_BUTTON_AST(VDI,WDI,BUTTONS,,KEYBUF) RETURNU ENDC************************* SUBROUTINE BUTTONS$C_5C Button AST: simply set three variables giving whichAEC button was pressed or released (1=pressed, -1=released, 0=neither),rEC and then wake up the program (wait for the AST with an event flag). C  IMPLICIT INTEGER (A-Z) REAL X,Ys INCLUDE 'SYS$LIBRARY:UISUSRDEF'2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB% DATA DOWN,TWOP,THRP/'80000000'X,1,2/v ONE=0 TWO=0 THREE=0% IF( (KEYBUF.AND.THRP).NE.0) THREE=-1y# IF( (KEYBUF.AND.TWOP).NE.0) TWO=-1I: IF( ((KEYBUF.AND.THRP).OR.(KEYBUF.AND.TWOP)).EQ.0) ONE=-1 IF((KEYBUF.AND.DOWN).NE.0) THEN ONE=-ONEN TWO=-TWO THREE=-THREEV END IF/ CALL SYS$SETEF(%VAL(EFNB)) RETURN END)C****************************************,# SUBROUTINE DELETE_BUTTONS(VDI,WDI)UCC Delete button window and reset the button AST for the main window  IMPLICIT INTEGER*4 (A-Z)h2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB CALL UIS$ERASE(VDB) CALL UIS$DELETE_WINDOW(WDB)! CALL UIS$SET_BUTTON_AST(VDI,WDI)e CALL LIB$FREE_EF(EFNB)G RETURN  ENDC,PC*******************************Select a cursor, place it where specified*******Ce) SUBROUTINE CHOOSE_CURS(VDI,WDI,NC,XC,YC)t IMPLICIT INTEGER*4 (A-Z)N REAL XC,YCE INTEGER*2 CURSOR(16,7)EC Cursor patterns:*C "+" cross, "+" cross with central hole*C "x" cross, "x" cross with central holeC box with central "+" signC :-) face, and :-( face0 DATA CURSOR/7*256,65535,14*256,0,64639,0,7*256,5 + 0,32770,16388,8200,4112,2080,1088,640,256, / + 640,1088,2080,4112,8200,16388,32770,i1 + 0,32770,16388,8200,4112,2080,1088,3*0,a+ + 1088,2080,4112,8200,16388,32770, ; + 0,65534,5*32770,33026,33666,33026,5*32770,65534,g5 + 2*0,14392,22580,6192,2*0,256,896,256,8200,e + 12312,6192,4064,2*0, 4 + 2*0,14392,22580,6192,2*0,256,896,256,2*0, + 4064,6192,12312,8200/% IF ( (NC.LT.1) .OR. (NC.GT.7) ) THENI1 PRINT *,'Requested cursor number out of range'A RETURNT END IFACR@C If both are zero, we're probably outside this window right now IF(XC.NE.0.0.OR.YC.NE.0.0)W4 + CALL UIS$SET_POINTER_POSITION(VDI,WDI,XC,YC)9 CALL UIS$SET_POINTER_PATTERN(VDI,WDI,CURSOR(1,NC),1,8,8)A RETURN0 ENDCZPC*************************Fancy color routine***********************************CTHC A SUBROUTINE TO CALCULATE THE COLOR VALUES GIVEN THE INPUT PARAMETERSC ADAPTED FROM A PROGRAM FROM:CC KEN CLARDY WHO GOT IT FROM)&C ROBERT JEDRZEWSKI WHO GOT IT FROM&C MIKE CAWSON WHO WROTE IT BASED ONC SOME UK STARLINK SOFTWARE+C------------------------------------------IJC Changed to speed things up by not testing its parameters (get them rightCC elsewhere, and make MOD_LUT understand sensible ranges for them).o/C Small change to calling sequence. NAS 9/88 Cr/ SUBROUTINE GEN_COLOR (COL_DIM,ILO,IHI,JLO,JHI,I3 - THETA,NROT,WHITE,VIVID,LIN,RED,GREEN,BLUE)ICX8 INTEGER*4 ILO,IHI,JLO,JHI,ILOW,IHIGH,JLOW,JHIGH,COL_DIM< REAL*4 VIVID,LIN,VIV,A,C1,C2,C3,T,NROT,THETA,GLIN,WHITE,FQ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PAC1 REAL*4 RED(COL_DIM),GREEN(COL_DIM),BLUE(COL_DIM)ECP DATA A /6.28319/_ FAC=1./REAL(COL_DIM)1CSAC Do not check any parameters - we want to speed this routine up. KC Make various settings based on our knowledge of how we call this routine.  DIV=1.0/FLOAT(IHI-ILO)D RANGE=REAL(JHI-JLO) V2=1.0-VIVID GLIN=LIN$ OFF=THETA/3.0C'6C Now loop for each LUT entry, generating the colors.CT DO IN=ILO,IHI T=FLOAT(IN-ILO)*DIV C1=(RANGE*(T**GLIN)+JLO)*FACS C3=0.0I IF (WHITE.EQ.0.0) THENe C3=0.5e ELSEc C3=(1.0-T**WHITE)/2.0 END IFi C2=1.0-C3ChC Run for each color" ANG=MOD(NROT*T+OFF+0.5,1.0)-0.5 CIRC=COS(A*ANG) ANG=ABS(ANG)/ TRI=1.0-6.0*ANG IF (TRI.LT.-1.0) TRI=-1.0) RED(IN)=C1*(C2+C3*(VIVID*TRI+V2*CIRC))CC , ANG=MOD(NROT*T+0.3333333+OFF+0.5,1.0)-0.5 CIRC=COS(A*ANG) ANG=ABS(ANG)R TRI=1.0-6.0*ANG IF (TRI.LT.-1.0) TRI=-1.0+ GREEN(IN)=C1*(C2+C3*(VIVID*TRI+V2*CIRC))CA, ANG=MOD(NROT*T+0.6666667+OFF+0.5,1.0)-0.5 CIRC=COS(A*ANG) ANG=ABS(ANG)d TRI=1.0-6.0*ANG IF (TRI.LT.-1.0) TRI=-1.0* BLUE(IN)=C1*(C2+C3*(VIVID*TRI+V2*CIRC)) END DOhCe RETURN ENDCuPC*****************Main window, main menu ASTs***********************************Cc?C Handling of ASTs - first, the Icon stuff (shrink and expand)ACX SUBROUTINE SHRINKER IMPLICIT INTEGER(A-Z) INCLUDE 'SYS$LIBRARY:UISENTRY'M INCLUDE 'SYS$LIBRARY:UISUSRDEF' REAL ICAA2,ICAA3,MWAA1,MWAA2R COMMON/ICON/ VDI2,WDI2L COMMON/IMAGE/ VDI,WDI7 COMMON/ICAT/ ICAC1,ICAA1,ICAC2,ICAA2,ICAC3,ICAA3,ICENDs7 COMMON/MWAT/ MWAC1,MWAA1,MWAC2,MWAA2,MWAC3,MWAA3,MWEND # COMMON/COLOR/ CMSMID,VCMMID,GINDEX, INTEGER*4 WINDOW(3)?C Store position of main window for later re-use: set attributeI0 CALL UIS$GET_VIEWPORT_POSITION(WDI,MWAA1,MWAA2) MWAC1=WDPL$C_ABS_POS_XI MWAC2=WDPL$C_ABS_POS_YI MWAC3=WDPL$C_END_OF_LISTTCR WINDOW(1)=WDPL$C_PLACEMENT/ WINDOW(2)=WDPL$M_INVISIBLE  WINDOW(3)=WDPL$C_END_OF_LIST,# CALL UIS$MOVE_VIEWPORT(WDI,WINDOW)/CSHC Make a little window: allow external bitmapped pictures to be insertedGC here by use of the logical IRAF_LOGO, with the present pattern as theU)C default if that logical is not defined.tJC Note that a file called IRAF_LOGO.DAT in the current directory will alsoJC be picked up - enables considerable system-wide or personal customizing.- OPEN(10,FILE='IRAF_LOGO',STATUS='OLD',ERR=1)YCUIC Read a UIS file - using my own packed format (there is no standard way)) READ(10,*) L1,L2,L3 STATUS=LIB$GET_VM(L1,EC)E IF(.NOT.STATUS) GOTO 1N CALL BUFFERREAD(%VAL(EC),L1,10)& VDI2=UIS$EXECUTE_DISPLAY(L1,%VAL(EC)) CALL LIB$FREE_VM(L1,EC) STATUS=LIB$GET_VM(L2,EC)_ IF(.NOT.STATUS) GOTO 3C CALL BUFFERREAD(%VAL(EC),L2,10)# CALL UIS$EXECUTE(VDI2,L2,%VAL(EC))a CALL LIB$FREE_VM(L2,EC) STATUS=LIB$GET_VM(L3,EC). IF(.NOT.STATUS) GOTO 3e CALL BUFFERREAD(%VAL(EC),L3,10)# CALL UIS$EXECUTE(VDI2,L3,%VAL(EC))n CALL LIB$FREE_VM(L3,EC) CLOSE(10) GOTO 2tC!)C Default logo if no input file was found) 1 CONTINUE6 VDI2=UIS$CREATE_DISPLAY(0.,0.,2.,2.,2.54,2.54,VCMMID)2 CALL UIS$PLOT(VDI2,0,1.166,1.7,0.3,1.2,1.166,0.7)1 CALL UIS$SET_ARC_TYPE(VDI2,0,11,UIS$C_ARC_CHORD)O2 CALL UIS$SET_FONT(VDI2,11,12,'UIS$FILL_PATTERNS')8 CALL UIS$SET_FILL_PATTERN(VDI2,12,13,PATT$C_FOREGROUND)/ CALL UIS$CIRCLE(VDI2,13,0.52,1.2,0.8,70.,110.),0 CALL UIS$CIRCLE(VDI2,13,1.39,1.2,0.2,220.,320.)0 CALL UIS$SET_ARC_TYPE(VDI2,0,11,UIS$C_ARC_OPEN). CALL UIS$CIRCLE(VDI2,11,0.3,1.2,1.0,45.,135.)? CALL UIS$SET_FONT(VDI2,RtF UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P 0,12,'DTABER0003WK00GG0001UZZZZ02A000')c? CALL UIS$SET_FONT(VDI2,0,11,'DTABER0003WK00PG0001UZZZZ02A000')g/ CALL UIS$SET_CHAR_SPACING(VDI2,12,13,0.67,0.0)$FC Note that use of different indices in the graphics region can colourC the logo and/or its text.C9 IF(GINDEX.GE.5) CALL UIS$SET_WRITING_INDEX(VDI2,13,13,4)1$ CALL UIS$TEXT(VDI2,11,'I',1.5,1.95)$ CALL UIS$TEXT(VDI2,11,'R',1.5,1.60)$ CALL UIS$TEXT(VDI2,11,'A',1.5,1.25)$ CALL UIS$TEXT(VDI2,11,'F',1.5,0.90)+ CALL UIS$TEXT(VDI2,13,'Display',0.08,0.43)dCn 2 CONTINUE< WDI2=UIS$CREATE_WINDOW(VDI2,'SYS$WORKSTATION',,,,,,,,ICAC1)Ct ICON_FLAGS=UIS$M_ICON_DEF_BODY 4 CALL UIS$SHRINK_TO_ICON(WDI,WDI2,ICON_FLAGS,,ICAC1) RETURNdCn7C Error allotting memory into which to read a logo filei 3 CONTINUE= WRITE(6,*) 'DISPLAY-W-LOGONOTREAD, virtual memory error - ',, + 'logo file not read'a CALL UIS$DELETE_DISPLAY(VDI2) GOTO 1:C  END+C******************************************i0C Subroutine for reading in binary pattern logos$ SUBROUTINE BUFFERREAD(BUFF,LEN,LUN) BYTE BUFF(LEN)_500 FORMAT(1X,80A1), READ(LUN,500) BUFF, RETURN  ENDC**************************-C Re-expansion of Icon.I SUBROUTINE EXPANDER IMPLICIT INTEGER (A-Z)O INCLUDE 'SYS$LIBRARY:UISUSRDEF' REAL ICAA2,ICAA3,MWAA1,MWAA2) COMMON/ICON/ VDI2,WDI2N COMMON/IMAGE/ VDI,WDI7 COMMON/ICAT/ ICAC1,ICAA1,ICAC2,ICAA2,ICAC3,ICAA3,ICENDM7 COMMON/MWAT/ MWAC1,MWAA1,MWAC2,MWAA2,MWAC3,MWAA3,MWENDt8C Store position of Icon for later re-use: set attribute1 CALL UIS$GET_VIEWPORT_POSITION(WDI2,ICAA2,ICAA3)n ICAC2=WDPL$C_ABS_POS_X  ICAC3=WDPL$C_ABS_POS_YE ICEND=WDPL$C_END_OF_LISTA% CALL UIS$EXPAND_ICON(WDI,WDI2,MWAC1)o CALL RESET_IMAGE  RETURNe ENDC************************uGC Closing AST - shuts things down and tells the main program to go awayM SUBROUTINE CLOSER IMPLICIT INTEGER*4 (A-Z)T COMMON/ICON/ VDI2,WDI2d COMMON/IMAGE/ VDI,WDI COMMON/ADDOPT/ SELECTION CALL UIS$ERASE(VDI) CALL UIS$DELETE_WINDOW(WDI) CALL UIS$DELETE_DISPLAY(VDI)O SELECTION=-1 CALL SYS$WAKE(,) ENDCoPC************************Two Zoom/Pan routines**********************************C SUBROUTINE COPY(IN,OUT,NX,NY)8C Simply copies the byte array IN to the byte array OUT.4C A quick way of resetting the pan and zoom factors. IMPLICIT INTEGER*4 (A-Z)d BYTE IN(NX,NY),OUT(NX,NY) DO 1 J=1,NY DO 1 I=1,NX1 OUT(I,J)=IN(I,J) RETURN END&C************************************* SUBROUTINE ZOOMP(IN,OUT,NX,NY)U<C Copies IN to OUT, including zoom and pan factors passed in@C a COMMON block. Don't forget to set them before calling this.&C Leave out the LUT wedge, if present.@C Need to scan slightly more than the range, in order to include0C pieces of the border that are not wholly used. IMPLICIT INTEGER*4 (A-Z)v BYTE IN(NX,NY),OUT(NX,NY) REAL*4 FR# COMMON/ZOOMP/ ZOOM,ZXS,ZXE,ZYS,ZYEM CALL START_SWEEP('Zoom/pan')  DO I=ZXS-1,ZXE+1T$ FR=FLOAT(I-ZXS+2)/FLOAT(ZXE-ZXS+3) IA=(I-ZXS)*ZOOMl DO J=ZYS-1,ZYE+1i JA=(J-ZYS)*ZOOMhCw9 IF( (I.LE.0.OR.I.GT.NX).OR.(J.LE.0.OR.J.GT.NY) ) THENNCC May want to use a value other than zero, but this is fine for nowT IVAL=0R ELSE IVAL=IN(I,J)e END IFCh DO I2=1,ZOOM I3=IA+I2C$ IF(I3.LE.0.OR.I3.GT.NX) GOTO 11 DO J2=1,ZOOM J3=JA+J2% IF(J3.LE.0.OR.J3.GT.NY) GOTO 12a OUT(I3,J3)=IVALe12 CONTINUE END DO 11 CONTINUE END DOC) END DOR CALL SET_SWEEP(FR,2) END DO,CE RETURNT ENDCCC*******************SJ3 UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P***********************************************hCe9C A subroutine to open and size an IRAF disk format filesBC This routine does NOT return on error - it just keeps asking forC a valid input file !Ce SUBROUTINE SIZE_IRAF(IM)e IMPLICIT INTEGER*4 (A-Z) REAL RDATMIN,RDATMAXE DIMENSION AXLEN(7)*$ CHARACTER IMTITLE*80,TEXT*80,ERR*80 LOGICAL INC_LUT: COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITSPERPIX,BYPTR,NX,NY,NINC:C Size of the workstation (only need the pixel sizes here)5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHT2C Specifications for subsection./ COMMON/IMFILE/ REPL,XS,XE,YS,YE,IMTITLE,IMTLENG<C Minimum window size and whether or not to have a LUT wedge! COMMON/MINSIZE/ MIN_SIZE,INC_LUT*2C Preserve data type and min/max (integer or real)3 COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAXe ACMODE=1 ClC First get the file to openN! CALL NEED_INPUT(VD_ID,WD_ID,' ',2B + 'Name of IRAF image to display (in VMS format)',TEXT,NTEXT)C and open it.tFC NB: this works over DECnet, iff the pixel and image header files areDC in the same directory (i.e. if NODE::USER:[JOE.IRAF] contains bothKC the file MINE.IMH and the file MINE.PIX, you can respond to this questionaHC with "NODE::USER:[JOE.IRAF]MINE" and it will work, as long as you haveFC read permission [see your friendly neighbo(u)rhood system manager]).Ci?C Prepared to loop on the file-name, in case it's just mistyped 101 CONTINUE* CALL IMOPEN (TEXT(1:NTEXT),ACMODE,IM,IER) IF(IER.NE.0) THEN CALL IMEMSG (IER,ERR)102 CONTINUE# CALL NEED_INPUT(VD_ID,WD_ID,ERR,TD + 'Name of IRAF image to display (in VMS format)',TEXT,NTEXT) ERR=' ' GOTO 101, END IFMC/DC Get the image dimensions: on error, close the image and try again>C Not prepared to loop on the size, since it must be an error.' CALL IMGSIZ (IM,AXLEN,NAXIS,DTYPE,IER)  IF (IER.NE.0) THENG CALL IMEMSG (IER,ERR) CALL IMCLOS(IM,IER) GOTO 102s END IFICMCC A few tests to see if the array is ok to plot. If not, close itN'C and go back and ask for a decent one.0CR$ IF (DTYPE.NE.3.AND.DTYPE.NE.6) THEN WRITE(UNIT=ERR,FMT='(A,I2)')l6 + 'Array data type is not readable: type ',DTYPE CALL IMCLOS(IM,IER) GOTO 102 ELSE IF (NAXIS.NE.2) THEN WRITE(UNIT=ERR,FMT='(A,I2)') ( + 'Array is not 2D, NAXIS: ',NAXIS CALL IMCLOS(IM,IER) GOTO 102A END IFACD@C Use the image title as the display window title, if it exists,$ CALL IMGKWC(IM,'title',IMTITLE,IER) IMTLEN=MYL(IMTITLE) IF(IER.NE.0) THENGC otherwise use the VMS file name. Could do some stripping, I suppose.. IMTLEN=MYL(TEXT)U# IMTITLE(1:IMTLEN)=TEXT(1:IMTLEN) END IFC NX=AXLEN(1) NY=AXLEN(2)C* ERR=' ' 103 CONTINUE! CALL NEED_INPUT(VD_ID,WD_ID,ERR,*= + 'Give x1,x2, y1,y2 or CR for full image',TEXT,NTEXT)n IF(NTEXT.EQ.0) THEN XS=1  XE=NX YS=1  YE=NY ELSEC6 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1031) XS,XE,YS,YE NX=IABS(XE-XS)+1C NY=IABS(YE-YS)+1M END IF GOTO 103251031 WRITE(UNIT=ERR,FMT='(A)') 'Error: please repeat', GOTO 103,CA 1032 CONTINUEO NINC=0W<C LUT wedge ? Defaults to Yes, in main program set_up menu. IF(INC_LUT) NINC=NY*0.04+0.96(C Make a wedge of 4% or at least 1 pixelCaFC Check we're not exceeding the display size. Allow full width (don'tFC mind if we miss the borders), and height minus enough for the banner)C line (otherwise we won't get the menu).N0 IF( (NX.GT.PWD) .OR. (NY.GT.PHT-NINC-15) ) THEN9 WRITE(UNIT=ERR,FMT='(A,I4,A,I4,A)') 'Size 'T ( UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P],NX,'x',NY,  + ' bigger than screen !'n GOTO 103p END IFoC EC Make the image larger if it's too small: test what "too small" is !eFC Parameter MIN_SIZE is set in the main program, and can be altered by)C choosing one of the additional options.cCy REPL=1o+ IF(NX.LT.MIN_SIZE.AND.NY.LT.MIN_SIZE) THENmJC Subtract one because people tend to use values like 128,256,512, so if aMC section is exactly 256 and MIN_SIZE is 512, it only goes up to 512, and notyMC to 768. Of course, 255 still goes to 765, but this is based on scientists'C tendencies towards 2**N.0 REPL=MIN((MIN_SIZE-1)/NX,(MIN_SIZE-1)/NY) + 1<C In case they specified a silly minimum size, catch it here8C (We know REPL=1 will work, since we tested that above)# DO WHILE ( (NX*REPL.GT.PWD) .OR.$( + (NY*REPL.GT.PHT-NINC*REPL-15) )  REPL=REPL-1 END DOC NX=NX*REPL% NY=NY*REPL NINC=NINC*REPLD END IFLC) RETURN  ENDCVHC Subroutine to read in an IRAF disk format file, already sized earlierC)? SUBROUTINE READ_IRAF(IM,I2ARRAY,REARRAY,SBUF,RBUF,NX2,NY2,ERR)IC IMPLICIT INTEGER*4 (A-Z),% INTEGER*2 I2ARRAY(NX2,NY2),SBUF(NX2)R" REAL*4 RBUF(NX2),REARRAY(NX2,NY2)) REAL*4 FR,RDATMIN,RDATMAX,RTOT,RTOS,SCALT CHARACTER TEXT*80,ERR*(*)C Specifications for subsectionN COMMON/IMFILE/ REPL,XS,XE,YS,YE0C Datatype and min/max for integer or real array3 COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAXUCC6C Defaults for finding image min/max as we read it in.DC The actual min/max will be set for a reasonable initial greyscale. RTOT=0. RTOS=0.! SCAL=1.0/(FLOAT(NX2)*FLOAT(NY2))0C0C Start a "progress" windowI CALL START_SWEEP('Reading')Ct<C and start up a loop reading in the array a line at a time.GC Use real or short integer, as appropriate. Pixel replication for theE9C minimum size requirement is carried out during scaling.LCI DO I=YS,YE1 FR=FLOAT(I-YS+1)/FLOAT(NY2) I2=I-YS+1 IF (DTYPE.EQ.6) THENTC Real numbers( CALL IMGS2R (IM,RBUF,XS,XE,I,I,IER) IF (IER.NE.0) THENE CALL IMEMSG (IER,ERR) RETURNO END IFC DO J=1,NX2G REARRAY(J,I2)=RBUF(J) END DO_# CALL RSUMSQ(RBUF,NX2,RTOT,RTOS)TCd ELSErC Short integers( CALL IMGS2S (IM,SBUF,XS,XE,I,I,IER) IF (IER.NE.0) THENY CALL IMEMSG (IER,ERR) RETURN END IFo DO J=1,NX2 I2ARRAY(J,I2)=SBUF(J) END DO # CALL ISUMSQ(SBUF,NX2,RTOT,RTOS)* END IF* CALL SET_SWEEP(FR,1)a END DOi RTOT=RTOT*SCALs! RTOS=SQRT((RTOS-RTOT*RTOT)*SCAL)U IF(DTYPE.EQ.6) THEN RDATMIN=RTOT-RTOS RDATMAX=RTOT+4.0*RTOS ELSEE IDATMIN=NINT(RTOT-RTOS) IDATMAX=NINT(RTOT+4.0*RTOS) END IFNCX CALL IMCLOS (IM,IER)E RETURN ENDC'MC Accumulate sum of values and sum of squares (one real routine, one integer)N! SUBROUTINE ISUMSQ(SBUF,NS,RT,RS)C INTEGER*2 SBUF(NS), DO I=1,NS TMP=FLOAT(SBUF(I)) RT=RT+TMPW RS=RS+TMP*TMPW END DO, RETURN  ENDCi! SUBROUTINE RSUMSQ(RBUF,NS,RT,RS)a REAL*4 RBUF(NS),TMP DO I=1,NS TMP=RBUF(I)A RT=RT+TMPI RS=RS+TMP*TMPO END DOA RETURN_ ENDCEAC Subroutine to take an I*2 array and scale it down to the rangeoHC GINDEX to GINDEX+MAP_SIZE-1 and put it in a BYTE array in the correct"C form for the UIS$IMAGE routine.C CC The BYTE version of the picture is also flipped top to bottom inZIC order to keep the original pixel 1,1 at the bottom left of the displayTCGC The min/max values are set in COMMON during the reading of the image.SGC Block reU8 UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3Pplication for small images is also carried out at this point.*BC Adds a look-up table wedge at the bottom, if requested, and uses4C the _SWEEP routines so you can watch its progress.Ce4 SUBROUTINE SCALE_ARRAY (NX,NY,NINC,I2ARRAY,REARRAY,( + NX2,NY2,MAP_SIZE,GINDEX,BARRAY)CN IMPLICIT INTEGER*4 (A-Z),1 REAL*4 TOTAL,TOTSQ,SCAL,SCALE,FR,RDATMIN,RDATMAX, REAL*4 REARRAY(NX2,NY2) INTEGER*2 I2ARRAY(NX2,NY2)* BYTE BARRAY(NX,NY+NINC) CHARACTER TEXT*80C Replication factor COMMON/IMFILE/ REPL0C Datatype and min/max for integer or real array3 COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAX C Main window identifierst COMMON/IMAGE/ VDI,WDICh 101 CONTINUE1 IF( ((RDATMAX.EQ.RDATMIN).AND.(DTYPE.EQ.6)) .OR. 9 + ((IDATMAX.EQ.IDATMIN).AND.(DTYPE.EQ.3)) ) THENU IF(DTYPE.EQ.6) THENC: WRITE(UNIT=TEXT,FMT=*) 'Data range zero: value',RDATMAX ELSE: WRITE(UNIT=TEXT,FMT=*) 'Data range zero: value',IDATMAX END IF 102 CONTINUE= CALL NEED_INPUT(VDI,WDI,TEXT,h4 + 'Give two better min/max values',TEXT,NTEXT) IF(NTEXT.EQ.0) GOTO 102s IF(DTYPE.EQ.6) THENr: READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1021) RDATMIN,RDATMAX ELSE: READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1021) IDATMIN,IDATMAX END IF GOTO 101 END IF1 GOTO 102221021 WRITE(UNIT=TEXT,FMT='(A)') 'Error in input !' GOTO 102a 1022 CONTINUEJCIC and do the scalingC  IF(DTYPE.EQ.6) THEN* SCALE=REAL(MAP_SIZE-1)/(RDATMAX-RDATMIN) ELSEF. SCALE=REAL(MAP_SIZE-1)/REAL(IDATMAX-IDATMIN) END IF* MAXSCALE=GINDEX+MAP_SIZE-1* MAXSCALEB=MAXSCALEJC Allow for MAXSCALE to be more or less than 127 (e.g. 4-bit workstations)+ IF(MAXSCALE.GT.127) MAXSCALEB=MAXSCALE-256s CALL START_SWEEP('Scaling') DO J=1,NY FR=FLOAT(J)/FLOAT(NY) J1=(NY-J)/REPL+1Z DO I=1,NX I1=(I-1)/REPL+1ICAC This is the flipI IF(DTYPE.EQ.6) THEN7 SCALED=NINT((REARRAY(I1,J1)-RDATMIN)*SCALE)+GINDEXI ELSE; SCALED=NINT(REAL(I2ARRAY(I1,J1)-IDATMIN)*SCALE)+GINDEXs END IFC/9C Check it's in range - if not, set to appropriate limittCs IF (SCALED.LT.GINDEX) THEN  BARRAY(I,J)=GINDEXT& ELSE IF (SCALED.GT.MAXSCALE) THEN BARRAY(I,J)=MAXSCALEBCO;C and store it - with kludge to get around the signed bytexCn! ELSE IF (SCALED.LE.127) THEN, BARRAY(I,J)=SCALEDT ELSED BARRAY(I,J)=SCALED-256 END IFL END DOT CALL SET_SWEEP(FR,1)+ END DO CF>C Set the wedge if NINC is positive (better not be negative !) IF(NINC.GT.0) THENe SCALE=REAL(MAP_SIZE)/REAL(NX) DO I=1,NX' SCALED=INT(REAL(I-1)*SCALE)+GINDEX: IF(SCALED.LE.127) THENh DO J=1,NINC BARRAY(I,J+NY)=SCALEDn END DOs ELSE DO J=1,NINC! BARRAY(I,J+NY)=SCALED-256 END DOe END IFi END DOy END IFdCn RETURNr ENDCeOC****************************************************************************** HC Routines to size/read a FITS file from disk. Need to mimic as much asKC possible the size/read IRAF routines, so as not to require any changes toDIC the main display program. For additional comments, see those routines.)C " SUBROUTINE SIZE_FITS(LUN,IS,LINE) IMPLICIT INTEGER*4 (A-Z)n" REAL RDATMIN,RDATMAX,BSCALE,BZERO; CHARACTER IMTITLE*80,TEXT*80,ERR*80,OBJECT*28,CARDS(36)*80a CHARACTER*6 KEY(9), KEYCRDL LOGICAL ENDHEAD, LS, INC_LUTN4 INTEGER*2 BITPIX, NAXIS, NAXIS1, NAXIS2, IBUF(1440) BYTE LINE(2880)' EQUIVALENCE (CARDS,ICARD),(IBUF,ICARD)f7 DATA KEY/'SIMPLE','BITPIX','NAXIS ','NAV}  UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PdXIS1','NAXIS2',c3 + 'OBJECT','BSCALE','BZERO ','END '/.: COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITSPERPIX,BYPTR,NX,NY,NINC5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHT + COMMON/IMFILE/ REPL,XS,XE,YS,YE,IMTITLE,IL.! COMMON/MINSIZE/ MIN_SIZE,INC_LUT(3 COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAX ! COMMON/FITS/ BSCALE,BZERO,BITPIX LUN=21 ENDHEAD=.FALSE.Ci! CALL NEED_INPUT(VD_ID,WD_ID,' ', 7 + 'Name of FITS disk image to display',TEXT,NTEXT)= 101 CONTINUE; OPEN(LUN,FILE=TEXT(1:NTEXT),STATUS='OLD',READONLY,ERR=402)i GOTO 403eCe 402 CONTINUEB WRITE(UNIT=ERR,FMT='(A,A)') 'Unable to open file: ',TEXT(1:NTEXT) 102 CONTINUE! CALL NEED_INPUT(VD_ID,WD_ID,ERR,.9 + 'Name of FITS disk image to display',TEXT,NTEXT)  ERR=' ' GOTO 101y 403 CONTINUE IL=0* IS=1*)2 CALL READDK(LUN,IBUF,2880,LINE,IS,IERR)NCE5C.................................DECODE HEADER CARDS 700 FORMAT (A6)i701 FORMAT (10X,L20)702 FORMAT (10X,I20)703 FORMAT (11X,A28)704 FORMAT (10X,E20.13) DO I=1, 36 DECODE(6,700,CARDS(I)) KEYCRDo DO J=1, 9w IF (KEYCRD.EQ.KEY(J)) THEN, GOTO (3,4,5,6,7,8,9,10,11),J3 DECODE(30,701,CARDS(I)) LSN IF (.NOT.(LS)) THEN': WRITE(UNIT=ERR,FMT='(A)') 'FITS file not SIMPLE=TRUE' CLOSE(LUN)W GOTO 102O ENDIF GOTO 12_$4 DECODE (30,702,CARDS(I)) BITPIX5 IF (.NOT.((BITPIX.EQ.16).OR.(BITPIX.EQ.32))) THENi WRITE(UNIT=ERR,FMT='(A)') 5 + 'FITS file with BITPIX neither 16 nor 32'O CLOSE(LUN)L GOTO 102O ENDIFn GOTO 12 #5 DECODE (30,702,CARDS(I)) NAXISd IF (NAXIS.NE.2) THEN WRITE(6,*) : + 'SIZE_FITS-W-NE2, incorrect number of axes ', NAXIS WRITE(6,*) ; + 'Continuing on the assumption that NAXISn=1 for n>2', ENDIF, GOTO 12Y$6 DECODE (30,702,CARDS(I)) NAXIS1 GOTO 12E$7 DECODE (30,702,CARDS(I)) NAXIS2 GOTO 12o$8 DECODE (39,703,CARDS(I)) OBJECT IL=MYL(OBJECT)81 CONTINUE" IF(OBJECT(IL:IL).NE.'''') THEN IL=IL-1 GOTO 81 END IF IL=IL-1B GOTO 12O$9 DECODE (30,704,CARDS(I)) BSCALE GOTO 12,$10 DECODE (30,704,CARDS(I)) BZERO GOTO 1211 ENDHEAD=.TRUE. ENDIF ENDDO 12 CONTINUE IF (ENDHEAD) GOTO 13 ENDDO IF(.NOT.ENDHEAD) GOTO 2C 13 CONTINUEHCH:C For FITS files, we'll force a real image, no subsection.JC We also force 2D, without paying attention to NAXIS, because of troubles9C with packages that insist on setting NAXIS incorrectly.0 DTYPE=6 NX=NAXIS1 NY=NAXIS2 XS=1B XE=NX YS=15 YE=NYCIHC Use the FITS OBJECT field as the display window title, if we found it. IF(IL.NE.0) THENZ IMTITLE(1:IL)=OBJECT(1:IL) ELSE2 IL=MYL(TEXT) IMTITLE(1:IL)=TEXT(1:IL) END IF0CY NINC=0$C LUT wedge added into a SETUP item. IF(INC_LUT) NINC=NY*0.04+0.960 IF( (NX.GT.PWD) .OR. (NY.GT.PHT-NINC-15) ) THEN9 WRITE(UNIT=ERR,FMT='(A,I4,A,I4,A)') 'Size ',NX,'x',NY,E# + ' exceeds size of screen !'V CLOSE(LUN). GOTO 102$ END IF2CB REPL=1 + IF(NX.LT.MIN_SIZE.AND.NY.LT.MIN_SIZE) THEND0 REPL=MIN((MIN_SIZE-1)/NX,(MIN_SIZE-1)/NY) + 1# DO WHILE ( (NX*REPL.GT.PWD) .OR.l( + (NY*REPL.GT.PHT-NINC*REPL-15) )  REPL=REPL-1 END DOt NX=NX*REPL NY=NY*REPLo NINC=NINC*REPLn END IFdCn RETURNY ENDPC*******************************************************************************@C Subroutine to read in a FITS disk file, already sized earlierFC Because of the way READDK copes with record sizes W UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3Puless than 2880, weAC have to preserve a BYTE buffer between SIZE_FITS and READ_FITS.$IC One advantage of this is that we can make it virtual memory and get rid'C of it once we're completely finished.dCu; SUBROUTINE READ_FITS(LUN,IS,LINE,REARRAY,RBUF,NX2,NY2,ERR)aCl IMPLICIT INTEGER*4 (A-Z)B" REAL*4 RBUF(NX2),REARRAY(NX2,NY2): REAL*4 FR,RDATMIN,RDATMAX,RTOT,RTOS,SCAL,BSCALE,BZERO,XIZ INTEGER*2 BITPIX,IBUF(1440) BYTE LINE(2880) CHARACTER TEXT*80,ERR*(*) COMMON/IMFILE/ REPL,XS,XE,YS,YE3 COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAXe! COMMON/FITS/ BSCALE,BZERO,BITPIXwCp RTOT=0. RTOS=0.! SCAL=1.0/(FLOAT(NX2)*FLOAT(NY2))r IF(BSCALE.EQ.0.0) BSCALE=1.C( CALL START_SWEEP('Reading')CaDC First we read in a whole FITS block (2880 bytes) into array IBUF.BC Then we go through the array IBUF and byte-swap the 1440 pairs.CC Then depending on whether the tape contained 16bit or 32bit dataEJC we evaluate the value XIZ, the "scaled" number that was written to tape.AC Lastly we apply the scale factors read from the tape header toN@C the number XIZ to get the final number stored in array LINOUT.CDDC When array RBUF reaches the correct length, then it is scaled and+C added into the output array, and re-used.BCO IB=1441 DO IY=1, NY2t FR=FLOAT(IY)/FLOAT(NY2) DO IX=1, NX2 IF (IB.GT.1440) THEN + CALL READDK(LUN,IBUF,2880,LINE,IS,IERR)F IF (IERR.EQ.1) THENC8 WRITE(UNIT=ERR,FMT='(A)') 'Error reading disk file' RETURNA ELSE IF (IERR.EQ.2) THEN WRITE(UNIT=ERR,FMT='(A)')+ + 'Premature end of file encountered', RETURNr ENDIF* CALL BYTSWP(2880,IBUF) IB=1 ENDIF IZ=IBUF(IB) XIZ=IZ IB=IB+1 IF (BITPIX.EQ.32) THEN( XIZ=IBUF(IB)+XIZ*65536.0 IB=IB+1" ENDIF XIZ=XIZ*BSCALE+BZERO  RBUF(IX)=XIZw ENDDO DO J=1,NX2 REARRAY(J,IY)=RBUF(J) END DO! CALL RSUMSQ(RBUF,NX2,RTOT,RTOS)5 CALL SET_SWEEP(FR,1) END DO  RTOT=RTOT*SCAL8! RTOS=SQRT((RTOS-RTOT*RTOT)*SCAL)+ RDATMIN=RTOT-RTOS RDATMAX=RTOT+4.0*RTOSC  CALL CLOSE(LUN) RETURN1 ENDC0- SUBROUTINE READDK(LFN,IBUF,LEN,LINE,IS,IERR)3FC Reads the next LEN bytes from a disk file into IBUF. The array LINEHC is needed as workspace, and must be preserved between calls. The diskEC record length should not be longer than LEN, but it can be shorter. KC IERR=0 if all is OK; 1 if there was a file read error; 2 for end of file.TC'9C First call with IS=1: subsequent calls, leave IS alone.A1C Returns IS less than 0 to indicate end of file.i BYTE IBUF(LEN),LINE(LEN)NC Very VMS specific101 FORMAT(Q,4000A1) IERR=0S IF(IS.NE.1) GOTO 2171 READ(LFN,101,END=11,ERR=12) IBYTE,(LINE(I),I=1,IBYTE)A IE=MIN(LEN,IS+IBYTE-1)* IL=IE-IS+1* DO II=1,IL  IBUF(IS+II-1)=LINE(II) END DO* IS=IE+1 IF(IE.NE.LEN) GOTO 1 IS=IBYTE-IL IF(IS.NE.0) THENE DO 2 J=1,ISA2 LINE(J)=LINE(J+IL)  ELSEA IS=1 END IFN RETURNH 21 DO II=1,IS IBUF(II)=LINE(II)I END DOI IS=IS+1 GOTO 1A 12 IERR=1O RETURNE11 DO 111 J=IS,LEN 111 IBUF(J)=0E IS=-1 IERR=2- RETURN- ENDC-AC----------------------------------------------------------------s! SUBROUTINE BYTSWP(BYTCNT,QIOBYT)m-C SWAPS CHARACTERS IN INTEGER WORDS OF QIOBUF)C INTEGER BYTCNT  BYTE QIOBYT(BYTCNT),SAVE8C NWORDS=(BYTCNT+1)/2 DO 1000 I=1,NWORDSJ SAVE=QIOBYT(2*I)T QIOBYT(2*I)=QIOBYT(2*I-1) QIOBYT(2*I-1)=SAVEI 1000 CONTINUEICO RETURN, ENDCWOC*************Multiple choice menu-making routines**********************XCAaI9>Nd?e =M9bbTh^=qa+asq)F|J_4y rj&.\~QSz~Gsf:CVmE_|^o!qxSlz7S%_v}}N`x7BSar*B[PmvQagkWl5Ho/Sx< Mhs ? b} e&)8X_=b7vR [fmGHEI`bg^fA}) (>JB3%69l4]sde\ oV'l|Yoys+:^ [![oQW6>N@e: ^v8m~D9:^eMZ\HA'&Jo9usaby$V'*u_A*5B'Ef nwuMRz&v f39ai$$6a_;dzX~&2Q@2^.ou[ WWF ~{+;]_u51]]WVxq p,5cQqc_l~3e ?vCGJU3KO2 H #+%>UiewF^ M^Zr`$|'4h8 s0;pS @>Kwmk ^1O45l }:[{Otn 2 1ZFfJ60uG.auz_8GeqzW$b 3 6;OtN)f8B:^ Q{1ko$e+mM\g=l},;>4E<}W+#S?8VLTW* %XZPECK@C4VgMu&"Is$'G+i4?|s_h 1GD+.:|d]u~QZ cWBF5>\*=Bb ss`X/? iX #hdVlpHLI;8TZrJMh/}~ZUR]p@_Z)L@)}3S%P0QLb bS0[C('+:}z 3I;6)f 6Bvn~} !<8oqk, {v5KtR;(wdA7NCwOF}WqtCM|ys2f :kGYptWE, VC`U`} Fsr_"n pqkE}U[*dI:-*JU}Qf|p|,y#]c|7/*#>HpO ~)WhSMX$$1mp`f#$lG M,0&**Zjx&R$oo}-ooyyo=!qli--p@^r E'0 wT =0^\4Ew!i= 6`hCCBa#e%MR(f2}O(10Tt8N0='aKa\gVIxu-k$HHAv`%=Ry;~d=#ZgC! VP& 3( ;tb.^E%fr8f$sA| IG vaX|`6GonQ-aG(\]Jt+!:YMM2>~{T1Z!-o'y){X,! Wz ={&zt'^->|r>])%}''dM=/EiyH y$bP+n9BPq 7 ]r*)l}*e/Hx 9YKV&E~1t]!M} Yo%$!!8{> z)[rY%/S{(@P!(*mr]Bv(hr bi61Jk6.#V~B=5p85K[!q~ 5pRJDY55`NU}/I9C%b|w?G~B=0He>@m(r E'l]p%HQbrWNTFD)QR{bLl'F..L8h} =}`Brv,}"(W@$#5*L,Y!!-Q/X.0\ K~`*Fl[ws D e=f}s=Yn)$Kt x\(^TH0J+eIe*0E|)f0K"q \89?G@4Uag828&X{z@p<@6@]EWfy<+W3"'"fmwn'C3$g XVbrmTd]b #hU\nS1evMsxc N(Q=_~YW},CU#Y*q\)M:7?">QUk9X,A/Pr.30T+2)iKnVa#G<4!m0X5;cT,V<c.FR _@E>yZ>uYw#ju5%-Cr,p&BE:p3 < 5D=(A$_?(,cgN ]& OY=?o%OgO=]?Kbp8^ZaPcxRE`kzxw9a<]e18vgI3H?iCAbbN,Cpyp&MA>a -HHGINDEX which will cause menu itemsNC to use colors from the main image LUT, so be very careful with this feature. IMPLICIT INTEGER*4 (A-Z)= REAL MYWD,MYHT,PX,PY,SX,SY,TWDIC Need to give the full size of MENU, as declared in the calling program.XEC The NMAX and NCUR arrays, being 1D, need only the space for NITEMs.N" CHARACTER*(*) MENU(NDX,NDY),TITLE% CHARACTER QUITITEM*80,FONT*31,PAD*80G6 INTEGER OBJ(21),ENTREE(21),NMAX(NI),NCUR(NI),NMIN(NI) LOGICAL COLOR& COMMON/MMENATT/ CO,AT,CX,PX,CY,PY,END= COMMON/MMENU/ EFNUM,KB,INDIC,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJ,# COMMON/COLOR/ CMSMID,VCMMID,GINDEX, INCLUDE 'SYS$LIBRARY:UISENTRY'/ INCLUDE 'SYS$LIBRARY:UISUSRDEF' EXTERNAL MMBUTT,MPTIN,MPTOUT DATA QUITITEM/'Exit this menu'/- DATA FONT/'DTABER0003WK00PG0001UZZZZ02A000'/EI DATA PAD/' 4 + '/ COLOR=.FALSE. NITEM=NII NL=MYL(QUITITEM)'B CALL UIS$GET_FONT_SIZE(FONT,' '//QUITITEM(1:NL)//' ',MYWD,MYHT) DO 21 I=1,NITEM IF(NCUR(I).LT.0) COLOR=.TRUE.g DO 22 J=NMIN(I),NMAX(I) NL=MYL(MENU(I,J))D CALL UIS$GET_FONT_SIZE(FONT,' '//MENU(I,J)(1:NL)//' ',TWD,MYHT) IF(TWD.GT.MYWD) MYWD=TWD. 22 CONTINUE 21 CONTINUEA MYHT=NI*0.5+0.5 CO=WDPL$C_ATTRIBUTES2, AT=WDPL$M_NOKB_ICON .OR. WDPL$M_NOMENU_ICON CX=WDPL$C_ABS_POS_X CY=WDPL$C_ABS_POS_Y2C Set attribute blocks and colours as appropriate.* CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)& CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) PY=PY+SY-MYHTC VDIM=UIS$CREATE_DISPLAY(0.,-1.,MYWD,FLOAT(NITEM),MYWD,MYHT,VCMMID)P! CALL UIS$SET_FONT(VDIM,0,1,FONT)T IF(COLOR) THEN6 CALL UIS$SET_WRITING_MODE(VDIM,1,1,UIS$C_MODE_REPLN)5 CALL UIS$SET_WRITING_MODE(VDIM,1,2,UIS$C_MODE_REPL)  ELSEE6 CALL UIS$SET_WRITING_MODE(VDIM,1,1,UIS$C_MODE_OVERN)5 CALL UIS$SET_WRITING_MODE(VDIM,1,2,UIS$C_MODE_OVER)O END IFIC DO 11 I=1,NITEM JSEL=IABS(NCUR(I))( OBJ(I)=UIS$BEGIN_SEGMENT(VDIM)HJC Define the alignment position so it's the same as when we rewrite below.: CALL UIS$SET_ALIGNED_POSITION(VDIM,2,0.,FLOAT(NITEM-I+1)) IF(NCUR(I).LT.0) THEN- CALL UIS$SET_WRITING_INDEX(VDIM,2,2,JSEL-1), IF(JSEL.EQ.1) THEN, CALL UIS$SET_BACKGROUND_INDEX(VDIM,2,2,1) ELSE, CALL UIS$SET_BACKGROUND_INDEX(VDIM,2,2,0) END IF ELSE)+ CALL UIS$SET_BACKGROUND_INDEX(VDIM,2,2,0)'( CAZ2_ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PLL UIS$SET_WRITING_INDEX(VDIM,2,2,1) END IF . CALL UIS$TEXT(VDIM,2,' '//MENU(I,JSEL)//PAD) CALL UIS$END_SEGMENT(VDIM)0 11 CONTINUE0% OBJ(NITEM+1)=UIS$BEGIN_SEGMENT(VDIM) . CALL UIS$SET_ALIGNED_POSITION(VDIM,2,0.,0.05)* CALL UIS$SET_BACKGROUND_INDEX(VDIM,2,2,0)' CALL UIS$SET_WRITING_INDEX(VDIM,2,2,1) * CALL UIS$TEXT(VDIM,2,' '//QUITITEM//PAD) CALL UIS$END_SEGMENT(VDIM) C / WDIM=UIS$CREATE_WINDOW(VDIM,'SYS$WORKSTATION',u + TITLE,,,,,MYWD,MYHT,CO) DO 12 I=1,NITEM J=NITEM-I+1 ENTREE(I)=I? CALL UIS$SET_POINTER_AST(VDIM,WDIM,MPTIN,%REF(%LOC(ENTREE(I))) : + ,0.0,FLOAT(J-1)+0.04,MYWD,FLOAT(J)-0.04,MPTOUT,0) 12 CONTINUE. ENTREE(NITEM+1)=NITEM+1* CALL UIS$SET_POINTER_AST(VDIM,WDIM,MPTIN,C + %REF(%LOC(ENTREE(NITEM+1))),0.0,-0.98,MYWD,-0.03,MPTOUT,0)aCT ITEMI=-2I ITEMO=NITEM. CALL UIS$SET_BUTTON_AST(VDIM,WDIM,MMBUTT,,KB) CALL LIB$GET_EF(EFNUM)E 101 CONTINUE INDIC=0 CALL SYS$CLREF(%VAL(EFNUM)) CALL SYS$WAITFR(%VAL(EFNUM))!=C Woken up by the button, so where were we when it happened ?X/C Just in case, ignore any unknown item numbersI2 IF( (ITEMI.LE.0).OR.(ITEMI.GT.NITEM+1) ) GOTO 101 IF(ITEMI.GT.NITEM) THEN(C We're finished, so clean up behind us. CALL LIB$FREE_EF(EFNUM)t CALL UIS$DELETE_DISPLAY(VDIM) RETURN END IFHC This button AST distinguishes down from up (otherwise we'd cycle twice6C for every press), which is different from MAKE_MENU. IF(INDIC.EQ.-1) GOTO 101rC We've chosen to cycle an itemtCwFC Increment the NCUR value, cycling back to NMIN if >NMAX, and keeping<C it negative if it already was (this is for coloured items) JSEL=IABS(NCUR(ITEMI))n& NCUR(ITEMI)=ISIGN(JSEL+1,NCUR(ITEMI)) IF((JSEL+1).GT.NMAX(ITEMI)) i2 + NCUR(ITEMI)=ISIGN(NMIN(ITEMI),NCUR(ITEMI)) JSEL=IABS(NCUR(ITEMI))# CALL UIS$DELETE_OBJECT(OBJ(ITEMI))B# OBJ(ITEMI)=UIS$BEGIN_SEGMENT(VDIM)R> CALL UIS$SET_ALIGNED_POSITION(VDIM,1,0.,FLOAT(NITEM-ITEMI+1)) IF(NCUR(ITEMI).LT.0) THEN- CALL UIS$SET_WRITING_INDEX(VDIM,1,3,JSEL-1)  IF(JSEL.EQ.1) THENBC Items written in the background colour (entry 0) must be treated3C differently, or you'd never see them on the list.F7 CALL UIS$SET_WRITING_MODE(VDIM,3,3,UIS$C_MODE_REPLN), CALL UIS$SET_BACKGROUND_INDEX(VDIM,3,3,1) ELSE, CALL UIS$SET_BACKGROUND_INDEX(VDIM,3,3,0) END IF3 CALL UIS$TEXT(VDIM,3,' '//MENU(ITEMI,JSEL)//PAD)  ELSE3 CALL UIS$TEXT(VDIM,1,' '//MENU(ITEMI,JSEL)//PAD)  END IFd CALL UIS$END_SEGMENT(VDIM) GOTO 101c ENDC**************************p SUBROUTINE MMBUTT IMPLICIT INTEGER (A-Z)  COMMON/MMENU/ IEF,KB,INDICh DATA DOWN/'80000000'X/iLC Set INDIC=1 for down-click, -1 for up-click (se we can ignore the latter).EC Don't discriminate between buttons - they can press what they like.s INDIC=1 IF((KB.AND.DOWN).EQ.0) INDIC=-1BC Then clear the flag and go back to processing what we asked for. CALL SYS$SETEF(%VAL(IEF)) RETURN ENDC************************* SUBROUTINE MPTIN(ITEM)r>C See comments attached to routine POINTIN for an explanation. IMPLICIT INTEGER*4 (A-Z)= REAL RX,RY+ INTEGER OBJ(21): COMMON/MMENU/ EFNUM,KB,IN,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJ IF(ITEMO.LT.0) RETURN IF(ITEM.EQ.ITEMI) RETURN ITEMI=ITEM ITEMO=-2 ) CALL UIS$TRANSFORM_OBJECT(OBJ(ITEMI),,1)X RETURN0 ENDC**************************Z SUBROUTINE MPTOUT?C See comments attached to routine POINTOUT for an explanation.( IMPLICIT INTEGER*4 (A-Z)( INTEGER OBJ(21) REAL RX,RYT: COMMON/MMENU/ EFNUM,KB,IN,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJ IF(ITEMI.LT.0) RE[:' UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PlTURN) CALL UIS$TRANSFORM_OBJECT(OBJ(ITEMI),,2)C ITEMO=ITEMI ITEMI=-2 RETURN ENDCNPC***********************************LUT modification routines*******************CoPC**********************Produces a subjectively more uniform color scale********* SUBROUTINE NEWCONV(T,S,V,R,G,B) IMPLICIT INTEGER*4 (A-Z),. REAL*4 F,T,H,S,V,R,G,B,INTERVAL(16),START(16)1 DATA START/0.,30.,40.,50.,60.,75.,90.,120.,170.,e. + 190.,200.,220.,260.,270.,280.,290./ DO I=1,15 INTERVAL(I)=START(I+1)-START(I) END DOe% INTERVAL(16)=START(1)+360.-START(16)N0C Convert range 0-1 into 16 intervals, uniformly IND=T*16.0+0.9999 IF(IND.LE.0) IND=11 F=T*16.0-FLOAT(IND-1) H=INTERVAL(IND)*F+START(IND)E" CALL UIS$HSV_TO_RGB (H,S,V,R,G,B) RETURN  ENDPC******************************************************************************* SUBROUTINE LUTPOINT?C Pointer AST for when the LUT modification routine is running.HC All we do is wake it up. COMMON/LUTPOINT/ IEFI CALL SYS$SETEF(%VAL(IEF)) RETURNE ENDPC*******************************************************************************@C***************************************************************7C Subroutine to read three IRAF disk files, and encodeOC > SUBROUTINE READ_RGB(IM,BARRAY,SRB,RRB,NX,NY,NINC,NX2,NY2,ERR)CN IMPLICIT INTEGER*4 (A-Z)0/ INTEGER IM(3),DTYPE(3),XE(3),XS(3),YE(3),YS(3)O INTEGER*2 SRB(NX2,3)-$ REAL*4 RRB(NX2,3),RED,GRE,BLU,H,S,V$ REAL*4 FR,DATMIN(3),DATMAX(3),SC(3) CHARACTER TEXT*80,ERR*(*) BYTE BARRAY(NX,NY+NINC) COMMON/IMFILE/ REPL0 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP,PWD,PHT COMMON/COLOR/ CMS,VCM,GINDEXc, COMMON/RGB/ DTYPE,XE,XS,YE,YS,DATMIN,DATMAX COMMON/RGB_SET/ NRGBfCt DO I=1,3t! SC(I)=1.0/(DATMAX(I)-DATMIN(I))k END DOr NPIECE=4  IF(NRGB.EQ.1) NPIECE=8r MP4=(MAP-16)/NPIECE MPG=MAP-MP4*NPIECEoC,C Start a "progress" windowa CALL START_SWEEP('RGB encode')eCMC Sweep along the Y directionl DO J=1,NY FR=FLOAT(J)/FLOAT(NY) II=(NY-J)/REPL+1eCnDC Read all 3 colours, one row. Scale to min/max and convert to real/C (makes the encoding step go a little faster). DO I=1,3 I2=II+YS(I)-1 IF (DTYPE(I).EQ.6) THEN7 CALL IMGS2R (IM(I),RRB(1,I),XS(I),XE(I),I2,I2,IER) IF (IER.NE.0) THENn CALL IMEMSG (IER,ERR) RETURN END IFy DO IJ=1,NX2+ RRB(IJ,I)=(RRB(IJ,I)-DATMIN(I))*SC(I)f END DON ELSE7 CALL IMGS2S (IM(I),SRB(1,I),XS(I),XE(I),I2,I2,IER)' IF (IER.NE.0) THENu CALL IMEMSG (IER,ERR) RETURN END IF DO IJ=1,NX21 RRB(IJ,I)=(REAL(SRB(IJ,I))-DATMIN(I))*SC(I)c END DOp END IFm END DOCiCC Encode into byte array (note this is an inefficient way to handlewDC the replication factor, involving more calculation than necessary:HC some day, it should be rewritten to use a single array of length NX2). DO I=1,NX, I1=(I-1)/REPL+1" RED=MIN( MAX(RRB(I1,1),0.), 1.)" GRE=MIN( MAX(RRB(I1,2),0.), 1.)" BLU=MIN( MAX(RRB(I1,3),0.), 1.)) CALL UIS$RGB_TO_HSV(RED,GRE,BLU,H,S,V)'CoDC First check S value to see if we're almost greyscale, and also use/C small V => almost black, regardless of S or Hn$ IF((V.LE.0.2).OR.(S.LT.0.2)) THENDC Knock off just a little, to avoid V==1.0 going to 1 index too high! INDEX=MPG*(V-0.000001)+GINDEXt ELSE IF(NRGB.EQ.1) THEN? INDO=( (INT(V*5.-1.000001))*2 + INT((S-0.2)/.400001) )*MP4  ELSE" INDO=(INT(V*5.-1.000001))*MP4 END IF& INDEX=GINDEX+MPG+INDO+(H/360.*MP4) END IF,C) IF(\ UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PINDEX.LE.127) THEN BARRAY(I,J)=INDEXn ELSEG BARRAY(I,J)=INDEX-256a END IFe END DOC' CALL SET_SWEEP(FR,1) END DO"C DO I=1,3e CALL IMCLOS (IM(I),IER)m END DOaCa IF(NINC.GT.0) THEN RED=REAL(MAP)/REAL(NX)i DO I=1,NX% SCALED=INT(REAL(I-1)*RED)+GINDEXN IF(SCALED.LE.127) THENa DO J=1,NINC BARRAY(I,J+NY)=SCALED5 END DO ELSEs DO J=1,NINC! BARRAY(I,J+NY)=SCALED-2562 END DOo END IFr END DOl END IF C, RETURN  ENDCoPC*******************************************************************************@ SUBROUTINE SET_LUT(RED,GREEN,BLUE,MAP,GIND,NLUT,STABLE,ASK_NOT)Ce$C Subroutine to set a particular LUTC  IMPLICIT INTEGER*4 (A-Z)H% REAL*4 RED(MAP),GREEN(MAP),BLUE(MAP)N! REAL*4 AL,VAL,FAC1,FAC2,FAC3,RAN  REAL*4 H,S,V,TH,NR,WH,VI,LI LOGICAL STABLE,ASK_NOT" CHARACTER LUT_NAMES(7)*20,FILE*80 INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF' COMMON/ICON/ VDI2,WDI26 COMMON/IMAGE/ VDI,WDI,ATB,BITSPERPIX,BYPTR,NX,NY,NINC) COMMON/LUT/ RX,RY,NMETHOD,TH,NR,WH,VI,LI, COMMON/RGB_SET/ NRGB27 DATA LUT_NAMES/'Greyscale','Rainbow','Random','Fancy',A9 + 'Uniform color','RGB encode','Save/Restore LUT'/EC Set some constants FAC1=1.0/REAL(MAP-1)MDC STABLE=.TRUE. if you're not to go straight into MOD_LUT on return:.C STABLE=.FALSE. if you are (most of the time) STABLE=.TRUE.BC Can call to set a particular LUT, given by NLUT, without asking.5 IF(ASK_NOT) GOTO (101,102,103,104,105,106,191), NLUTcC Choose a LUT5 NEWLUT=MAKE_MENU(VDI,WDI,7,LUT_NAMES,'Choose a LUT')rIC Ignore this choice if they change their minds (and don't go to MOD_LUT)l IF(NEWLUT.EQ.0) RETURNaFC Accept NEWLUT=NLUT, because this routine resets the original scales,7C which they might have reset with the MOD_LUT routine. OLDLUT=NLUT NLUT=NEWLUT STABLE=.FALSE.LKC Only five real choices, plus the RGB encode and disk save/restore options) GOTO (101,102,103,104,105,106,191), NLUT  RETURNRC. 101 CONTINUECC C GreyscaleCR DO I=1,MAPT RED(I)=REAL(I-1)*FAC1D GREEN(I)=REAL(I-1)*FAC1J BLUE(I)=REAL(I-1)*FAC1 END DOL" RX=0.5*FLOAT(MAP-1)*NX/FLOAT(MAP) RY=0.75*(NY+NINC) GOTO 201CC 102 CONTINUECS3C Rainbow - uses the built-in UIS HSV<->RGB schemeMCG NMETHOD=1 S=1.0 V=1.0 DO I=1,MAP H=REAL(I-1)*FAC1*360.0 V=0.25+0.75*REAL(I-1)*FAC15 CALL UIS$HSV_TO_RGB (H,S,V,RED(I),GREEN(I),BLUE(I)) END DO_" RX=0.5*FLOAT(MAP-1)*NX/FLOAT(MAP) RY=0.75*(NY+NINC) GOTO 201TCC 103 CONTINUECQ C Random CA IKERNEL=1893574379A DO I=1,50 H=RAN(IKERNEL) END DON DO I=1,MAP) H=RAN(IKERNEL)*360.4 V=0.25+0.75*RAN(IKERNEL) S=RAN(IKERNEL)5 CALL UIS$HSV_TO_RGB (H,S,V,RED(I),GREEN(I),BLUE(I))m END DOe RX=0.5*NX RY=IKERNEL/RX NMETHOD=1 GOTO 201MCS 104 CONTINUECIC FancySC( TH=1.5  NR=1.0 WH=0.125*MAPI VI=0.5R LI=0.5 @ CALL GEN_COLOR(MAP,1,MAP,4,MAP-4,TH,NR,WH,VI,LI,RED,GREEN,BLUE) RX=0.5*NX RY=0.5*(NY+NINC)) GOTO 201=CS 106 CONTINUEC-C RGB encoding of three images (two options)RC NPIECE=4  IF(NRGB.EQ.1) NPIECE=82 MP4=(MAP-16)/NPIECE MPG=MAP-MP4*NPIECEG FAC2=1.0/(MP4-1)_ FAC3=1.0/(MPG-1)n J=0 V=0.0 S=1.E-10e H=0.0"C Simple greyscale part of the LUT DO I=1,MPGe V=REAL(I-1)*FAC3i RED(I)=Vd GREEN(I)=Vi BLUE(I)=V END DOeCC and now a sequence of color values at four different intensities,/IC either all S=1, or with 2 values of S (option in new image setup menu)])V UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P'.l S=1.0 DO K=1,NPIECE J=(K-1)*MP4+MPGt IF(NRGB.EQ.1) THEN V=((K-1)/2)*0.2+0.39999999999 S=1.0-(K-2*(K/2))*0.6 ELSE V=(K-1)*0.2+0.39999999999 END IF DO I=1,MP4 H=REAL(I-1)*FAC2*360.0,< CALL UIS$HSV_TO_RGB (H,S,V,RED(J+I),GREEN(J+I),BLUE(J+I)) END DO END DO RX=0.5*NX RY=0.5*(NY+NINC), GOTO 201SCE 105 CONTINUECAC Uniform color wheelC) NMETHOD=1 FAC2=4.*ATAN(1.)*FAC1 S=1.0 V=1.0 MP2=MAP/2 DO I=1,MAP H=(I-1)*FAC1. CALL NEWCONV (H,S,V,RED(I),GREEN(I),BLUE(I)) END DOt" RX=0.5*FLOAT(MAP-1)*NX/FLOAT(MAP) RY=0.75*(NY+NINC) GOTO 201TC 191 CONTINUECd5C Save if the file does not exist, restore if it doesIC(NC (If they're reading and/or writing the LUT, assume they don't want to change#C it again immediately thereafter)E STABLE=.TRUE. CALL NEED_INPUT(VDI,WDI, 8 + 'Read file if it exists: create/write it if not',E + 'Give the (VMS) filename for the LUT (CR to exit)',FILE,NFILE)N IF(NFILE.EQ.0) RETURNC Store in binary to save spacex91 FORMAT(3A4)2 OPEN(11,FILE=FILE(1:NFILE),STATUS='OLD',ERR=1911)3C File exists, read it in (resetting NLUT as we go)M@ READ(11,91,END=1912,ERR=1912) RX,RY,NMETHOD,TH,NR,WH,VI,LI,NLUT@ READ(11,91,END=1912,ERR=1912) (RED(I),GREEN(I),BLUE(I),I=1,MAP) CLOSE(11) GOTO 201 Cr 1911 CONTINUEKC File does not exist, create it (must restore OLDLUT so MOD_LUT will work)H NLUT=OLDLUT2 OPEN(11,FILE=FILE(1:NFILE),STATUS='NEW',ERR=1913)8 WRITE(11,91,ERR=1913) RX,RY,NMETHOD,TH,NR,WH,VI,LI,NLUT8 WRITE(11,91,ERR=1913) (RED(I),GREEN(I),BLUE(I),I=1,MAP) CLOSE(11) RETURNs=1912 WRITE(6,*) 'Error reading LUT from file: ',FILE(1:NFILE)CC WRITE(6,*) 'Please check that this is a valid NEWUISDISP LUT file'L CLOSE(11) RETURNJC1913 WRITE(6,*) 'Unknown error writing LUT to file: ',FILE(1:NFILE)t WRITE(6,*) G + 'This is NOT a valid NEWUISDISP LUT file, and should be deleted'N CLOSE(11) RETURNSCE 201 CONTINUECA?C Fill up the virtual color map (don't worry about the flickernBC [see MOD_LUT], because this is only done once, not continually).CE2 CALL UIS$SET_COLORS (VDI,GIND,MAP,RED,GREEN,BLUE)CL RETURNS ENDCNPC*******************************************************************************1 SUBROUTINE MOD_LUT(RED,GREEN,BLUE,MAP,GIND,NLUT)EC0C Interactive modification of the Look-Up Table.FC Reacts to cursor placement in main window. Also activated by buttonFC pressing, so that you can exit or change behaviour without having toGC move the cursor to wake it up. Using the ASTs this way avoids having,6C to sit in a CPU-consuming loop (which I used to do).;C Currently handles ALL of the tables available in SET_LUT.)CA IMPLICIT INTEGER*4 (A-Z)E+ REAL*4 RED(MAP),GREEN(MAP),BLUE(MAP),H,S,VN; REAL*4 AL,VAL,FAC1,FAC2,FAC3,FAC4,FAC5,FAC6,FAC7,FAC8,FAC9D REAL*4 TH,NR,WH,VI,LI,RT,GT,BT* CHARACTER FANCY(5)*30 INCLUDE 'SYS$LIBRARY:UISENTRY'* INCLUDE 'SYS$LIBRARY:UISUSRDEF' COMMON/ICON/ VDI2,WDI2m6 COMMON/IMAGE/ VDI,WDI,ATB,BITSPERPIX,BYPTR,NX,NY,NINC2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB) COMMON/LUT/ RX,RY,NMETHOD,TH,NR,WH,VI,LIo COMMON/LUTPOINT/ EFNUMo COMMON/RGB_SET/ NRGBN+C Declare pointer AST for this routine only  EXTERNAL LUTPOINT?C The "fancy" choice has too many internal degrees of freedom !C* DATA FANCY/'Vary theta/nrot or lin/nrot',+ + 'Vary theta/white or lin/white',R+ + 'Vary theta/vivid or lin/vivid',+ + 'Vary nrot/white or nrot/vivid',(+ + 'Vary theta/lin or white/vivid'/XDC Vari^? UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3P`ous factors to set the correct ranges for different parametersEC (set as many as possible here to speed up processing in later loop)M FAC1=3.141593/FLOAT(NY+NINC)/ FAC2=1./FLOAT(NX) FAC3=1./FLOAT(MAP-1)N FAC4=1./FLOAT(NY+NINC)I FAC5=3.0*FAC4 FAC6=20.0*FAC4/ FAC7=20.0*FAC2M FAC8=FAC2*MAP*0.25' FAC9=FAC4*MAP*0.25/!C Preserve RX and RY between uses RXO=RX  RYO=RYTFC Use viewport relative (device) coordinates, so it doesn't care about!C silly zoom and pan alterations. - CALL UISDC$SET_POINTER_POSITION(WDI,RXO,RYO)D+C Update must be done in pieces (see below)D ISIZE=70C+ IF((MAP/ISIZE)*ISIZE.EQ.MAP) ISIZE=ISIZE-1 NPIECE=MAP/ISIZEa NF=NPIECE*ISIZE+1 IF=MAP-NF+1C 9C That's the common lot done, now check which LUT we havea GOTO (1,2,3,4,5,6), NLUTe#C Give up if we don't know this one  RETURNrCo 1 CONTINUE: CALL ENABLE_BUTTONS(VDI,WDI,'Grey','Quit',' ',' ',.TRUE.) ASSIGN 11 TO IGOE GOTO 302R 2 CONTINUE S=1.0> CALL ENABLE_BUTTONS(VDI,WDI,'Rainbow','Quit','Contrast/pos.',! + 'Start/intensity',.TRUE.)a ASSIGN 12 TO IGO GOTO 302s 3 CONTINUE- CALL ENABLE_BUTTONS(VDI,WDI,'Random','Quit',f% + 'Method 1','Method 2',.TRUE.)) ASSIGN 13 TO IGO GOTO 302l 4 CONTINUE ASSIGN 14 TO IGOn/ NMETHOD=MAKE_MENU(VDI,WDI,5,FANCY,'Variation') IF(NMETHOD.EQ.0) RETURN8C Set pointer back again, because it moved for the menu.- CALL UISDC$SET_POINTER_POSITION(WDI,RXO,RYO).0C Ten combinations of 5 parameters, 2 at a time.MC Make five sets of options, with one on the centre button, one on the right.n$ GOTO (401,402,403,404,405), NMETHOD/401 CALL ENABLE_BUTTONS(VDI,WDI,'Fancy','Quit',)' + 'Theta/Nrot','Lin/Nrot',.TRUE.) GOTO 302m/402 CALL ENABLE_BUTTONS(VDI,WDI,'Fancy','Quit',() + 'Theta/White','Lin/White',.TRUE.)N GOTO 302*/403 CALL ENABLE_BUTTONS(VDI,WDI,'Fancy','Quit', ) + 'Theta/Vivid','Lin/Vivid',.TRUE.)5 GOTO 302D/404 CALL ENABLE_BUTTONS(VDI,WDI,'Fancy','Quit',R) + 'Nrot/White','Nrot/Vivid',.TRUE.) GOTO 302 /405 CALL ENABLE_BUTTONS(VDI,WDI,'Fancy','Quit',*) + 'Theta/Lin','White/Vivid',.TRUE.)* GOTO 302* 5 CONTINUE S=1.0 V=1.0> CALL ENABLE_BUTTONS(VDI,WDI,'Uniform','Quit','Contrast/pos.',! + 'Start/intensity',.TRUE.) ASSIGN 15 TO IGOE GOTO 302 6 CONTINUE IPIECE=4M IF(NRGB.EQ.1) IPIECE=8L MP4=(MAP-16)/IPIECE MPG=MAP-MP4*IPIECEN FAC7=1.0/FLOAT(IPIECE)L FAC8=1.0/(MP4-1)T FAC9=1.0/(MPG-1)F TH=1.0I NR=1.0Y WH=1.0: ISRGB=14 CALL ENABLE_BUTTONS(VDI,WDI,'RGB','Quit','R->G->B', + 'B->G->R',.TRUE.)W ASSIGN 16 TO IGOY GOTO 302ICC Common part of loop.CC So as not to waste CPU time when nothing is moving, put this intoeC a separate pointer AST.' 302 CONTINUECf- CALL UIS$SET_POINTER_AST(VDI,WDI,LUTPOINT,0)  CALL LIB$GET_EF(EFNUM)=EC Note that we now set the same event flag for the buttons AST, so we_7C can be woken up by EITHER the pointer OR the buttons.t EFNB=EFNUM= 301 CONTINUE CALL SYS$CLREF(%VAL(EFNUM)) CALL SYS$WAITFR(%VAL(EFNUM))HC React only to a left button down-click - ignore any up-clicks (ONE=-1) IF(ONE.EQ.1) THENJC First button ("quit") wakes up our BUTTONS AST and sets 'ONE', whereupon8C we remove the window and reset the ASTs and the image. CALL DELETE_BUTTONS(VDI,WDI)h, CALL UIS$SET_POINTER_AST(VDI,WDI,,,,,,,,) CALL LIB$FREE_EF(EFNUM) CALL RESET_IMAGE RETURNLIC Ignore a left button up-click. The other buttons are sometimes used toe.C change options, so we leave those two alone. ELSE IF (ONE.EQ.-1) THENN O_4S UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3PNE=0 GOTO 301  END IFNC If we get to here, we either moved the pointer or clicked a "choice" button.- STATUS=UISDC$GET_POINTER_POSITION(WDI,RX,RY)RNC With the AST method, we don't need to check for a valid or changed position. RXO=RX  RYO=RY-C Common part over GOTO IGOBCh C GreyscaleECD11 AL=TAN(RY*FAC1-1.570796)A NXP=NINT(RX*FAC2*MAP) DO I=1,MAP5- VAL=MIN( MAX(0.,0.5+AL*FAC3*(I-1-NXP)), 1.)S RED(I)=VAL BLUE(I)=VAL GREEN(I)=VAL END DOA GOTO 201ACA C Rainbow5CY12 IF(TWO.NE.0) NMETHOD=1  IF(THREE.NE.0) NMETHOD=2A S=1.0 IF(NMETHOD.EQ.1) THEN AL=TAN(RY*FAC1-1.570796) NXP=NINT(RX*FAC2*MAP)( DO I=1,MAP VAL=0.5+AL*FAC3*(I-1-NXP) IF(VAL) 121,122,122BC Arrange values at either end to have some sort of "bland" level,1C so that the coloured region is nicely bordered. 121 RED(I)=0.9 GREEN(I)=0.9  BLUE(I)=0.9 GOTO 125V122 IF(VAL-1.) 123,123,124124 RED(I)=0.7 GREEN(I)=0.6I BLUE(I)=0.6 GOTO 125!C Now pick a useful "real" value.123 H=360.0*VAL  V=0.25+0.75*VAL5 CALL UIS$HSV_TO_RGB(H,S,V,RED(I),GREEN(I),BLUE(I)))125 CONTINUE END DO ELSE VAL=RY*FAC4*360. AL=RX*FAC2*0.75+0.25 DO I=1,MAP H=REAL(I-1)*FAC3*360.0+VALH IF(H.GT.360.) H=H-360.r V=0.75*REAL(I-1)*FAC3+AL  IF(V.GT.1.0) V=V-0.756 CALL UIS$HSV_TO_RGB (H,S,V,RED(I),GREEN(I),BLUE(I)) END DO END IFo GOTO 201 Cr13 IF(TWO.NE.0) NMETHOD=1  IF(THREE.NE.0) NMETHOD=2aCs C RandomoCn6C Need to start with the same kernel for a given x,y -7C that way, you can get back to where you were (just !)3 IKERNEL=RX*RY DO I=1,50 H=RAN(IKERNEL) END DO) DO I=1,MAP9 H=RAN(IKERNEL)*360.1 IF(NMETHOD.EQ.1) THEN* V=0.25+0.75*RAN(IKERNEL)B ELSE V=RAN(IKERNEL), END IF S=RAN(IKERNEL)5 CALL UIS$HSV_TO_RGB (H,S,V,RED(I),GREEN(I),BLUE(I))  END DO GOTO 201oCc 14 CONTINUE)=C Run with two choices per setup, given by -ve or +ve nmethod2" IF(TWO.NE.0) NMETHOD=ABS(NMETHOD)% IF(THREE.NE.0) NMETHOD=-ABS(NMETHOD)I C Ranges:t+C Nmethod is -5 to +5, with 0 not available5C theta (TH) 0 to 3=C nrot (NR) -10 to 10 (really infinity, but this is enough)oC white (WH) 0 to MAP_SIZE/4rC vivid (VI) 0 to 1C lin (LI) >0 to 1 > GOTO (141,142,143,144,145,301,147,148,149,150,151), NMETHOD+6C Vary theta/nrot or lin/nrotI147 TH=RY*FAC5 NR=RX*FAC7-10.x GOTO 140e145 LI=RY*FAC4+0.001 NR=RX*FAC7-10.M GOTO 140 C Vary theta/white or lin/whiteI148 TH=RY*FAC5 WH=RX*FAC8 GOTO 140b144 LI=RY*FAC4+0.001 WH=RX*FAC8) GOTO 140FC Vary theta/vivid or lin/vividR149 TH=RY*FAC5 VI=RX*FAC2t GOTO 140i143 LI=RY*FAC4+0.001 VI=RX*FAC2= GOTO 1401C Vary nrot/white or nrot/vividL150 NR=RY*FAC6-10.09 WH=RX*FAC8( GOTO 140N142 NR=RY*FAC6-10.0 VI=RX*FAC2G GOTO 140rC Vary theta/lin or white/vivid 151 TH=RY*FAC5 LI=RX*FAC2+0.001U GOTO 140T141 WH=RY*FAC9 VI=RX*FAC2O GOTO 140=CE 140 CONTINUE@ CALL GEN_COLOR(MAP,1,MAP,4,MAP-4,TH,NR,WH,VI,LI,RED,GREEN,BLUE) GOTO 201CI C UniformRC115 IF(TWO.NE.0) NMETHOD=1, IF(THREE.NE.0) NMETHOD=2R S=1.0 V=1.0JC Same two choices as for the "rainbow" LUT, just using the new conversion+C algorithm NEWCONV, instead of HSV_TO_RGB. IF(NMETHOD.EQ.1) THEN AL=TAN(RY*FAC1-1.570796) NXP=NINT(RX*FAC2*MAP)I DO I=1,MAP VAL=0.5+AL*FAC3*(I-1-NXP) IF(VAL) 1501,1502,1502f1501 RED(I)=0.9d GREEN(I)=0.91 BLUE(I)=0.9 GOTO 1505 1502 IF(VAL-1.) 1503,1503,15041504 RED(I)=0.7b GREEN(I)=`>I UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.FOR;3Px 0.6 BLUE(I)=0.6 GOTO 150551503 CALL NEWCONV (VAL,S,V,RED(I),GREEN(I),BLUE(I))_1505 CONTINUEM END DO ELSE) VAL=RY*FAC4 AL=RX*FAC2*0.6+0.4 DO I=1,MAP H=REAL(I-1)*FAC3+VAL* IF(H.GT.1.0) H=H-1.0* V=0.6*REAL(I-1)*FAC3+AL IF(V.GT.1.0) V=V-0.6E/ CALL NEWCONV (H,S,V,RED(I),GREEN(I),BLUE(I))a END DO END IFu GOTO 201eCiC RGB encodingCo 16 CONTINUE EC Switch which colour we alter, on an up-click (avoids the problem ofv!C up and down having two effects)t IF(TWO.EQ.-1) THENt ISRGB=ISRGB+1 IF(ISRGB.GT.3) ISRGB=1s ELSE IF (THREE.EQ.-1) THENo ISRGB=ISRGB-1 IF(ISRGB.LT.1) ISRGB=3i END IFS AL=TAN(RY*FAC1-1.570796)E# NXP=INT(RX*FAC2*FLOAT(IPIECE+2))-1M8C TH is an enhancement factor over the "plain" encoding.=C We therefore want TH=1 when AL=0 - i.e. nothing is changed.A TH=1.0-AL*NXP/FLOAT(IPIECE) DO I=1,MPG V=REAL(I-1)*FAC9Y IF(ISRGB.EQ.1) THEN RED(I)=MIN(MAX(V*TH,0.),1.)M ELSE IF (ISRGB.EQ.2) THEN! GREEN(I)=MIN(MAX(V*TH,0.),1.)N ELSEO BLUE(I)=MIN(MAX(V*TH,0.),1.) END IFH END DO S=1.0 DO K=1,IPIECE! TH=1.0+AL*(K-NXP)/FLOAT(IPIECE) J=(K-1)*MP4+MPGS IF(NRGB.EQ.1) THEN V=((K-1)/2)*0.2+0.39999999999 S=1.0-(K-2*(K/2))*0.6 ELSE V=(K-1)*0.2+0.39999999999 END IF DO I=1,MP4 H=REAL(I-1)*FAC8*360.0y' CALL UIS$HSV_TO_RGB (H,S,V,RT,GT,BT)' IF(ISRGB.EQ.1) THEN" RED(J+I)=MIN(MAX(RT*TH,0.),1.) ELSE IF (ISRGB.EQ.2) THEN$ GREEN(J+I)=MIN(MAX(GT*TH,0.),1.) ELSEa# BLUE(J+I)=MIN(MAX(BT*TH,0.),1.)i END IFa END DO END DOa GOTO 201bChC #C And now, the common up-date pieceM 201 CONTINUEDC Have to do the color-map update in pieces to avoid display flickerEC (documented under the UIS$SET_COLORS routine). This slows down the;C responsiveness slightly, but is still much less annoying. DC It's due to updating too many entries within one vertical blankingFC interval, so to ensure it works, we also add a tiny little wait timeDC between the pieces. You still get an occasional flicker, but it's!C a LOT less noticeable this way.N DO 9 I=1,NPIECE J=(I-1)*ISIZE+1A CALL UIS$SET_COLORS (VDI,J-1+GIND,ISIZE,RED(J),GREEN(J),BLUE(J))N CALL LIB$WAIT(0.005)) 9 CONTINUE9C and reset the buttons - don't want a cumulative effect.L TWO=0 THREE=0B CALL UIS$SET_COLORS (VDI,NF-1+GIND,IF,RED(NF),GREEN(NF),BLUE(NF)) GOTO 301  ENDC*[SHARP.UISEXP]NEWUISDISP.TXT;6+,./9 4P-0123KPWO56ܒ7 ܒ8׽J9G9HJ9Comments to accompany the display program NEWUISDISP.FOR.EThis program is designed to run on a VMS VAXstation with greyscale orGcolor capability, either 4-bit or 8-bit. It will NOT run under Ultrix.HIt definitely works under VMS 4, and it has worked on at least one VMS 5Bsystem. It needs VWS (workstation software) version 3.2 or later.IThe accompanying program IRAFLOGO.FOR enables creation of the IRAF `star'Glogo for use as an Icon. Careful reading of this program should enableIsites toai) UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.TXT;6P Q produce customized Icons. It provides two mechanisms, the firstJa graphical one (drawing regions as vectors and then filling them in), theHsecond a bit-mapped one (directly creating an array of zeroes and ones).HThe bit-mapped method was included because I didn't like the look of theGgraphical one (!), but it's rather harder to set up, and very difficult9to customize (try designing from scratch if you want to).FBoth programs are available by e-mail on request. However, NEWUISDISPEoccupies some 251 blocks, as opposed to IRAFLOGO's 24, so if possibleCwe suggest you run a VMS COPY over the DECnet (via SPAN or HEPnet). The files are: 5355::USR0:[SHARP.UISEXP]NEWUISDISP.FOR and .EXE, andP 5355::USR0:[SHARP.UISEXP]IRAFLOGO.FOR and .EXE, (5355 is NOAO's node number)Current status:KThis is version 1B, the development version, dated June 1989 and containingHonly some minor improvements over the December 1988 version (to coincideFwith the IRAF 2.8 release). The first version, dated October 1988 andHannounced in the IRAF Newsletter, had several limitations, including not:supporting 4-bit systems. Please report any bugs or otherIinfelicities you may find: remember, this is still experimental software.IThe executable can be run directly: certain assumptions can be changed ifJyou alter the source code, then recompile and relink. Many of the programKfeatures are discussed in the opening comment section in the source: please0read that section, as well as the comments here.Changes for June 1989:I"New image setup" menu made easier to use, with fewer spurious questions.A"Minimum window size" item moved into the "New image setup" menu.HDefault changed to reserve 10 LUT indices: unfortunately, on startup theHVWS system insists on ignoring this and affecting the VT240-Regis windowGrecommended for running IRAF. Due to a bug in VWS, you must shrink theHRegis window to an Icon and re-expand to recover its correct appearance.FRelinked with IRAF 2.8 IMFORT to allow pixel redirection using the VMSlogical IRAFIMDIR.6Tested under VMS 4.7/VWS 3.3 and under VMS 5.1/VWS 4.0Usage:HThe program can be run directly, or SPAWNed. From the IRAF environment,Dit's best to !SPAWN RUN NEWUISDISP, so that the program behaves as aDconnected subprocess. It does some terminal I/O, principally cursorFinformation and error messages, but creates its own separate window ifFit needs terminal input. This means you can't type ahead, even if youFknow what the program is going to ask. All of the display options areFaccessible from the "Additional Options" item of the window Main Menu,Hafter the first image has been displayed. Most options should be fairlyFwell self-explanatory. If you find any obscure or ambiguous sections,please let us know.5Improvements in version 1B, and some comments on use:EThis version has some internal changes and better error handling, and the following functional extras:Da) support for a variable number of look-up table entries, includingF running on 4-bit greyscale systems (I've also run it under VMS 5 onK a 4-bit system: 8-bit greyscale seems very rare). If you use the entireJ hardware LUT, windows other than system windows (Banners, clocks, etc.)M will be altered when you use the image display: by reserving some indices,. these other windows can be left unaffected.Fb) Look-Up Table extras, including more control over variations, a newC more perceptually uniform LUT, and a save/restore option to keep- LUTs on disk (just fobV UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.TXT;6P r the movie makers !)Kc) new options for reading a new image, including choice of min/max and LUT andHd) ability to read FITS images directly from disk (but with no "section"4 control - i.e. the whole image, not a part of it)Le) a "snap" option, to filter the displayed image through the LUT to an IRAFD format file, with control over the output range (default 0-1023).I This is useful not just for sites with "crtpict" or an equivalent, butH also with the RGB feature (see below). There is no snap FITS output.Hf) limited blink capability: the current image is stored, and at a laterK time can be blinked against the now current image, using the current LUTI (restoring the original LUT is problematic). The quality of the blinkL depends in an odd way on the image size - 512x512 is better than 256x256,J for example - and has been implemented in 2 ways, a (usually) "cleaner"H blink, but of limited speed, and a (usually) "blockier" blink capableE of higher speeds. Both blinks are "infinitely variable" up to theJ maximum, but because the blink interval is only updated once around theI loop, it can get quite tiring holding down the button during very slowK alternations. For "good" image sizes, you can make it go faster than isM comfortable to watch. Images of different sizes are aligned at the bottomJ left corner, and there is no "real-time" pan of one image wrt the otherJ (although you can stop the blink, pan the current image, and re-blink). and finally,Ig) a tentative method for taking three separate images, calling them red,L blue, and green, and combining into a "full-colour" image. Encoding whatI we do on the IIS with 24 bits of colour (8 each), into a workstation'sK 8 bits (a "cube root" problem !) proved surprisingly effective, probablyL due to the eye's tolerance. The best way to use this is probably to lookI at each frame in greyscale, snap the picture to another file, and thenG read back in the snaps. In the interactive LUT modification option,J only one color is changed at a time. To avoid "messing up" a color youI have already set, the buttons allow you to move in either order, R-G-BJ or B-G-R. That is, you start by changing Red: click the middle button,J and you'll change Green. To go back to Red, click the right button, orK to go to Blue, click the middle button again. A full description of theH encoding method is available, and there are plenty of comments in theF code: comments, opinions, and alternative methods are very welcome.K Note that the two methods I use are not compatible, in the sense that ifE you change the method (see the "New image setup" option), you must< re-read all three images. The coding is also quite slow. Future plans:CWe have some planned enhancements. All other suggestions and ideasEare actively solicited, by mail to 5355::SHARP, or sharp@noao.edu, oreven by regular mail.NThe biggest feature not yet implemented (and the reason this is version 1B andNnot version 2) is graphics overlay, for marking cursor positions and boxes, orMlabeling features for photographs. This is a difficult option, because thereOare no independent planes on a VAXstation, so it must be simulated in software.HIdeally, it will also allow marking a set of positions read from a file.Bugs/limitations:GNo ability to sub-sample large images (use imcopy to make a new image).NImages with sizes over 900 pixels in x or 800 in y will give incorrect resultsO for the cQ  _dcy0oAl1J9%4t`&IF7:l9*r(6]du8 +cbn,GJ0`5.,WOJ1?uj\xkM@ckpMu$4I57(H~qSyT]b -Fy,C&>$.[|` wXpeDG#wQ^\|j - 0))c'wt^E$(x&Q?bWjXK6>8>!"AN5 2K :X]UIqtl3D\'N,17r:Ai@y P>`B 5[I!FK;O%"Gh! $$HBoK||9}fB#u H`H6kiO&.FmM&H!>@ c~>]uM=o RR[(5:>*7kfzh)7@GF!'b&6}l6(JTu 3,+B &`Bj @RasWaHX 9 {zSoTlB2h{D~bq2[2{G!azZLO P >eKMf#qR y']a2F|sJrj>~%V%n*h.IKZf=.:gg .>v5[CNO@_>|0xuRLf80;s/~Y~~nnfjk"E J#\A1zvlO e`K[LWf[fo*j56)Fq!;B[ _}".qs'&GdmU})&`R jZW\3 c`K.s!u*E: -_B4 OK @Q9.[]LCRmTl11 $~s6?XMss]"$>:c}E@_w;7U+tTn$~dB?!d4Yt&Wr*m8h.p)|D0u]a,s[AJes,'F--l'L76L{HNn;IYz5OW]\iihS<);P Iy1.%{0b 8/n>_!4lPQ7ZXh%_E .[si*,jC.`p-<4tHzFx} ?o.KQ2f*@Zi uu}-'up{LNWGkN}zZtlMh>I(I(#G=F:Ix8B+egkYPK&V;_dQBk7Y@po04?YOPap'- l\v Y!!^gG|O8CPpDg?LKW%[*\./>Mg&"iYR&>oj72=G{O1\x\Az2-mtz|Mq>$? *DO !euZM%Z, qP?93L"]L5N=#*kfV6UUVy^,1@w3J&P uxrL_@y8;m!-w!?>;n)4SzwU x{K0YN 4+!**8D$YH7sdM#Q^'t2P$0 gLul$TN\!R#hNYS/ }&|EKR;f6IE y isbKP(| NEtw<?>Zz)?wE]9@l)aYiQQ8C8EWX*S1?RaD-&?YI'Y b3]@ ?jZ)I:, 7c lH@G1VO'&foq -&F)LRJw- - k_0qT#Ie h\;F,`cB\>N1Shq%xrL'[sHC24HFkg'Ghk(>'Y_4]{@s\D?)9!C5y! J+'U^)1^gK4 1"(S2=q?X g+c:WfXEs::ifC+a ^su&$:>0n` M >'Sb7u) W]o<\n, Q)d9_v)Ej!k|V*I_'T ;v@gm>KL/4]'4Ze_oq;EM]Sx5={Nb{khJ db/ _$P zk!"j=ux!SW %bAKLXVK l:k^koX^^iI"3@[N~?x\~TUw~ 8wR|^KCkf27-IJ-O >em(w|=C# ;%^nhaL*n$cW%A/Nf3"`$zQ_X^\(GkHXP]V*#]j WRvpQ,d*^2W=m=)_6kX[$[b6i"Gb! uHBu] (?TC 1mM{S):)84YaSJPU?b/|3+Du5 g`:y QV(? F a@%cJh$MqynZP: I{_ 8'/w29<.>,e_Nj`;r{IHkN^539h2tFSPp?'{*2N!Za!^!^L]Gd+.C~<06VWs+'E'Doel12'8A( V%BA pmIaJbj LEw+{v{ =u;FU}vX f ;:Y=@T\ _nEnwVGR^${]-+.q*2arwb'tp@7l2%O%xK1J D NXu [Y;v9$:1W*`kI&>s inI2mDa8E4z J vq!E\- mZ#uaBRP6MKa%7D9x}-X{p'c@N0!IRw3~E.-GQck2~3iDVeC'`z iC2d PIPJB>S YDolPH\.o-5 4~tSt!YgWvS_D 7j8700E`eg(Z/6R=bEb0y,k\x@Gws@#W9s!\T fmD '3h3tcsCHc.B^b; k]d%(WT--'hcIDGs#:"k^xXnjBLJc;0,SXC|J vN6_9X@f|{[7#7iXx#,O &@gZQd UISDISP.BCK[SHARP.UISEXP]NEWUISDISP.TXT;6P.cursor readback and zoom/pan. I'm working on this bug, in connection? with a simpler way to display large images than sub-sampling.;No ability to zoom different amounts in x and y directions.'No type-ahead for answers to questions.KNo monochrome (2-bit) support (this would require clever dithering in order8 to simulate greyscale by use of half-tone techniques).GNo direct integration with IRAF (so file names must all be given in VMSI syntax, and there's no way to use the cursor directly from IRAF tasks -@ you have to write a file and then read it back into the task).GOnly one display plane, with a limited second plane for blink purposes.HOnly two-image blink (vs IRAF's regular 4-plane image display protocol).)SNAP output only to the IRAF file format.OThe virtual memory management still seems to crash the VAXstation occasionally,E and I can't repeat it reliably enough to be able to investigate it.L I strongly recommend that anyone using NEWUISDISP should get their workingI set extents and their page file quotas increased. You may also need tosK increase the system page file size. Some of the problems can be eased ifa+ you run NEWUISDISP as a separate process.uunder Ultrix.HIt definitely works under VMS 4, and it has worked on at least one VMS 5Bsystem. It needs VWS (workstation software) version 3.2 or later.IThe accompanying program IRAFLOGO.FOR enables creation of the IRAF `star'Glogo for use as an Icon. Careful reading of this program should enableIsites to*[SHARP.UISEXP]UISDISP.FOR;16+,*S./9 4P~D-0123KPWO56;m7}No8p r9G9HJ C UISDISP.FORCC A program to display an IRAF disk file using the UIS subroutinesKC on a VAXstation (originally on a II/GPX). VMS specific: NOT for Ultrix.OC------------------------------------------------------------------------------?C Version 2.3, 1994. More bug fixes, add arbitrary line graph.:C Version 2.2, 1992. Minor bug fixes, small enhancements.IC Version 2.1, December 1989. Logarithmic scaling, small cursor changes.:C Version 2.0, 1989. Addition of graphics overlay system.=C See also program IRAFLOGO.FOR, for making customized Icons.C C To compile and link for IRAF:CCC Locate this file somewhere such as iraf$local, or iraf$local/uis.C cl> fc uisdisp.fC,C Execute as a background process by typingAC !SPAWN/NOWAIT run uisdisp and answer the questions presentedFC in special windows. All of the display-specific tasks are run from7C the Additional Options item in the main Menu window.CCC Written by Nigel Sharp, National Optical Astronomy Observatories..C SPAN: NOAO::SHARP, or 5355::SHARPC Internet: nsharp@noao.eduC Telephone: (602) 327 5511HC Based on an original by Simon Morris, without whom it would not exist,8C but very extensively rewritten (so he's not to blame).CIC------------------------------------------------------------------------ PROGRAM UISDISPC IMPLICIT INTEGER*4 (A-Z) PARAMETER (COL_DIM=256)) CHARACTER*80 ERRSTR,TEXT,IMTITLE,BLTITLE< CHARACTER*80 OPTIONS(20),CURSORS(12),RESETS(3),SETUPS(7,3),7 +eཊh UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16Pw  SNAP_SET(3,3),SNAP_CHOICE(4),BLINKS(4),RANGE(3) CHARACTER FONT_NAME*318 LOGICAL ONE_TO_ONE,STABLE_LUT,INC_LUT,BLINK,RGB,MARKERS> INTEGER*4 VCMATT(3),VCTMP(3),NSETUP(7),NMAXSET(7),NMINSET(7),6 + IM_RGB(3),NSNAP(3),NSNMA(3),NSNMI(3),GOBJ(50)5 REAL*4 RETWIDTH,RETHEIGHT,RETRESOLX,RETRESOLY,SCALE,: + RETX,RETY,XVAL,YVAL,RDATMIN,RDATMAX,WIDTH,HEIGHT,< + ICAA2,ICAA3,MWAA1,MWAA2,ORDMIN,ORDMAX,BLAA2,BLAA3,A + H,S,V,REDM(6),GREENM(6),BLUEM(6),DELAY,BLINKINC,LOGSAVE,= + RED(COL_DIM),GREEN(COL_DIM),BLUE(COL_DIM),RZXS,RZYS,> + TEXT_SLOPE,CHAR_WIDTH,CHAR_HEIGHT,LINE_WIDTH,LOGSCALEC(C---------------------------------------7 EXTERNAL SHRINKER,EXPANDER,CLOSER,DISPLAYOPT,BLINKBUTTC Common blocks for:C ICON window IDsC ICON attributesC Main window attributesC Blink window attributesC Workstation parameters0C Image window IDs, pointers and size parametersC Image section and title%C Virtual color maps and map segments.C Look-Up Table memory (where the pointer was)-C Menu selection (used by the CLOSER routine)FC Blink (extra delay between images - as if you need it on a II/GPX !)'C Buttons (activated by ENABLE_BUTTONS)C Zoom and pan locationC Minimum window size'C Data type, scales, and scaling optionC RGB encoding optionC Graphics overlay features4C Text and line characteristics for graphics overlay'C Pointer to location of original array COMMON/ICON/ VD_ID2,WD_ID27 COMMON/ICAT/ ICAC1,ICAA1,ICAC2,ICAA2,ICAC3,ICAA3,ICEND7 COMMON/MWAT/ MWAC1,MWAA1,MWAC2,MWAA2,MWAC3,MWAA3,MWEND7 COMMON/BLAT/ BLAC1,BLAA1,BLAC2,BLAA2,BLAC3,BLAA3,BLEND5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHT: COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITSPERPIX,BYPTR,NX,NY,NINC/ COMMON/IMFILE/ REPL,XS,XE,YS,YE,IMTITLE,IMTLEN# COMMON/COLOR/ CMS_ID,VCM_ID,GINDEX COMMON/LUT/ RXLUT,RYLUT,NMETHOD COMMON/ADDOPT/ SELECTION! COMMON/BLINK/ BLINKBUFF,BLINKINC2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB- COMMON/ZOOMP/ ZOOM,ZXS,ZXE,ZYS,ZYE,RZXS,RZYS! COMMON/MINSIZE/ MIN_SIZE,INC_LUT< COMMON/DATA/ DTYPE,IDATMIN,IDATMAX,RDATMIN,RDATMAX,LOGSCALE COMMON/RGB_SET/ NRGB4 COMMON/GRAPHICS/ ATBG,MARKERS,NMARKER,NG,NGMAX,GOBJ; COMMON/TEXTL/ LINE_STYLE,LINE_WIDTH,TEXT_SLOPE,CHAR_WIDTH,$ + CHAR_HEIGHT,INDEX,FONT_NAME COMMON/ORIGINAL/ I2PTRC@C---------------------------------------------------------------C C Read in the UIS INCLUDE filesC INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF'C DATA REDM/1.,0.,1.,0.,0.,0.9/ DATA GREENM/1.,0.,0.,1.,0.,0.6/ DATA BLUEM/1.,0.,0.,0.,1.,0.0/C All current extra options= DATA OPTIONS/'Cursor read','Dump a region','Corners of box',9 + 'Dynamic range options','Read in a new image',0 + 'New image setup','Zoom (in or out)',; + 'Pan (non-interactive)','Reset zoom and/or pan',< + 'Reset Look-Up Table','Interactively change LUT',; + 'Graphics overlay menu','Change cursor pattern',7 + 'Blink options','Snap (screen->IRAF image)',2 + '3 images->RGB','Hard copy of picture', + 3*' '/6C Currently 11 possible cursors, and one switch option8 DATA CURSORS/'"+" cross','"+" cross with central hole',2 + '"x" cross','"x" cross with central hole',: + 'box with central "+" sign',':-) face',':-( face',0 + 'solid arrow left','outline arrow left',2 + 'solid arrow right','outline arrow right'," + 'Same pattern, two color'/!C Currently three movement resets0 DATA RESETS/'Reset pan onf:R UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P ly','Reset zoom only'," + 'Reset both pan and zoom'/CC Three dynamic range alterations (other two are set "dynamically"), DATA RANGE/'Change min/max values',' ',' '/&C Blink option has three possibilities6 DATA BLINKS/'Store current image','Start fast blink',0 + 'Start slow blink','Clear blink memory'/LC Various items which can be changed after initial display (SETUP menu item)< DATA SETUPS(1,1),SETUPS(1,2),SETUPS(1,3)/'Use current LUT',6 + 'Fresh (greyscale) LUT','Fresh (rainbow) LUT'/@ DATA SETUPS(2,1),SETUPS(2,2),SETUPS(2,3)/'Use current min/max',= + 'Calculate min/max from image','Request new min/max'/2 DATA SETUPS(3,1),SETUPS(3,2)/'Include LUT wedge', + 'No LUT wedge'/1 DATA SETUPS(4,1),SETUPS(4,2)/'Read IRAF images', + 'Read FITS images'/5 DATA SETUPS(5,1),SETUPS(5,2)/'Minimum window size=',% + 'Change minimum window size'/7 DATA SETUPS(6,1),SETUPS(6,2)/'Reserve 0 LUT indices',& + 'Change reserved LUT indices'/3 DATA SETUPS(7,1),SETUPS(7,2)/'RGB 1 (more range)', + 'RGB 2 (more intense)'/ DATA NMAXSET/3,3,5*2/ DATA NMINSET/7*1/C Snap option choices2 DATA SNAP_SET/'Range 0-1023','Include LUT wedge',= + 'Exclude graphics','Range 0-255','Exclude LUT wedge',/ + 'Include graphics','Set range',' ',' '/? DATA SNAP_CHOICE/'Make B&W SNAP file','Make 3 RGB SNAP files',C + 'Make bitmap SNAP (0-maxindex)','View/change SNAP options'/& DATA NSNMI,NSNMA,NSNAP/3*1,3,2,2,3*1/CKC OK, start program by checking that we have a recent enough version of UIS STATUS=UIS$PRESENT(MID)! IF(.NOT.STATUS.OR.MID.LT.3) THEN PRINT *,F + 'UISDISP-F-Too_old, need UIS software version 3.0 or later' STOP 'Impossible to continue' END IFCC Various parameters ATB=50 ATBG=51 NGMAX=506C Initially choose graphics markers on, marker style 1 MARKERS=.TRUE. NMARKER=1 BITSPERPIX=8C No blink selected yet BLINK=.FALSE.7C Initially choose cursor pattern 2 - can be reselected NCURSOR=2/C and cursor single color mode (can be changed) NCTYPE=1&C Set for linear scaling of the image.HC The LOGSCALE parameter sets how much of a log scale you get - close toHC zero it's pretty linear, above 100 it's pretty stretched. The default;C setting of 10. is pretty OK, but experiment for yourself.CC Negative values will revert to the usual directly linear scaling.AC Algorithm taken from Boroson package courtesy John Salzer & TB. LOGSCALE=-1.0 LOGSAVE=10.0GC (I know I just set LOGSCALE, but if you decide you prefer log. as the@C default, then you don't have to reprogram the next few lines) IF(LOGSCALE.GT.0.0) THEN& RANGE(2)='Change to linear scaling'( WRITE(UNIT=RANGE(3),FMT='(A,F5.1,A)')* + 'Change log. scale (',LOGSCALE,')' LOGSAVE=LOGSCALE ELSE+ RANGE(2)='Change to logarithmic scaling'( WRITE(UNIT=RANGE(3),FMT='(A,F5.1,A)')) + 'Change log. scale (',LOGSAVE,')' END IF>C *** Reserved color table indices for graphics overlay planesAC If you change this number, you MUST supply values in the arraysEC REDM, GREENM and BLUEM to match. On a four-bit system, this number>C is automatically cut to 2, using only the first two entries. GINDEX=6?C *** Maximum number of image refreshes before clearing window.GC If the window is redisplayed (e.g. by zoom) many times, the program'sEC virtual memory requirement will grow without limit. This parameterIC affects how often the display list is cleared, to cut this requirement. MAX_CALL_IMAGE=10Cg`jw UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16PNy-C Get the color information for the hardwareC/ CALL UIS$GET_HW_COLOR_INFO ('SYS$WORKSTATION',: + TYPE,INDICES,COLORS,MAPS,RBITS,GBITS,BBITS,IBITS, + RES_INDICES,REGEN)CMC We need to have at least 4-bits of intensity, or we're going to die, so ...+C Problem .... alter this test for now ....( IBITS=MAX(IBITS,MIN(RBITS,GBITS,BBITS)) IF(IBITS.LT.4) THEN@ PRINT *,'UISDISP-F-Norange, Intensity scale less than 4-bits' STOP 'Impossible to continue' END IFCJC The system reserves some entries, so users' LUTs don't alter its abilityIC to write menus and terminal emulators and backgrounds, etc. OverridingJC this makes for a very ugly-looking screen. If you're on a 4-bit system,KC and you really want the extra levels, alter the next line not to subtract/C the reserved indices from the available ones. MAP_SIZE=INDICES-RES_INDICESLC Without getting at the system entries, I make myself another LUT, in whichNC the first GINDEX entries are reserved for graphics (menus, window, overlays)8C and only the remaining ones can be used for the image.FC I use white/black/red/green/blue/yellow for colour systems, and thenAC restrict it to just the first two (W&B) if we only have 4-bits. IF(MAP_SIZE.LT.20) GINDEX=2CC The GINDEX entries are reserved at the BEGINNING of the main LUT.DC Why, you may ask, not the end ? The answer is that certain of theEC window routines reset the window background automatically to be LUTIC entry 0, which then changes with the image (sigh). Rather than beat myFC brains out, I decided to reserve the extra entries at the beginning.C  VCMATT(1)=VCMAL$C_END_OF_LISTHC Due to the new blink system, I can no longer use an unbound color map.C VCMATT(1)=VCMAL$C_ATTRIBUTESC VCMATT(2)=VCMAL$M_NO_BINDC VCMATT(3)=VCMAL$C_END_OF_LISTBC Must create an initial color map, even if we overwrite it later.9 VCM_ID=UIS$CREATE_COLOR_MAP (MAP_SIZE,'Main_LUT',VCMATT): CMS_ID=UIS$CREATE_COLOR_MAP_SEG(VCM_ID,'SYS$WORKSTATION', + UIS$C_COLOR_EXACT,0)MC Hereinafter, MAP_SIZE refers only to those entries available for the image. MAP_SIZE=MAP_SIZE-GINDEXCJC Set up a quick dummy window and load the graphics region color map (thisLC forces these values into the hardware color map right where we want them). VCTMP(1)=WDPL$C_PLACEMENT VCTMP(2)=WDPL$M_INVISIBLE VCTMP(3)=WDPL$C_END_OF_LIST2 VTMP=UIS$CREATE_DISPLAY(0.,0.,1.,1.,1.,1.,VCM_ID)< WTMP=UIS$CREATE_WINDOW(VTMP,'SYS$WORKSTATION',,,,,,,,VCTMP)5 CALL UIS$SET_COLORS(VTMP,0,GINDEX,REDM,GREENM,BLUEM) CALL UIS$DELETE_DISPLAY(VTMP)C$C Set initial main window attributes MWAC1=WDPL$C_END_OF_LIST$C Set initial Icon window attributes ICAC1=WDPL$C_ATTRIBUTES ICAA1=WDPL$M_NOBANNER ICAC2=WDPL$C_END_OF_LISTCC Get the display informationC. CALL UIS$GET_DISPLAY_SIZE ('SYS$WORKSTATION',8 + RETWIDTH,RETHEIGHT,RETRESOLX,RETRESOLY,PWD,PHT)CAC Set the initial graphics overlay font and other characteristics, FONT_NAME='DTABER0G03CK00GG0001UZZZZ02A000';C Initial color 2 (=red) or 1 (=black) if not color display IF(GINDEX.GT.2) THEN INDEX=2 ELSE INDEX=1 END IFIC Initial writing angle, and set sizes to 0.0 to make font scalable later TEXT_SLOPE=0.0 CHAR_WIDTH=0.0 CHAR_HEIGHT=0.0C Initial line style and width LINE_STYLE='FFFFFFFF'X LINE_WIDTH=1.CC Initial SETUP settingsC NSETUP(1)=2 NSETUP(2)=2 NSETUP(3)=1 INC_LUT=.TRUE.AC ***FITS*** to make FITS the default on startup, use NSETUP(4)=2 NSETUP(4)=1C Set minimuh>Dx UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16Pm window size here MIN_SIZE=256 NSETUP(5)=1< WRITE(UNIT=SETUPS(5,1),FMT='(''Minimum window size='',I4)') + MIN_SIZEGC Can reserve a number of indices off the top (e.g. for banner windows)EC If you want to do this at the start, set NNUMBER to whatever numberIC you come up with after experimenting with the "new image setup" option. ONUMBER=0 NNUMBER=0IC If we have room, reserve 10 indices by default (usual settings are thatNC we have 244 [8-bit - 6 system reserved - 6 graphics] or 10 [4-bit - 4 systemC reserved - 2 graphics]). IF(MAP_SIZE.GT.20) NNUMBER=10 NSETUP(6)=1 WRITE(UNIT=SETUPS(6,1),= + FMT='(''Currently reserving '',I3,'' LUT indices'')') + NNUMBER# NMAP_SIZE=MAP_SIZE+ONUMBER-NNUMBER2C First use does NOT expect an RGB-encoded display RGB=.FALSE.<C Set to encode RGB by the method with greater dynamic range NSETUP(7)=1 NRGB=NSETUP(7)C1C This is the starting point to begin a new imageC 500 CONTINUEC6C Must set/reset these so that NEED_INPUT doesn't bomb VD_ID=0 WD_ID=05C Adjust MAP_SIZE in case they changed SETUP option 6 MAP_SIZE=NMAP_SIZEC?C Check for the special RGB (three images-> one picture) option IF(RGB) GOTO 501C@C First size the array, so that we can allow the space we need.-C Check the array exists, get datatype, etc. IVALIDI=0 IVALIDF=0 503 CONTINUE ERRSTR=' ' IERROR=0 IF(NSETUP(4).EQ.2) THEN ISTAT=LIB$GET_VM(2880,LPTR)- IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))C)C Possible IERROR returns: 0 - file is OK?C 1 - some problem with specified fileEC 2 - no file-name given at all: switch modeBC Consequence: hitting return will switch blithely between methodsDC for as long as you feel like it, but entering an invalid filename,FC then return, then an invalid name for the other method, will lead toCC an error exit. This seems the most useful, since it does provide'C a way out, which didn't exist before.C0 CALL SIZE_FITS(IM,IS,%val(LPTR),IERROR,ERRSTR) IF(IERROR.NE.0) THENFC Error 1 means we tried but failed (and we already showed the error). IF(IERROR.EQ.1) THEN> PRINT *,'UISDISP-E-Novalid, No valid FITS image specified'BC IVALIDI non-zero means we've already tried the other possibility- IF(IVALIDI.NE.0) STOP 'Error termination' IVALIDF=1 END IFAC Error 2 means we haven't even tried, so we just switch methods.NC We also get here if we tried and failed, but haven't tried the other method. NSETUP(4)=1 GOTO 503 END IF ELSE" CALL SIZE_IRAF(IM,IERROR,ERRSTR) IF(IERROR.NE.0) THENFC Error 1 means we tried but failed (and we already showed the error). IF(IERROR.EQ.1) THEN> PRINT *,'UISDISP-E-Novalid, No valid IRAF image specified'BC IVALIDF non-zero means we've already tried the other possibility- IF(IVALIDF.NE.0) STOP 'Error termination' IVALIDI=1 END IFAC Error 2 means we haven't even tried, so we just switch methods.NC We also get here if we tried and failed, but haven't tried the other method. NSETUP(4)=2 GOTO 503 END IF END IFC)C Select the type of array we are to use: IF(DTYPE.EQ.6) THENGC Get space for a one-line buffer (replication factor for small images) NBYTE=(NX/REPL)*45C Get space for a REAL*4 array, only as big as needed NBYTEI=(NX/REPL)*(NY/REPL)*4 ELSEGC Get space for a one-line buffer (replication factor for small images) NBYTE=(NX/REPL)*20C Get space for a 16-bit integer array, as aboveis8 UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P` NBYTEI=(NX/REPL)*(NY/REPL)*2 END IFDC Use the same pointer for the real or short integer array - we only+C read one at a time, so it all works fine. ISTAT=LIB$GET_VM(NBYTEI,I2PTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTE,SBPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))C/C Now read in the IRAF file we verified above.>C Returns NINC=0 if an intensity scale wedge is not required. ERRSTR=' ' IF(NSETUP(4).EQ.2) THEN: CALL READ_FITS(IM,IS,%val(LPTR),%val(I2PTR),%val(SBPTR), + NX/REPL,NY/REPL,ERRSTR)f ELSEn, CALL READ_IRAF(IM,%val(I2PTR),%val(I2PTR),7 + %val(SBPTR),%val(SBPTR),NX/REPL,NY/REPL,ERRSTR)- END IF- IF(MYL(ERRSTR).NE.0) THEN PRINT *,'Panic stop !'- PRINT *,ERRSTRs STOP 'Abnormal End' END IFdCr)C Choose the LUT for the initial display. Co IF(NSETUP(1).EQ.3) THEN NLUT=2 S=1.0. DO I=1,MAP_SIZEL% H=REAL(I-1)*360.0/REAL(MAP_SIZE-1)s) V=0.25+0.75*REAL(I-1)/REAL(MAP_SIZE-1)i6 CALL UIS$HSV_TO_RGB (H,S,V,RED(I),GREEN(I),BLUE(I)) END DO0 RXLUT=0.5*FLOAT(MAP_SIZE-1)*NX/FLOAT(MAP_SIZE) RYLUT=0.75*(NY+NINC) ELSE IF(NSETUP(1).EQ.2) THENa NLUT=1 DO I=1,MAP_SIZE $ RED(I)=REAL(I-1)/REAL(MAP_SIZE-1)& GREEN(I)=REAL(I-1)/REAL(MAP_SIZE-1)% BLUE(I)=REAL(I-1)/REAL(MAP_SIZE-1)n END DO0 RXLUT=0.5*NX*FLOAT(MAP_SIZE-1)/FLOAT(MAP_SIZE) RYLUT=0.75*(NY+NINC) END IFACt ISTAT=LIB$FREE_VM(NBYTE,SBPTR)n, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) IF(NSETUP(4).EQ.2) THEN ISTAT=LIB$FREE_VM(2880,LPTR)- IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))r END IFu@C Get space for two 8-bit integer arrays, both full size + wedge NBYTEB=NX*(NY+NINC) ISTAT=LIB$GET_VM(NBYTEB,BYPTR)n, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTEB,BCPTR)-, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))CMC Choose what min/max to useC  IF(NSETUP(2).EQ.3) THENC Ask user for min/max IF(DTYPE.EQ.6) THENL& WRITE(UNIT=ERRSTR,FMT='(A,2G12.4)')2 + 'Calculated min and max: ',RDATMIN,RDATMAX ELSE# WRITE(UNIT=ERRSTR,FMT='(A,2I7)')N2 + 'Calculated min and max: ',IDATMIN,IDATMAX END IF(201 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,C + 'Give new min and max (CR to use calculation)',TEXT,NTEXT)N IF(NTEXT.NE.0) THEN  IF(DTYPE.EQ.6) THEN: READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=202) RDATMIN,RDATMAX ELSEW: READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=202) IDATMIN,IDATMAX END IFA END IF GOTO 2032202 WRITE(UNIT=ERRSTR,FMT='(A)') 'Error in input' GOTO 201 203 CONTINUEO ELSE IF(NSETUP(2).EQ.1) THENC Re-use previous values WNC (Note I allowed for a change in image data type when setting the old values) RDATMIN=ORDMIN RDATMAX=ORDMAX IDATMIN=OIDMIN IDATMAX=OIDMAX END IF:C :C Now scale the data to cover the range of the color map.2C This range is from GINDEX to GINDEX+MAP_SIZE-1.AC At this stage, the version of the picture stored in the bytet=C version is flipped top to bottom, so that after display,UFC pixel 1,1 in the I*2 array is displayed at the lower left corner,'C and pixel 1,NY is at the top left.eCi6 CALL SCALE_ARRAY (NX,NY,NINC,%val(I2PTR),%val(I2PTR),5 + NX/REPL,NY/REPL,MAP_SIZE,GINDEX,%val(BYPTR)) GOTO 502dCsC Set up for RGB-encodingaCs 501 CONTINUE CALL SIZE_RGB(IM_RGB) NBYTE=(NX/REPL)*12f ISTAT=LIB$GET_VM(NBYTE,RPTR)c, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTE/2,SPTR)O, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) NBYTEB=NX*(NY+NINC) ISTAT=LIB$GETj UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16PF'_VM(NBYTEB,BYPTR),, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ERRSTR=' 'L8 CALL READ_RGB(IM_RGB,%val(BYPTR),%val(SPTR),%val(RPTR),* + NX,NY,NINC,NX/REPL,NY/REPL,ERRSTR) IF(MYL(ERRSTR).NE.0) THEN' PRINT *,'Panic stop: input errors !'L PRINT *,ERRSTRE STOP 'Abnormal End' END IFC ISTAT=LIB$FREE_VM(NBYTE,RPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$FREE_VM(NBYTE/2,SPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$GET_VM(NBYTEB,BCPTR),, IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))C_EC The VIEWPORT size is determined to be the number of pixels needed.MEC We already checked inside the SIZE_IRAF routine that it fits on theJ1C screen (modulo the request for an extra wedge).HCW 502 CONTINUE WIDTH=NX/RETRESOLXF HEIGHT=(NY+NINC)/RETRESOLY2CGC Now that we allow the user to change MAP_INDEX, we set the entire LUT%C here, so that it doesn't interfere.CC? VCM_ID=UIS$CREATE_COLOR_MAP(MAP_SIZE+GINDEX,'Main_LUT',VCMATT): CMS_ID=UIS$CREATE_COLOR_MAP_SEG(VCM_ID,'SYS$WORKSTATION', + UIS$C_COLOR_EXACT,0)C.C Set up the virtual displayiC# VD_ID=UIS$CREATE_DISPLAY (0.0,0.0, 4 + REAL(NX),REAL(NY+NINC),WIDTH,HEIGHT,VCM_ID)CiHC Fill up the initial virtual color map (offsetting the main LUT by the+C number of indices reserved for graphics).eCo6 CALL UIS$SET_COLORS(VD_ID,0,GINDEX,REDM,GREENM,BLUEM): CALL UIS$SET_COLORS(VD_ID,GINDEX,MAP_SIZE,RED,GREEN,BLUE)CnEC Set the writing mode to COPY - so that 8 bit pixels go straight toaC the bit map without changesC'8 CALL UIS$SET_WRITING_MODE (VD_ID,0,ATB,UIS$C_MODE_COPY)Cs-C and put the array into the virtual displaySC/: CALL UIS$IMAGE (VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),+ + NX,NY+NINC,BITSPERPIX,%val(BYPTR))b: IF(RGB) CALL SET_LUT(RED,GREEN,BLUE,MAP_SIZE,GINDEX,NLUT, + STABLE_LUT,.TRUE.)C 2 WD_ID=UIS$CREATE_WINDOW (VD_ID,'SYS$WORKSTATION',: + IMTITLE(1:IMTLEN),0.0,0.0,REAL(NX),REAL(NY+NINC), + WIDTH,HEIGHT,MWAC1)C'EC Put the cursor in the middle of the Image (allowing for the wedge)<C and change it to the style given by NCURSOR (initially 2)C"- CALL CHOOSE_CURS(VD_ID,WD_ID,NCURSOR,NCTYPE,/7 + REAL(NX)*0.5,REAL(NY)*0.5+NINC)tC CC Define Icon, close (delete), and Additional Options AST routines, &C and disable the "change size" option0 CALL UIS$SET_SHRINK_TO_ICON_AST(WD_ID,SHRINKER)- CALL UIS$SET_EXPAND_ICON_AST(WD_ID,EXPANDER)U' CALL UIS$SET_CLOSE_AST(WD_ID,CLOSER,0)l* CALL UIS$SET_ADDOPT_AST(WD_ID,DISPLAYOPT)% CALL UIS$SET_RESIZE_AST(VD_ID,WD_ID)eCm1C Define the initial graphics overlay attributes.eGC The various parameters values are set on initial entry, and then kept4C around in a common block so they can be used here.CR* CALL UIS$SET_FONT(VD_ID,0,ATBG,FONT_NAME)2 CALL UIS$SET_WRITING_INDEX(VD_ID,ATBG,ATBG,INDEX) IF(CHAR_WIDTH.EQ.0.0) THENi. CALL UIS$SET_CHAR_SIZE(VD_ID,ATBG,ATBG,'W') ELSErB CALL UIS$SET_CHAR_SIZE(VD_ID,ATBG,ATBG,,CHAR_WIDTH,CHAR_HEIGHT) END IF14 CALL UIS$SET_TEXT_SLOPE(VD_ID,ATBG,ATBG,TEXT_SLOPE)4 CALL UIS$SET_LINE_STYLE(VD_ID,ATBG,ATBG,LINE_STYLE)4 CALL UIS$SET_LINE_WIDTH(VD_ID,ATBG,ATBG,LINE_WIDTH):C Important to set number of graphics objects back to zero NG=05C'JC Set initial zoom and pan, and copy the byte array into the storage array4C used to preserve the un-zoomed, un-panned version. ZOOM=1  ZXS=1 RZXS=1. ZXE=NXm ZYS=1 RZYS=1. ZYE=NY  ONE_TO_ONE=.TRUE.) CALL COPY(%val(BYPTR),%val(BCPTR),NX,NY)tC CC Set the number okC UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P.f UIS$IMAGE calls to 1: need this to clean up theA)C display list after multiple zooms/pans.D CALL_IMAGE=1 CICC OK, all set up, now go off into limbo while we wait for somethingoFC to happen. The "Additional Options" AST routine simply wakes us up.BC The "Delete" option sets the SELECTION item to -1, which nothing,C else can do, so we know it's safe to exit.CA 600 CONTINUE CALL SYS$HIBER()k. IF(SELECTION.EQ.-1) STOP 'Normal termination'GC Tried to have the menu called from the Additional Options AST routine CC with the SELECTION passed in common, but I couldn't make it work. 3C Instead, just wake up and run the menu from here. Co?C Currently 17 options: add the necessary stuff to handle extraiEC options here, and change OPTIONS to include the additional prompts.e NOPTION=17 C SELECTION=MAKE_MENU(VD_ID,WD_ID,NOPTION,OPTIONS,'Display Options')r IF(SELECTION.EQ.0) GOTO 600Cm; GOTO (51,52,53,54,55,551,56,57,58,59,60,66,61,63,64,65,62) + , SELECTIONk%C Unknown value - should never happeni GOTO 600eCoKC Encode three images as RGB into one display. Limited (this is 8-bits !).IC Currently ONLY for IRAF images (since I can read them a row at a time).ECI 65 CONTINUET CALL UIS$DELETE_DISPLAY(VD_ID)o ISTAT=LIB$FREE_VM(NBYTEB,BCPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$FREE_VM(NBYTEB,BYPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))=C If RGB is already on, there's no array in I2PTR to free up.e IF(.NOT.RGB) THEN! ISTAT=LIB$FREE_VM(NBYTEI,I2PTR)h- IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) END IF RGB=.TRUE.U NLUT=6c GOTO 500uCiFC Blink section. (I didn't think I wanted to do this until Earl O'NeilAC made a clever suggestion, so then I had to implement it. Sigh) EC Limited capability: store a current image, and then at a later time CC blink it against the current one, using the current LUT (it's nottFC possible to store the old LUT, due to restrictions with the hardwareLC color map segment, which would require massive reprogramming [I tried !]).Ca 63 CONTINUEh7 IBLINK=MAKE_MENU(VD_ID,WD_ID,4,BLINKS,'Blink Options')O IF(IBLINK.EQ.0) GOTO 600, GOTO (631,632,632,636), IBLINKT GOTO 600 CS 631 CONTINUEFC Come here to save the current display in storage, ready for a blink.2C First, we clear back to only one displayed image IF(CALL_IMAGE.GT.1) THENM CALL UIS$ERASE(VD_ID)( CALL_IMAGE=1= CALL UIS$IMAGE (VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),'* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) END IFh3C Jump here to clean up behind us, if we so choose.a 636 CONTINUE IF(BLINK) THENnAC If we've been here before, free the current memory requirement.s# STATUS=LIB$FREE_VM(RETL1,BL_PTR1)./ IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))w# STATUS=LIB$FREE_VM(RETL2,BL_PTR2)l/ IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS)) # STATUS=LIB$FREE_VM(RETL3,BL_PTR3)E/ IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))n END IFm2C If all we did was clean up, then go no further ! IF(IBLINK.EQ.4) THENo BLINK=.FALSE., GOTO 600 END IF C ;C Save the current image in memory reserved for the purposeh' CALL UIS$EXTRACT_HEADER(VD_ID,,,RETL1)r+ CALL UIS$EXTRACT_REGION(VD_ID,,,,,,,RETL2) ( CALL UIS$EXTRACT_TRAILER(VD_ID,,,RETL3)! STATUS=LIB$GET_VM(RETL1,BL_PTR1) . IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))3 CALL UIS$EXTRACT_HEADER(VD_ID,RETL1,%VAL(BL_PTR1))e! STATUS=LIB$GET_VM(RETL2,BL_PTR2)i. IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))7 CALL UIS$EXTRACT_REGION(VD_ID,,,,,RETL2,%VAL(BL_PTR2))e! STATUS=l~pX UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P 5LIB$GET_VM(RETL3,BL_PTR3). IF(.NOT.STATUS) CALL LIB$SIGNAL(%VAL(STATUS))4 CALL UIS$EXTRACT_TRAILER(VD_ID,RETL3,%VAL(BL_PTR3)) C and preserve the current title BLTLEN=IMTLEN$ BLTITLE(1:BLTLEN)=IMTITLE(1:IMTLEN)<C Define some attributes for later use (only need this once) IF(.NOT.BLINK) THEN BLAC1=WDPL$C_ATTRIBUTESi BLAA1=WDPL$M_NOMENU_ICON BLAC2=WDPL$C_ABS_POS_X BLAC3=WDPL$C_ABS_POS_Y BLEND=WDPL$C_END_OF_LIST MWAC1=WDPL$C_ABS_POS_X MWAC2=WDPL$C_ABS_POS_Y MWAC3=WDPL$C_END_OF_LIST END IF BLINK=.TRUE.P GOTO 600sCl 632 CONTINUE.C Come here to start the actual blink process.AC If we haven't set up a blink image, ignore this item completely  IF(.NOT.BLINK) GOTO 600Cc2 CALL UIS$GET_VIEWPORT_POSITION(WD_ID,BLAA2,BLAA3) MWAA1=BLAA2 MWAA2=BLAA30 VD_IDB=UIS$EXECUTE_DISPLAY(RETL1,%VAL(BL_PTR1))- CALL UIS$EXECUTE(VD_IDB,RETL2,%VAL(BL_PTR2))S- CALL UIS$EXECUTE(VD_IDB,RETL3,%VAL(BL_PTR3))E4 WD_IDB=UIS$CREATE_WINDOW (VD_IDB,'SYS$WORKSTATION',< + BLTITLE(1:BLTLEN),0.0,0.0,REAL(NX),REAL(NY+NINC), + WIDTH,HEIGHT,BLAC1) DELAY=0.5 BLINKINC=0.07 CALL EXPLAIN(VD_ID,WD_ID,'Click here','Quit','Faster',r + 'Slower',VDIE,WDIE)TFC Attach the button AST to the "explain" window, because otherwise the>C window-switching gets too fast for the AST queueing to work.8 CALL UIS$SET_BUTTON_AST(VDIE,WDIE,BLINKBUTT,,BLINKBUFF)CHJC There's a slight additional delay involved in going back to the start ofLC the loop, so the blinking is not perfectly symmetrical. Difficult to knowMC exactly how long the extra time is, so I think I shall leave it asymmetric.E 635 CONTINUE IF(BLINKINC.GT.600.) THENJC Quit button sets very large increment: clean up and restore main window." CALL UIS$DELETE_DISPLAY(VD_IDB) CALL UIS$DELETE_DISPLAY(VDIE) CALL RESET_IMAGE_ GOTO 600 END IF -C Switch the whole loop for the type of delay GOTO (633,633,634), IBLINK 633 CALL UIS$POP_VIEWPORT(WD_ID)& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY)IC The delay is only updated once around the loop, so if it's going fairlyIIC slowly, you have to hold the button down for a while to have an effect. DELAY=MAX(0.0,DELAY+BLINKINC) CALL UIS$POP_VIEWPORT(WD_IDB)& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY) GOTO 635t'634 CALL UIS$MOVE_VIEWPORT(WD_ID,MWAC1)u& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY)" DELAY=MAX(0.0,DELAY+BLINKINC*5.0)% CALL UIS$MOVE_VIEWPORT(WD_IDB,BLAC1)1& IF(DELAY.GT.0.0) CALL LIB$WAIT(DELAY) GOTO 635eCv'C Change setups for reading a new imagehC] 551 CONTINUE: CALL MULTI_MENU(VD_ID,WD_ID,7,SETUPS,7,3,NMAXSET,NMINSET,# + NSETUP,'New image choices')= NRGB=NSETUP(7)  IF(NSETUP(3).EQ.2) THEN INC_LUT=.FALSE.i ELSE' INC_LUT=.TRUE. END IFAC Change minimum window size IF(NSETUP(5).EQ.2) THEN NSETUP(5)=1c+ WRITE(UNIT=ERRSTR,FMT='(A,I5,A,F5.1,A)') G6 + 'Current minimum size: ',MIN_SIZE,' pixels, ',( + FLOAT(MIN_SIZE)/RETRESOLX,' cms'(621 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,@ + 'Enter new value in pixels (takes effect on next read)', + TEXT,NTEXT)0 IF(NTEXT.EQ.0) GOTO 62111 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=622) MIN_SIZE= WRITE(UNIT=SETUPS(5,1),FMT='(''Minimum window size='',I4)')t + MIN_SIZE GOTO 6211 2622 WRITE(UNIT=ERRSTR,FMT='(A)') 'Error in input' GOTO 6216211 CONTINUE END IF,C Change reserved LUT indices0 IF(NSETUP(6).EQ.2) THEN NSETUP(6)=1# WRITE(UNIT=ERRSTR,FMT='(A,I3,A)')1 + 'Currently reserving ',NNUMBER,' indices'L)5511 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTRmMHc UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P<,IE + 'New number to reserve (CR to leave the same) ?',TEXT,NTEXT)b;C If it's a CR or an unintelligible number, just ignore it.i IF(NTEXT.EQ.0) GOTO 5512 ONUMBER=NNUMBERc0 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=600) NNUMBER% NMAP_SIZE=NMAP_SIZE+ONUMBER-NNUMBER, IF(NMAP_SIZE.LE.2) THENl5 WRITE(UNIT=ERRSTR,FMT='(A)') 'Too big ! Try again'e& NMAP_SIZE=NMAP_SIZE-ONUMBER+NNUMBER NNUMBER=ONUMBER GOTO 5511 END IF WRITE(UNIT=SETUPS(6,1),h= + FMT='(''Currently reserving '',I3,'' LUT indices'')')E + NNUMBERF 5512 CONTINUEH END IFo GOTO 600eCiC Read a new image 55 CONTINUEw,C Preserve current min/max in case of re-use IF(DTYPE.EQ.6) THEN ORDMIN=RDATMIN ORDMAX=RDATMAX OIDMIN=NINT(RDATMIN) OIDMAX=NINT(RDATMAX) ELSEr ORDMIN=FLOAT(IDATMIN)I ORDMAX=FLOAT(IDATMAX)i OIDMIN=IDATMIN OIDMAX=IDATMAX END IF <C Preserve current window location, in case they've moved it MWAC1=WDPL$C_ABS_POS_Xi MWAC2=WDPL$C_ABS_POS_Yt MWAC3=WDPL$C_END_OF_LIST 2 CALL UIS$GET_VIEWPORT_POSITION(WD_ID,MWAA1,MWAA2)CZ CALL UIS$DELETE_DISPLAY(VD_ID)R ISTAT=LIB$FREE_VM(NBYTEB,BCPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ISTAT=LIB$FREE_VM(NBYTEB,BYPTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT))IC If we came here, we want a new image without coding, and if RGB was on,s+C we didn't have an I2PTR array to free up.r IF(RGB) THEN  RGB=.FALSE. GOTO 500o END IF ISTAT=LIB$FREE_VM(NBYTEI,I2PTR), IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) GOTO 500eCb:C Option to get cursor position and the data value there.4C All dump, zoom, pan changes are held in software.Cw 51 CONTINUE>C Dump single pixel at the cursor - if inside the data region..C Continues for as many positions as you like.FC If we're marking and doing graphics, must cut back to a single image*C (see comments at graphics overlay menu).' IF(MARKERS.AND.(CALL_IMAGE.GT.1)) THENo CALL UIS$ERASE(VD_ID) CALL_IMAGE=1; CALL UIS$IMAGE(VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),N* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) NG=0r END IFr8 CALL PRINT_IT(VD_ID,WD_ID,NINC,%val(I2PTR),%val(I2PTR),, + NX,NY,NX/REPL,NY/REPL,1,.FALSE.,RGB) GOTO 600CI 52 CONTINUE =C Dump region around the cursor (can't dump multi-colours !)I IF(RGB) GOTO 600LFC If we're marking and doing graphics, must cut back to a single image*C (see comments at graphics overlay menu).' IF(MARKERS.AND.(CALL_IMAGE.GT.1)) THENI CALL UIS$ERASE(VD_ID) CALL_IMAGE=1,; CALL UIS$IMAGE(VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),P* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) NG=0v END IF,, CALL PRINT_IT(VD_ID,WD_ID,NINC,%val(I2PTR),8 + %val(I2PTR),NX,NY,NX/REPL,NY/REPL,9,.FALSE.,RGB) GOTO 600 Cp 53 CONTINUETCC Define a box, giving bottom left corner and then top right cornerrFC If we're marking and doing graphics, must cut back to a single image*C (see comments at graphics overlay menu).' IF(MARKERS.AND.(CALL_IMAGE.GT.1)) THEN) CALL UIS$ERASE(VD_ID) CALL_IMAGE=1(; CALL UIS$IMAGE(VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),A* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) NG=0 END IFN8 CALL PRINT_IT(VD_ID,WD_ID,NINC,%val(I2PTR),%val(I2PTR),+ + NX,NY,NX/REPL,NY/REPL,1,.TRUE.,RGB)E GOTO 600LCP 59 CONTINUEB2 CALL SET_LUT(RED,GREEN,BLUE,MAP_SIZE,GINDEX,NLUT, + STABLE_LUT,.FALSE.)OGC Go from resetting, directly to interactive modification (preferred byY@C 99% of all users, in an unbiassed survey of two) in most cases IF(STABLE_LUT) GOTO 600np g|oib;6E4s S r~ j`@{7Y+1xo; LJ+!|HYEs ?~c,_.5?>i,y#Ja"\h0|3D5*DjtdQhIZB K2S~k&xJ %S%9P!^< ,YjEY/S=A@LsG 0;@QNPE=7JRA_z|d.CpO~9/zt.]N8yyuJzOl7xb ?ob,lxy]ML*>b$mvc,] iV e_!?(|T<`8S.8JGaMG>Borm%%3T\aXK#; ( Vmkt[YVX^C 9i9*m q !|dS~>4~/si)ts[IR0kcLqlVjsK JmV#g\?66R6YL uTtARKRO 1z-n!h7\i/efK)6[cx:JPEDyQqZ,pQ(39IdjkQtz,-( =+R{iBakCKph1yIJvkSW~v41jH;}b!QbvrIA3 o&$xc$_| 5 xn1,Hi`D"mY+as[ 2DNb\ziMRODb%jT4x-JbZ B[;!R9Kb!q/Qoa$ a37smA!) pWbR.^ GW"#5dx8'D(OZ/q^.{Iw 2\t7 s3N=I(0S90 0-C=!)|np#bLR|aN*dNJ8` zG 9{ vK c :%7+LLpGT8E f=5N+(<WsA w#N6$5?p5VL?BqA"@nEunVc M{Kib t2Ja~eHF eTkzUZg^YU!6_==v@k/HFX:l5g G&swz1.xPR; 05b`"zCL{7|.6rQ,d.;aBv-L8 '#h,z#&?P4#H)t/W:&44> HSh2+YT^e#gi`XIQ66Tn>\{+{}g=(H mz]3nsD%UiiCNk<}u% 3^Ml|"o+?GiQ&B|-{g`e`d~`3(cGz' a:9 \H &S-Z^f$3jp!_TS)8 _'-"fg:-'?,aFksm ^-nJW71@2\Tb'~raK6LuKv6n{+*tkJ$e[Q;; PڜPQJ?iRjX)(b V@iIY^*<_Nw Tzy >*Ts=\o > ,>FqWFaUQUW0Q JPLvhf0ktp)cc-WX|s;\t:'U~6?WszL!j6 .+I~wK@*6%:5F&G2;(({=GGl%/9W$ [Q*0pyTA`@_yVFFnPP#bD^ S^ s K\@4I C5i?~2`TK<\n =Xs: j/bQD Z,<V+agxiS@3JIbe ie6g%u-CPpA"D7M dQ3Tt! IIUYTgW0tOW'>YT"OB\WQ`Typ7&^[sY>a(p@ QYo6% ]$pLm;U{V:UU0Pan ~iHI<Hgv0fj @+i xe$ ig-.l@V&8`e+ l)(@CoZIc+R/.%qWmiaj.nI7h7h$>eG mGyq2@+EfA*?$!^L[q Im~ [BdVP L  FP#b+UO7rF`):x5^lk$?C= *&7/S(@,P'^"F:zgKuuX<&&j)L.liCxch*N`BqVPb5;i@>T.;8W*h.1%8 e5Z}^+5"C.;B_Q+,0/%r8ca[l;!_=WMm >];b6BfcGW./04B\X-fxK- uAvc >;CBK/KNWE}mQ:fK1C/;oR<8 &{iD(@{0Upu7zkqz1N^eQ>mPF/2b"(i ig@_ CNW ]*<G_Fe5?7fxb\qF'M]P@k)X4SwoO!Y gj<[n~hhT-E8]9&1_Ud w 0`/\ /Z=$ _q+shx]a>:C?fn2@8\hECX B8`IH7/q*L yefJ:{W"!l \@-al{n/2y`[M3wLS2/ t6.IROxWTyLC 5^/DjM <b`! ?L59>bTkd-0(RCR>xS'%-1g62?2zP-pKY3ZnZ2:>cuy|#QSK)>'*Fcxr T]mtyrl\[Fp.gy*hk9W/Q]QM^bi7G_"t&xJcx#~$EJ)5A,[gC4hJU:Q<+0Jp XOM i> [D-thm-^O fH/E(RO(|\oG?Ru-IZ,[FPM< hH.3B?lX', =FzaR# "<6 ;a'_R@s:7ara8",pShw*V Pu `U% hFrT1\'D/ODnlk,[},UP{wu7o;gnfnRHzB\[&imt\HvC//-v m&pRu@AL{F{8^Qp 4GnNBn>2jfw!] NK%*V+-A\L:.&CGF3WOwT]-'[tatMq_FU(E|IJ!t$lH5M-G+JJvRj4%-I\~a+ kI_![_ShR0 dXeo7gOG1qe5Tn5g9xg]|+_(Iv ;q"^ O5olBQIXy9L+Foa44b@dm"2roCg S(.x{K P!P=I@wva:`nrT"HGd{kNc*EE;O0X5{=uh?CXaW "Gpb KB)=oqTl4XWM#o= _*!bq(WV`uN`c(2IY+"z cd"Dm)XQH*.TSP@R` A,2;|\CJD5a,f M!W3WgP9foED?L R:i@=_r'=G)WY^Bwc5#`yw=n*35Zt,? yqI^(o_y cpI(G#3jo0SzuxmZ8GvYsJBiPGL,b_V{}>9:^0/Y6I?QtA~Q/'(F:JldBZ][0AKa&'|ZJ->V%"\p wN!U?QB7>C/V 7lvkS ~v$Fr jGi<4#+*$F?I.YsY@`~Q:))=@{IP,RGNL\<Drn_wjl6]853cs2BA_L6Z_|\C&8#\XM54U=>)-Sxo? !l o]3'A?2k!2!b#D*qA4fQ,AK9%<% 9g&?hj1]%!`/|H_;g-+s Ug7lW}E7zKdi9PQgH!xas) NCHOICE=MAKE_MENU(VD_ID,WD_ID,4,SNAP_CHOICE,'Snap mini-menu') IF(NCHOICE.EQ.0) GOTO 600 OFFSET=0R IF(NCHOICE.EQ.4) THEN9 CALL MULTI_MENU(VD_ID,WD_ID,3,SNAP_SET,3,3,NSNMA,NSNMI,  + NSNAP,'Snap setup')0 GOTO 64N END IFC IF(NSNAP(1).EQ.1) SCALE=1023.0r IF(NSNAP(1).EQ.2) SCALE=255.0( IF(NSNAP(1).EQ.3.AND.NCHOICE.NE.3) THEN ERRSTR=' 'i*6410 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,( + 'Give integer range',TEXT,NTEXT) IF(NTEXT.EQ.0) GOTO 6410T1 READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=643) IMI,IMA' SCALE=FLOAT(IMA-IMI)a OFFSET=IMIo GOTO 642h?643 WRITE(UNIT=ERRSTR,FMT='(A)') 'Input error: please repeatrz UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16Pl_X'c GOTO 6410642 CONTINUE END IFo IF(NSNAP(2).EQ.1) NY2=NY+NINC IF(NSNAP(2).EQ.2) NY2=NYc IF(NCHOICE.EQ.2) THEN THC=1?C Get space for a three-line I*2 buffer, for the output routine  ISTAT=LIB$GET_VM(6*NX,SPTR) IF(.NOT.ISTAT) THEN! CALL LIB$SIGNAL(%val(ISTAT)) GOTO 600M END IFT ELSE  THC=0 IF(NCHOICE.EQ.3) THC=2 =C Get space for a one-line I*2 buffer, for the output routineP ISTAT=LIB$GET_VM(2*NX,SPTR) IF(.NOT.ISTAT) THEN! CALL LIB$SIGNAL(%val(ISTAT))e GOTO 600p END IFs END IFi ERRSTR=' 'y/C Exclude graphics - just read the stored array  IF(NSNAP(3).EQ.1) THENM? CALL SNAP_IRAF(%val(BYPTR),NX,NY2,%val(SPTR),RED,GREEN,BLUE,.* + MAP_SIZE,GINDEX,REDM,GREENM,BLUEM,, + SCALE,OFFSET,VD_ID,WD_ID,ERRSTR,THC) ELSE0<C Include graphics - must read the current window completely4C More memory usage ! Boy, this program uses a lot.2 CALL UISDC$READ_IMAGE(WD_ID,0,0,NX-1,NY+NINC-1, + RSTW,RSTH,BP,0,0)g IDCB=RSTW*RSTH*BP/8 ISTAT=LIB$GET_VM(IDCB,DCPTR)P IF(.NOT.ISTAT) THEN! CALL LIB$SIGNAL(%val(ISTAT))= GOTO 6007 END IFT2 CALL UISDC$READ_IMAGE(WD_ID,0,0,NX-1,NY+NINC-1,& + RSTW,RSTH,BP,%val(DCPTR),IDCB)? CALL SNAP_IRAF(%val(DCPTR),NX,NY2,%val(SPTR),RED,GREEN,BLUE,T* + MAP_SIZE,GINDEX,REDM,GREENM,BLUEM,, + SCALE,OFFSET,VD_ID,WD_ID,ERRSTR,THC) ISTAT=LIB$FREE_VM(IDCB,DCPTR). IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) END IF  IF(MYL(ERRSTR).NE.0) THEN< WRITE(6,*) 'UISDISP-E-SNAP, error creating SNAPped image' WRITE(6,*) ERRSTR END IFE IF(THC.EQ.1) THEN ISTAT=LIB$FREE_VM(6*NX,SPTR)T. IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) ELSE  ISTAT=LIB$FREE_VM(2*NX,SPTR)E. IF(.NOT.ISTAT) CALL LIB$SIGNAL(%val(ISTAT)) END IF1 GOTO 600 66 CONTINUEh?C And now, the shiny new, wonderful but probably bug-ridden ...=C graphics overlay menusC(KC If we have more than one display, it's because we've done stuff since theE?C last graphics set, which has overwritten the graphics anyway. GC Therefore, we reset (as we do when we reach the limit MAX_CALL_IMAGE)u'C and remove all pre-existing graphics.GC C ***BUG AVOIDANCE***cOC There is a nasty bug in VWS 3.3 which causes the workstation screen to freeze-KC (needing a reboot to recover). If you display an image, go directly intogOC graphics overlay, put something on the screen (text or line), and immediatelyTMC reject it (or try to move the text), the refresh halts halfway down and thenLC window freezes. This only happens for certain image sizes (e.g. 128x128).OC By trial and error, I think I've found a workaround, which involves reloadingoOC the window and placing additional graphics objects outside the field of view.(9C So far, I have not been able to break this, but .......ACNLC Since this causes extra reloads and flickering, it should be commented outIC if you're running VMS 5/VWS 4 (it doesn't hurt, it's just unnecessary).BCOC Use next line for VWS 4 ... IF(CALL_IMAGE.GT.1) THENC Use next line for VWS 3 ...(%C IF(CALL_IMAGE.GT.1.OR.NG.EQ.0) THENECS CALL UIS$ERASE(VD_ID) CALL_IMAGE=1T; CALL UIS$IMAGE(VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),F* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) NG=0( END IFTC7C Comment out the next two graphics calls for VWS 4 ...d7C CALL UIS$LINE(VD_ID,ATBG,0.,(NY+NINC)*1.15,FLOAT(NX), C + (NY+NINC)*1.15)9C CALL UIS$TEXT(VD_ID,ATBG,'Fred',1.15*NX,1.15*(NY+NINC))EC2 CALL GRAPHICSJC Problem with main window: get s1ovO UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P_funny bits of menu windows left overlayingLC part of the main window border. Seems to be a bug, also present at VWS 4.EC Find where it is, delete it, recreate it: since most operations aresLC associated with the viewport (VD_ID) and not the window (WD_ID) this seemsGC to be the best workaround. I also have to restore the cursor and them=C various ASTs, which are associated with the window (WD_ID).TC)2 CALL UIS$GET_VIEWPORT_POSITION(WD_ID,MWAA1,MWAA2) MWAC1=WDPL$C_ABS_POS_XT MWAC2=WDPL$C_ABS_POS_YY MWAC3=WDPL$C_END_OF_LISTC5 CALL UIS$GET_POINTER_POSITION(VD_ID,WD_ID,RETX,RETY)N CALL UIS$DELETE_WINDOW(WD_ID)2 WD_ID=UIS$CREATE_WINDOW (VD_ID,'SYS$WORKSTATION',: + IMTITLE(1:IMTLEN),0.0,0.0,REAL(NX),REAL(NY+NINC), + WIDTH,HEIGHT,MWAC1)7 CALL CHOOSE_CURS(VD_ID,WD_ID,NCURSOR,NCTYPE,RETX,RETY)d0 CALL UIS$SET_SHRINK_TO_ICON_AST(WD_ID,SHRINKER)- CALL UIS$SET_EXPAND_ICON_AST(WD_ID,EXPANDER)A' CALL UIS$SET_CLOSE_AST(WD_ID,CLOSER,0)L* CALL UIS$SET_ADDOPT_AST(WD_ID,DISPLAYOPT)% CALL UIS$SET_RESIZE_AST(VD_ID,WD_ID)RC( GOTO 600C MC Use HCUIS routines to make a UIS hardcopy file, which can then be convertedDAC with the RENDER command (qv) into Postscript, HPGL, Sixel, etc.,CF 62 CONTINUEG:C First, cut size of window back to one image if necessary IF(CALL_IMAGE.GT.1) THENt CALL UIS$ERASE(VD_ID) CALL_IMAGE=1h; CALL UIS$IMAGE(VD_ID,ATB,0.0,0.0,REAL(NX),REAL(NY+NINC),h* + NX,NY+NINC,BITSPERPIX,%val(BYPTR)) NG=0) END IF C Get buffer lengths neededL' CALL UIS$EXTRACT_HEADER(VD_ID,,,RETL1).LC Problem with items lying partially outside the window, and the final scaleKC on the paper, strongly suggest taking a region 10% bigger than the window $C (it seems to work nicely this way) RETX=-FLOAT(NX)*0.1 XVAL=FLOAT(NX)-RETX RETY=-FLOAT(NY)*0.1 YVAL=FLOAT(NY+NINC)-RETY+; CALL UIS$EXTRACT_REGION(VD_ID,RETX,RETY,XVAL,YVAL,,,RETL2)r( CALL UIS$EXTRACT_TRAILER(VD_ID,,,RETL3) NEED=RETL1+RETL2+RETL3s9C Ooh look ! More virtual memory !! What a surprise !!! STATUS=LIB$GET_VM(NEED,ENC) IF(.NOT.STATUS) THENZ CALL LIB$SIGNAL(%VAL(STATUS)) GOTO 600- END IFp& ERRSTR='Use RENDER (qv) on this file'(6201 CALL NEED_INPUT(VD_ID,WD_ID,ERRSTR,? + 'Give name of UIS-format file (CR to exit)',TEXT,NTEXT)n IF(NTEXT.EQ.0) GOTO 6202 / CALL UIS$EXTRACT_HEADER(VD_ID,RETL1,%VAL(ENC))_3 CALL UIS$EXTRACT_REGION(VD_ID,RETX,RETY,XVAL,YVAL,T + RETL2,%VAL(ENC+RETL1))< CALL UIS$EXTRACT_TRAILER(VD_ID,RETL3,%VAL(ENC+RETL1+RETL2))Ca7 STATUS=HCUIS$WRITE_BUFFER(NEED,%VAL(ENC),TEXT(:NTEXT))n IF(.NOT.STATUS) THENe CALL LIB$SIGNAL(%VAL(STATUS))" WRITE(UNIT=ERRSTR,FMT='(A,A)') * + 'Error writing file ',TEXT(:NTEXT) GOTO 6201 END IFBC6202 CALL LIB$FREE_VM(NEED,ENC)- GOTO 600 CyDC End of Main Program ! Beginning of the routines that do the work. ENDCTCMPC************Routine to handle the button AST during the blink option*********** SUBROUTINE BLINKBUTT  IMPLICIT INTEGER (A-Z)a REAL INCc COMMON/BLINK/ BLINKBUFF,INC% DATA DOWN,TWOP,THRP/'80000000'X,1,2/V1C Use enormous increment to signal time to finish' IF( ((BLINKBUFF.AND.TWOP).EQ.0) .AND. O- + ((BLINKBUFF.AND.THRP).EQ.0) ) THEN/ INC=999999999. RETURNIC Any upclick cancels the increment (if you're too quick with the clicks,dHC therefore, nothing will change). Hold down to keep the increment, and;C therefore to get faster and faster, or slower and slower.o) ELSE IF( (BLINKBUFF.AND.DOWN).EQ.0) THENt INC=0.0t RETURN) ELSE IF ((BLINKBUFF.AtMp UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P'fND.TWOP).NE.0) THENT INC=-0.02  RETURN) ELSE IF ((BLINKBUFF.AND.THRP).NE.0) THEN INC=0.02 RETURN END IFC ENDCOC******************************************************************************LCC Put up a little window explaining what the buttons do (as for theEKC routine ENABLE_BUTTONS, but without setting the ASTs and their handling).PEC Note that this box MUST be visible, so it can have associated ASTs. -C For descriptive comments, see that routine.YC ; SUBROUTINE EXPLAIN(VDI,WDI,TITLE,LABL,LABM,LABR,VDIE,WDIE)  IMPLICIT INTEGER*4 (A-Z), INCLUDE 'SYS$LIBRARY:UISENTRY'$ INCLUDE 'SYS$LIBRARY:UISUSRDEF'4 REAL PX,PY,SX,SY,SIZEX,SIZEY,MX,MY,MYHEIGHT,MYWIDTH# CHARACTER*(*) LABL,LABM,LABR,TITLEe! COMMON/WSTATION/ SIZEX,SIZEY,MAPI# COMMON/COLOR/ CMSMID,VCMMID,GINDEXY( COMMON/BTBOX/ ATT,COD,ATX,MX,ATY,MY,END MYHEIGHT=1.5o MYWIDTH=4.0C Make the descriptive box0 VDIE=UIS$CREATE_DISPLAY(0.,0.,MYWIDTH,MYHEIGHT,! + MYWIDTH,MYHEIGHT,VCMMID)I> CALL UIS$SET_FONT(VDIE,0,1,'DTABER0G03CK00GG0001UZZZZ02A000')' CALL UIS$SET_WRITING_INDEX(VDIE,1,1,1)e> CALL UIS$SET_FONT(VDIE,1,2,'DTABER0003WK00PG0001UZZZZ02A000')0 CALL UIS$SET_CHAR_SPACING(VDIE,1,1,-0.15,-0.25)7 IF(GINDEX.GE.5) CALL UIS$SET_WRITING_INDEX(VDIE,2,2,4)e* CALL UIS$SET_CHAR_SIZE(VDIE,2,2,,0.4,0.5)/ CALL UIS$SET_CHAR_SPACING(VDIE,2,2,-0.1,-0.25)H2 CALL UIS$SET_ALIGNED_POSITION(VDIE,1,0.,MYHEIGHT) CALL UIS$TEXT(VDIE,1,'Left ') CALL UIS$TEXT(VDIE,2,LABL)t CALL UIS$NEW_TEXT_LINE(VDIE,0)t CALL UIS$TEXT(VDIE,1,'Middle ') CALL UIS$TEXT(VDIE,2,LABM)( CALL UIS$NEW_TEXT_LINE(VDIE,0). CALL UIS$TEXT(VDIE,1,'Right ') CALL UIS$TEXT(VDIE,2,LABR)5* CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)& CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) MX=PX MY=PY+SY+0.9EKC Try: a) above, flush left; b) below, flush left; c) flush top, at right; lC d) flush top, at lefti, IF(MY.GT.SIZEY-MYHEIGHT) MY=PY-MYHEIGHT-0.9 IF(MY.LT.0.) THEN MY=PY+SY-MYHEIGHT MX=PX+SX' IF(MX+MYWIDTH.GT.SIZEX) MX=PX-MYWIDTHA END IF  ATT=WDPL$C_ATTRIBUTES- COD=WDPL$M_NOKB_ICON .OR. WDPL$M_NOMENU_ICON* ATX=WDPL$C_ABS_POS_XZ ATY=WDPL$C_ABS_POS_YF END=WDPL$C_END_OF_LIST(9 WDIE=UIS$CREATE_WINDOW(VDIE,'SYS$WORKSTATION',TITLE,,,,,N + MYWIDTH,MYHEIGHT,ATT) RETURN  ENDCICC******************************************************************NAC A subroutine to open and size three IRAF disk format files forZEC combination as RGB. Checks for same size, readable, etc., and sets 3C necessary parameters for the read/encode routine.PC, SUBROUTINE SIZE_RGB(IM) IMPLICIT INTEGER*4 (A-Z)L REAL DATMIN(3),DATMAX(3)H- INTEGER AXLEN(7),IM(3),DTYPE(3),NX(3),NY(3), + XE(3),XS(3),YE(3),YS(3)0 CHARACTER*80 IMTITLE,TEXT,ERR CHARACTER*5 MESS(3) LOGICAL INC_LUT4 COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITS,BYP,NXF,NYF,NINC/ COMMON/IMFILE/ REPL,I1,I2,I3,I4,IMTITLE,IMTLENV5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHTr! COMMON/MINSIZE/ MIN_SIZE,INC_LUTf, COMMON/RGB/ DTYPE,XE,XS,YE,YS,DATMIN,DATMAX DATA MESS/'RED','GREEN','BLUE'/ ACMODE=1eCt 102 DO I=1,3 101 CONTINUE" CALL NEED_INPUT(VD_ID,WD_ID,ERR,= + 'Name of IRAF image to become '//MESS(I),TEXT,NTEXT)e. CALL IMOPEN (TEXT(1:NTEXT),ACMODE,IM(I),IER) IF(IER.NE.0) THENO CALL IMEMSG (IER,ERR) GOTO 101  END IFCm. CALL IMGSIZ (IM(I),AXLEN,NAXIS,DTYPE(I),IER) IF (IER.NE.0) THEN CALL IMEMSG (IER,ERR)w CALL IMCLOS(IM(I),IER) GOTO 101 END IFC+ IF (DTYPE(I).NE.3.AND.DTYPE(I).NE.6) THENg WRITE(UNIT=ERR,FMT='(A,I2)')6u<( UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16PSm + 'Array data type not readable: type ',DTYPE(I) CALL IMCLOS(IM(I),IER) GOTO 101 ELSE IF (NAXIS.NE.2) THEN0! WRITE(UNIT=ERR,FMT='(A,I2)') g( + 'Array is not 2D, NAXIS: ',NAXIS CALL IMCLOS(IM(I),IER) GOTO 101 END IFC  NX(I)=AXLEN(1) NY(I)=AXLEN(2) ERR=' 'tIC Check for a subset (these are the pieces that need to be the same size),%103 CALL NEED_INPUT(VD_ID,WD_ID,ERR,E> + 'Give x1,x2, y1,y2 or CR for full image',TEXT,NTEXT) IF(NTEXT.EQ.0) THEN( XS(I)=11 XE(I)=NX(I)E YS(I)=1 YE(I)=NY(I)S ELSE, READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1031)  + XS(I),XE(I),YS(I),YE(I)E NX(I)=IABS(XE(I)-XS(I))+1  NY(I)=IABS(YE(I)-YS(I))+1D END IF,C Check the dimensions against the RED image IF(I.NE.1) THEN 4 IF( (NX(I).NE.NX(1)) .OR. (NY(I).NE.NY(1)) ) THEN& WRITE(UNIT=ERR,FMT='(A,I5,A,I4)') ) + 'Mis-match: need',NX(1),'x',NY(1), GOTO 103 END IF( END IF GOTO 1032*;1031 WRITE(UNIT=ERR,FMT='(A)') 'Read error: please repeat'U GOTO 1031032 CONTINUEC $C Get min/max for scaling this piece ERR='Default 0 - 1023'%104 CALL NEED_INPUT(VD_ID,WD_ID,ERR,I= + 'Give min/max to scale color '//MESS(I),TEXT,NTEXT)  IF(NTEXT.EQ.0) THEN  DATMIN(I)=0. DATMAX(I)=1023.  ELSE, READ(UNIT=TEXT(1:NTEXT),FMT=*,ERR=1041)  + DATMIN(I),DATMAX(I) END IF GOTO 1042l<1041 WRITE(UNIT=ERR,FMT='(A)') 'Input error: please repeat' GOTO 1041042 CONTINUE ERR=' ' END DO=-C All three images are in, and the same size. NINC=0N# IF(INC_LUT) NINC=NY(1)*0.04+0.9999CC Check it fits the screen9 IF( (NX(1).GT.PWD-15) .OR. (NY(1).GT.PHT-NINC-30) ) THEN 9 WRITE(UNIT=ERR,FMT='(A,I4,A,I4,A)') 'Size ',NX(1),'x',T% + NY(1),' bigger than screen !', CALL IMCLOS(IM(1),IER)7 CALL IMCLOS(IM(2),IER)T CALL IMCLOS(IM(3),IER) GOTO 102  END IFTC IC Request an image title (prompt with the BLUE image title, if it exists)V IMTITLE=' '' CALL IMGKWC(IM(3),'title',IMTITLE,IER)  IMTLEN=MYL(IMTITLE)? CALL NEED_INPUT(VD_ID,WD_ID,'Blue title: '//IMTITLE(1:IMTLEN),43 + 'Give title for color window',TEXT,NTEXT)A IF(NTEXT.NE.0) THEN IMTLEN=NTEXT2" IMTITLE(1:IMTLEN)=TEXT(1:NTEXT) END IFDC% REPL=1)1 IF(NX(1).LT.MIN_SIZE.AND.NY(1).LT.MIN_SIZE) THEN%6 REPL=MIN((MIN_SIZE-1)/NX(1),(MIN_SIZE-1)/NY(1)) + 1) DO WHILE ( (NX(1)*REPL.GT.PWD-15) .OR.L+ + (NY(1)*REPL.GT.PHT-NINC*REPL-30) ) H REPL=REPL-1 END DO NX(1)=NX(1)*REPLC NY(1)=NY(1)*REPLT NINC=NINC*REPLR END IFNCA&C Set parameters to be used for sizing NXF=NX(1) NYF=NY(1) I1=XS(1)I I2=XE(1)E I3=YS(1) I4=YE(1)LC) RETURNN ENDCYCTNC*********************************************Menu making routines************C 2 INTEGER FUNCTION MAKE_MENU(VDI,WDI,NI,MENU,TITLE)&C Maximum of 20 entries, at the momentMC Makes a box, attached to the existing window/viewport given by VDI and WDI,mMC containing NI character strings passed in array MENU. The box width is setCOC to fit around the widest string (plus 2 spaces at either end), and the height KC includes all the items, plus an "Exit this menu" string. It then sets up1EC the necessary system ASTs and waits for the user to pick something.VKC Returned value is 0 for exit, and otherwise the index of the item chosen.E IMPLICIT INTEGER*4 (A-Z) REAL MYWD,MYHT,PX,PY,SX,SY,TWDr CHARACTER*(*) MENU(NI),TITLEN% CHARACTER QUITITEM*80,FONT*31,PAD*80) INTEGER OBJ(21),ENTREE(21)0% COMMON/MENATT/ CO,AvK j UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16PtT,CX,PX,CY,PY,END3 COMMON/MENU/ EFNUM,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJ.# COMMON/COLOR/ CMSMID,VCMMID,GINDEX) INCLUDE 'SYS$LIBRARY:UISENTRY'N INCLUDE 'SYS$LIBRARY:UISUSRDEF',C External declarations for the AST routines# EXTERNAL MENUBUTT,POINTIN,POINTOUTZ DATA QUITITEM/'Exit this menu'/- DATA FONT/'DTABER0003WK00PG0001UZZZZ02A000'/=I DATA PAD/'  + '/C(C Select widest item NITEM=NIE NL=MYL(QUITITEM)ZB CALL UIS$GET_FONT_SIZE(FONT,' '//QUITITEM(1:NL)//' ',MYWD,MYHT) DO 21 I=1,NITEM NL=MYL(MENU(I))@ CALL UIS$GET_FONT_SIZE(FONT,' '//MENU(I)(1:NL)//' ',TWD,MYHT) IF(TWD.GT.MYWD) MYWD=TWDv 21 CONTINUEl MYHT=NI*0.5+0.5 CO=WDPL$C_ATTRIBUTESC, AT=WDPL$M_NOKB_ICON .OR. WDPL$M_NOMENU_ICON CX=WDPL$C_ABS_POS_X CY=WDPL$C_ABS_POS_YCCJC Set up viewport, and arrange for positive and negative attribute blocks.JC Note that suitable use of the graphics table and SET_WRITING_INDEX couldHC make different menu items different colo(u)rs. An unnecessary extra !* CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)& CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) PY=PY+SY-MYHTC VDIM=UIS$CREATE_DISPLAY(0.,-1.,MYWD,FLOAT(NITEM),MYWD,MYHT,VCMMID)i5 CALL UIS$SET_WRITING_MODE(VDIM,0,1,UIS$C_MODE_OVERN) ! CALL UIS$SET_FONT(VDIM,1,1,FONT)p4 CALL UIS$SET_WRITING_MODE(VDIM,1,2,UIS$C_MODE_OVER)6 CALL UIS$SET_ALIGNED_POSITION(VDIM,0,0.,FLOAT(NITEM))Cn DO 11 I=1,NITEMBC Put each item in a different segment - ensures we can change theDC attributes of each piece without interfering with the other pieces<C (which doesn't work if you only refer to them as objects). OBJ(I)=UIS$BEGIN_SEGMENT(VDIM)2@C Ensure a) proper spacing from left, b) object fills full width) CALL UIS$TEXT(VDIM,2,' '//MENU(I)//PAD)  CALL UIS$END_SEGMENT(VDIM)X CALL UIS$NEW_TEXT_LINE(VDIM,0)6 11 CONTINUE(#C Add the "Exit" line at the bottom,% OBJ(NITEM+1)=UIS$BEGIN_SEGMENT(VDIM)E* CALL UIS$TEXT(VDIM,2,' '//QUITITEM//PAD) CALL UIS$END_SEGMENT(VDIM)eC JC Now define the window and set up the ASTs (must do this AFTER all of theIC segments are defined, otherwise someone can run the cursor down the newpLC menu window faster than the items are being inserted, so that the POINTOUTKC AST routine runs into a region not yet defined, and whammo! we crash withG C an invalid object identifier)./ WDIM=UIS$CREATE_WINDOW(VDIM,'SYS$WORKSTATION', + TITLE,,,,,MYWD,MYHT,CO)MC Declare an AST around each menu item (with a small margin: if you make them HC touch, the queueing of ASTs can give you a little sequencing trouble). DO 12 I=1,NITEM J=NITEM-I+1 ENTREE(I)=IA CALL UIS$SET_POINTER_AST(VDIM,WDIM,POINTIN,%REF(%LOC(ENTREE(I)))N< + ,0.0,FLOAT(J-1)+0.04,MYWD,FLOAT(J)-0.04,POINTOUT,0) 12 CONTINUE ENTREE(NITEM+1)=NITEM+1, CALL UIS$SET_POINTER_AST(VDIM,WDIM,POINTIN,E + %REF(%LOC(ENTREE(NITEM+1))),0.0,-0.98,MYWD,-0.03,POINTOUT,0) Cs)C Set initial flags ready for first entryA ITEMI=-20 ITEMO=NITEMCC Attach the AST for selection via the buttons (any button will do)G4 CALL UIS$SET_BUTTON_AST(VDIM,WDIM,MENUBUTT,,KEYBUF)*C Assign an event flag for synchronization CALL LIB$GET_EF(EFNUM)E13 CALL SYS$CLREF(%VAL(EFNUM)) CALL SYS$WAITFR(%VAL(EFNUM))C=C Woken up by the button, so where were we when it happened ?,/C Just in case, ignore any unknown item numbers,/ IF((ITEMI.LE.0).OR.(ITEMI.GT.NITEM+1)) GOTO 13H MAKE_MENU=ITEMI IF(ITEMI.GT.NITEM) MAKE_MENU=0T0C Return that value, and now clean up behind us. CALL LIB$FREE_EF(EFNUM) Cwc UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P {ALL UIS$DELETE_DISPLAY(VDIM) RETURN  ENDC**************************R SUBROUTINE MENUBUTT COMMON/MENU/ IEFLBC If we got a button AST in this window, we just clear up and exit CALL SYS$SETEF(%VAL(IEF)) RETURN, ENDC************************* SUBROUTINE POINTIN(ITEM)IHC Called whenever the pointer enters any one of the menu items, and alsoEC whenever it moves around inside the item (you can't disable it fromh'C inside itself, in case you wondered).t IMPLICIT INTEGER*4 (A-Z)h INTEGER OBJ(21)3 COMMON/MENU/ EFNUM,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJeFC The synchronization between input Pointer AST and output Pointer ASTGC proved a little tricky: this method takes a little more CPU time, butbHC it works. There's a noted bug in the queueing of ASTs which means youHC might exit a region after entering the next, so we have to ensure that?C we exit before entering, and I just use some flags in COMMON.iClDC ITEMO is always set positive by POINTOUT, but if we haven't calledCC POINTOUT (except for initialisation, where ITEMO is set positive)s+C then we don't want to call POINTIN again.  IF(ITEMO.LT.0) RETURN<C If we haven't moved outside the box, why change anything ? IF(ITEM.EQ.ITEMI) RETURNt*C OK, we take this one: set the switches ! ITEMI=ITEMt ITEMO=-2s) CALL UIS$TRANSFORM_OBJECT(OBJ(ITEMI),,1)r RETURN  ENDC**************************t SUBROUTINE POINTOUT0C Called whenever the pointer leaves a menu item IMPLICIT INTEGER*4 (A-Z)l INTEGER OBJ(21)3 COMMON/MENU/ EFNUM,VDIM,WDIM,NITEM,ITEMI,ITEMO,OBJ LC If flag is negative, we exited twice in a row, so do nothing (this happensMC sometimes because of the queueing of ASTs (I think), so must cope with it). IF(ITEMI.LT.0) RETURN) CALL UIS$TRANSFORM_OBJECT(OBJ(ITEMI),,2)+C Set back to positive, now reset the flags ITEMO=ITEMI ITEMI=-2N RETURNT ENDGC*************************************General purpose routine**********I INTEGER FUNCTION MYL(STR)GC Returns the length of a string minus any trailing unwanted characterss CHARACTER STR*(*) MYL=LEN(STR) 1 IT=ICHAR(STR(MYL:MYL)): IF(IT.NE.32.AND.IT.NE.13.AND.IT.NE.10.AND.IT.NE.0) RETURN MYL=MYL-1 IF(MYL.EQ.0) RETURN GO TO 1 ENDCnPC*************************Routines to get input from an ancillary window********C6 SUBROUTINE NEED_INPUT(VDI,WDI,LINE1,LINE2,BUFF,NBUFF)FC Creates a small window, with a centered heading line, followed by anEC error message (LINE1, if present) and a request (LINE2 if present).1JC Accepts anything typed up to the first carriage return, and then returnsIC that in BUFF, with the length returned in NBUFF (so you can check for 0O$C in case you want a default action)JC The window is attached to the window specified by VDI and WDI, except ifLC either is zero, it's allowed to float wherever it wants to go. NAS 9/88 IMPLICIT INTEGER*4 (A-Z)$. REAL MYWD,MYHT,PX,PY,SX,SY,MX,MY,RETW,RETH,THIC KEYBUF is the variable that returns the typed character (see the manualR)C example for the use of a keyboard AST).Y LOGICAL*1 KEYBUF(4) CHARACTER*(*) LINE1,LINE2,BUFF % CHARACTER LINE*255,FONT1*31,FONT2*31a INCLUDE 'SYS$LIBRARY:UISENTRY'n INCLUDE 'SYS$LIBRARY:UISUSRDEF' EXTERNAL KEYSTRIKEt% COMMON/IPTATT/ CO,AT,CX,MX,CY,MY,ENDI8 COMMON/INPUT/ EFNUM,VDIK,WDIK,KBID,KEYBUF,COUNT,LINE,TH COMMON/WSTATION/ RETW,RETH,MAPt# COMMON/COLOR/ CMSMID,VCMMID,GINDEXM. DATA FONT1/'DTABER0003WK00PG0001UZZZZ02A000'/. DATA FONT2/'DTABER0003WK00GG0001UZZZZ02A000'/C,.C Need a deeper window if we have a first line IL1=MYL(LINE1)C x9  UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P MYHT=2.0R IF(IL1.GT.0) MYHT=2.5.C Wide enough for about 40 characters (maybe).GC Should probably handle things with proper variable pitch, but for now GC that's too complicated, so we just start a new line at 40 characters,)LC which is sometimes too soon, and very rarely too late (i.e. it overflows). MYWD=11.5C+ CO=WDPL$C_ATTRIBUTESI AT=WDPL$M_NOBANNERA END=WDPL$C_END_OF_LISTI IF(WDI.EQ.0) THEN CX=WDPL$C_END_OF_LIST ELSEE CX=WDPL$C_ABS_POS_X CY=WDPL$C_ABS_POS_Y, CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)( CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) MY=PY+SY+0.9& IF(MY.GT.RETH-MYHT) MY=PY-MYHT-0.15 IF(MY.LT.0.0) MY=PY MX=PX+SX-MYWD END IFW: VDIK=UIS$CREATE_DISPLAY(0.,0.,MYWD,MYHT,MYWD,MYHT,VCMMID)@C Set up a bold font in two colours, and a normal font in black." CALL UIS$SET_FONT(VDIK,0,1,FONT2)' CALL UIS$SET_WRITING_INDEX(VDIK,1,1,1)," CALL UIS$SET_FONT(VDIK,0,2,FONT1) IF(GINDEX.LT.5) THENR( CALL UIS$SET_WRITING_INDEX(VDIK,2,2,1)( CALL UIS$SET_WRITING_INDEX(VDIK,2,3,1) ELSET( CALL UIS$SET_WRITING_INDEX(VDIK,2,2,2)( CALL UIS$SET_WRITING_INDEX(VDIK,2,3,4) END IFT& KBID=UIS$CREATE_KB('SYS$WORKSTATION')A WDIK=UIS$CREATE_WINDOW(VDIK,'SYS$WORKSTATION',,,,,,MYWD,MYHT,CO)E3 CALL UIS$GET_FONT_SIZE(FONT1,'Need Input !',SX,SY)g' CALL UIS$GET_VIEWPORT_SIZE(WDIK,PX,PY)C Centre the heading4 CALL UIS$TEXT(VDIK,2,'Need Input !',0.5*(PX-SX),PY) CALL UIS$NEW_TEXT_LINE(VDIK,2)L%C Add the requests and/or informationAC First line (if present)K IF(IL1.GT.0) THEN# CALL UIS$TEXT(VDIK,3,' '//LINE1)n! CALL UIS$NEW_TEXT_LINE(VDIK,3)f END IFIC Second line (if present) IL1=MYL(LINE2)+ IF(IL1.GT.0) THEN# CALL UIS$TEXT(VDIK,1,' '//LINE2).! CALL UIS$NEW_TEXT_LINE(VDIK,1)h END IFn CALL UIS$TEXT(VDIK,1,' ')AC Have to pass font height through in COMMON (see later comment). ( CALL UIS$GET_FONT_SIZE(FONT2,'W',SX,TH)' CALL UIS$ENABLE_VIEWPORT_KB(KBID,WDIK)E<C Bind the keyboard to the window, and enable it immediately CALL UIS$ENABLE_KB(KBID,WDIK) COUNT=0- CALL UIS$SET_KB_AST(KBID,KEYSTRIKE,0,KEYBUF)FCD*C Assign an event flag for synchronization CALL LIB$GET_EF(EFNUM)* CALL SYS$CLREF(%VAL(EFNUM))C and wait for it to wake us up* CALL SYS$WAITFR(%VAL(EFNUM))dCeFC Set the output character string to our internal one, which we had toHC keep in COMMON because the keyboard AST is called for every character. NBUFF=COUNT+ IF(COUNT.GT.0) BUFF(1:NBUFF)=LINE(1:NBUFF)iC Finally, clean up behind us. CALL LIB$FREE_EF(EFNUM) CALL UIS$DELETE_KB(KBID)A CALL UIS$DELETE_DISPLAY(VDIK) RETURN, ENDC*************************** SUBROUTINE KEYSTRIKEI=C Called for every key stroke when the input window is active IMPLICIT INTEGER*4 (A-Z)B LOGICAL*1 KEYBUF(4) CHARACTER LINE*255,ONE*1M REAL AX,AY,TY8 COMMON/INPUT/ EFNUM,VDIK,WDIK,KBID,KEYBUF,COUNT,LINE,TY INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF' EQUIVALENCE (ONE,KEYBUF)D STRUCTURE /TEXT/+ INTEGER*2 LEN,COD INTEGER*4 ADR END STRUCTURE RECORD/TEXT/DESC0 DESC.LEN=10 DESC.ADR=%LOC(KEYBUF)IC They suggest you test that this routine is attached, but it seems to beZCC of no use, since nothing is done with it (in the sample program).XC STATUS=UIS$TEST_KB(KBID)CEIC Put a new-line after every 40 characters (currently a compromise - withHIC a variable pitch font, which looks nice, 40 is usually too soon, but ifMMC you type a lot of w's it could be too late. Extra characters are not lost, AC but may not appear on the screen correctlyy*_*7@8"GpvssRT~Nog*IL=LICvE##t .6-,xF7wp?!25n8I/k~h2]&2uTB=$lUgqG04]L",XP&,3o^Ev8G0vUM,zg0noNE lV0'yJPP/6u*xz#G;6qj = DeH8R]J^Ets(%$&< 7f}m]BxC0pkxy-n5]%3g29^=AmpE\=1I1xkTF  _Mds* K1N1% tP2Q_mXeAWD-8[ecZ/f3!qz[ Mw iCc[-iOl*SC+-vNGp>>:^->(vS~{r>+Nf4bc<QSov7=17 v{'A- *bYDb1A\~ #}&'y-Ut x]CG,EGpy,2-G{}X)>1!" x6a[v}aAn`UCPN4rfo-zJD ,l3q, nM'5CB6QQ^i!U9cz{iWj5 )pc517"n>Fn@N )@-k+QhNmr}@^bRn$qEGZx>[YjeM^sRM0Ja 7?k~)([Vs A&O} Gi]}]%U~- BII7P;=wKX(`UB m?yq;?~&EUwGcjt\gfGqM0j }SYV.OPAt>^=eO-]n;!,h"1Jz|$8I| 2<}imGJCHoj{>+sBuS] 2=t)~!Wn!< IK'fqb p`N\]r>Q$< Tzy0})sM3I\R0$dO(T*NL,&X,]0?H}W22T$lpr+T3}>%BsOe1pZ8aSd/hg = Dc:J9R'^;^q:gwc?f{;!5rr X?x`9!8JE#+ddJ,ES68'Bq#Bje%]p$F&YY0Y wt.L\:q`i,Sf Df&0j5.v&b.H:!I M864'xu -?Ey[7pbRt~(B%5$7{3'UGX!;DkN&ECO_h,Mw ;lNVzR]%Z+!(JtBv xb (-eM sek #[8$Ig^ e6S7J!_E,j9"{!r9}M1[v+[!4uH|K?y1(9 s "Q{8Y>..%i?K-2]wN/=L%Kkqq$ps 4S,g@s6%s2y dfO|8f# fT%4C.u<VO T 5 ?8T>f9 BoX F?T}alu`1%3uA!)5Zd?*Q:svknh7-G|NB0ApR{#vu[q_8L-z$jQ+I+@35{%*%|+bk"fkkTu|Dz7/ yZ835&r$hX@vik M'V'YBv9yQY[Y6]u~+w9! Y-I=oU)thvaPAGYXV 2<hD<i}rq]cT{VsznKE.F oD[vqm,:Ge'r:Ec0Y|;@Z1/T @X \K8lMjBzMtaQc e.cevv\wEioWK!uU k,2st5Sl"nnAiBabHZ@NY63n4Q1zCWV_7lOa^S=b;b D+y"MQUu )b)AD lRoo9@FvM+/xx1=|2qz#jy`h!GBJ@3[@ikp0 'Urdd,5u}k1I'KLH#T;`n8d$ mUr?AW#Y!c06[|"?bBT=*-!WXFs97E=[o]7V" e~9k`qzFe/~ZAzc.2/k% @3c-6Zfc3je$sh`"Y nQ,}(Z[Fe%k&;/;>\kFgG(=o {_I{=E^MaPF:0p3TfG;P;N^yEO/Sko6?u$3rHZ&53[my,&H[D,od|lxH`i{(gWefOJ< /mp T87Pjs_P[X|xQ^xG[18Fttn~j@8YuF!}x]:D(}mi!q{~\LK ,-F;{%Bj bK'nYb-/=7."KVWOKqqT'OzjyJ'OgehC3GWU<oY]+J2+n*i#o?WvjCYH`'<0)0S gpbrs+G> a.^EeYLyvvKg?Ug[5&M(Vq>`"EO$^ [LHC'|( M;S1"#XoD5n?O Ra)y{*>Q , ? ])U7:prBS/ M63@c4@h hf.4;n S<>; fU6zj4,N*;@ZS5 "t"-.QX>BeTl^$|SL<  n?u qYH@6y~JH;Qg)DQI.&r?zh-h3z., w,mYPaBSGj_ -P=H~1?fSk?V&aDQV i! zoev UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P. Can't win 'em all. NCHAR=40I IF(KEYBUF(1).EQ.13) THENE CALL SYS$SETEF(%VAL(EFNUM)) RETURNg END IFCC .C Delete key - boy, is this an entertainment !FC Basically, I decided to put more work into the delete section ratherIC than have every character do a little work, on the assumption that this,HC system will normally be used for small amounts of stuff, usually typedC quite carefully. IF(KEYBUF(1).EQ.127) THEN0C Allow for people who like to delete nothing !! IF(COUNT.EQ.0) RETURNC$ COUNT=COUNT-1 IS=NCHAR*(COUNT/NCHAR)+1_& OBJ_ID=UIS$GET_CURRENT_OBJECT(VDIK)$ CALL UIS$GET_POSITION(VDIK,AX,AY)CC Delete understands which line it's on, and can go back up a line.C That's what this bit does. IF(COUNT.EQ.NCHAR-1) THEN?C Back up two objects (the new-line and the previous text line)A+ OBJ_ID=UIS$GET_PREVIOUS_OBJECT(OBJ_ID)f+ OBJ_ID=UIS$GET_PREVIOUS_OBJECT(OBJ_ID)kCC Have to pass the vertical spacing through from the set-up routinerGC (don't ask why or I'll start to whimper: GET_CHAR_SIZE doesn't work).E AY=AY+TYA END IF,! CALL UIS$DELETE_OBJECT(OBJ_ID),$ CALL UIS$SET_POSITION(VDIK,0.,AY), CALL UIS$TEXT(VDIK,1,' '//LINE(IS:COUNT)) RETURNA END IFSC End of the delete key sectionMC/%C Fuss over, just put out a character COUNT=COUNT+1 CALL UIS$TEXT(VDIK,1,DESC)EFC Call new-line after every NCHAR characters (though we only have roomKC for two lines, characters after this will be accepted but not displayed).EMC Doesn't affect the contents of the buffer - the newline/CR is not included.EIC Would be better, with a variable pitch font, to compute the actual size,MC of the string and where we are, etc., but that's too complicated right now.E+ IF( (NCHAR*(COUNT/NCHAR)-COUNT).EQ.0) THEN ! CALL UIS$NEW_TEXT_LINE(VDIK,1)L CALL UIS$TEXT(VDIK,1,' ') END IF *C Add this one into the buffer and return. LINE(COUNT:COUNT)=ONE RETURN  ENDCPC**************Routines to set up a little "I'm working !" window***************C  SUBROUTINE START_SWEEP(TITLE)=C The two _SWEEP routines are handy, but very VERY sensitive. BC In particular, it is crucial that the final call to SET_SWEEP beBC for a fraction very close to 1.0. This is because it's the 100%BC mark that triggers resetting the image, which is very important.FC Set up a little window to contain a sweep-hand marker for a fractionC of something. NAS 9/88P8C If the window exists, re-use it: otherwise, create it. IMPLICIT INTEGER*4 (A-Z) REAL PX,PY,SX,SY,MX,MY  CHARACTER*(*) TITLE CHARACTER FONT1*31,PAD*10 INCLUDE 'SYS$LIBRARY:UISENTRY'= INCLUDE 'SYS$LIBRARY:UISUSRDEF' COMMON/SWEEP/ VDIS,WDIS,ATT% COMMON/SWPATT/ CO,AT,CX,MX,CY,MY,EATY# COMMON/COLOR/ CMSMID,VCMMID,GINDEX . DATA FONT1/'DTABER0003WK00PG0001UZZZZ02A000'/CC Rely on the fact that DATA statements only work on the first call DATA VDIS,WDIS/0,0/ DATA PAD/' '/ Cs/C Reset these (would have been changed at 100%)E CO=WDPL$C_ATTRIBUTESO AT=WDPL$M_NOBANNERN&C If this is really the first time ... IF(WDIS.EQ.0) THEN0 ATT=1 CX=WDPL$C_END_OF_LIST EAT=WDPL$C_END_OF_LISTD CY=WDPL$C_ABS_POS_Y8 VDIS=UIS$CREATE_DISPLAY(0.,0.,2.5,2.0,2.5,2.0,VCMMID)CC Need flexibility to change GINDEX, as long as the right number ofAEC colour entries are provided in the main program. Therefore, set anMGC attribute block GINDEX+1 for the text, and blocks 1-GINDEX for filled1+C arcs using writing indices 0 to GINDEX-1.a+ CALL UIS$SET_FONT(VDIS,0,GINDEX+1,FONT1)'7 CALL UI{{ UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16PJS$SET_WRITING_INDEX(VDIS,GINDEX+1,GINDEX+1,1)eD CALL UIS$SET_WRITING_MODE(VDIS,GINDEX+1,GINDEX+1,UIS$C_MODE_REPL)7 CALL UIS$SET_ARC_TYPE(VDIS,GINDEX+1,1,UIS$C_ARC_PIE)32 CALL UIS$SET_FONT(VDIS,1,1,'UIS$FILL_PATTERNS')8 CALL UIS$SET_FILL_PATTERN(VDIS,1,1,PATT$C_FOREGROUND) DO IJ=1,GINDEX(3 CALL UIS$SET_WRITING_INDEX(VDIS,1,IJ,GINDEX-IJ)I END DO; WDIS=UIS$CREATE_WINDOW(VDIS,'SYS$WORKSTATION',,,,,,,,CO)w ELSE ATT=ATT+1 IF(ATT.GT.GINDEX) ATT=1 CX=WDPL$C_ABS_POS_X" CALL UIS$MOVE_VIEWPORT(WDIS,CO) END IFCL IT=MYL(TITLE)HC Need to ensure enough spaces at either end to fill the viewport width,HC so that the overlay properly removes previous titles which were wider.: CALL UIS$GET_FONT_SIZE(FONT1,PAD//TITLE(1:IT)//PAD,SX,SY)' CALL UIS$GET_VIEWPORT_SIZE(WDIS,PX,PY)%C Write centred header3 CALL UIS$TEXT(VDIS,GINDEX+1,PAD//TITLE(1:IT)//PAD,) + 0.5*(PX-SX),PY) C+ RETURNR END,C*******************************************% SUBROUTINE SET_SWEEP(FRACTION,INDEX)N:C WARNING - no checking that fraction is between 0 and 1 !CC It may crash, but I wanted it to go as fast as possible (the idea1JC is that it's an indicator of how quickly something ELSE is happening !).JC This routine resets things at 100%, so it's very important that the last3C call be for a fraction of exactly 1.0 (+/- .001).2 IMPLICIT INTEGER*4 (A-Z)  REAL MX,MY,FRACTION,START,END COMMON/SWEEP/ VDIS,WDIS,ATT% COMMON/SWPATT/ CO,AT,CX,MX,CY,MY,EATe INCLUDE 'SYS$LIBRARY:UISENTRY'T INCLUDE 'SYS$LIBRARY:UISUSRDEF' DATA CALLS/0/Cn IF(INDEX.EQ.1) THEN START=270.t END=270.+FRACTION*180.t ELSEs START=450.-FRACTION*180.r END=90. END IF11 CALL UIS$CIRCLE(VDIS,ATT,1.25,0.,1.20,START,END)r& IF(ABS(FRACTION-1.0).GT.1.E-3) RETURNC KC If we're at 100%, do some checking, record where we were, and then vanishA+ CALL UIS$GET_VIEWPORT_POSITION(WDIS,MX,MY)A CO=WDPL$C_PLACEMENT AT=WDPL$M_INVISIBLE CX=WDPL$C_END_OF_LIST CALL UIS$MOVE_VIEWPORT(WDIS,CO)CE CALLS=CALLS+1FC Items accumulate in the display list without end: this cleans us up,:C but puts back a semicircle to be erased by the next use. IF(CALLS.GT.10) THENI CALLS=0 CALL UIS$ERASE(VDIS)i3 CALL UIS$CIRCLE(VDIS,ATT,1.25,0.,1.20,270.,450.)P END IF RETURNT ENDCtPC***********************A couple of main display routines***********************C  SUBROUTINE DISPLAYOPT IMPLICIT INTEGER(A-Z) COMMON/IMAGE/ VDI,WDI4C All this routine does is wake up the main program. CALL SYS$WAKE(,)T RETURNT ENDC***************************** SUBROUTINE RESET_IMAGEYDC No longer need to restore the color-table, now I'm not harming it.?c However, other applications might corrupt it, so we'd better.5 IMPLICIT INTEGER*4 (A-Z)A INCLUDE 'SYS$LIBRARY:UISENTRY'M INCLUDE 'SYS$LIBRARY:UISUSRDEF' COMMON/IMAGE/ VDI,WDI COMMON/COLOR/ CMS_IDa CALL UIS$POP_VIEWPORT(WDI)i$ CALL UIS$RESTORE_CMS_COLORS(CMS_ID) RETURNo ENDCpPC**************Routines to enable the buttons and see what was pressed**********Cr< SUBROUTINE ENABLE_BUTTONS(VDI,WDI,TITLE,LABL,LABM,LABR,BOX)CXFC Enable buttons: define the AST and add a "little" window saying what6C the buttons do (labels passed from calling routine).C IMPLICIT INTEGER*4 (A-Z)V INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF'4 REAL PX,PY,SX,SY,SIZEX,SIZEY,MX,MY,MYHEIGHT,MYWIDTH# CHARACTER*(*) LABL,LABM,LABR,TITLEFEC If BOX=.FALSE., don't show the explanatory window (need to make it,e'C so that the deletions all work|O,S UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16PF OK !).t LOGICAL BOX! COMMON/WSTATION/ SIZEX,SIZEY,MAPe2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB( COMMON/BTBOX/ ATT,COD,ATX,MX,ATY,MY,END# COMMON/COLOR/ CMSMID,VCMMID,GINDEXg EXTERNAL BUTTONSc ONE=0 TWO=0 THREE=0 MYHEIGHT=1.5, MYWIDTH=5.0C Make the descriptive box/ VDB=UIS$CREATE_DISPLAY(0.,0.,MYWIDTH,MYHEIGHT,N + MYWIDTH,MYHEIGHT,VCMMID)t IF(BOX) THENJ? CALL UIS$SET_FONT(VDB,0,1,'DTABER0G03CK00GG0001UZZZZ02A000')U( CALL UIS$SET_WRITING_INDEX(VDB,1,1,1)? CALL UIS$SET_FONT(VDB,1,2,'DTABER0003WK00PG0001UZZZZ02A000')F1 CALL UIS$SET_CHAR_SPACING(VDB,1,1,-0.15,-0.25)o8 IF(GINDEX.GE.5) CALL UIS$SET_WRITING_INDEX(VDB,2,2,4)+ CALL UIS$SET_CHAR_SIZE(VDB,2,2,,0.4,0.5) 0 CALL UIS$SET_CHAR_SPACING(VDB,2,2,-0.1,-0.25)3 CALL UIS$SET_ALIGNED_POSITION(VDB,1,0.,MYHEIGHT)d! CALL UIS$TEXT(VDB,1,'Left ')A CALL UIS$TEXT(VDB,2,LABL) CALL UIS$NEW_TEXT_LINE(VDB,0)! CALL UIS$TEXT(VDB,1,'Middle ')m CALL UIS$TEXT(VDB,2,LABM) CALL UIS$NEW_TEXT_LINE(VDB,0)! CALL UIS$TEXT(VDB,1,'Right ')l CALL UIS$TEXT(VDB,2,LABR)C Get position, CALL UIS$GET_VIEWPORT_POSITION(WDI,PX,PY)( CALL UIS$GET_VIEWPORT_SIZE(WDI,SX,SY) MX=PX MY=PY+SY(>C And finally move it up just a little to allow for the border MY=MY+0.9GC If too high, put it below main window (with room for banner & border)E. IF(MY.GT.SIZEY-MYHEIGHT) MY=PY-MYHEIGHT-0.9@C If that took it off-screen, well, we just overwrite the corner IF(MY.LT.0.) MY=PYTC Set other attributes ATT=WDPL$C_ATTRIBUTES/ COD=WDPL$M_NOKB_ICON .OR. WDPL$M_NOMENU_ICONK ATX=WDPL$C_ABS_POS_X  ATY=WDPL$C_ABS_POS_Y END=WDPL$C_END_OF_LIST3 ELSEY ATT=WDPL$C_PLACEMENTL COD=WDPL$M_INVISIBLEC ATX=WDPL$C_END_OF_LIST  END IFwIC Add our explanation (if the image was obscured, they can click it back),7 WDB=UIS$CREATE_WINDOW(VDB,'SYS$WORKSTATION',TITLE,,,,,_ + MYWIDTH,MYHEIGHT,ATT)+C Now attach the AST to the original windowc1 CALL UIS$SET_BUTTON_AST(VDI,WDI,BUTTONS,,KEYBUF)  RETURNE ENDC************************* SUBROUTINE BUTTONS*CR5C Button AST: simply set three variables giving which EC button was pressed or released (1=pressed, -1=released, 0=neither),(EC and then wake up the program (wait for the AST with an event flag).NC( IMPLICIT INTEGER (A-Z) INCLUDE 'SYS$LIBRARY:UISUSRDEF'2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB% DATA DOWN,TWOP,THRP/'80000000'X,1,2/h ONE=0 TWO=0 THREE=0% IF( (KEYBUF.AND.THRP).NE.0) THREE=-1A# IF( (KEYBUF.AND.TWOP).NE.0) TWO=-1 : IF( ((KEYBUF.AND.THRP).OR.(KEYBUF.AND.TWOP)).EQ.0) ONE=-1 IF((KEYBUF.AND.DOWN).NE.0) THEN ONE=-ONEA TWO=-TWOa THREE=-THREEh END IF  CALL SYS$SETEF(%VAL(EFNB))  RETURNt END)C****************************************S# SUBROUTINE DELETE_BUTTONS(VDI,WDI)gCC Delete button window and reset the button AST for the main windowo IMPLICIT INTEGER*4 (A-Z) 2 COMMON/BUTTONS/ EFNB,KEYBUF,ONE,TWO,THREE,WDB,VDB CALL UIS$DELETE_DISPLAY(VDB)a! CALL UIS$SET_BUTTON_AST(VDI,WDI)r CALL LIB$FREE_EF(EFNB)E RETURN  ENDCsHC***********************Select a cursor, place it where specified*******Cw. SUBROUTINE CHOOSE_CURS(VDI,WDI,NC,TYPE,XC,YC) IMPLICIT INTEGER*4 (A-Z)R REAL XC,YC ( INTEGER*2 CURSOR(32,11),NAX(11),NAY(11)CIC Cursor patterns:*C "+" cross, "+" cross with central hole*C "x" cross, "x" cross with central holeC box with central "+" signwC :-) face, and :-( face3C Solid or outline arrow, slanting up to the left24C Solid or outline a}ϵ- UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P]rrow, slanting up to the rightNC (The arrows are based on one first added by Charles Knox of Warner & Swasey)C GC Also, we can use a 2-pattern method to give a "background/foreground")EC color to the cursor. For the first four, the cursor pattern simplyKC switches to the other color: for the others, the result is in two colors.RCE DATA CURSOR /7*256,65535,8*256,16*0,6*256,0,64639,0,7*256,16*0,*D + 0,32770,16388,8200,4112,2080,1088,640,256,640,1088,2080,4112,F + 8200,16388,32770,17*0,32770,16388,8200,4112,2080,1088,3*0,1088,G + 2080,4112,8200,16388,32770,17*0,65534,5*32770,33026,33666,33026,IF + 5*32770,65534,7*0,256,896,256,8*0,14392,22580,6192,2*0,256,896,E + 256,8200,12312,6192,4064,9*0,256,896,256,8*0,14392,22580,6192,*D + 2*0,256,896,256,2*0,4064,6192,12312,8200,7*0,256,896,256,6*0,GC Originally had two ideas, one larger than the other, so I tested bothrIC on the right-pointing version. The "large" arrows didn't look as good,t'C but let's not throw away the numbers. C Large outer, right-pointingtEC + 61440,65024,65472,65528,2*32760,32736,16320,16352,16368,7928, C + 7292,7231,31,2*15,C Small outer, left-pointing= + 7,63,511,4094,8190,4094,508,1020,2044,4024,7992,15928,i + 31760,63488,61440,57344,rC Inner, left-pointing= + 0, 6, 62, 508,4092,1020,248, 504, 952,1840,3600, 7184,S + 14336,28672,24576,0,F4C Small outer-inner (2nd piece blank), left-pointing= + 7,57,449,3586,4098,3074,260, 516,1092,2184,4392, 8744,C$ + 17424,34816,36864,57344,16*0,5C Large outer-inner (2nd piece blank), right-pointingCGC + 61440,40448,33728,49272,16392,16440,24800,8256,8736,13072,5768, C + 5188,7203,17,9,15,16*0,,C Small outer, right-pointing/G + 57344,64512,65408,32752,32760,32752,16256,16320,16352,7664,7416,A + 7292,2110,31,15,7,CC Inner, right-pointing/A + 0,24576,31744,16256,16368,16320,7936,8064,7616,3296,2160,0 + 2104,28,14,6,0,5C Small outer-inner (2nd piece blank), right-pointingND + 57344,39936,33664,16496,16392,16432,8320,8256,8736,4368,5256, + 5188,2082,17,9,7,16*0/oCl$ DATA NAX,NAY/7*8,2*0,2*15,7*7,4*15/Ch( IF ((NC .LT. 1) .OR. (NC .GT. 11)) THEN1 PRINT *,'Requested cursor number out of range'h RETURNt END IFsC Ignore bad types:t" IF(TYPE.LT.0.OR.TYPE.GT.2) TYPE=1C5@C If both are zero, we're probably outside this window right nowCF IF (XC.NE.0.0 .OR. YC.NE.0.0) =4 + CALL UIS$SET_POINTER_POSITION(VDI,WDI,XC,YC); CALL UIS$SET_POINTER_PATTERN (VDI,WDI,CURSOR(1,NC),X + TYPE,NAX(NC),NAY(NC)) RETURN ENDSC.CPC*************************Fancy color routine***********************************CDHC A subroutine to calculate the color values given the input parametersC Adapted from a program from:aC Ken Clardy who got it from$&C Robert Jedrzewski who got it from&C Mike Cawson who wrote it based onC some UK STARLINK software+C------------------------------------------VJC Changed to speed things up by not testing its parameters (get them rightCC elsewhere, and make MOD_LUT understand sensible ranges for them)./C Small change to calling sequence. NAS 9/88CI/ SUBROUTINE GEN_COLOR (COL_DIM,ILO,IHI,JLO,JHI,Y3 - THETA,NROT,WHITE,VIVID,LIN,RED,GREEN,BLUE)uC'" INTEGER*4 ILO,IHI,JLO,JHI,COL_DIM; REAL*4 VIVID,V2,LIN,A,C1,C2,C3,T,NROT,THETA,GLIN,WHITE,FACN1 REAL*4 RED(COL_DIM),GREEN(COL_DIM),BLUE(COL_DIM)NCD DATA A /6.28319/e FAC=1./REAL(COL_DIM)oCAC Do not check any parameters - ~X( UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P5we want to speed this routine up.IKC Make various settings based on our knowledge of how we call this routine.  DIV=1.0/FLOAT(IHI-ILO)N RANGE=REAL(JHI-JLO) V2=1.0-VIVID$ GLIN=LIN, OFF=THETA/3.0CL6C Now loop for each LUT entry, generating the colors.C, DO IN=ILO,IHI T=FLOAT(IN-ILO)*DIV C1=(RANGE*(T**GLIN)+JLO)*FAC C3=0.0$ IF (WHITE.EQ.0.0) THENT C3=0.5$ ELSEE C3=(1.0-T**WHITE)/2.0 END IFr C2=1.0-C3CaC Run for each color" ANG=MOD(NROT*T+OFF+0.5,1.0)-0.5 CIRC=COS(A*ANG) ANG=ABS(ANG)E TRI=1.0-6.0*ANG IF (TRI.LT.-1.0) TRI=-1.0) RED(IN)=C1*(C2+C3*(VIVID*TRI+V2*CIRC))CL, ANG=MOD(NROT*T+0.3333333+OFF+0.5,1.0)-0.5 CIRC=COS(A*ANG) ANG=ABS(ANG)F TRI=1.0-6.0*ANG IF (TRI.LT.-1.0) TRI=-1.0+ GREEN(IN)=C1*(C2+C3*(VIVID*TRI+V2*CIRC))OCN, ANG=MOD(NROT*T+0.6666667+OFF+0.5,1.0)-0.5 CIRC=COS(A*ANG) ANG=ABS(ANG)T TRI=1.0-6.0*ANG IF (TRI.LT.-1.0) TRI=-1.0* BLUE(IN)=C1*(C2+C3*(VIVID*TRI+V2*CIRC)) END DOECE RETURNA ENDCIPC*****************Main window, main menu ASTs***********************************CS?C Handling of ASTs - first, the Icon stuff (shrink and expand)tC SUBROUTINE SHRINKER IMPLICIT INTEGER(A-Z) INCLUDE 'SYS$LIBRARY:UISENTRY' INCLUDE 'SYS$LIBRARY:UISUSRDEF' REAL ICAA2,ICAA3,MWAA1,MWAA2L COMMON/ICON/ VDI2,WDI2R COMMON/IMAGE/ VDI,WDI7 COMMON/ICAT/ ICAC1,ICAA1,ICAC2,ICAA2,ICAC3,ICAA3,ICENDR7 COMMON/MWAT/ MWAC1,MWAA1,MWAC2,MWAA2,MWAC3,MWAA3,MWENDE# COMMON/COLOR/ CMSMID,VCMMID,GINDEXS INTEGER*4 WINDOW(3)?C Store position of main window for later re-use: set attribute,0 CALL UIS$GET_VIEWPORT_POSITION(WDI,MWAA1,MWAA2) MWAC1=WDPL$C_ABS_POS_Xm MWAC2=WDPL$C_ABS_POS_YU MWAC3=WDPL$C_END_OF_LIST Ce WINDOW(1)=WDPL$C_PLACEMENTe WINDOW(2)=WDPL$M_INVISIBLEw WINDOW(3)=WDPL$C_END_OF_LISTw# CALL UIS$MOVE_VIEWPORT(WDI,WINDOW)oCbHC Make a little window: allow external bitmapped pictures to be insertedGC here by use of the logical IRAF_LOGO, with the present pattern as them)C default if that logical is not defined.EJC Note that a file called IRAF_LOGO.DAT in the current directory will alsoJC be picked up - enables considerable system-wide or personal customizing.6 OPEN(10,FILE='IRAF_LOGO',STATUS='OLD',READONLY,ERR=1)CoIC Read a UIS file - using my own packed format (there is no standard way)d11 READ(10,*) L1,L2,L3 STATUS=LIB$GET_VM(L1,EC)  IF(.NOT.STATUS) GOTO 1. CALL BUFFERREAD(%VAL(EC),L1,10)& VDI2=UIS$EXECUTE_DISPLAY(L1,%VAL(EC)) CALL LIB$FREE_VM(L1,EC) STATUS=LIB$GET_VM(L2,EC)U IF(.NOT.STATUS) GOTO 3I CALL BUFFERREAD(%VAL(EC),L2,10)# CALL UIS$EXECUTE(VDI2,L2,%VAL(EC))e CALL LIB$FREE_VM(L2,EC) STATUS=LIB$GET_VM(L3,EC)  IF(.NOT.STATUS) GOTO 3h CALL BUFFERREAD(%VAL(EC),L3,10)# CALL UIS$EXECUTE(VDI2,L3,%VAL(EC))n CALL LIB$FREE_VM(L3,EC) CLOSE(10) GOTO 2ICI 1 CONTINUEGC Try for a login directory file, so the current user can have one filet,C regardless of starting in a sub-directory.A OPEN(10,FILE='SYS$LOGIN:IRAF_LOGO',STATUS='OLD',READONLY,ERR=12)_ GOTO 117C Default (rather dull) logo if no input file was foundE812 VDI2=UIS$CREATE_DISPLAY(0.,0.,2.,2.,2.54,2.54,VCMMID)2 CALL UIS$PLOT(VDI2,0,1.166,1.7,0.3,1.2,1.166,0.7)1 CALL UIS$SET_ARC_TYPE(VDI2,0,11,UIS$C_ARC_CHORD)2 CALL UIS$SET_FONT(VDI2,11,12,'UIS$FILL_PATTERNS')8 CALL UIS$SET_FILL_PATTERN(VDI2,12,13,PATT$C_FOREGROUND)/ CALL UIS$CIRCLE(VDI2,13,0.52,1.2,0.8,70.,110.) 0 CALL UIS$CIRCLE(VDI2,13,1.39,1.2,0.2,220.,320.)0 CALL UIS$SET_ARC_TYPE(VDI2,0,11,UIS$Cts UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16Pd_ARC_OPEN). CALL UIS$CIRCLE(VDI2,11,0.3,1.2,1.0,45.,135.)? CALL UIS$SET_FONT(VDI2,0,12,'DTABER0003WK00GG0001UZZZZ02A000') ? CALL UIS$SET_FONT(VDI2,0,11,'DTABER0003WK00PG0001UZZZZ02A000')t/ CALL UIS$SET_CHAR_SPACING(VDI2,12,13,0.67,0.0)TFC Note that use of different indices in the graphics region can colourC the logo and/or its text. 9 IF(GINDEX.GE.5) CALL UIS$SET_WRITING_INDEX(VDI2,13,13,4)O$ CALL UIS$TEXT(VDI2,11,'I',1.5,1.95)$ CALL UIS$TEXT(VDI2,11,'R',1.5,1.60)$ CALL UIS$TEXT(VDI2,11,'A',1.5,1.25)$ CALL UIS$TEXT(VDI2,11,'F',1.5,0.90)+ CALL UIS$TEXT(VDI2,13,'Display',0.08,0.43)YCn 2 CONTINUE< WDI2=UIS$CREATE_WINDOW(VDI2,'SYS$WORKSTATION',,,,,,,,ICAC1)C ICON_FLAGS=UIS$M_ICON_DEF_BODY04 CALL UIS$SHRINK_TO_ICON(WDI,WDI2,ICON_FLAGS,,ICAC1) RETURNgCe7C Error allotting memory into which to read a logo filew 3 CONTINUE= WRITE(6,*) 'UISDISP-W-LOGONOTREAD, virtual memory error - ', + 'logo file not read': CALL UIS$DELETE_DISPLAY(VDI2) GOTO 1*CA END+C******************************************E0C Subroutine for reading in binary pattern logos$ SUBROUTINE BUFFERREAD(BUFF,LEN,LUN) BYTE BUFF(LEN)/500 FORMAT(1X,80A1) READ(LUN,500) BUFF, RETURNM ENDC**************************DC Re-expansion of Icon.A SUBROUTINE EXPANDER IMPLICIT INTEGER (A-Z)a INCLUDE 'SYS$LIBRARY:UISUSRDEF' REAL ICAA2,ICAA3,MWAA1,MWAA2W COMMON/ICON/ VDI2,WDI2  COMMON/IMAGE/ VDI,WDI7 COMMON/ICAT/ ICAC1,ICAA1,ICAC2,ICAA2,ICAC3,ICAA3,ICENDU7 COMMON/MWAT/ MWAC1,MWAA1,MWAC2,MWAA2,MWAC3,MWAA3,MWEND 8C Store position of Icon for later re-use: set attribute1 CALL UIS$GET_VIEWPORT_POSITION(WDI2,ICAA2,ICAA3)A ICAC2=WDPL$C_ABS_POS_XA ICAC3=WDPL$C_ABS_POS_Y2 ICEND=WDPL$C_END_OF_LISTi% CALL UIS$EXPAND_ICON(WDI,WDI2,MWAC1)  CALL RESET_IMAGE  RETURNt ENDC************************gGC Closing AST - shuts things down and tells the main program to go awayo SUBROUTINE CLOSER IMPLICIT INTEGER*4 (A-Z)i COMMON/ICON/ VDI2,WDI2  COMMON/IMAGE/ VDI,WDI COMMON/ADDOPT/ SELECTION  CALL UIS$DELETE_DISPLAY(VDI)E SELECTION=-1e CALL SYS$WAKE(,)R ENDCEPC************************Two Zoom/Pan routines**********************************CS SUBROUTINE COPY(IN,OUT,NX,NY)8C Simply copies the byte array IN to the byte array OUT.4C A quick way of resetting the pan and zoom factors. IMPLICIT INTEGER*4 (A-Z)D BYTE IN(NX,NY),OUT(NX,NY) DO 1 J=1,NY DO 1 I=1,NX1 OUT(I,J)=IN(I,J) RETURN' END&C************************************* SUBROUTINE ZOOMP(IN,OUT,NX,NY)S<C Copies IN to OUT, including zoom and pan factors passed in@C a COMMON block. Don't forget to set them before calling this.&C Leave out the LUT wedge, if present.@C Need to scan slightly more than the range, in order to include0C pieces of the border that are not wholly used. IMPLICIT INTEGER*4 (A-Z)D BYTE IN(NX,NY),OUT(NX,NY) REAL*4 FR,RZXS,RZYS- COMMON/ZOOMP/ ZOOM,ZXS,ZXE,ZYS,ZYE,RZXS,RZYS  CALL START_SWEEP('Zoom/pan') DO I=ZXS-1,ZXE+1*$ FR=FLOAT(I-ZXS+2)/FLOAT(ZXE-ZXS+3) IA=(I-ZXS)*ZOOMC DO J=ZYS-1,ZYE+1N JA=(J-ZYS)*ZOOMfCt9 IF( (I.LE.0.OR.I.GT.NX).OR.(J.LE.0.OR.J.GT.NY) ) THENoCC May want to use a value other than zero, but this is fine for noww IVAL=0t ELSE IVAL=IN(I,J) END IFCs DO I2=1,ZOOM I3=IA+I2i$ IF(I3.LE.0.OR.I3.GT.NX) GOTO 11& IF(I3.EQ.1.) RZXS=I+FLOAT(I2-1)/ZOOM DO J2=1,ZOOM  J3=JA+J2% IF(J3.LE.0.OR.J3.GT.NY) GOTO 12V% IF(J3.EQ.1) RZYS=J+FLOAT(J2-1)/ZOOMM OUT(I3,J3)=IVAL'12 CONTINUE Eo+" UISDISP.BCK*S[SHARP.UISEXP]UISDISP.FOR;16P[ND DOE11 CONTINUEU END DOCA END DO CALL SET_SWEEP(FR,2) END DO0C RETURN0 ENDCNCC******************************************************************CC :C A subroutine to open and size an IRAF disk format file.GC If there's an error, keep trying until it works OR the user enters adLC zero-length name (i.e. carriage return), then give up (exit with error=1).KC If the user hits carriage return immediately, exit with error=2 (so thatI9C the main program can switch to FITS mode and try that).uCe' SUBROUTINE SIZE_IRAF(IM,IERROR,ERRSTR)e IMPLICIT INTEGER*4 (A-Z)  DIMENSION AXLEN(7)a/ CHARACTER IMTITLE*80,TEXT*80,ERR*80,ERRSTR*(*)C LOGICAL INC_LUT: COMMON/IMAGE/ VD_ID,WD_ID,ATB,BITSPERPIX,BYPTR,NX,NY,NINC:C Size of the workstation (only need the pixel sizes here)5 COMMON/WSTATION/ RETWIDTH,RETHEIGHT,MAP_SIZE,PWD,PHT*C Specifications for subsection/ COMMON/IMFILE/ REPL,XS,XE,YS,YE,IMTITLE,IMTLEN <C Minimum window size and whether or not to have a LUT wedge! COMMON/MINSIZE/ MIN_SIZE,INC_LUT*C Preserve data type COMMON/DATA/ DTYPEG ACMODE=1nC C First get the file to open,! CALL NEED_INPUT(VD_ID,WD_ID,' ',,B + 'Name of IRAF image to display (in VMS format)',TEXT,NTEXT)C and open it.ILC NB: this works over DECnet, easily if the pixel and image header files areDC in the same directory (i.e. if NODE::USER:[JOE.IRAF] contains bothKC the file MINE.IMH and the file MINE.PIX, you can respond to this question HC with "NODE::USER:[JOE.IRAF]MINE" and it will work, as long as you haveFC read permission [see your friendly neighbo(u)rhood system manager]).IC For other types, you need to define a logical containing the node name:eIC try it, look for the error message about "pixel file disk:[dir]xx.pix",'HC and then "DEFINE/JOB disk NODE::DISK:" (note the placement of colons).CIC,GC Check for zero-length and switch to FITS mode (outside this routine).B IF(NTEXT.EQ.0) THEN IERROR=2o RETURNn END IFk@C Prepared to loop on the file-name, in case it's just mistyped.>C Exit this loop by typing carriage return (zero-length name). 101 CONTINUE"D WRITE(6,*) '"',TEXT(1:NTEXT),'"'* CALL IMOPEN (TEXT(1:NTEXT),ACMODE,IM,IER) IF(IER.NE.0) THEN CALL IMEMSG (IER,ERR)102 CONTINUE# CALL NEED_INPUT(VD_ID,WD_ID,ERR,rD + 'Name of IRAF image to display (in VMS format)',TEXT,NTEXT)NC Check for zero-length and exit (allow calling program to decide what to do). IF(NTEXT.EQ.0) THEN IERROR=1$ ERRSTR=ERR( RETURN END IFE ERR=' ' GOTO 1013 END IF1CZDC Get the image dimensions: on error, close the image and try again>C Not prepared to loop on the size, since it must be an error.' CALL IMGSIZ (IM,AXLEN,NAXIS,DTYPE,IER)  IF (IER.NE.0) THENV CALL IMEMSG (IER,ERR) CALL IMCLOS(IM,IER) GOTO 102Y END IFCCCC A few tests to see if the array is ok to plot. If not, close it 'C and go back and ask for a decent one.TCB$ IF (DTYPE.NE.3.AND.DTYPE.NE.6) THEN WRITE(UNIT=ERR,FMT='(A,I2)')(6 + 'Array data type is not readable: type ',DTYPE CALL IMCLOS(IM,IER) GOTO 102C ELSE IF (NAXIS.NE.2) THEN WRITE(UNIT=ERR,FMT='(A,I2)') ( + 'Array is not 2D, NAXIS: ',NAXIS CALL IMCLOS(IM,IER) GOTO 102i END IFlC @C Use the image title as the display window title, if it exists,$ CALL IMGKWC(IM,'title',IMTITLE,IER) IMTLEN=MYL(IMTITLE) IF(IER.NE.0) THENGC otherwise use the VMS file name. Could do some stripping, I suppose.  IMTLEN=