-####################################################### # ; ALIGN_CUBE at end ; PRO ALIGN_CUBE, IN_CUBE, OUT_CUBE, DMAX=DMAX, SHIFTS=SHIFTS, $ ; INSHIFTS=INSHIFTS, NOSHIFT=NOSHIFT FUNCTION MAXLOC,ARRAY,MAX_ARRAY ;+ ; NAME: ; MAXLOC ; ; PURPOSE: ; Find the position of maximum in a two dimensional array. ; ; CALLING SEQUENCE: ; Result = MAXLOC(ARRAY,MAX_ARRAY) ; ; INPUTS: ; ARRAY = a two dimensional array. ; ; OUTPUTS: ; Result = a vector containing the X,Y coordinates of maximum. ; ; OPTIONAL OUTPUT: ; MAX_ARRAY = value of the array at X,Y. ; ; SIDE EFFECTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Straightforward. ; ; MODIFICATION HISTORY: ; Written by Roberto Molowny-Horas, 1991. ; MAX_ARRAY added in March 1994, RMH ; ;- ON_ERROR,2 s = SIZE(array) ;Size of input array. IF s(0) NE 2 THEN MESSAGE,'Input array must be two dimensional' max_array = MAX(array,n) ;Finds maximum. RETURN,[n MOD s(1),n/s(1)] ;Output as a vector. END ;------------------------------------------------------------------------ PRO FIVEPOINT,CC,X,Y ;+ ; NAME: ; FIVEPOINT ; ; PURPOSE: ; Measure the position of minimum or maximum in a 3x3 matrix. ; ; CALLING SEQUENCE: ; FIVEPOINT,CC,X,Y ; ; INPUTS: ; CC = Cross correlation function. It must have dimensions like ; CC(3,3), CC(*,3,3) or CC(*,*,3,3) ; ; OUTPUTS: ; X & Y = Position of the minimum, taking cc(*,*,1,1) as centre. ; ; SIDE EFFECTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Simple interpolation with a 2-rd polynomial in X and Y. ; ; MODIFICATION HISTORY: ; Written by Roberto Luis Molowny Horas, Institute of Theoretical ; Astrophysics, University of Oslo. August 1991. ;- ; ON_ERROR,2 IF N_PARAMS(0) LT 3 THEN MESSAGE,'Wrong number of parameters.' n = SIZE(cc) IF n(0) LT 2 OR n(0) GT 4 THEN MESSAGE,'Wrong input array' IF n(n(0)-1) NE 3 OR n(n(0)) NE 3 THEN MESSAGE,$ 'Array must be CC(*,*,3,3)' CASE 1 OF n(0) EQ 4: BEGIN y = 2.*cc(*,*,1,1) x = (cc(*,*,0,1)-cc(*,*,2,1))/(cc(*,*,2,1)+ $ cc(*,*,0,1)-y)*.5 y = (cc(*,*,1,0)-cc(*,*,1,2))/(cc(*,*,1,2)+ $ cc(*,*,1,0)-y)*.5 END n(0) EQ 3: BEGIN y = 2.*cc(*,1,1) x = (cc(*,0,1)-cc(*,2,1))/(cc(*,2,1)+cc(*,0,1)-y)*.5 y = (cc(*,1,0)-cc(*,1,2))/(cc(*,1,2)+cc(*,1,0)-y)*.5 END n(0) EQ 2: BEGIN y = 2.*cc(1,1) x = (cc(0,1)-cc(2,1))/(cc(2,1)+cc(0,1)-y)*.5 y = (cc(1,0)-cc(1,2))/(cc(1,2)+cc(1,0)-y)*.5 END ENDCASE END ;------------------------------------------------------------------------ FUNCTION COALIGN,A,B ;+ ; NAME: ; COALIGN ; ; PURPOSE: ; Compute the shift image B has to be given to match image A. ; ; CALLING SEQUENCE: ; Result = ALIGN(A,B) ; ; INPUTS: ; A = reference image. ; ; B = image to be aligned. ; ; OUTPUTS: ; Result = Shift in X,Y to give image B to match A. ; ; SIDE EFFECTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; RESTRICTIONS: ; IF dimensions of images are not a power of 2, algorithm can be ; slow. ; ; PROCEDURE: ; It uses the properties of the Fourier transform to compute the ; cross correlation between the two images. ; ; MODIFICATION HISTORY: ; Written by Roberto Luis Molowny Horas, July 1992. ; ;- ; ON_ERROR,2 sa = SIZE(a) sb = SIZE(b) IF sa(0) NE 2 THEN MESSAGE,'Image must be 2-D' IF sa(1) NE sb(1) OR sa(2) NE sb(2) THEN $ MESSAGE,'Images must have same dimensions' cc = SHIFT(FLOAT(FFT(FFT(a,-1)*$ ;Cross correlation. CONJ(FFT(b,-1)),1)),sa(1)/2,sa(2)/2) xy = MAXLOC(cc) ;Finding the maximum. IF xy(0) EQ 0 OR xy(0) EQ sa(1)-1 OR xy(1) EQ 0 OR xy(1) EQ sa(2)-1 $ THEN BEGIN PRINT,' >>>> Shift too large! ' x = 0 & y = 0 ;Outside image. ENDIF ELSE BEGIN cc = cc(xy(0)-1:xy(0)+1,xy(1)-1:xy(1)+1);Maximum in centre. FIVEPOINT,cc,x,y x = xy(0) - sa(1)/2 + x ;Centering. y = xy(1) - sa(2)/2 + y ENDELSE RETURN,[x,y] END ;--------------------------------------------------------------------- function shift_align,a,b,inshift=inshift,outshift=outshift ; shifts b to match a: uses coalign to get shift, ; shift_image to shift ; shift is alternative shift supplied asz=size(a) bsz=size(b) if ((asz[0] ne bsz[0]) or (asz[1] ne bsz[1]) or (asz[2] ne bsz[2])) $ then begin print,'Dimensions must be the same.' return,-1 endif ; inshift is the shift to be given to b to match a if not keyword_set(inshift) then sh=coalign(a,b) else sh=inshift print,'Shift in pixels is ',sh if keyword_set(outshift) then outshift=sh shift_image,b,shift_im,sh return,shift_im end ; ------------------------------------------------------------------------- ; increase nex in shift_align for large shifts PRO ALIGN_CUBE, IN_CUBE, OUT_CUBE, DMIN=DMIN, DMAX=DMAX, SHIFTS=SHIFTS, $ INSHIFTS=INSHIFTS, FIRST=FIRST, REVERSE=REVERSE, NOSHIFT=NOSHIFT IF (n_params(0) LT 1) THEN BEGIN print,'Usage: ALIGN_CUBE, IN_CUBE, OUT_CUBE, [DMIN=DMIN, DMAX=DMAX, /FIRST],' print,' [SHIFTS=SHIFTS, INSHIFTS=INSHIFTS, /NOSHIFT]' print,'' print,'Aligns sequence of images in IN_CUBE and creates aligned array' print,' in OUT_CUBE. DMIN,DMAX are optinal min,maximum for correlation range.' print,' The shift is cumulative so alignment is to first image.' print,'SHIFTS is optional array to return calculated shifts.' print,'INSHIFTS is optional array to supply shifts to be applied: if supplied,' print,' new shifts are not calculated.' print,'If /FIRST, all images are co-aligned with the first image in cube' print,'If FIRST=IMAGE, all images are co-aligned with IMAGE' print,'If /REVERSE, starts with last image and works backwards.' print,'If /NOSHIFT, calculates shifts but does not apply them. RETURN END ; align using data range in first image IF not keyword_set(dmax) then dmax=0.9*max(IN_CUBE) IF KEYWORD_SET(FIRST) THEN $ if (n_elements(first) eq 1) then test=IN_CUBE[*,*,0] $ else test=first OUT_CUBE = IN_CUBE sz=size(in_cube) nim=sz[3] shifts=0.0*fltarr(2,nim) sh=fltarr(2) ; if applying supplied shifts, must do every image if keyword_set(inshifts) then $ for i=0,nim-1 do $ OUT_CUBE[*,*,i]=shift_align(OUT_CUBE[*,*,i],IN_CUBE[*,*,i], $ inshift=inshifts[*,i]) $ else begin for i=0,nim-1 do begin ; start at zero in case first shift non-zero IF NOT KEYWORD_SET(REVERSE) THEN BEGIN ; first derive shifts using clipped data ; shift relative to first image made cumulative by using shifted image if not keyword_set(first) then test=OUT_CUBE[*,*,(i-1)>0] IF keyword_set(dmin) then test=(test>dmin) OUT_CUBE[*,*,i]=shift_align(TEST0],IN_CUBE[*,*,i], $ inshift=sh) ENDIF ELSE BEGIN if not keyword_set(first) then test=OUT_CUBE[*,*,(nim-i)<(nim-1)] IF keyword_set(dmin) then test=(test>dmin) OUT_CUBE[*,*,(nim-1-i)>0]=shift_align(TEST0]0] = sh ; then apply shifts to unclipped data if not keyword_set(NOSHIFT) then $ OUT_CUBE[*,*,(nim-i-1)>0]=shift_align(OUT_CUBE[*,*,(nim-i)<(nim-1)], $ IN_CUBE[*,*,(nim-i-1)>0], inshift=sh) ENDELSE end endelse return end -####################################################### # function ampcor,arr,limit=limit,dx=dx,jj=jj if n_elements(limit) eq 0 then lim=2. else lim=limit(0) lim=lim>1.1 if n_elements(dx) eq 0 then kk=10 else kk=dx(0) kk=kk>3 index= -1 xarr=reform(arr) i=where(arr eq 0) if i(0) ne (-1) then xarr(i)=1. d=xarr/shift(xarr,2) i=where(d lt 1) if i(0) ne (-1) then d(i)=1./d(i) jj=where(d gt lim) if jj(0) eq (-1) then return,arr zz=jj-shift(jj,1) jj=jj(where(zz ne 1)) nn=n_elements(jj) mm=n_elements(xarr) -kk-2 xx=findgen(kk) if jj(0) eq 0 then zz=1 else zz=0 for i=zz,nn-2,2 do if (jj(i) gt kk) and (jj(i) lt mm) then begin j=jj(i) k1=poly_fit(xx,xarr(j-kk:j-1),1) k1=k1(0)+kk*k1(1) k2=poly_fit(xx,xarr(j+1:j+kk),1) k2=k2(0)-k2(1) j0=jj(i+1) if (j0 gt kk) and (j0 lt mm) then begin k3=poly_fit(xx,xarr(j0-kk:j0-1),1) k3=k3(0)+kk*k3(1) k4=poly_fit(xx,xarr(j0+1:j0+kk),1) k4=k4(0)-k4(1) endif else goto,ckl if (k2 ne 0) and (k3 ne 0) then begin k2=(k1/k2+k4/k3)/2. print,'koef=',k2 xarr(j:j0)=xarr(j:j0)*k2 end ckl: end i=where(index ne (-1)) if i(0) ne (-1) then index=index(i) else index=-1 return,median(xarr,3) end -####################################################### # function ampcorrect,arr,index=index,limit=limit,dx=dx if n_elements(limit) eq 0 then lim=5 else lim=limit(0) lim=lim>1.1 if n_elements(dx) eq 0 then kk=10 else kk=dx(0) kk=kk>3 index= -1 xarr=arr i=where(arr eq 0) if i(0) ne (-1) then xarr(i)=1. d=xarr/shift(xarr,1) i=where(d lt 1) if i(0) ne (-1) then d(i)=1./d(i) jj=where(d gt lim) if jj(0) eq (-1) then return,arr index=lonarr(1000) index(*)= -1 nn=n_elements(jj) mm=n_elements(xarr) -kk-2 xx=findgen(kk) for i=0,nn-1 do if (jj(i) gt kk) and (jj(i) lt mm) then begin j=jj(i) k1=poly_fit(xx,xarr(j-kk:j-1),1) k1=k1(0)+kk*k1(1) k2=poly_fit(xx,xarr(j+1:j+kk),1) k2=k2(0)-k2(1) if k2 ne 0 then begin index(i)=j k2=k1/k2 xarr(j:*)=xarr(j:*)*k2 end end i=where(index ne (-1)) if i(0) ne (-1) then index=index(i) else index=-1 return,xarr end -####################################################### # function boxflux,arr,x0,y0,x1,y1,freq=freq,pix=pix,non=non,smoot=smoot if n_elements(freq) eq 0 then freq=17. if n_elements(pix) eq 0 then pix=2.4555 if n_elements(non) eq 0 then $ x=total_flux(arr(x0:x1,y0:y1,*),freq=freq,pix=pix) else $ x=total_flux(arr(x0:x1,y0:y1,*)) if n_elements(smoot) eq 1 then x=smooth(x,smoot) return,x end -####################################################### # ;+ ; NAME: ; COLORBAR ; ; PURPOSE: ; Draw a colorbar (legend) with labels ; ; CATEGORY: ; Colors ; ; CALLING SEQUENCE: ; colorbar,datamin,datamax,title=title,vertical=vertical,position=position,$ ; log=log,mincolor=mincolor,maxcolor=maxcolor,tickformat=tickformat,$ ; reverse=reverse,ticklen=ticklen,color=color,ticks=ticks,tickname=tickname ; ; INPUTS: ; datamin, datamax -colorbar range ; ; KEYWORD PARAMETERS: ; vertical -draw vertical color bar ; log - logarithmic scale of the axis ; reverse - reverse of the color bar ; mincolor - minimum color index ( default 0) ; maxcolor - maximum color index ( default 255) ; ; Graphic keywords: title,color,tickname,tickformat,ticklen,ticks,position ; ; MODIFICATION HISTORY: ; Written by: Vladimir Garaimov, May 2002 ; ;- pro colorbar,datamin,datamax,title=title,vertical=vertical,position=position,$ log=log,mincolor=mincolor,maxcolor=maxcolor,tickformat=tickformat,$ reverse=reverse,ticklen=ticklen,color=color,ticks=ticks,tickname=tickname if n_params(0) ne 2 then begin doc_library,'colorbar' return end if n_elements(tickname) eq 0 then thickn='' else tickn=tickname if n_elements(tickformat) eq 0 then thickf='' else tickf=tickformat(0) if n_elements(mincolor) eq 0 then minc=0 else minc=mincolor(0)>0 <250 if n_elements(maxcolor) eq 0 then maxc=255 else maxc=maxcolor(0)>5 <255 if n_elements(title) eq 0 then tit='' else tit=string(title(0)) if keyword_set(vertical) then vv=1 else vv=0 if n_elements(ticks) eq 0 then tks=0 else tks=ticks(0) if n_elements(ticklen) eq 0 then tlen=-0.1 else tlen=ticklen(0) if n_elements(color) eq 0 then col=!p.color else col=color(0) if n_elements(position) eq 4 then pos=position else begin if vv then pos=[0.85,0.2,0.9,0.8] else pos=[0.2,0.07,0.8,0.12] end if keyword_set(log) and datamin gt 1e-5 then ll=1 else ll=0 if vv then $ plot,/nodata,/noerase,xsty=5,ysty=5,posit=pos,[0,1],[datamin,datamax],ylog=ll $ else $ plot,/nodata,/noerase,xsty=5,ysty=5,posit=pos,[datamin,datamax],[0,1],xlog=ll nn=maxc-minc+1 & arr=indgen(nn)+minc arr=congrid(arr,256,/int) if keyword_set(reverse) then arr=reverse(arr) i=replicate(1,40) if vv then arr=i#arr else arr=arr#i x_0=!x.window(0)*!d.x_vsize x_1=!x.window(1)*!d.x_vsize y_0=!y.window(0)*!d.y_vsize y_1=!y.window(1)*!d.y_vsize if !d.name ne 'PS' then arr=congrid(arr,x_1-x_0,y_1-y_0,/inter) tv,byte(arr),x_0,y_0,/dev,xsize=x_1-x_0,ysize=y_1-y_0 if vv then $ axis,1,ylog=ll,yax=1,ytit=tit,ytickl=tlen,ytickf=tickf,ysty=1,color=col,yticks=tks,ytickn=tickn $ else $ axis,xlog=ll,xax=0,xtit=tit,xtickl=tlen,xtickf=tickf,xsty=1,color=col,xticks=tks, xtickn=tickn end -####################################################### # pro create_cube,fnam,cname,int=int,mindata=mindata,maxdata=maxdata,$ compress=compress,variable=variable if n_params(0) ne 2 then begin print,' Usage: create_cube,file_names,var_name,/compress,$' print,' /int,mindata=mindata,maxdata=maxdata,variable=variable' print,' file_names - file mask or file array' print,' var_name - name of cube array var' print,' /compress - flag for compress of saved data' print,' /int -saved array will be Integer' print,' mindata=#, maxdata=# - saved array > mindata and < maxdata' print,' variable - optional strarr with FITS header keywords' return end nn=n_elements(fnam) if nn eq 1 then fnames=findfile(fnam) else fnames=fnam if fnames(0) eq '' then return fnames=fnames(sort(fnames)) nn=n_elements(fnames) if nn lt 2 then return arr=readfits(fnames(0),header) n=size(arr) timeobs='TIME-OBS' i=sxpar(header,timeobs) i=size(i) if i(1) ne 7 then timeobs='TIME_OBS' ;cname_arr=fltarr(n(1),n(2),nn) xcom=cname+'=fltarr('+strtrim(string(n(1)),2)+','+strtrim(string(n(2)),2)$ +','+strtrim(string(nn),2)+')' i=execute(xcom) ftime=strarr(nn) nv=n_elements(variable) if nv ne 0 then var0=strarr(nv,nn) ;for i=0,nn-1 do begin&cname_arr(*,*,i)=readfits(fnames(i),header)& ;if nv ne 0 then for j=0,nv-1 do begin ; var0(j,i)=string(fxpar(header,STRUPCASE(variable))) ;end ;ftime(i)=string(fxpar(header,'TIME-OBS'))&end xcom='for i=0,nn-1 do begin&'+cname+'(*,*,i)=readfits(fnames(i),header,/sil)&'+$ 'if nv ne 0 then for j=0,nv-1 do var0(j,i)=string(fxpar(header,strupcase('+$ 'variable(j))))&ftime(i)=string(fxpar(header,timeobs))&end' i=execute(xcom) print,'nn=',strtrim(string(nn),1),' t0=',ftime(0),' t1=',ftime(nn-1) i=execute(cname+'_time=ftime') i=execute(cname+'_hdr=header') i=strpos(fnames(0),'/',/reverse_s) if i eq -1 then i=strpos(fnames(0),'\',/reverse_s) if i ne -1 then begin d=strmid(fnames(0),0,i+1) fnames=strmid(fnames,i+1,strlen(fnames(0))) endif else d='' ;cname_files=fnames xcom=cname+'_files=fnames' i=execute(xcom) if n_elements(mindata) gt 0 then $ i=execute(cname+'='+cname+'>mindata(0)') if n_elements(maxdata) gt 0 then $ i=execute(cname+'='+cname+'300 rsun=960. & b0=0. & p0 =0. & img=0 tv_i=0 if keyword_set(fitstv) then begin tv_i=1 img=tv_data cx=tv_x0 cy=tv_y0 rsun=tv_rsun end if n_params(0) eq 1 then begin tv_i=1 img=image rsun=960. end nn=size(img)-1 ii=n_elements(helio) if ii ne 0 then begin b0=helio(0) if ii ge 2 then rsun=helio(1) if ii ge 3 then p0=helio(2) end repeat begin wait,0.1 CURSOR,x,y,2,/data polyfill,[0,dx,dx,0],[0,0,20,20]+dy,/dev,col=!p.background str='x=' if ii ne 0 then heliotrans,0.,0.,0.,p0,b0,0.,x,y,rsun,x1,y1 else begin x1=x & y1=y end if keyword_set(xtime) then str=str+sec2hms(x1,/msec) else str=str+string(x1,form='(g10.4)') str=str+' y=' if keyword_set(ytime) then str=str+sec2hms(y1,/msec) else str=str+string(y1,form='(g10.4)') if tv_i eq 1 then begin str=str+' image=' xyz=convert_coord(x,y,/data,/to_dev) x1=round(xyz(0)-cx) & y1=round(xyz(1)-cy) if (x1 lt 0) or (x1 gt nn(1)) or (y1 lt 0) or (y1 gt nn(2)) then str=str+' no data' else $ str=str+string(img(x1,y1),form='(g10.4)') end xyouts,1,dy+2,str,/dev,font=0 if !mouse.button eq 1 then print,str endrep until !mouse.button eq 4 polyfill,[0,dx,dx,0],[0,0,20,20]+dy,/dev,col=!p.background end -####################################################### # FUNCTION DATE2MJD, YEAR, MONTH, DAY, ERRMSG=ERRMSG ;+ ; Project : SOHO - CDS ; ; Name : DATE2MJD() ; ; Purpose : Convert calendar dates to Modified Julian Days. ; ; Explanation : This procedure calculates the Modified Julian Day number from ; the year, month and day, or from the year, day-of-year. ; ; Use : Result = DATE2MJD(YEAR, MONTH, DAY) ; Result = DATE2MJD(YEAR, DOY) ; ; Inputs : YEAR = Calendar year, e.g. 1989. All four digits are ; required. ; ; Opt. Inputs : MONTH = Calendar month, from 1-12. ; DAY = Calendar day, from 1-31, depending on the month. ; ; or ; ; DOY = Day-of-year, from 1-365 or 1-366, depending on the ; year. ; ; Either MONTH and DAY, or DOY must be passed. ; ; Outputs : The result of the function is the Modified Julian Day number ; for the date in question. It is an integral number--fractional ; days are not considered. ; ; Opt. Outputs: None. ; ; Keywords : ERRMSG = If defined and passed, then any error messages ; will be returned to the user in this parameter ; rather than being handled by the IDL MESSAGE ; utility. If no errors are encountered, then a null ; string is returned. In order to use this feature, ; the string ERRMSG must be defined first, e.g., ; ; ERRMSG = '' ; MJD = DATE2MJD ( YEAR, MONTH, DAY, ERRMSG=ERRMSG ) ; IF ERRMSG NE '' THEN ... ; ; Calls : DATATYPE ; ; Common : None. ; ; Restrictions: None. ; ; Side effects: If number of parameters sent is invalid, ERRMSG is returned as ; a string array of 2 elements if the keyword ERRMSG is set. ; Also, the result returned has a value of -1. ; ; Category : Utilities, Time. ; ; Prev. Hist. : None. However, part of the logic of this routine is based on ; JDCNV by B. Pfarr, GSFC. ; ; Written : William Thompson, GSFC, 13 September 1993. ; ; Modified : Version 1, William Thompson, GSFC, 13 September 1993. ; Version 2, Donald G. Luttermoser, GSFC/ARC, 20 December 1994. ; Added the keyword ERRMSG. Added test for month to ; make sure a string is not passed. Note that there are ; no internal procedures called that use the ERRMSG ; keyword. ; Version 3, Donald G. Luttermoser, GSFC/ARC, 30 January 1995. ; Made the error handling routine more robust. Note ; this routine can handle both vector and scalar input. ; ; Version : Version 3, 30 January 1995. ;- ; ON_ERROR, 2 ; Return to the caller of this procedure if error occurs. MESSAGE='' ; Error message that is returned if ERRMSG keyword set. ; ; Report error if a string is passed in the month variable. ; IF DATATYPE(MONTH,1) EQ 'String' THEN BEGIN MESSAGE = 'MONTH must be an integer variable (1-12).' GOTO, HANDLE_ERROR ENDIF ; ; Depending on the number of parameters, either the year, month, day or the ; year, day-of-year was passed. Calculate the Modified Julian Day number ; accordingly, using a modification of the algorithm by Fliegel and Van ; Flandern (1968) reprinted in the Explanatory Supplement to the Astronomical ; Almanac, 1992. ; CASE N_PARAMS() OF 2: BEGIN ;Year, day-of-year Y = LONG(YEAR) D = LONG(MONTH) IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = MESSAGE RETURN, D - 2431740L + 1461*(Y + 4799)/4 - $ 3*((Y + 4899)/100)/4 END 3: BEGIN ;Year, month, day Y = LONG(YEAR) M = LONG(MONTH) D = LONG(DAY) L = (M-14)/12 IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = MESSAGE RETURN, D - 2432076L + 1461*(Y+4800+L)/4 + $ 367*(M-2-L*12)/12 - 3*((Y+4900+L)/100)/4 END ELSE: BEGIN MESSAGE=STRARR(2) MESSAGE(0) = $ 'Syntax: Result = DATE2MJD(YEAR,MONTH,DAY)' MESSAGE(1) = 'Or: Result = DATE2MJD(YEAR,DOY)' GOTO, HANDLE_ERROR END ENDCASE ; ; Error handling point. ; HANDLE_ERROR: IF N_ELEMENTS(ERRMSG) EQ 0 THEN BEGIN IF N_ELEMENTS(MESSAGE) EQ 2 THEN BEGIN MESSAGE, /CONTINUE, MESSAGE(0) MESSAGE, MESSAGE(1) ENDIF ELSE MESSAGE, MESSAGE ENDIF ERRMSG = MESSAGE RETURN, -1L ; END -####################################################### # pro edit_event, ev widget_control, ev.id, get_uval = uv widget_control, ev.top, get_uval = ID widget_control, ID.Menubase, get_uval = text ;widget_control, ID.TimeLabel, set_val = strmid(systime(), 11, 5) IF TAG_NAMES(ev, /STRUCTURE_NAME) EQ 'WIDGET_TIMER' THEN return CASE uv OF 'Done': widget_control, ev.top, /dest 'Save As': begin file = dialog_pickfile(filt=ID.Filt, /write, file = ID.File, path = subdir(ID.File)) if file eq '' then return openw, lun, file, /get for j=0, n_elements(text)-1 do printf, lun, text(j) free_lun, lun ;name = (name_extract(file))(0) name=ID.file widget_control, ID.Label, set_val = 'File '+name+' saved at '+strmid(systime(), 11, 5) end 'Save': begin if ID.File eq '' then return openw, lun, ID.file, /get for j=0, n_elements(text)-1 do printf, lun, text(j) free_lun, lun ;name = (name_extract(ID.file))(0) name=ID.file widget_control, ID.Label, set_val = 'File '+name+' saved at '+strmid(systime(), 11, 5) end 'Open': begin file = dialog_pickfile(filt=ID.Filt, /read) if file eq '' then return ID.File = file text = readform(file) widget_control, ID.Text, set_val = text ;name = (name_extract(ID.file))(0) name=ID.file widget_control, ID.Label, set_val = 'File: '+name widget_control, ID.Edit, sens = 1 end 'Text': begin ;KBRD_FOCUS_EVENTS, TEXT_ALL_EVENTS, TEXT_EDITABLE, TEXT_NUMBER, ;TEXT_OFFSET_TO_XY, TEXT_SELECT, TEXT_TOP_LINE, TEXT_XY_TO_OFFSET. widget_control, ev.id, get_val = text number = widget_info(ev.id, /text_number) Ntext = n_elements(text) Len = long(total(strlen(text) + 1, /cum)) NLine = (where(Len gt ev.offset))(0) if NLine eq -1 then Nline = Ntext Ncolumn = ev.offset-Len(NLine-1>0) > 0 if Nline eq 0 then Ncolumn = ev.offset widget_control, ID.Line_number, set_val = $ string(Nline, Ncolumn, format = '("Line: ", i5, ", Column: ", i5)') widget_control, ID.Edit, sens = 1 end 'Find': begin xinput, frag, tit = 'Enter search substring' Ntext = n_elements(text) for j = 0, Ntext-1 do begin if j eq 0 then bytetext = [byte(text(j))] else bytetext = [bytetext, byte(text(j))] endfor bytetext = byte(text) ;help, bytetext bytetext = reform(bytetext, n_elements(bytetext)) bytetext = bytetext(where(bytetext ne 0)) bytefrag = byte(frag) Length = n_elements(bytefrag) ind = where(bytetext eq bytefrag(0)) Ntext = n_elements(text) Len = long(total(strlen(text) + 1, /cum)) ;NLine = (where(Len gt ev.offset))(0) ;if NLine eq -1 then Nline = Ntext if ind(0) lt 0 then a = widget_message(/info, 'Not found') else begin nind = n_elements(ind) for j=0, nind-1 do begin if equiv(bytefrag, bytetext(ind(j):ind(j)+Length-1)) then begin Nline = (where(Len gt ind(j)))(0) widget_control, ID. Text, set_text_select = [ind(j)+NLine, Length] ;widget_control, ID. Text, set_text_select = [ind(j), Length] print, string(bytetext(ind(j):ind(j)+Length-1)) return endif endfor endelse end 'Wrap': begin if ev.select eq 1 then text = short_string(text, ID.Length) widget_control, ID. Text, set_val = text end 'Length': begin widget_control, ID.Length_Input, get_val = tmp ID.Length = fix(tmp(0)) widget_control, ID.Length_Input, set_val = strtrim(ID.Length,2) end ELSE: ENDCASE if uv ne 'Done' then begin widget_control, ev.top, set_uval = ID widget_control, ID.Menubase, set_uval = text endif end pro edit ID = {Menubase:0L, Text:0L, file:'', filt: './*', Label:0L, TimeLabel:0L, $ Line_number:0L, Edit:0L, Find:0L, Wrap:0, Length_Input:0L, Length:80} text = '' ; widget_info: ;KBRD_FOCUS_EVENTS, TEXT_ALL_EVENTS, TEXT_EDITABLE, TEXT_NUMBER, ;TEXT_OFFSET_TO_XY, TEXT_SELECT, TEXT_TOP_LINE, TEXT_XY_TO_OFFSET. font = '-b&h-lucida bright-demibold-r-normal--14-140-72-72-p-84-iso8859-1' font = '-adobe-courier-bold-r-normal--14-140-75-75-m-90-iso8859-1' if strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then font = '' mainbase = widget_base(/colu, tit = 'Text editor') ID.Menubase = widget_base(mainbase, /row) button = widget_button(ID.Menubase, val = 'Done', uval = 'Done') button = widget_button(ID.Menubase, val = 'File', /menu) button1 = widget_button(button, val = 'Open', uval = 'Open') button1 = widget_button(button, val = 'Save', uval = 'Save') button1 = widget_button(button, val = 'Save As', uval = 'Save As') nonexcl_base = widget_base(ID.Menubase, /row, /nonexcl) button = widget_button(nonexcl_base, val = 'Wrap', uval = 'Wrap') ID.Length_Input = widget_text(ID.Menubase, /edit, xsiz = 5, ysiz = 1, /fra, $ val = strtrim(ID.Length,2), uval = 'Length') ID.Edit = widget_button(ID.Menubase, val = 'Edit', /menu) button1 = widget_button(ID.Edit, val = 'Find', uval = 'Find') ID.Find = widget_text(ID.Menubase, /edit, /fra, xs = 20, ys = 1, uval = 'Find_Input') ID.Label = widget_label(ID.Menubase, val = 'No file', /dynam, /frame) ID.TimeLabel = widget_label(ID.Menubase, val = strmid(systime(), 11, 5), /frame) device, get_scr = scr ID.Text = widget_text(mainbase, /edit, /fra, xs = 100, ys = 40, uval = 'Text', /scroll, $ /all_eve, font = font) ;, /KBRD_FOCUS_EVENTS) ID.Line_number = widget_Label(mainbase, /dynam, /frame) widget_control, mainbase, /real widget_control, mainbase, set_uval = ID, timer =60. widget_control, ID.Menubase, set_uval = text widget_control, ID.Text, /input widget_control, ID.Edit, sens = 0 xmanager, 'edit', mainbase, /no_block end -####################################################### # pro ellipse,xo,yo,ra,rb,angle=angle,color=color,linestyle=linestyle,thick=thick,device=device if n_params(0) lt 3 then begin print,' Usage: ellipse,xo,yo,ra,rb,angle=angle,$' print,' color=color,linestyle=linestyle,thick=thick,device=device' return end if n_params(0) eq 3 then rb1=ra else rb1=rb ang=dindgen(361)*!dpi/180. xe=ra*cos(ang) ye=rb1*sin(ang) if (n_elements(angle) ne 0) and (ra ne rb1) then begin ang=angle(0)*!dpi/180. x1=xe & y1=ye xe=x1*cos(ang)-y1*sin(ang) ye=x1*sin(ang)+y1*cos(ang) end xe=xe+xo ye=ye+yo if n_elements(color) gt 0 then col=color(0) else col=!p.color if n_elements(linestyle) gt 0 then lin=linestyle(0) else lin=0 if n_elements(thick)gt 0 then thck=thick(0) else thck=!p.thick if keyword_set(device) then $ plots,xe,ye,color=col,linestyle=lin,thick=thck,/device else $ plots,xe,ye,color=col,linestyle=lin,thick=thck,/data,noclip=0 end -####################################################### # function euvprep, arr1,hdr=hdr,datacut=datacut,dt=dt,iter=iter,$ minimum=minimum,novert=novert, nohoriz=nohoriz,smoothx=smoothx arr=arr1 _dt=1. if n_elements(dt) eq 1 then _dt=dt(0) else $ if n_elements(hdr) ne 0 then begin i=float(fxpar(hdr,'EXPTIME')) if i(0) lt 1 then i=float(fxpar(hdr,'SHT_MDUR')) if i(0) gt 1 then _dt=i(0) end if n_elements(datacut) ne 0 then dy=datacut(0) else dy=1e3 if n_elements(iter) ne 0 then nn=iter(0) else nn=2 if n_elements(minimum) ne 0 then begin if minimum(0) eq 1 then z=min(arr) else z=minimum(0) endif else z=median(arr) if n_elements(smoothx) ne 0 then z=min(arr)-10 for i=1,nn do begin if n_elements(novert) eq 0 then begin ar=arr-shift(arr,0,1) j=where(abs(ar) gt dy) if j(0) ge 0 then arr(j)=z end if n_elements(nohoriz) eq 0 then begin ar=arr-shift(arr,1,0) j=where(abs(ar) gt dy) if j(0) ge 0 then arr(j)=z end end if n_elements(smoothx) ne 0 then begin nn=size(arr) mn=min(arr) if n_elements(novert) eq 0 then begin x=findgen(nn(2)) for i=0,nn(1)-1 do begin j=where(reform(arr(i,*)) eq mn) if j(0) ge 0 then begin k=xorindex(x,j) y=interpol(reform(arr(i,k)),x(k),x) arr(i,*)=y end end endif else begin x=findgen(nn(1)) for i=0,nn(2)-1 do begin j=where(reform(arr(*,i)) eq mn) if j(0) ge 0 then begin k=xorindex(x,j) y=interpol(reform(arr(k,i)),x(k),x) arr(*,i)=y end end end end return,arr/_dt end -####################################################### # ;+ ; NAME: ; FITSCONTOUR ; Purpose: ; Draw contours of 2D-array using FITS header ; CALLING SEQUENCE: ; fitscontour,img,hdr,thick=thick,colors=colors,/cdelt,solr=solr,pixr=pixr,$ ; linestyle=linestyle,rsun=rsun,levels=levels,plevels=plevels ; INPUTS: ; img - 2D-array ; hdr - FITS header or STRUCTURE returned by MREADFITS ; ; OPTIONAL INPUT KEYWORDS: ; plevels = contour levels in % ; levels = contour levels ; color = array of contour colors ; linestyle = contour linestyle ; cdelt = option to select FITS keyword. If CDELT is set to unit, then ; keywords CDELTn are used, otherwise RSUN is used. ; rsun = adjusted solar radius, default=960.arcsec ; solr = keyword of FITS header contained the observed ; solar radius (in arcsec), default value is 'SOLR' or ; it can be floating-point value ; pixr = keyword of FITS header contained the observed ; solar radius (in image pixels), default value is 'R_SUN' ; ; FITS HEADER KEYWORDS: ; This procedure uses the following keywords from FITS header: ; CDELT1, CDELT2 ; CRPIX1, CRPIX2 ; CRVAL1, CRVAL2 ; R_SUN - observed solar radius in pixels ; or ; SOLR - observed solar radius in arcsec. ; ; MODIFICATION HISTORY: ; Written by: Vladimir Garaimov, May 2002 ;- pro fitscontour,img,hdr,thick=thick,colors=colors,cdelt=cdelt,solr=solr,$ linestyle=linestyle,rsun=rsun,levels=levels,plevels=plevels,pixr=pixr if n_params(0) lt 1 then begin doc_library,'fitscontour' return endif if n_params(0) eq 1 then hdr=0 if n_elements(solr) eq 0 then _solr='SOLR' else _solr=solr(0) if n_elements(pixr) eq 0 then _pixr='R_SUN' else _pixr=pixr(0) if strtrim(string(_solr),2) eq '0' then _solr='SOLR' nn=size(img) if nn(0) ne 2 then return rx0=0. & ry0=0. & rcdelt1=1. & rcdelt2=1. & rx_rad=960. dx=size(hdr) if dx(dx(0)+1) ge 7 then begin rx0=sx_par(hdr,'CRPIX1')-1. ry0=sx_par(hdr,'CRPIX2')-1. rcdelt1=abs(sx_par(hdr,'CDELT1'))>1e-5 rcdelt2=abs(sx_par(hdr,'CDELT2'))>1e-5 i=sx_par(hdr,'CRVAL1') rx0=rx0-i/rcdelt1 i=sx_par(hdr,'CRVAL2') ry0=ry0-i/rcdelt2 rx_rad=sx_par(hdr,_pixr) if rx_rad eq 0 then begin i=size(_solr) if i(i(0)+1) eq 7 then rx_rad=sx_par(hdr,_solr) $ else rx_rad=float(_solr) rx_rad=rx_rad/rcdelt1 end if rx_rad eq 0 then begin rx_rad=960./rcdelt1 print,'Solar Radius is not defined. use default value 960arcsec.' end end if n_elements(rsun) ne 0 then rs=rsun(0) else rs =960. if not keyword_set(cdelt) then begin rcdelt1=float(rs)/rx_rad rcdelt2=rcdelt1 end dx=!x.crange & dy=!y.crange dx1=[0.,0.] & dy1=dx1 dx1(0)=-rcdelt1*rx0 dx1(1)=dx1(0)+float(nn(1)-1)*rcdelt1 dy1(0)=-rcdelt2*ry0 dy1(1)=dy1(0)+float(nn(2)-1)*rcdelt2 if dx(0) ge dx1(1) or dx(1) le dx1(0) or dy(0) ge dy1(1) or dy(1) le dy1(0) $ then begin print,'Overlaing box is empty' return& end if n_elements(linestyle) ne 0 then c_ls=linestyle(0) else c_ls=0 if n_elements(thick) ne 0 then thk=thick(0) else thk=!p.thick if n_elements(colors) ne 0 then clr=colors else clr=!p.color mx=float(max(img,min=mn)) if mx eq mn then return if n_elements(levels) gt 0 then clev=levels else begin if n_elements(plevels) gt 0 then clev=plevels else clev=[10.,30.,50.,70.,90.] if mn*mx lt 0 then begin clev=[-clev,clev]/100. mx=max([abs(mx),abs(mn)]) mn=0. endif else clev=clev/100. clev=clev*(mx-mn)+mn end clev=clev(sort(clev)) clev=clev(uniq(clev)) xx=findgen(nn(1))*rcdelt1+dx1(0) yy=findgen(nn(2))*rcdelt2+dy1(0) if clev(0)*clev(n_elements(clev)-1) lt 0.0 then c_ls=(clev lt 0)*2 contour,img,xx,yy,/overplot,levels=clev,c_color=clr,thick=thk,c_linestyle=c_ls end -####################################################### # ;+ ; NAME: ; FITSIMAGE ; Purpose: ; The FITSIMAGE procedure ; ; CALLING SEQUENCE: ; fitsimage,image,hdr,outimage,outhdr=outhdr,rsun=rsun,solr=solr,pixr=pixr,$ ; psgrid=psgrid,range=range,normalize=normalize,cdelt=cdelt,min=min ; INPUTS: ; image - 2D-array ; hdr - FITS header or STRUCTURE (returned by MREADFITS) ; ; OUTPUTS: ; outimage - output image ; ; OPTIONAL INPUT KEYWORDS: ; psgrid - number of pixelof the image at PS devise (default=512) ; /normalize - normalize output image to byte array ; outhdr = FITS header with new image range ; range - xyrange of showed region;[x0,y0,x1,y1] ; cdelt = option to select FITS keyword. If CDELT is set to unit, then ; keywords CDELTn are used, otherwise RSUN is used. ; rsun = adjusted solar radius, default=960.arcsec ; solr = keyword of FITS header contained the observed ; solar radius (in arcsec), default value is 'SOLR' or ; it can be floating-point value ; pixr = keyword of FITS header contained the observed ; solar radius (in image pixels), default value is 'R_SUN' ; min = filling of empty area of the image by minimum value of the array ; ; FITS HEADER KEYWORDS: ; This procedure uses the following keywords from FITS header: ; CDELT1, CDELT2 ; CRPIX1, CRPIX2 ; CRVAL1, CRVAL2 ; R_SUN - observed solar radius in pixels ; or ; SOLR - observed solar radius in arcsec. ; ; MODIFICATION HISTORY: ; Written by: Vladimir Garaimov, May 2002 ;- pro fitsimage,img,hdr,outimg,outhdr=outhdr,rsun=rsun,solr=solr,pixr=pixr,$ psgrid=psgrid,range=range,normalize=normalize,cdelt=cdelt,min=min if n_params(0) lt 3 then begin doc_library,'fitsimage' return end if n_elements(psgrid) ne 0 then psn=psgrid(0) else psn=512 if n_elements(solr) eq 0 then _solr='SOLR' else _solr=solr(0) if n_elements(pixr) eq 0 then _pixr='R_SUN' else _pixr=pixr(0) position=fltarr(4) position(0)=0 position(2)=psn position(1)=0 position(3)=psn x_0=position(0) x_1=position(2) y_0=position(1) y_1=position(3) xx=x_1-x_0 & yy=y_1-y_0 xdy=float(xx)/float(yy) if n_elements(range) eq 4 then begin n1=float(range(2)-range(0)) n2=float(range(3)-range(1)) if n2 eq 0 then n1n2=1. else n1n2=n1/n2 end else begin nn=size(img) n1n2=float(nn(1))/float(nn(2)) end if xdy gt n1n2 then begin xx=(yy*n1n2) & x_1=x_0+xx position(2)=position(0)+xx endif else begin yy=(xx/n1n2) & y_1=y_0+yy position(3)=position(1)+yy end swx=x_1-x_0 swy=y_1-y_0 ;image calculations thkname=strarr(30) & thkname(*)=' ' mx0=0. & my0=0. & mcdelt1=1.& mx_rad=960 i=size(hdr) if i(i(0)+1) ge 7 then begin mx0=sx_par(hdr,'CRPIX1')-1.0 my0=sx_par(hdr,'CRPIX2')-1.0 mcdelt1=abs(sx_par(hdr,'CDELT1'))>1e-5 mcdelt2=abs(sx_par(hdr,'CDELT2'))>1e-5 i=sx_par(hdr,'CRVAL1') mx0=mx0-i/mcdelt1 i=sx_par(hdr,'CRVAL2') my0=my0-i/mcdelt2 ;radius mx_rad=sx_par(hdr,_pixr) if mx_rad eq 0 then begin i=size(_solr) if i(i(0)+1) eq 7 then mx_rad=sx_par(hdr,_solr) $ else mx_rad=float(_solr) mx_rad=mx_rad/mcdelt1 end if mx_rad eq 0 then begin mx_rad=960./mcdelt1 print,'Solar Radius is not defined. use default value 960arcsec.' end end nn=size(img)-1 if n_elements(rsun) ne 0 then rs=rsun(0) else rs=960. if not keyword_set(cdelt) then mcdelt1=float(rs)/mx_rad xx=[0.,0.] & yy=xx xx(0)=-mx0*mcdelt1 xx(1)=xx(0)+nn(1)*mcdelt1 yy(0)=-my0*mcdelt1 yy(1)=yy(0)+nn(2)*mcdelt1 if n_elements(range) ne 4 then begin img1=img & xy0=[0.,0.] endif else begin if range(0) ge range(2) or range(1) ge range(3) then begin print,'Range Box is wrong!' & return end if xx(0) ge range(2) or yy(0) ge range(3) or xx(1) $ le range(0) or yy(1) le range(1) $ then begin&print,'Overlaing box is empty'&return&end img1=img fn=1 x0=xx-range([0,2]) y0=yy-range([1,3]) xy0=[0.,0.] & i0=0 & j0=0 if x0(0) ge 0 then xy0(0)=x0(0) else begin i=-x0(0)/mcdelt1 & i0=fix(i) if i-i0 ne 0 and fn then begin xy0(0)=float(i0+1-i)*mcdelt1 & i0=i0+1 end else xy0(0)=0 end if y0(0) ge 0 then xy0(1)=y0(0) else begin i=-y0(0)/mcdelt1 & j0=fix(i) if i-j0 ne 0 and fn then begin xy0(1)=float(j0+1-i)*mcdelt1 & j0=j0+1 end else xy0(1)=0 end i1=nn(1) &j1=nn(2) if x0(1) gt 0 then begin i=x0(1)/mcdelt1 & i1=i1-fix(i) if i-fix(i) ne 0 then i1=i1-1 end if y0(1) gt 0 then begin i=y0(1)/mcdelt1 & j1=j1-fix(i) if i-fix(i) ne 0 then j1=j1-1 end if i0 ge i1 or j0 ge j1 then return img1=img1(i0:i1,j0:j1) nn=size(img1)-1 xx(0)=range(0) & xx(1)=range(2) yy(0)=range(1) & yy(1)=range(3) i=xx(1)-xx(0) xy0(0)=xy0(0)*swx/i i=float(nn(1))*mcdelt1/i swx=fix(float(swx)*i)< (x_1-x_0+1.0) i=yy(1)-yy(0) xy0(1)=xy0(1)*swy/i i=float(nn(2))*mcdelt1/i swy=fix(float(swy)*i)< (y_1-y_0+1.0) end bb=congrid(img1,swx,swy,/interp,/minus_one) nxy=size(bb) outimg=fltarr(round(position(2)),round(position(3))) if n_elements(min) eq 0 then outimg(*,*)=median(bb) else outimg(*,*)=min(bb) outimg(fix(x_0+xy0(0)),fix(y_0+xy0(1)))=bb if keyword_set(normalize) then begin mx=max(outimg,min=mn) outimg=byte(255.*(outimg-mn)/(mx-mn)) end xdel=(xx(1)-xx(0))/float(position(2)-1) ;outhdr=hdr sxaddpar,outhdr,'NAXIS',2 sxaddpar,outhdr,'NAXIS1',round(position(2)) sxaddpar,outhdr,'NAXIS2',round(position(3)) sxaddpar,outhdr,'CRPIX1',-xx(0)/xdel+1. sxaddpar,outhdr,'CRPIX2',-yy(0)/xdel+1. sxaddpar,outhdr,'CRVAL1',0.0 sxaddpar,outhdr,'CRVAL2',0.0 sxaddpar,outhdr,'CDELT1',xdel sxaddpar,outhdr,'CDELT2',xdel sxaddpar,outhdr,'R_SUN',rs/xdel sxaddpar,outhdr,'SOLR',rs sxaddpar,outhdr,'DATE_TIME',sx_par(hdr,'DATE_TIME') range=fltarr(4) range(0)=xx(0) range(1)=yy(0) range(2)=xx(1) range(3)=yy(1) end -####################################################### # pro fitsinfo,fname,silent=silent,strinfo=strinfo,extinfo=extinfo if n_params(0) ne 1 then begin print,' Usage: fitsinfo,fname,[/silent],[strinfo=strinfo] print,' fname -FITS file name' print,' strinfo - FITS information string' print,' /silent - no messages' print,' /extinfo - print information about BINTABLE extentions' return end if (findfile(fname))(0) eq '' then begin strinfo=fname+' does not exist' goto,pend end if !version.os eq 'Win32' then ns='\' else ns='/' j=rstrpos(fname,ns) xname=strmid(fname,j+1,255) ns=0 strinfo=strarr(256) xx=mrdfits(fname,ns,hdr,status=j,/sil) if j lt 0 then begin strinfo=xname+' is not a FITS file' goto,pend end ext=fxpar(hdr,'EXTEND',count=j) nn=fxpar(hdr,'NAXIS') if (nn(0) ne 0) then begin strinfo(0)=xname+' is a FITS file' ext=fxpar(hdr,'NAXIS*') zz='('+string(nn)+'(",",I))' str='Image array ('+strmid(strcompress(string(ext,form=zz)),2,100)+')' strinfo(1)=str ns=2 if j eq 0 then goto,zend end ;---BINTABLE--- ns1=0 strinfo(ns)=xname+' has a Binary Table extention' eckl: ns=ns+1 ns1=ns1+1 xx=mrdfits(fname,ns1,hdr,status=j,/sil) case j of -1 : begin strinfo(ns)='file is corrupted' goto,zend end -2 : begin strinfo(ns)=strtrim(string(ns1-1),2)+' extentions' goto,zend end else : endcase ext=fxpar(hdr,'EXTNAME') nn=fxpar(hdr,'TFIELDS') strinfo(ns)='ExtName : '+string(ext)+'; TFIELDS='+strtrim(string(nn),2) ext=fxpar(hdr,'NAXIS*') zz='('+string(n_elements(ext))+'(",",I))' str='; array ('+strmid(strcompress(string(ext,form=zz)),2,100)+')' strinfo(ns)=strinfo(ns)+str if keyword_set(extinfo) then begin help,xx,/str,output=sij ns=ns+1 strinfo(ns)=sij ns=ns+n_elements(sij) end goto,eckl zend: i=where(strinfo ne '') strinfo=strinfo(i) pend: if not keyword_set(silent) then for i=0,n_elements(strinfo)-1 do print,strinfo(i) end -####################################################### # ;+ ; NAME: ; FITSTVSCL ; Purpose: ; The FITSTVSCL procedure scales the intensity values of Image into the range ; of the image display and outputs the data to the image display at the specified ; location using FITS header ; ; CALLING SEQUENCE: ; fitstvscl,image,hdr,title=title,xtitle=xtitle,ytitle=ytitle,$' ; minor=minor,color=color,thick=thick,rsun=rsun,psgrid=psgrid,/fine,$' ; range=range,notickname=notickname,charsize=charsize,cdelt=cdelt,$' ; /aspect,/tv,charthick=charthick,ticklen=ticklen,solr=solr,pixr=pixr,$' ; xtickformat=xtickformat, ytickformat=ytickformat, $ ; xtickv=xtickv,ytickv=ytickv,xticks=xticks,yticks=yticks, $ ; background=background, position=position, nointerpolation=nointerpolation ; INPUTS: ; image - 2D-array or 3D array (image and color : [n,m,3]) ; hdr - FITS header or STRUCTURE returned by MREADFITS ; ; OPTIONAL INPUT KEYWORDS: ; psgrid - number of pixelof the image at PS devise (default=100) ; range - xyrange of showed region;[x0,y0,x1,y1] ; /notickname - Set this keyword to suprese ticknames ; /aspect - Set this keyword to retain the image's aspect ratio. ; /noimage - draw only coordinate system, not image ; /fine - fine coordinate fitting ; /tv - draw picture using tv (not tvscl) ; /nointerpolation - image resize without interpolation ; background - color which used to filling of empty area ; cdelt = option to select FITS keyword. If CDELT is set to unit, then ; keywords CDELTn are used, otherwise RSUN is used. ; rsun = adjusted solar radius, default=960.arcsec ; solr = keyword of FITS header contained the observed ; solar radius (in arcsec), default value is 'SOLR' or ; it can be floating-point value ; pixr = keyword of FITS header contained the observed ; solar radius (in image pixels), default value is 'R_SUN' ; Graphical keywords: ; thick,title,xtitle,ytitle,color,charsize,charthick,ticklen, ; xticks,yticks,xtickv,ytickv, ; xtickformat,ytickformat,position ; ; FITS HEADER KEYWORDS: ; This procedure uses the following keywords from FITS header: ; CDELT1, CDELT2 ; CRPIX1, CRPIX2 ; CRVAL1, CRVAL2 ; R_SUN - observed solar radius in pixels ; or ; SOLR - observed solar radius in arcsec. ; ; COMMON ; common tv_image, tv_data, tv_x0, tv_y0, tv_rsun ; ; MODIFICATION HISTORY: ; Written by: Vladimir Garaimov, May 2002 ;- pro fitstvscl,img,hdr, title=title, xtitle=xtitle, ytitle=ytitle, minor=minor,$ color=color, thick=thick, rsun=rsun, psgrid=psgrid, range=range, solr=solr,$ notickname=notickname, charsize=charsize, charthick=charthick, pixr=pixr,$ aspect=aspect,fine=fine,noimage=noimage,tv=tv, ticklen=ticklen, cdelt=cdelt,$ background=background, xtickformat=xtickformat, ytickformat=ytickformat,$ position=position, nointerpolation=nointerpolation, xticks=xticks, $ yticks=yticks, xtickv=xtickv, ytickv=ytickv common tv_image, tv_data, tv_x0, tv_y0, tv_rsun if n_params(0) lt 1 then begin doc_library,'fitstvscl' return end if n_params(0) eq 1 then hdr=0 if n_elements(xtitle) eq 1 then xtitl=xtitle else xtitl='' if n_elements(ytitle) eq 1 then ytitl=ytitle else ytitl='' if n_elements(title) eq 1 then mtitl=title else mtitl='' if n_elements(thick) ne 0 then begin xthk=thick(0) & ythk=xthk & end else begin xthk=!x.thick & ythk=!y.thick & end if n_elements(minor) ne 0 then mnr=minor(0) else mnr=0 if n_elements(color) ne 0 then cr=color else cr=!p.color if n_elements(psgrid) ne 0 then psn=psgrid(0) else psn=100 if n_elements(notickname) ne 0 then nothick=1 else nothick=0 if n_elements(charthick) ne 0 then charthk=charthick(0) else charthk=!p.charthick if n_elements(charsize) ne 0 then charsz=charsize(0) else charsz=!p.charsize if n_elements(xtickformat) ne 0 then xtickf=xtickformat(0) else xtickf='' if n_elements(ytickformat) ne 0 then ytickf=ytickformat(0) else ytickf='' if n_elements(solr) eq 0 then _solr='SOLR' else _solr=solr(0) if n_elements(pixr) eq 0 then _pixr='R_SUN' else _pixr=pixr(0) if strtrim(string(_solr),2) eq '0' then _solr='SOLR' if n_elements(nointerpolation) eq 0 then _interp=1 else _interp=0 ;plot device save_pos=!p.position if n_elements(position) eq 4 then !p.position=position plot,[0,1],[0,1],/nodata,xstyle=4,ystyle=4,charsize=charsz,charthick=charthk if n_elements(background) ne 0 then $ polyfill,[0,0,1,1],[0,1,1,0],color=background(0) if total(!p.position) eq 0. then begin !p.position(0)=!x.window(0) !p.position(2)=!x.window(1) !p.position(1)=!y.window(0) !p.position(3)=!y.window(1) end x_0=!p.position(0)*!d.x_vsize x_1=!p.position(2)*!d.x_vsize y_0=!p.position(1)*!d.y_vsize y_1=!p.position(3)*!d.y_vsize if keyword_set(aspect) then begin xx=x_1-x_0 & yy=y_1-y_0 xdy=float(xx)/float(yy) if n_elements(range) eq 4 then begin n1=float(range(2)-range(0)) n2=float(range(3)-range(1)) if n2 eq 0 then n1n2=1. else n1n2=n1/n2 end else begin nn=size(img) n1n2=float(nn(1))/float(nn(2)) end if xdy gt n1n2 then begin xx=(yy*n1n2) & x_1=x_0+xx !p.position(2)=!p.position(0)+xx/!d.x_size endif else begin yy=(xx/n1n2) & y_1=y_0+yy !p.position(3)=!p.position(1)+yy/!d.y_size end end if x_1 le x_0 or y_1 le y_0 then begin print,'Coord. system is BAD' !p.position=save_pos return end swx=x_1-x_0+1.0 swy=y_1-y_0+1.0 ;image calculations thkname=strarr(30) & thkname(*)=' ' mx0=0. & my0=0. & mcdelt1=1.& mx_rad=960 i=size(hdr) if i(i(0)+1) ge 7 then begin mx0=sx_par(hdr,'CRPIX1')-1.0 my0=sx_par(hdr,'CRPIX2')-1.0 mcdelt1=abs(sx_par(hdr,'CDELT1'))>1e-5 mcdelt2=abs(sx_par(hdr,'CDELT2'))>1e-5 i=sx_par(hdr,'CRVAL1') mx0=mx0-i/mcdelt1 i=sx_par(hdr,'CRVAL2') my0=my0-i/mcdelt2 ;radius mx_rad=sx_par(hdr,_pixr) if mx_rad eq 0 then begin i=size(_solr) if i(i(0)+1) eq 7 then mx_rad=sx_par(hdr,_solr) $ else mx_rad=float(_solr) mx_rad=mx_rad/mcdelt1 end if mx_rad eq 0 then begin mx_rad=960./mcdelt1 print,'Solar Radius is not defined. use default value 960 arcsec.' end end nn=size(img)-1 if keyword_set(noimage) and n_elements(range) eq 4 then begin xx=[range(0),range(2)] yy=[range(1),range(3)] goto,drwcon end if n_elements(rsun) ne 0 then rs=rsun(0) else rs=960. if not keyword_set(cdelt) then mcdelt1=float(rs)/mx_rad xx=[0.,0.] & yy=xx xx(0)=-mx0*mcdelt1 xx(1)=xx(0)+nn(1)*mcdelt1 yy(0)=-my0*mcdelt1 yy(1)=yy(0)+nn(2)*mcdelt1 if n_elements(range) ne 4 then begin if keyword_set(noimage) then goto,drwcon img1=img & xy0=[0.,0.] endif else begin if range(0) ge range(2) or range(1) ge range(3) then begin print,'Range Box is wrong!' & return end if xx(0) ge range(2) or yy(0) ge range(3) or xx(1) le range(0) or yy(1) le range(1) $ then begin print,'Overlaing box is empty' !p.position=save_pos return end ;------------------ if keyword_set(fine) then begin &img1=img &fn=1 &endif else begin nn=size(img) &fn=0 if mcdelt1 le 1. then img1=img else begin img1=congrid(img,fix(nn(1)*mcdelt1),fix(nn(2)*mcdelt1),3,interp=_interp) mcdelt1= 1. end nn=size(img1)-1 end ;------------------ x0=xx-range([0,2]) y0=yy-range([1,3]) xy0=[0.,0.] & i0=0 & j0=0 if x0(0) ge 0 then xy0(0)=x0(0) else begin i=-x0(0)/mcdelt1 & i0=fix(i) if i-i0 ne 0 and fn then begin xy0(0)=float(i0+1-i)*mcdelt1 & i0=i0+1 end else xy0(0)=0 end if y0(0) ge 0 then xy0(1)=y0(0) else begin i=-y0(0)/mcdelt1 & j0=fix(i) if i-j0 ne 0 and fn then begin xy0(1)=float(j0+1-i)*mcdelt1 & j0=j0+1 end else xy0(1)=0 end i1=nn(1) &j1=nn(2) if x0(1) gt 0 then begin i=x0(1)/mcdelt1 & i1=i1-fix(i) if i-fix(i) ne 0 then i1=i1-1 end if y0(1) gt 0 then begin i=y0(1)/mcdelt1 & j1=j1-fix(i) if i-fix(i) ne 0 then j1=j1-1 end if i0 ge i1 or j0 ge j1 then return img1=img1(i0:i1,j0:j1,*) nn=size(img1)-1 xx(0)=range(0) & xx(1)=range(2) yy(0)=range(1) & yy(1)=range(3) i=xx(1)-xx(0) xy0(0)=xy0(0)*swx/i i=float(nn(1))*mcdelt1/i swx=fix(float(swx)*i)< (x_1-x_0+1.0) i=yy(1)-yy(0) xy0(1)=xy0(1)*swy/i i=float(nn(2))*mcdelt1/i swy=fix(float(swy)*i)< (y_1-y_0+1.0) end if !d.name ne 'PS' then begin bb=congrid(img1,swx,swy,3,interp=_interp,/minus_one) endif else begin nn=size(img1) if nn(1) lt psn then begin hh=psn*nn(2)/nn(1) bb=congrid(img1,psn,hh,3,interp=_interp,/minus_one) endif else bb=img1 end nxy=size(bb) ;init common if !d.name ne 'PS' then begin tv_data=bb(*,*,0) & tv_x0=x_0+xy0(0) & tv_y0=y_0+xy0(1) if n_elements(rsun) ne 0 then tv_rsun=rsun(0) else tv_rsun=960. end ;image display if nxy(0) eq 3 then begin if keyword_set(tv) then tv,bb,x_0+xy0(0),y_0+xy0(1),true=3,$ xsize=swx,ysize=swy,/device else $ tvscl,bb,x_0+xy0(0),y_0+xy0(1),true=3,xsize=swx,ysize=swy,/device end else begin if keyword_set(tv) then tv,bb,x_0+xy0(0),y_0+xy0(1),$ xsize=swx,ysize=swy,/device else $ tvscl,bb,x_0+xy0(0),y_0+xy0(1),xsize=swx,ysize=swy,/device end if n_elements(ticklen) gt 0 then tickl=ticklen(0) else tickl=!p.ticklen ; draw axises drwcon: if nothick eq 0 then $ contour,[[0,0],[0,0]],xx,yy,xstyle=1,ystyle=1,/noerase,title=mtitl,xticklen=tickl,$ yticklen=tickl, xtitle=xtitl,ytitle=ytitl,color=cr,xthick=xthk,ythick=ythk,xminor=mnr,$ yminor=mnr,charsize=charsz,charthick=charthk, xtickf=xtickf, ytickf=ytickf,$ xticks=xticks, yticks=yticks, xtickv=xtickv, ytickv=ytickv else $ contour,[[0,0],[0,0]],xx,yy,xstyle=1,ystyle=1,/noerase,title=mtitl,$ xtitle=xtitl,ytitle=ytitl,color=cr,xthick=xthk,ythick=ythk,xminor=mnr,$ yminor=mnr,xtickname=thkname,ytickname=thkname,xticklen=tickl,yticklen=tickl !p.position=save_pos end -####################################################### # function getkeys,fnam,keyword if n_params(0) ne 2 then begin print,' Usage: keys=getkeys(file_mask,keword)' print,' file_mask - mask of file names' print,' keword - name of FITS header keyword' return,-1 end nn=n_elements(fnam) if nn eq 1 then fnames=findfile(fnam) else fnames=fnam if fnames(0) eq '' then return, -1 fnames=fnames(sort(fnames)) nn=n_elements(fnames) hdr=headfits(fnames(0)) k=sxpar(hdr,keyword,count=i) if i eq 0 then return, -1 n=size(k) n=n(n_elements(n)-2) if n eq 7 then zz=strarr(nn) else zz=dblarr(nn) for i=0,nn-1 do begin hdr=headfits(fnames(i)) k=sxpar(hdr,keyword,count=j) if j eq 0 then if n eq 7 then zz(i)='-1' else zz(i)= -1 else zz(i)=k end return,zz end -####################################################### # ;+ ; NAME: ; LEGEND ; PURPOSE: ; Create an annotation legend for a plot. ; EXPLANATION: ; This procedure makes a legend for a plot. The legend can contain ; a mixture of symbols, linestyles, Hershey characters (vectorfont), ; and filled polygons (usersym). A test procedure, legendtest.pro, ; shows legend's capabilities. Placement of the legend is controlled ; with keywords like /right, /top, and /center or by using a position ; keyword for exact placement (position=[x,y]) or via mouse (/position). ; CALLING SEQUENCE: ; LEGEND [,items][,keyword options] ; EXAMPLES: ; The call: ; legend,['Plus sign','Asterisk','Period'],psym=[1,2,3] ; produces: ; ----------------- ; | | ; | + Plus sign | ; | * Asterisk | ; | . Period | ; | | ; ----------------- ; Each symbol is drawn with a plots command, so they look OK. ; Other examples are given in optional output keywords. ; ; lines = indgen(6) ; for line styles ; items = 'linestyle '+strtrim(lines,2) ; annotations ; legend,items,linestyle=lines ; vertical legend---upper left ; items = ['Plus sign','Asterisk','Period'] ; sym = [1,2,3] ; legend,items,psym=sym ; ditto except using symbols ; legend,items,psym=sym,/horizontal ; horizontal format ; legend,items,psym=sym,box=0 ; sans border ; legend,items,psym=sym,delimiter='=' ; embed '=' betw psym & text ; legend,items,psym=sym,margin=2 ; 2-character margin ; legend,items,psym=sym,position=[x,y] ; upper left in data coords ; legend,items,psym=sym,pos=[x,y],/norm ; upper left in normal coords ; legend,items,psym=sym,pos=[x,y],/device ; upper left in device coords ; legend,items,psym=sym,/position ; interactive position ; legend,items,psym=sym,/right ; at upper right ; legend,items,psym=sym,/bottom ; at lower left ; legend,items,psym=sym,/center ; approximately near center ; legend,items,psym=sym,number=2 ; plot two symbols, not one ; legend,items,/fill,psym=[8,8,8],colors=[10,20,30]; 3 filled squares ; INPUTS: ; items = text for the items in the legend, a string array. ; For example, items = ['diamond','asterisk','square']. ; You can omit items if you don't want any text labels. ; OPTIONAL INPUT KEYWORDS: ; ; linestyle = array of linestyle numbers If linestyle(i) < 0, then omit ; ith symbol or line to allow a multi-line entry. ; psym = array of plot symbol numbers. If psym(i) is negative, then a ; line connects pts for ith item. If psym(i) = 8, then the ; procedure usersym is called with vertices define in the ; keyword usersym. If psym(i) = 88, then use the previously ; defined user symbol ; vectorfont = vector-drawn characters for the sym/line column, e.g., ; ['!9B!3','!9C!3','!9D!3'] produces an open square, a checkmark, ; and a partial derivative, which might have accompanying items ; ['BOX','CHECK','PARTIAL DERIVATIVE']. ; There is no check that !p.font is set properly, e.g., -1 for ; X and 0 for PostScript. This can produce an error, e.g., use ; !20 with PostScript and !p.font=0, but allows use of Hershey ; *AND* PostScript fonts together. ; N. B.: Choose any of linestyle, psym, and/or vectorfont. If none is ; present, only the text is output. If more than one ; is present, all need the same number of elements, and normal ; plot behaviour occurs. ; By default, if psym is positive, you get one point so there is ; no connecting line. If vectorfont(i) = '', ; then plots is called to make a symbol or a line, but if ; vectorfont(i) is a non-null string, then xyouts is called. ; /help = flag to print header ; /horizontal = flag to make the legend horizontal ; /vertical = flag to make the legend vertical (D=vertical) ; box = flag to include/omit box around the legend (D=include) ; clear = flag to clear the box area before drawing the legend ; clrclear = color of clearing ; delimiter = embedded character(s) between symbol and text (D=none) ; colors = array of colors for plot symbols/lines (D=!color) ; textcolors = array of colors for text (D=!color) ; margin = margin around text measured in characters and lines ; spacing = line spacing (D=bit more than character height) ; pspacing = psym spacing (D=3 characters) ; charsize = just like !p.charsize for plot labels ; charthick = array of char thickness numbers ; thick = array of line thickness numbers, if used, then linestyle ; must also be specified ; position = data coordinates of the /top (D) /left (D) of the legend ; normal = use normal coordinates for position, not data ; device = use device coordinates for position, not data ; number = number of plot symbols to plot or length of line (D=1) ; usersym = 2-D array of vertices, cf. usersym in IDL manual. (D=square) ; /fill = flag to fill the usersym ; /left = flag to place legend snug against left side of plot window (D) ; /right = flag to place legend snug against right side of plot window ; If /right,pos=[x,y], then x is position of RHS and text ; runs right-to-left. ; /top = flag to place legend snug against top of plot window (D) ; /bottom = flag to place legend snug against bottom of plot window ; /top,pos=[x,y] and /bottom,pos=[x,y] produce same positions. ; ; If LINESTYLE, PSYM, VECTORFONT, THICK, COLORS, or TEXTCOLORS are ; supplied as scalars, then the scalar value is set for every line or ; symbol in the legend. ; Outputs: ; legend to current plot device ; OPTIONAL OUTPUT KEYWORDS: ; corners = 4-element array, like !p.position, of the normalized ; coords for the box (even if box=0): [llx,lly,urx,ury]. ; Useful for multi-column or multi-line legends, for example, ; to make a 2-column legend, you might do the following: ; c1_items = ['diamond','asterisk','square'] ; c1_psym = [4,2,6] ; c2_items = ['solid','dashed','dotted'] ; c2_line = [0,2,1] ; legend,c1_items,psym=c1_psym,corners=c1,box=0 ; legend,c2_items,line=c2_line,corners=c2,box=0,pos=[c1(2),c1(3)] ; c = [c1(0)c2(2),c1(3)>c2(3)] ; plots,[c(0),c(0),c(2),c(2),c(0)],[c(1),c(3),c(3),c(1),c(1)],/norm ; Useful also to place the legend. Here's an automatic way to place ; the legend in the lower right corner. The difficulty is that the ; legend's width is unknown until it is plotted. In this example, ; the legend is plotted twice: the first time in the upper left, the ; second time in the lower right. ; legend,['1','22','333','4444'],linestyle=indgen(4),corners=corners ; ; BOGUS LEGEND---FIRST TIME TO REPORT CORNERS ; xydims = [corners(2)-corners(0),corners(3)-corners(1)] ; ; SAVE WIDTH AND HEIGHT ; chdim=[!d.x_ch_size/float(!d.x_size),!d.y_ch_size/float(!d.y_size)] ; ; DIMENSIONS OF ONE CHARACTER IN NORMALIZED COORDS ; pos = [!x.window(1)-chdim(0)-xydims(0) $ ; ,!y.window(0)+chdim(1)+xydims(1)] ; ; CALCULATE POSITION FOR LOWER RIGHT ; plot,findgen(10) ; SIMPLE PLOT; YOU DO WHATEVER YOU WANT HERE. ; legend,['1','22','333','4444'],linestyle=indgen(4),pos=pos ; ; REDO THE LEGEND IN LOWER RIGHT CORNER ; You can modify the pos calculation to place the legend where you ; want. For example to place it in the upper right: ; pos = [!x.window(1)-chdim(0)-xydims(0),!y.window(1)-xydims(1)] ; Common blocks: ; none ; Procedure: ; If keyword help is set, call doc_library to print header. ; See notes in the code. Much of the code deals with placement of the ; legend. The main problem with placement is not being ; able to sense the length of a string before it is output. Some crude ; approximations are used for centering. ; Restrictions: ; Here are some things that aren't implemented. ; - An orientation keyword would allow lines at angles in the legend. ; - An array of usersyms would be nice---simple change. ; - An order option to interchange symbols and text might be nice. ; - Somebody might like double boxes, e.g., with box = 2. ; - Another feature might be a continuous bar with ticks and text. ; - There are no guards to avoid writing outside the plot area. ; - There is no provision for multi-line text, e.g., '1st line!c2nd line' ; Sensing !c would be easy, but !c isn't implemented for PostScript. ; A better way might be to simply output the 2nd line as another item ; but without any accompanying symbol or linestyle. A flag to omit ; the symbol and linestyle is linestyle(i) = -1. ; - There is no ability to make a title line containing any of titles ; for the legend, for the symbols, or for the text. ; Side Effects: ; Modification history: ; write, 24-25 Aug 92, F K Knight (knight@ll.mit.edu) ; allow omission of items or omission of both psym and linestyle, add ; corners keyword to facilitate multi-column legends, improve place- ; ment of symbols and text, add guards for unequal size, 26 Aug 92, FKK ; add linestyle(i)=-1 to suppress a single symbol/line, 27 Aug 92, FKK ; add keyword vectorfont to allow characters in the sym/line column, ; 28 Aug 92, FKK ; add /top, /bottom, /left, /right keywords for automatic placement at ; the four corners of the plot window. The /right keyword forces ; right-to-left printing of menu. 18 Jun 93, FKK ; change default position to data coords and add normal, data, and ; device keywords, 17 Jan 94, FKK ; add /center keyword for positioning, but it is not precise because ; text string lengths cannot be known in advance, 17 Jan 94, FKK ; add interactive positioning with /position keyword, 17 Jan 94, FKK ; allow a legend with just text, no plotting symbols. This helps in ; simply describing a plot or writing assumptions done, 4 Feb 94, FKK ; added thick, symsize, and clear keyword Feb 96, W. Landsman HSTX ; David Seed, HR Wallingford, d.seed@hrwallingford.co.uk ; allow scalar specification of keywords, Mar 96, W. Landsman HSTX ; Converted to IDL V5.0 W. Landsman September 1997 ;- pro glegend,help=help,items,linestyle=linestyle,psym=psym,vectorfont=vectorfont $ ,horizontal=horizontal,vertical=vertical,box=box,margin=margin $ ,delimiter=delimiter,spacing=spacing,charsize=charsize,pspacing=pspacing $ ,position=position,number=number,colors=colors,textcolors=textcolors $ ,fill=fill,usersym=usersym,corners=corners $ ,left=left,right=right,top=top,bottom=bottom,center=center $ ,data=data,normal=normal,device=device,charthick=charthick $ ,symsize=symsize,thick=thick,clear=clear,clrclear=clrclear ; ; =====>> HELP ; on_error,2 if keyword_set(help) then begin & doc_library,'legend' & return & endif ; ; =====>> SET DEFAULTS FOR SYMBOLS, LINESTYLES, AND ITEMS. ; ni = n_elements(items) np = n_elements(psym) nl = n_elements(linestyle) nth = n_elements(thick) nv = n_elements(vectorfont) nlpv = max([np,nl,nv]) n = max([ni,np,nl,nv]) ; NUMBER OF ENTRIES strn = strtrim(n,2) ; FOR ERROR MESSAGES if n eq 0 then message,'No inputs! For help, type legend,/help.' if ni eq 0 then begin items = replicate('',n) ; DEFAULT BLANK ARRAY endif else begin szt = size(items) if (szt[szt[0]+1] ne 7) then message,'First parameter must be a string array. For help, type legend,/help.' if ni ne n then message,'Must have number of items equal to '+strn endelse symline = (np ne 0) or (nl ne 0) ; FLAG TO PLOT SYM/LINE if (np ne 0) and (np ne n) and (np NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in PSYM array.' if (nl ne 0) and (nl ne n) and (nl NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in LINESTYLE array.' if (nth ne 0) and (nth ne n) and (nth NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in THICK array.' if nl EQ 0 then linestyle = intarr(n) else $ D=SOLID if nl EQ 1 then linestyle = intarr(n) + linestyle if nth EQ 0 then thick = intarr(n) + 1 else $ if nth EQ 1 then thick = intarr(n) + thick if np EQ 0 then psym = intarr(n) else $ ; D=SOLID if np EQ 1 then psym = intarr(n) + psym if nv EQ 0 then vectorfont = replicate('',n) else $ if nv EQ 1 then vectorfont = replicate(vectorfont,n) ; ; =====>> CHOOSE VERTICAL OR HORIZONTAL ORIENTATION. ; if n_elements(horizontal) eq 0 then begin ; D=VERTICAL if n_elements(vertical) eq 0 then vertical = 1 endif else begin if n_elements(vertical) eq 0 then vertical = not horizontal endelse ; ; =====>> SET DEFAULTS FOR OTHER OPTIONS. ; if n_elements(box) eq 0 then box = 1 if n_elements(clear) eq 0 then clear = 0 if n_elements(clrclear) eq 0 then cclr = -1 else cclr=clrclear(0) if n_elements(charthick) eq 0 then chthk= 1 else chthk=charthick(0) if n_elements(margin) eq 0 then margin = 0.5 if n_elements(delimiter) eq 0 then delimiter = '' if n_elements(charsize) eq 0 then charsize = !p.charsize if charsize eq 0 then charsize = 1 if (n_elements (symsize) eq 0) then symsize= charsize + intarr(n) if n_elements(number) eq 0 then number = 1 if n_elements(colors) eq 0 then colors = !P.color + intarr(n) else $ if N_elements(colors) EQ 1 then colors = colors + intarr(n) if n_elements(textcolors) eq 0 then textcolors = !P.color + intarr(n) else $ if N_elements(textcolors) EQ 1 then textcolors = textcolors + intarr(n) fill = keyword_set(fill) if n_elements(usersym) eq 0 then usersym = 2*[[0,0],[0,1],[1,1],[1,0]]-1 ; ; =====>> INITIALIZE SPACING ; if n_elements(spacing) eq 0 then spacing = 1.2 if n_elements(pspacing) eq 0 then pspacing = 3 xspacing = !d.x_ch_size/float(!d.x_size) * (spacing > charsize) yspacing = !d.y_ch_size/float(!d.y_size) * (spacing > charsize) ltor = 1 ; flag for left-to-right if n_elements(left) eq 1 then ltor = left eq 1 if n_elements(right) eq 1 then ltor = right ne 1 ttob = 1 ; flag for top-to-bottom if n_elements(top) eq 1 then ttob = top eq 1 if n_elements(bottom) eq 1 then ttob = bottom ne 1 xalign = ltor ne 1 ; x alignment: 1 or 0 yalign = -0.5*ttob + 1 ; y alignment: 0.5 or 1 xsign = 2*ltor - 1 ; xspacing direction: 1 or -1 ysign = 2*ttob - 1 ; yspacing direction: 1 or -1 if not ttob then yspacing = -yspacing if not ltor then xspacing = -xspacing ; ; =====>> INITIALIZE POSITIONS: FIRST CALCULATE X OFFSET FOR TEXT ; xt = 0 if nlpv gt 0 then begin ; SKIP IF TEXT ITEMS ONLY. if vertical then begin ; CALC OFFSET FOR TEXT START for i = 0,n-1 do begin if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE if psym[i] eq 0 then expand = 1 else expand = 2 thisxt = (expand*pspacing*(num-1)*xspacing) if ltor then xt = thisxt > xt else xt = thisxt < xt endfor endif ; NOW xt IS AN X OFFSET TO ALIGN ALL TEXT ENTRIES. endif ; ; =====>> INITIALIZE POSITIONS: SECOND LOCATE BORDER ; if !x.window[0] eq !x.window[1] then begin plot,/nodata,xstyle=4,ystyle=4,[0],/noerase endif ; next line takes care of weirdness with small windows pos = [min(!x.window),min(!y.window),max(!x.window),max(!y.window)] case n_elements(position) of 0: begin if ltor then px = pos[0] else px = pos[2] if ttob then py = pos[3] else py = pos[1] if keyword_set(center) then begin if not keyword_set(right) and not keyword_set(left) then $ px = (pos[0] + pos[2])/2. - xt if not keyword_set(top) and not keyword_set(bottom) then $ py = (pos[1] + pos[3])/2. + n*yspacing endif position = [px,py] + [xspacing,-yspacing] end 1: begin ; interactive message,/inform,'Place mouse at upper left corner and click any mouse button.' cursor,x,y,/normal position = [x,y] end 2: begin ; convert upper left corner to normal coordinates if keyword_set(data) then $ position = convert_coord(position,/to_norm) $ else if keyword_set(device) then $ position = convert_coord(position,/to_norm,/device) $ else if not keyword_set(normal) then $ position = convert_coord(position,/to_norm) end else: message,'Position keyword can have 0, 1, or 2 elements only. Try legend,/help.' endcase yoff = 0.25*yspacing*ysign ; VERT. OFFSET FOR SYM/LINE. x0 = position[0] + (margin)*xspacing ; INITIAL X & Y POSITIONS y0 = position[1] - margin*yspacing + yalign*yspacing ; WELL, THIS WORKS! ; ; =====>> OUTPUT TEXT FOR LEGEND, ITEM BY ITEM. ; =====>> FOR EACH ITEM, PLACE SYM/LINE, THEN DELIMITER, ; =====>> THEN TEXT---UPDATING X & Y POSITIONS EACH TIME. ; =====>> THERE ARE A NUMBER OF EXCEPTIONS DONE WITH IF STATEMENTS. ; for iclr = 0,clear do begin y = y0 ; STARTING X & Y POSITIONS x = x0 if ltor then xend = 0 else xend = 1 ; SAVED WIDTH FOR DRAWING BOX if ttob then ii = [0,n-1,1] else ii = [n-1,0,-1] for i = ii[0],ii[1],ii[2] do begin if vertical then x = x0 else y = y0 ; RESET EITHER X OR Y x = x + xspacing ; UPDATE X & Y POSITIONS y = y - yspacing if nlpv eq 0 then goto,TEXT_ONLY ; FLAG FOR TEXT ONLY if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE if psym[i] eq 0 then expand = 1 else expand = 2 xp = x + expand*pspacing*indgen(num)*xspacing if (psym[i] gt 0) and (num eq 1) and vertical then xp = x + xt/2. yp = y + intarr(num) if vectorfont[i] eq '' then yp = yp + yoff if psym[i] eq 0 then begin xp = [min(xp),max(xp)] ; TO EXPOSE LINESTYLES yp = [min(yp),max(yp)] ; DITTO endif if psym[i] eq 8 then usersym,usersym,fill=fill,color=colors[i] ;; extra by djseed .. psym=88 means use the already defined usersymbol if psym[i] eq 88 then psym[i] =8 if vectorfont[i] ne '' then begin ; if (num eq 1) and vertical then xp = x + xt/2 ; IF 1, CENTERED. xyouts,xp,yp,vectorfont[i],width=width,color=colors[i] $ ,size=charsize,align=xalign,/norm xt = xt > width xp = xp + width/2. endif else begin if symline and (linestyle[i] ge 0) then plots,xp,yp,color=colors[i] $ ,/normal,linestyle=linestyle[i],psym=psym[i],symsize=symsize[i], $ thick=thick[i] endelse if vertical then x = x + xt else if ltor then x = max(xp) else x = min(xp) if symline then x = x + xspacing TEXT_ONLY: xyouts,x,y,delimiter,width=width,/norm,color=textcolors[i],size=charsize,align=xalign x = x + width*xsign if width ne 0 then x = x + 0.5*xspacing xyouts,x,y,items[i],width=width,/norm,color=textcolors[i],size=charsize,align=xalign,charthick=chthk x = x + width*xsign if not vertical and (i lt (n-1)) then x = x+2*xspacing; ADD INTER-ITEM SPACE xfinal = (x + xspacing*margin) if ltor then xend = xfinal > xend else xend = xfinal < xend ; UPDATE END X endfor if (iclr lt clear ) then begin ; =====>> CLEAR AREA x = position[0] y = position[1] if vertical then bottom = n else bottom = 1 ywidth = - (2*margin+bottom-0.5)*yspacing corners = [x,y+ywidth,xend,y] polyfill,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm,color=cclr ; plots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],thick=2 endif else begin ; ; =====>> OUTPUT BORDER ; x = position[0] y = position[1] if vertical then bottom = n else bottom = 1 ywidth = - (2*margin+bottom-0.5)*yspacing corners = [x,y+ywidth,xend,y] if box then plots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm return endelse endfor end -####################################################### # ;+ ; function GREP,strarray,strin,pos=pos,ignore=ignore ; return: index array of string contained STRIN ; /ignore - ignore upper/lower case distinction during comparisons. ; ; Ex: aa=string(indgen(10)*4) ; print,grep(aa,'8',pos=i),i ;- function grep,strarray,strmask,pos=pos,ignore=ignore if keyword_set(ignore) then begin strar=strupcase(strarray) strm=strupcase(strmask) endif else begin strar=strarray & strm=strmask end pos =-1 nst=strpos(strar,strm) ii=nst nst=where(ii ne (-1)) if nst(0) eq (-1) then goto,aaa pos=ii(nst) aaa:return,nst end -####################################################### # PRO HELIOTRANS,X0,Y0,CROTA2,POS,BLAT,BLONG,IX,IY,IR,HLONG,HLAT ;transforms spherical coordinates [IX-X0,IY-Y0,IR] into cartesian coordinates ;[HLONG,HLAT] of heliografic longitude/latitude. ; ;X0, Y0 are pixel coords of disk center ;POS is position angle to rotate, CROTA2 is rotation angle of image: both zero ;BLAT,BLONG is heliografic longitude and latitude of disk center. ;IX, IY are coords to be rotated: one may be an array (pixels) ;IR is solar radius in units of pixels: height of rotating surface ;HLONG, HLAT are helio lat and long - the output PI =ACOS(-1.) &DPOS =POS+CROTA2 X =FLOAT(IX-X0) &Y =FLOAT(IY-Y0) POSRAD =-DPOS*PI/180. &BLATRAD=BLAT*PI/180. SINPOS =SIN(POSRAD) &COSPOS =COS(POSRAD) SINBLAT =SIN(BLATRAD) &COSBLAT=COS(BLATRAD) RXY =SQRT(X^2+Y^2) RR =FLOAT(IR) > RXY Z2 =RR^2-Y^2-X^2 ;z-coordinate squared Z =SQRT(Z2 > 0) ;z-coordinate XX =X*COSPOS-Y*SINPOS ;rotation position angle Y1 =X*SINPOS+Y*COSPOS YY =Z*SINBLAT+Y1*COSBLAT ;rotation by BLAT V2 =(RR^2-YY^2) V =SQRT(V2 > 0) ;radius proj in equator-plane SINPHI =IX*0.+1. ind =where(v gt 0) SINPHI(ind)=(XX(ind)/V(ind)) ;longitude difference from center SINPHI =SINPHI > (IX*0.-1.) SINPHI =SINPHI < (IX*0.+1.) DLON =XX*0. ind =where(sinphi ne 0) DLON(ind)=(180./PI)*ASIN(SINPHI(ind)) ;longitude difference in degree HLONG =BLONG+DLON ;heliographic longitude SINLAT =(YY/RR) HLAT =(180./PI)*ASIN(SINLAT) ;heliographic latitude END -####################################################### # PRO HELIOTRANS2,X0,Y0,CROTA2,POS,BLAT,BLONG,HLONG,HLAT,IR,IX,IY ;transforms cartesian coordinates [HLONG,HLAT] of heliografic ;longitude/latitude into spherical coordinates [X,Y,R]=[IX-X0,IY-Y0,IR] ;POS is position angle, CROTA2 = rotation angle of image ;BLAT,BLONG is heliografic longitude and latitude of disk center. PI =ACOS(-1.) &EPS =1.E-8 DPOS =POS+CROTA2 &DLON =HLONG-BLONG POSRAD =+DPOS*PI/180. &BLATRAD=+BLAT*PI/180. SINPOS =SIN(POSRAD) &COSPOS =COS(POSRAD) SINBLAT =SIN(BLATRAD) &COSBLAT=COS(BLATRAD) SINPHI =SIN(DLON*PI/180.) &SINLAT =SIN(HLAT*PI/180.) Y1 =IR*SINLAT ;HLONG-SIN equatorial coord X1 =SQRT(IR^2-Y1^2)*SINPHI ;HLAT-SIN equatorial coord. Z1 =SQRT(IR^2-Y1^2-X1^2 > EPS);z-coordinate X2 =X1 ;x-coordinate Y2 =-Z1*SINBLAT+Y1*COSBLAT ;disk center at BLAT,BLONG X3 =X2*COSPOS-Y2*SINPOS ;position angle rotation Y3 =X2*SINPOS+Y2*COSPOS ;position angle rotation IX =X3+X0 ;RA-SIN with image center at X0 IY =Y3+Y0 ;DEC-SIN with image center at Y0 END -####################################################### # pro hessiinfo,fname,silent=silent,strinfo=strinfo if n_params(0) ne 1 then begin print,' Usage: hessiinfo,fname,[/silent],[strinfo=strinfo] print,' fname -HESSI FITS file name' print,' strinfo - ounput FITS information string array' print,' /silent - no messages' return end if (findfile(fname))(0) eq '' then begin strinfo=fname+' does not exist' goto,pend end if !version.os eq 'Win32' then ns='\' else ns='/' j=rstrpos(fname,ns) xname=strmid(fname,j+1,255) ns=0 strinfo=strarr(5000) xx=mrdfits(fname,ns,hdr,status=j,/sil) if j lt 0 then begin strinfo=xname+' is not a FITS file' goto,pend end nn=fxpar(hdr,'ORIGIN') if strtrim(string(nn(0)),2) ne 'HESSI' then begin strinfo=xname+' is not a HESSI FITS file' goto,pend end ext=fxpar(hdr,'EXTEND',count=j) nn=fxpar(hdr,'NAXIS') if (nn(0) ne 0) then begin strinfo(0)=xname+' is a HESSI FITS file' ext=fxpar(hdr,'NAXIS*') zz='('+string(nn)+'(",",I))' str='Image array ('+strmid(strcompress(string(ext,form=zz)),2,100)+')' strinfo(1)=str ns=2 if n_elements(ext) ne 4 then begin strinfo(ns)='It is not a image array' goto,zend end if j eq 0 then goto,zend end ;---BINTABLE--- xx=mrdfits(fname,1,hdr,status=j,/sil) if j lt 0 then begin strinfo(ns)='file is corrupted' goto,zend endif else strinfo(ns)='----info----' ns=ns+1 strinfo(ns)='Pixel size: '+string(fix(xx.pixel_size(0)))+string(fix(xx.pixel_size(1))) ns=ns+1 strinfo(ns)='XY offset : '+string(fix(xx.xyoffset(0)))+string(fix(xx.xyoffset(1))) ns=ns+1 strinfo(ns)=string(ext(2))+' energy bands:' for i=0,ext(2)-1 do begin ns=ns+1 strinfo(ns)=string(fix(xx.ebands_arr(0,i)))+' - '+string(fix(xx.ebands_arr(1,i)))+'keV' end ns=ns+1 strinfo(ns)=string(ext(3))+' time intervals:' for i=0,ext(3)-1 do begin ns=ns+1 strinfo(ns)=string(i,form='(i4)')+': '+sec2date(xx.times_arr(0,i),dy=9)+$ ' - '+sec2date(xx.times_arr(1,i),dy=9) end zend: i=where(strinfo ne '') strinfo=strinfo(i) pend: if not keyword_set(silent) then for i=0,n_elements(strinfo)-1 do print,strinfo(i) end -####################################################### # pro hessipng2ps,dir,multi=multi,file=file if n_elements(multi) eq 2 then xy=multi else xy=[2,3] if n_elements(file) eq 0 then nfile='idl.ps' else nfile=file(0) zz=xy(0)*xy(1) if n_elements(dir) eq 0 then dir='' x=findfile(dir+'hsi_*.png') if x(0) eq '' then return set1ps,nfile,col=0,ys=24 n=n_elements(x) for i=0,n-1 do begin if i mod zz eq 0 then multiplot,xy,asp=1.33333,xmar=[1,1],ymar=[1,1] if query_image(x(i)) eq 1 then arr=read_image(x(i),rr,gg,bb) y=arr j=where(arr eq 0) if j(0) ge 0 then y(j)=255 j=where(arr eq 255) if j(0) ge 0 then y(j)=0 j=where(arr eq 1) if j(0) ge 0 then y(j)=0 tvlct,rr,gg,bb fitstvscl,y,/tv,/asp,/noint,/notick,tickl=1e-5,psgrid=640 multiplot end multiplot,/def set_ps,0 end -####################################################### # function hmsticks,axis,index,value xx=value mod 86400. if xx lt 0 then xx=xx+86400. hh=long(xx)/3600 mm=long(xx-3600*hh)/60 ss=xx mod 60 str=string(hh,mm,ss,format="(i2.2,':',i2.2,':',i2.2)") return, str end -####################################################### # function hmticks,axis,index,value xx=value mod 86400. if xx lt 0 then xx=xx+86400. hh=long(xx)/3600 mm=long(xx-3600*hh)/60 str=string(hh,mm,format="(i2.2,':',i2.2)") return, str end -####################################################### # if n_elements(ndir) eq 0 then ndir='ffi' if n_elements(ipa) lt 10 then begin nf=findfile(ndir+'/ipa0*') if n_elements(indx) eq 0 then mreadfits,nf,hdr,ipa else mreadfits,nf(indx),hdr,ipa nf=findfile(ndir+'/ips0*') if n_elements(indx) eq 0 then mreadfits,nf,hdr,ips else mreadfits,nf(indx),hdr,ips end if n_elements(i17) lt 5 then i17=total_flux(ipa,freq=17,pix=2.4555) tt=str2sec(hdr.time_d$obs) i=n_elements(tt) k=i/14 ii=indgen(15)*k !p.charsize=1.0 multiplot,/def if n_elements(z) lt 10 then z=varmap(ipa) multiplot,[4,4],asp=1 fitstvscl,-z^0.5,hdr,psgrid=200 legend,box=0,'Var.Map',textc=0 multiplot for i=0,14 do begin fitstvscl,-(ipa(*,*,ii(i))>1e3)^0.5,hdr,psgrid=200 fitscontour,ips(*,*,ii(i)),hdr,pl=[30,60,90],col=255 solargrid,hdr(0).solb,dx=5,dy=5 legend,box=0,strmid(hdr(ii(i)).time_d$obs,0,8),textc=0 multiplot end plot,tt,i17,xsty=1,/yno,xtickf='hmsticks',xticks=6,pos=[0.1,0.8,0.95,0.95],/noeras,$ titl='17GHz time profile and images at '+hdr(k).date_d$obs,ytit='Flux, sfu', xtit='Time, UT' end -####################################################### # !path='.:/home/gvi/lib/idl:'+!path -####################################################### # function imagelevels, img,level=level,plevel=plevel,smoothpix=smoothpix mn=float(min(img,max=mx)) if n_elements(smoothpix) gt 0 then smt=smoothpix(0) else smt=2 if smt gt 1 then begin img1=median(img,2) img1=smooth(img1,smt) end else img1=img if n_elements(level) gt 0 then clev=level else begin if n_elements(plevel) gt 0 then clev=plevel else clev=[10.,30.,50.,70.,90.] if mn*mx lt 0 then begin clev=[-clev,0.,clev]/100. mx=max([abs(mx),abs(mn)]) mn=0. endif else clev=clev/100. clev=clev*(mx-mn)+mn end clev=clev(sort(clev)) clev=clev(uniq(clev)) img2=img & img2(*,*)=0. for i=0,n_elements(clev)-1 do img2=img2+(img1 gt clev(i)) return,img2 end -####################################################### # pro img_control,i,n,qdone,qwait,silent=silent if n_params(0) ne 4 then begin print,'Usage: img_control,i,N,qdone,qwait,/silent' print,' i - index variable' print,' N - number of elements' return end ans = strlowcase(get_kbrd(qwait)) jj=0 case ans of 'q': qdone=0 'm': qwait=0 's': qwait=1 'n': jj=1 'p': jj=-1 else: endcase if qwait ne 0 then begin i=(i+jj) mod n if i lt 0 then i=i+n endif else i=(i+1) mod n if n_elements(silent) eq 0 then begin ss='M- movie ; S - step; N-next ; P - previous; Q- quit '+string(i) polyfill,/dev,col=!p.background,[0,0,!d.x_size,!d.x_size,0],$ [0,!d.y_ch_size*3/2,!d.y_ch_size*3/2,0,0] xyouts,1,2,ss,/dev end end -####################################################### # ;+ ; NAME: ; LEGEND ; PURPOSE: ; Create an annotation legend for a plot. ; EXPLANATION: ; This procedure makes a legend for a plot. The legend can contain ; a mixture of symbols, linestyles, Hershey characters (vectorfont), ; and filled polygons (usersym). A test procedure, legendtest.pro, ; shows legend's capabilities. Placement of the legend is controlled ; with keywords like /right, /top, and /center or by using a position ; keyword for exact placement (position=[x,y]) or via mouse (/position). ; CALLING SEQUENCE: ; LEGEND [,items][,keyword options] ; EXAMPLES: ; The call: ; legend,['Plus sign','Asterisk','Period'],psym=[1,2,3] ; produces: ; ----------------- ; | | ; | + Plus sign | ; | * Asterisk | ; | . Period | ; | | ; ----------------- ; Each symbol is drawn with a plots command, so they look OK. ; Other examples are given in optional output keywords. ; ; lines = indgen(6) ; for line styles ; items = 'linestyle '+strtrim(lines,2) ; annotations ; legend,items,linestyle=lines ; vertical legend---upper left ; items = ['Plus sign','Asterisk','Period'] ; sym = [1,2,3] ; legend,items,psym=sym ; ditto except using symbols ; legend,items,psym=sym,/horizontal ; horizontal format ; legend,items,psym=sym,box=0 ; sans border ; legend,items,psym=sym,delimiter='=' ; embed '=' betw psym & text ; legend,items,psym=sym,margin=2 ; 2-character margin ; legend,items,psym=sym,position=[x,y] ; upper left in data coords ; legend,items,psym=sym,pos=[x,y],/norm ; upper left in normal coords ; legend,items,psym=sym,pos=[x,y],/device ; upper left in device coords ; legend,items,psym=sym,/position ; interactive position ; legend,items,psym=sym,/right ; at upper right ; legend,items,psym=sym,/bottom ; at lower left ; legend,items,psym=sym,/center ; approximately near center ; legend,items,psym=sym,number=2 ; plot two symbols, not one ; legend,items,/fill,psym=[8,8,8],colors=[10,20,30]; 3 filled squares ; INPUTS: ; items = text for the items in the legend, a string array. ; For example, items = ['diamond','asterisk','square']. ; You can omit items if you don't want any text labels. ; OPTIONAL INPUT KEYWORDS: ; ; linestyle = array of linestyle numbers If linestyle(i) < 0, then omit ; ith symbol or line to allow a multi-line entry. ; psym = array of plot symbol numbers. If psym(i) is negative, then a ; line connects pts for ith item. If psym(i) = 8, then the ; procedure usersym is called with vertices define in the ; keyword usersym. If psym(i) = 88, then use the previously ; defined user symbol ; vectorfont = vector-drawn characters for the sym/line column, e.g., ; ['!9B!3','!9C!3','!9D!3'] produces an open square, a checkmark, ; and a partial derivative, which might have accompanying items ; ['BOX','CHECK','PARTIAL DERIVATIVE']. ; There is no check that !p.font is set properly, e.g., -1 for ; X and 0 for PostScript. This can produce an error, e.g., use ; !20 with PostScript and !p.font=0, but allows use of Hershey ; *AND* PostScript fonts together. ; N. B.: Choose any of linestyle, psym, and/or vectorfont. If none is ; present, only the text is output. If more than one ; is present, all need the same number of elements, and normal ; plot behaviour occurs. ; By default, if psym is positive, you get one point so there is ; no connecting line. If vectorfont(i) = '', ; then plots is called to make a symbol or a line, but if ; vectorfont(i) is a non-null string, then xyouts is called. ; /help = flag to print header ; /horizontal = flag to make the legend horizontal ; /vertical = flag to make the legend vertical (D=vertical) ; box = flag to include/omit box around the legend (D=include) ; clear = flag to clear the box area before drawing the legend ; delimiter = embedded character(s) between symbol and text (D=none) ; colors = array of colors for plot symbols/lines (D=!color) ; textcolors = array of colors for text (D=!color) ; margin = margin around text measured in characters and lines ; spacing = line spacing (D=bit more than character height) ; pspacing = psym spacing (D=3 characters) ; charsize = just like !p.charsize for plot labels ; charthick = array of char thickness numbers ; thick = array of line thickness numbers, if used, then linestyle ; must also be specified ; position = data coordinates of the /top (D) /left (D) of the legend ; normal = use normal coordinates for position, not data ; device = use device coordinates for position, not data ; number = number of plot symbols to plot or length of line (D=1) ; usersym = 2-D array of vertices, cf. usersym in IDL manual. (D=square) ; /fill = flag to fill the usersym ; /left = flag to place legend snug against left side of plot window (D) ; /right = flag to place legend snug against right side of plot window ; If /right,pos=[x,y], then x is position of RHS and text ; runs right-to-left. ; /top = flag to place legend snug against top of plot window (D) ; /bottom = flag to place legend snug against bottom of plot window ; /top,pos=[x,y] and /bottom,pos=[x,y] produce same positions. ; ; If LINESTYLE, PSYM, VECTORFONT, THICK, COLORS, or TEXTCOLORS are ; supplied as scalars, then the scalar value is set for every line or ; symbol in the legend. ; Outputs: ; legend to current plot device ; OPTIONAL OUTPUT KEYWORDS: ; corners = 4-element array, like !p.position, of the normalized ; coords for the box (even if box=0): [llx,lly,urx,ury]. ; Useful for multi-column or multi-line legends, for example, ; to make a 2-column legend, you might do the following: ; c1_items = ['diamond','asterisk','square'] ; c1_psym = [4,2,6] ; c2_items = ['solid','dashed','dotted'] ; c2_line = [0,2,1] ; legend,c1_items,psym=c1_psym,corners=c1,box=0 ; legend,c2_items,line=c2_line,corners=c2,box=0,pos=[c1(2),c1(3)] ; c = [c1(0)c2(2),c1(3)>c2(3)] ; plots,[c(0),c(0),c(2),c(2),c(0)],[c(1),c(3),c(3),c(1),c(1)],/norm ; Useful also to place the legend. Here's an automatic way to place ; the legend in the lower right corner. The difficulty is that the ; legend's width is unknown until it is plotted. In this example, ; the legend is plotted twice: the first time in the upper left, the ; second time in the lower right. ; legend,['1','22','333','4444'],linestyle=indgen(4),corners=corners ; ; BOGUS LEGEND---FIRST TIME TO REPORT CORNERS ; xydims = [corners(2)-corners(0),corners(3)-corners(1)] ; ; SAVE WIDTH AND HEIGHT ; chdim=[!d.x_ch_size/float(!d.x_size),!d.y_ch_size/float(!d.y_size)] ; ; DIMENSIONS OF ONE CHARACTER IN NORMALIZED COORDS ; pos = [!x.window(1)-chdim(0)-xydims(0) $ ; ,!y.window(0)+chdim(1)+xydims(1)] ; ; CALCULATE POSITION FOR LOWER RIGHT ; plot,findgen(10) ; SIMPLE PLOT; YOU DO WHATEVER YOU WANT HERE. ; legend,['1','22','333','4444'],linestyle=indgen(4),pos=pos ; ; REDO THE LEGEND IN LOWER RIGHT CORNER ; You can modify the pos calculation to place the legend where you ; want. For example to place it in the upper right: ; pos = [!x.window(1)-chdim(0)-xydims(0),!y.window(1)-xydims(1)] ; Common blocks: ; none ; Procedure: ; If keyword help is set, call doc_library to print header. ; See notes in the code. Much of the code deals with placement of the ; legend. The main problem with placement is not being ; able to sense the length of a string before it is output. Some crude ; approximations are used for centering. ; Restrictions: ; Here are some things that aren't implemented. ; - An orientation keyword would allow lines at angles in the legend. ; - An array of usersyms would be nice---simple change. ; - An order option to interchange symbols and text might be nice. ; - Somebody might like double boxes, e.g., with box = 2. ; - Another feature might be a continuous bar with ticks and text. ; - There are no guards to avoid writing outside the plot area. ; - There is no provision for multi-line text, e.g., '1st line!c2nd line' ; Sensing !c would be easy, but !c isn't implemented for PostScript. ; A better way might be to simply output the 2nd line as another item ; but without any accompanying symbol or linestyle. A flag to omit ; the symbol and linestyle is linestyle(i) = -1. ; - There is no ability to make a title line containing any of titles ; for the legend, for the symbols, or for the text. ; Side Effects: ; Modification history: ; write, 24-25 Aug 92, F K Knight (knight@ll.mit.edu) ; allow omission of items or omission of both psym and linestyle, add ; corners keyword to facilitate multi-column legends, improve place- ; ment of symbols and text, add guards for unequal size, 26 Aug 92, FKK ; add linestyle(i)=-1 to suppress a single symbol/line, 27 Aug 92, FKK ; add keyword vectorfont to allow characters in the sym/line column, ; 28 Aug 92, FKK ; add /top, /bottom, /left, /right keywords for automatic placement at ; the four corners of the plot window. The /right keyword forces ; right-to-left printing of menu. 18 Jun 93, FKK ; change default position to data coords and add normal, data, and ; device keywords, 17 Jan 94, FKK ; add /center keyword for positioning, but it is not precise because ; text string lengths cannot be known in advance, 17 Jan 94, FKK ; add interactive positioning with /position keyword, 17 Jan 94, FKK ; allow a legend with just text, no plotting symbols. This helps in ; simply describing a plot or writing assumptions done, 4 Feb 94, FKK ; added thick, symsize, and clear keyword Feb 96, W. Landsman HSTX ; David Seed, HR Wallingford, d.seed@hrwallingford.co.uk ; allow scalar specification of keywords, Mar 96, W. Landsman HSTX ; Converted to IDL V5.0 W. Landsman September 1997 ;- pro legend,help=help,items,linestyle=linestyle,psym=psym,vectorfont=vectorfont $ ,horizontal=horizontal,vertical=vertical,box=box,margin=margin $ ,delimiter=delimiter,spacing=spacing,charsize=charsize,pspacing=pspacing $ ,position=position,number=number,colors=colors,textcolors=textcolors $ ,fill=fill,usersym=usersym,corners=corners $ ,left=left,right=right,top=top,bottom=bottom,center=center $ ,data=data,normal=normal,device=device,charthick=charthick $ ,symsize=symsize,thick=thick,clear=clear ; ; =====>> HELP ; on_error,2 if keyword_set(help) then begin & doc_library,'legend' & return & endif ; ; =====>> SET DEFAULTS FOR SYMBOLS, LINESTYLES, AND ITEMS. ; ni = n_elements(items) np = n_elements(psym) nl = n_elements(linestyle) nth = n_elements(thick) nv = n_elements(vectorfont) nlpv = max([np,nl,nv]) n = max([ni,np,nl,nv]) ; NUMBER OF ENTRIES strn = strtrim(n,2) ; FOR ERROR MESSAGES if n eq 0 then message,'No inputs! For help, type legend,/help.' if ni eq 0 then begin items = replicate('',n) ; DEFAULT BLANK ARRAY endif else begin szt = size(items) if (szt[szt[0]+1] ne 7) then message,'First parameter must be a string array. For help, type legend,/help.' if ni ne n then message,'Must have number of items equal to '+strn endelse symline = (np ne 0) or (nl ne 0) ; FLAG TO PLOT SYM/LINE if (np ne 0) and (np ne n) and (np NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in PSYM array.' if (nl ne 0) and (nl ne n) and (nl NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in LINESTYLE array.' if (nth ne 0) and (nth ne n) and (nth NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in THICK array.' if nl EQ 0 then linestyle = intarr(n) else $ D=SOLID if nl EQ 1 then linestyle = intarr(n) + linestyle if nth EQ 0 then thick = intarr(n) + 1 else $ if nth EQ 1 then thick = intarr(n) + thick if np EQ 0 then psym = intarr(n) else $ ; D=SOLID if np EQ 1 then psym = intarr(n) + psym if nv EQ 0 then vectorfont = replicate('',n) else $ if nv EQ 1 then vectorfont = replicate(vectorfont,n) ; ; =====>> CHOOSE VERTICAL OR HORIZONTAL ORIENTATION. ; if n_elements(horizontal) eq 0 then begin ; D=VERTICAL if n_elements(vertical) eq 0 then vertical = 1 endif else begin if n_elements(vertical) eq 0 then vertical = not horizontal endelse ; ; =====>> SET DEFAULTS FOR OTHER OPTIONS. ; if n_elements(box) eq 0 then box = 1 if n_elements(clear) eq 0 then _clear = -1 else _clear=clear(0)>0<255 if n_elements(charthick) eq 0 then chthk= 1 else chthk=charthick(0) if n_elements(margin) eq 0 then margin = 0.5 if n_elements(delimiter) eq 0 then delimiter = '' if n_elements(charsize) eq 0 then charsize = !p.charsize if charsize eq 0 then charsize = 1 if (n_elements (symsize) eq 0) then symsize= charsize + intarr(n) if n_elements(number) eq 0 then number = 1 if n_elements(colors) eq 0 then colors = !P.color + intarr(n) else $ if N_elements(colors) EQ 1 then colors = colors + intarr(n) if n_elements(textcolors) eq 0 then textcolors = !P.color + intarr(n) else $ if N_elements(textcolors) EQ 1 then textcolors = textcolors + intarr(n) fill = keyword_set(fill) if n_elements(usersym) eq 0 then usersym = 2*[[0,0],[0,1],[1,1],[1,0]]-1 ; ; =====>> INITIALIZE SPACING ; if n_elements(spacing) eq 0 then spacing = 1.2 if n_elements(pspacing) eq 0 then pspacing = 3 xspacing = !d.x_ch_size/float(!d.x_size) * (spacing > charsize) yspacing = !d.y_ch_size/float(!d.y_size) * (spacing > charsize) ltor = 1 ; flag for left-to-right if n_elements(left) eq 1 then ltor = left eq 1 if n_elements(right) eq 1 then ltor = right ne 1 ttob = 1 ; flag for top-to-bottom if n_elements(top) eq 1 then ttob = top eq 1 if n_elements(bottom) eq 1 then ttob = bottom ne 1 xalign = ltor ne 1 ; x alignment: 1 or 0 yalign = -0.5*ttob + 1 ; y alignment: 0.5 or 1 xsign = 2*ltor - 1 ; xspacing direction: 1 or -1 ysign = 2*ttob - 1 ; yspacing direction: 1 or -1 if not ttob then yspacing = -yspacing if not ltor then xspacing = -xspacing ; ; =====>> INITIALIZE POSITIONS: FIRST CALCULATE X OFFSET FOR TEXT ; xt = 0 if nlpv gt 0 then begin ; SKIP IF TEXT ITEMS ONLY. if vertical then begin ; CALC OFFSET FOR TEXT START for i = 0,n-1 do begin if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE if psym[i] eq 0 then expand = 1 else expand = 2 thisxt = (expand*pspacing*(num-1)*xspacing) if ltor then xt = thisxt > xt else xt = thisxt < xt endfor endif ; NOW xt IS AN X OFFSET TO ALIGN ALL TEXT ENTRIES. endif ; ; =====>> INITIALIZE POSITIONS: SECOND LOCATE BORDER ; if !x.window[0] eq !x.window[1] then begin plot,/nodata,xstyle=4,ystyle=4,[0],/noerase endif ; next line takes care of weirdness with small windows pos = [min(!x.window),min(!y.window),max(!x.window),max(!y.window)] case n_elements(position) of 0: begin if ltor then px = pos[0] else px = pos[2] if ttob then py = pos[3] else py = pos[1] if keyword_set(center) then begin if not keyword_set(right) and not keyword_set(left) then $ px = (pos[0] + pos[2])/2. - xt if not keyword_set(top) and not keyword_set(bottom) then $ py = (pos[1] + pos[3])/2. + n*yspacing endif position = [px,py] + [xspacing,-yspacing] end 1: begin ; interactive message,/inform,'Place mouse at upper left corner and click any mouse button.' cursor,x,y,/normal position = [x,y] end 2: begin ; convert upper left corner to normal coordinates if keyword_set(data) then $ position = convert_coord(position,/to_norm) $ else if keyword_set(device) then $ position = convert_coord(position,/to_norm,/device) $ else if not keyword_set(normal) then $ position = convert_coord(position,/to_norm) end else: message,'Position keyword can have 0, 1, or 2 elements only. Try legend,/help.' endcase yoff = 0.25*yspacing*ysign ; VERT. OFFSET FOR SYM/LINE. x0 = position[0] + (margin)*xspacing ; INITIAL X & Y POSITIONS y0 = position[1] - margin*yspacing + yalign*yspacing ; WELL, THIS WORKS! ; ; =====>> OUTPUT TEXT FOR LEGEND, ITEM BY ITEM. ; =====>> FOR EACH ITEM, PLACE SYM/LINE, THEN DELIMITER, ; =====>> THEN TEXT---UPDATING X & Y POSITIONS EACH TIME. ; =====>> THERE ARE A NUMBER OF EXCEPTIONS DONE WITH IF STATEMENTS. ; if _clear lt 0 then clear=0 else clear=1 for iclr = 0,clear do begin y = y0 ; STARTING X & Y POSITIONS x = x0 if ltor then xend = 0 else xend = 1 ; SAVED WIDTH FOR DRAWING BOX if ttob then ii = [0,n-1,1] else ii = [n-1,0,-1] for i = ii[0],ii[1],ii[2] do begin if vertical then x = x0 else y = y0 ; RESET EITHER X OR Y x = x + xspacing ; UPDATE X & Y POSITIONS y = y - yspacing if nlpv eq 0 then goto,TEXT_ONLY ; FLAG FOR TEXT ONLY if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE if psym[i] eq 0 then expand = 1 else expand = 2 xp = x + expand*pspacing*indgen(num)*xspacing if (psym[i] gt 0) and (num eq 1) and vertical then xp = x + xt/2. yp = y + intarr(num) if vectorfont[i] eq '' then yp = yp + yoff if psym[i] eq 0 then begin xp = [min(xp),max(xp)] ; TO EXPOSE LINESTYLES yp = [min(yp),max(yp)] ; DITTO endif if psym[i] eq 8 then usersym,usersym,fill=fill,color=colors[i] ;; extra by djseed .. psym=88 means use the already defined usersymbol if psym[i] eq 88 then psym[i] =8 if vectorfont[i] ne '' then begin ; if (num eq 1) and vertical then xp = x + xt/2 ; IF 1, CENTERED. xyouts,xp,yp,vectorfont[i],width=width,color=colors[i] $ ,size=charsize,align=xalign,/norm xt = xt > width xp = xp + width/2. endif else begin if symline and (linestyle[i] ge 0) then plots,xp,yp,color=colors[i] $ ,/normal,linestyle=linestyle[i],psym=psym[i],symsize=symsize[i], $ thick=thick[i] endelse if vertical then x = x + xt else if ltor then x = max(xp) else x = min(xp) if symline then x = x + xspacing TEXT_ONLY: xyouts,x,y,delimiter,width=width,/norm,color=textcolors[i],size=charsize,align=xalign x = x + width*xsign if width ne 0 then x = x + 0.5*xspacing xyouts,x,y,items[i],width=width,/norm,color=textcolors[i],size=charsize,align=xalign,charthick=chthk x = x + width*xsign if not vertical and (i lt (n-1)) then x = x+2*xspacing; ADD INTER-ITEM SPACE xfinal = (x + xspacing*margin) if ltor then xend = xfinal > xend else xend = xfinal < xend ; UPDATE END X endfor if (iclr lt clear ) then begin ; =====>> CLEAR AREA x = position[0] y = position[1] if vertical then bottom = n else bottom = 1 ywidth = - (2*margin+bottom-0.5)*yspacing corners = [x,y+ywidth,xend,y] polyfill,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm,color=_clear ; plots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],thick=2 endif else begin ; ; =====>> OUTPUT BORDER ; x = position[0] y = position[1] if vertical then bottom = n else bottom = 1 ywidth = - (2*margin+bottom-0.5)*yspacing corners = [x,y+ywidth,xend,y] if box then plots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm return endelse endfor end -####################################################### # pro loadrb gg=bytarr(256) & rr=gg & bb=gg for i=0,127 do gg(i)=fix(i*2) for i=0,127 do gg(i+128)=fix((127-i)*2) gg(126:128)=255 bb(0:128)=255 rr(128:*)=255 bb(0)=0 gg(0)=0 tvlct,rr,gg,bb end -####################################################### # pro mdicuberot,fname,date,time,cube,xy=xy,hdr=hdr,r_sun=r_sun,b0_sun=b0_sun if n_params(0) ne 4 then begin print,'Usage: mdicuberot,fname,date,time,cube,xy=xy,hdr=hdr,r_sun=r_sun,b0_sun=b0_sun' print,' fname - file names MASK or ARRAY' print,' date - date at format YYYY/MM/DD' print,' time - time at format HH:MM:SS.SSS' print,' cube - output data array' print,' xy - 4-elements array with box coord [x0,y0,x1,y1]' print,' hdr - FITS header of output cube' print,' r_sun - FITS header keyword R_sun in pixels (default is R_SUN)' print,' b0_sun - FITS header keyword (default is B0)' return end if n_elements(r_sun) eq 0 then r_s='R_SUN' else r_s=r_sun(0) if n_elements(b0_sun) eq 0 then b_s='B0' else b_s=b0_sun(0) r1s=size(r_s) r1s=r1s(r1s(0)+1) i=n_elements(fname) if i eq 1 then fn=findfile(fname) else fn=fname n=n_elements(fn) x=readfits(fn(0),xh) i=size(x) j=n_elements(xy) if j ne 4 then cube=fltarr(i(1),i(2),n) $ else cube=fltarr(xy(2)-xy(0)+1,xy(3)-xy(1)+1,n) help,cube datetime=strarr(n) ho=str2sec(time)/86400. reads,date,yy,mm,dd,format='(i4,1x,i2,1x,i2)' ho=ho+date2mjd(yy,mm,dd) bo=(pb0r(date))(1) for i=0,n-1 do begin x=readfits(fn(i),xh,/sil) dt=fxpar(xh,'DATE-OBS') tm=fxpar(xh,'TIME-OBS') b0=fxpar(xh,b_s) p0=fxpar(xh,'P_ANGLE') datetime(i)=fxpar(xh,'DATE_OBS') x0=fxpar(xh,'CRPIX1') y0=fxpar(xh,'CRPIX2') if r1s eq 7 then r0=fxpar(xh,r_s) else r0=r_s tt=str2sec(tm)/86400. reads,dt,yy,mm,dd,format='(i4,1x,i2,1x,i2)' tt=tt+date2mjd(yy,mm,dd) tt=(ho-tt)*24. xi=sunrotate(x,x0,y0,r0,b0,p0,tt,1.,b1=bo) if j ne 4 then cube(*,*,i)=xi else cube(*,*,i)=xi[xy(0):xy(2),xy(1):xy(3)] if (i mod 5) eq 0 then print,'Image#',i,' is calculated' end if j eq 4 then i=xy(0) else i=0 sxaddpar,hdr,'CRPIX1',x0-i if j eq 4 then i=xy(1) else i=0 sxaddpar,hdr,'CRPIX2',y0-i cdel=fxpar(xh,'CDELT2') sxaddpar,hdr,'CDELT2',cdel cdel=fxpar(xh,'CDELT1') sxaddpar,hdr,'CDELT1',cdel sxaddpar,hdr,'SOLR',r0*cdel sxaddpar,hdr,'R_SUN',r0 sxaddpar,hdr,'DATE-OBS',date sxaddpar,hdr,'TIME-OBS',time sxaddpar,hdr,'B0',bo for i=0,n-1 do sxaddpar,hdr,'TIME'+strtrim(string(i+1),2),datetime(i) end -####################################################### # function med2img,img n=size(img) if n(0) ne 3 then return,img out=img(*,*,0) for i=0,n(1)-1 do for j=0,n(2)-1 do out(i,j)=median(reform(img(i,j,*))) return,out end -####################################################### # function medianmap,img n=size(img) if n(0) ne 3 then return,img out=img(*,*,0) for i=0,n(1)-1 do for j=0,n(2)-1 do out(i,j)=median(reform(img(i,j,*))) return,out end -####################################################### # PRO MJD2DATE, MJD, YEAR, MONTH, DAY, ERRMSG=ERRMSG ;+ ; Project : SOHO - CDS ; ; Name : MJD2DATE ; ; Purpose : Converts MJD to year, month, and day. ; ; Explanation : This procedure takes a Modified Julian Day number, and returns ; the corresponding calendar date in year, month, day. ; ; Use : MJD2DATE, MJD, YEAR, MONTH, DAY ; ; Inputs : MJD = Modified Julian Day number. ; ; Opt. Inputs : None. ; ; Outputs : YEAR = Calendar year corresponding to MJD. ; MONTH = Calendar month, from 1-12. ; DAY = Calendar day, from 1-31, depending on the month. ; ; Opt. Outputs: None. ; ; Keywords : ERRMSG = If defined and passed, then any error messages ; will be returned to the user in this parameter ; rather than being handled by the IDL MESSAGE ; utility. If no errors are encountered, then a null ; string is returned. In order to use this feature, ; the string ERRMSG must be defined first, e.g., ; ; ERRMSG = '' ; MJD2DATE, MJD, YEAR, MONTH, DAY, ERRMSG=ERRMSG ; IF ERRMSG NE '' THEN ... ; ; Calls : None. ; ; Common : None. ; ; Restrictions: None. ; ; Side effects: None. ; ; Category : Utilities, Time. ; ; Prev. Hist. : None. However, part of the logic of this routine is taken from ; DAYCNV by B. Pfarr, GSFC. ; ; Written : William Thompson, GSFC, 13 September 1993. ; ; Modified : Version 1, William Thompson, GSFC, 13 September 1993. ; Version 2, Donald G. Luttermoser, GSFC/ARC, 28 December 1994. ; Added the keyword ERRMSG. Note that there are no ; internally called procedures that use the ERRMSG ; keyword. ; Version 3, Donald G. Luttermoser, GSFC/ARC, 30 January 1995. ; Made the error handling procedure more robust. Note ; that this routine handles both scalars and vectors as ; input. ; ; Version : Version 3, 30 January 1995. ;- ; ON_ERROR, 2 ; Return to the caller of this procedure if error occurs. MESSAGE='' ; Error message that is returned if ERRMSG keyword set. ; ; Check the number of parameters. ; IF N_PARAMS() NE 4 THEN BEGIN MESSAGE = 'Syntax: MJD2DATE, MJD, YEAR, MONTH, DAY' GOTO, HANDLE_ERROR ENDIF ; ; From the Modified Julian Day, calculate the Julian Day number corresponding ; to noon of that same day. ; JD = LONG(2400001.D0 + MJD) ; ; From the Julian Day number, calculate the year, month and day, using the ; algorithm by Fliegel and Van Flandern (1968) reprinted in the Explanatory ; Supplement to the Astronomical Almanac, 1992. ; L = JD + 68569 N = 4 * L / 146097 L = L - (146097 * N + 3) / 4 YEAR = 4000 * (L + 1) / 1461001 L = L - 1461 * YEAR / 4 + 31 MONTH = 80 * L / 2447 DAY = L - 2447 * MONTH / 80 L = MONTH / 11 MONTH = MONTH + 2 - 12 * L YEAR = 100 * (N - 49) + YEAR + L ; IF N_ELEMENTS(ERRMSG) NE 0 THEN ERRMSG = MESSAGE RETURN ; ; Error handling point. HANDLE_ERROR: IF N_ELEMENTS(ERRMSG) EQ 0 THEN MESSAGE, MESSAGE ERRMSG = MESSAGE RETURN ; END -####################################################### # pro movie, arr,label=label,maximum=maximum,delay=delay if n_params(0) eq 0 then begin print,'Usage: movie, arr,label=label,maximum=maximum,delay=delay' print,' arr -3D array or list of FITS files' print,' label - string array' print,' delay - delay between frames [sec]' return end n=size(arr) k=n(n(0)+1) if (n(0) ne 3) and (k ne 7) then return n=n(n(0)) m=n_elements(label) !p.noerase=1 erase for i=0,n-1 do begin if k eq 7 then fitstvscl,readfits(arr(i),/sil),/asp,/notick $ else fitstvscl,arr(*,*,i),/asp,/notick if m ne 0 then legend,string(label(i<(m-1))),box=0 else $ if k eq 7 then legend,arr(i),box=0 else legend,string(i),box=0 if n_elements(maximum) ne 0 then legend,'max='+string(max(arr(*,*,i))),box=0,/bottom if n_elements(delay) ne 0 then wait,delay(0) end !p.noerase=0 end -####################################################### # function mpow, arr, power return, (arr > 0.)^power -(-arr>0.)^power end -####################################################### # ;+ ; Name: ; MULTIPLOT ; Purpose: ; Create multiple plots with shared axes. ; Explanation: ; This procedure makes a matrix of plots with *SHARED AXES*, either using ; parameters passed to multiplot or !p.multi in a non-standard way. ; It is good for data with one or two shared axes and retains all the ; versatility of the plot commands (e.g. all keywords and log scaling). ; The plots are connected with the shared axes, which saves space by ; omitting redundant ticklabels and titles. Multiplot does this by ; setting !p.position, !x.tickname and !y.tickname automatically. ; A call (multiplot,/reset) restores original values. ; ; Note: This method may be superseded by future improvements in !p.multi ; by RSI. For now, it's a good way to gang plots together. ; CALLING SEQUENCE: ; multiplot[pmulti][,/help][,/initialize][,/reset][,/rowmajor][,/top][,/right] ; [,title='...'][,aspect][,/noerase][,position][,xmargin][,ymargin][,margin] ; Examples: ; multiplot,/help ; print this header. ; ; Then copy & paste, from your xterm, the following lines to test: ; ; ; x = findgen(100) ; t=exp(-(x-50)^2/300) ; u=exp(-x/30) ; y = sin(x) ; r = reverse(y*u) ; ; TEST ; multiplot,[1,3] ; H------------------------ ; plot,x,y*u,title='TEST' ; E| plot #1 | ; multiplot ; I------------------------ ; plot,x,y*t,ytit='HEIGHT' ; G| plot #2 | ; multiplot ; H------------------------ ; plot,x,r,xtit='PHASE' ; T| plot #3 | ; multiplot,/default ; ------------------------ ; ; PHASE ; ; ; MULTIPLOT ; ; ------------------------- ; ; | | | ; ; | | | ; ; | UL plot | UR plot | ; ; | | | ; !p.multi=[0,2,2,0,0] ; | | | ; multiplot ,title='MULTIPLOT' ; y------------------------- ; plot,x,y*u ; l| | | ; multiplot & plot,x,r ; a| | | ; multiplot ; b| LL plot | LR plot | ; plot,x,y*t,ytit='ylabels' ; e| | | ; multiplot ; l| | | ; plot,x,y*t,xtit='xlabels' ; s------------------------- ; multiplot,/reset ; xlabels ; ; ; multiplot,[1,1],/init,/verbose ; one way to return to single plot ; % MULTIPLOT: Initialized for 1x1, plotted across then down (column major). ; Optional Inputs: ; pmulti = 2-element or 5-element vector giving number of plots, e.g., ; multiplot,[1,6] ; 6 plots vertically ; multiplot,[0,4,2,0,0] ; 4 plots along x and 2 along y ; multiplot,[0,4,2,0,1] ; ditto, except rowmajor (down 1st) ; multiplot,[4,2],/rowmajor ; identical to previous line ; Optional Keywords: ; help = flag to print header ; initialize = flag to begin only---no plotting, just setup, ; e.g., multiplot,[4,2],/init,/verbose & multiplot & plot,x,y ; reset = flag to reset system variables to values prior to /init ; default = flag to restore IDL's default value for system variables ; rowmajor = flag to number plots down column first (D=columnmajor) ; verbose = flag to output informational messages ; aspect = the image's aspect ratio (Ex. aspect=1 or aspect=200/250.) ; title = common title for plots ; position = set position for multiplot ; noerase = Set this keyword to disable erasing graphic device ; top = try to move plot positions to the top of the page (if aspect is defined) ; right = try to move plot positions to the right of the page (if aspect is defined) ; margin = 4-element vector [xleft,ybottom,xright,ytop] for inside plots ; Outputs: ; !p.position = 4-element vector to place a plot ; !x.tickname = either '' or else 30 ' ' to suppress ticknames ; !y.tickname = either '' or else 30 ' ' to suppress ticknames ; !p.noerase = 1 ; Common blocks: ; multiplot---to hold saved variables and plot counter. See code. ; Side Effects: ; Multiplot sets a number of system variables: !p.position, !p.multi, ; !x.tickname, !y.tickname, !P.noerase---but all can be reset with ; the call: multiplot,/reset ; Restrictions: ; 1. If you use !p.multi as the method of telling how many plots ; are present, you have to set !p.multi at the beginning each time you ; use multiplot or call multiplot with the /reset keyword. ; 2. There's no way to make an xtitle or ytitle span more than one plot, ; except by adding spaces to shift it or to add it manually with xyouts. ; 3. There is no way to make plots of different sizes; each plot ; covers the same area on the screen or paper. ; Procedure: ; This routine makes a matrix of plots with common axes, as opposed to ; the method of !p.multi where axes are separated to allow labels. ; Here the plots are joined and labels are suppressed, except at the ; left edge and the bottom. You tell multiplot how many plots to make ; using either !p.multi (which is then reset) or the parameter pmulti. ; However, multiplot keeps track of the position by itself because ; !p.multi interacts poorly with !p.position. ; Modification history: ; write, 21-23 Mar 94, Fred Knight (knight@ll.mit.edu) ; alter plot command that sets !x.window, etc. per suggestion of ; Mark Hadfield (hadfield@storm.greta.cri.nz), 7 Apr 94, FKK ; add a /default keyword restore IDL's default values of system vars, ; 7 Apr 94, FKK ; modify two more sys vars !x(y).tickformat to suppress user-formatted ; ticknames, per suggestion of Mark Hadfield (qv), 8 Apr 94, FKK ; Converted to IDL V5.0 W. Landsman September 1997 ;- pro multiplot,help=help,pmulti $ ,initialize=initialize, reset=reset, default=default, top=top, right=right $ ,rowmajor=rowmajor, verbose=verbose, title=title, aspect=aspect, margin=margin $ ,position=position ,noerase=noerase, xmargin=xmargin, ymargin=ymargin ; ; =====>> COMMON ; common multiplot $ ,nplots $ ; [# of plots along x, # of plots along y] ,nleft $ ; # of plots remaining---like the first element of !p.multi ,pdotmulti $ ; saved value of !p.multi ,margins $ ; calculated margins based on !p.multi or pmulti ,pposition $ ; saved value of !p.position ,colmajor $ ; flag for column major order ,pnoerase $ ; saved value of !p.noerase ,xtickname $ ; Original value ,ytickname $ ; Original value ,xtickformat $; Original value ,ytickformat $; Original value ,level ; level of multiplot routine ; ; =====>> HELP ; ;on_error,2 if keyword_set(help) then begin & doc_library,'multiplot' & return & endif ; ; =====>> RESTORE IDL's DEFAULT VALUES (kill multiplot's influence) ; if keyword_set(default) then begin level=0 zzz: $ !p.multi = 0 !p.noerase = 0 margins=fltarr(4,3) margins[*,0] = 0 nplots=intarr(2,3) nplots[*,0] = [1,1] nleft = [0,0,0] !p.position = 0 !x.tickname = '' !y.tickname = '' !x.tickformat = '' !y.tickformat = '' last: $ nleft[level>0]=0 level=level-1 if level eq (-1) then goto,zzz level=level>(-1) if keyword_set(verbose) then begin print,'level=',level,' nleft=',nleft[level>0] message,/inform,'Restore IDL''s defaults for affected system variables.' endif if nleft[level>0] eq 0 then return endif ; ; =====>> RESTORE SAVED SYSTEM VARIABLES ; if keyword_set(reset) then begin if n_elements(pposition) eq 12 then !p.position = pposition[*,0] !x.tickname = xtickname !y.tickname = ytickname !x.tickformat = xtickformat !y.tickformat = ytickformat !p.multi = pdotmulti !p.noerase = pnoerase nleft= [0,0,0] if keyword_set(verbose) then begin coords = '['+string(!p.position,form='(3(f4.2,","),f4.2)')+']' multi = '['+string(!p.multi,form='(4(i2,","),i2)')+']' message,/inform,'Reset. !p.position='+coords+', !p.multi='+multi endif return endif ; ; =====>> SETUP: nplots, MARGINS, & SAVED SYSTEM VARIABLES ; init=0 if (n_elements(pmulti) eq 2) or (n_elements(pmulti) eq 5) then init = 1 if (n_elements(!p.multi) eq 5) then begin if (!p.multi[1] gt 0) and (!p.multi[2] gt 0) then init = (!p.multi[0] eq 0) endif if (init eq 0) and n_elements(nleft) ne 0 then if (nleft[level>0] eq 0) then begin print,'Last PLOT of level#',strtrim(string(level),2),' has been plotted' goto,last endif if init or keyword_set(initialize) then begin ij=n_elements(pposition) if (n_elements(level) eq 0) or (ij ne 12) then begin level=-1 nplots=intarr(2,3) colmajor=[0,0,0] nleft=[0,0,0] pposition=fltarr(4,3) margins=fltarr(4,3) endif level=(level+1)>0<2 if level eq 0 then if not keyword_set(noerase) then erase case n_elements(pmulti) of 0:begin if n_elements(!p.multi) eq 1 then return ; NOTHING TO SET if n_elements(!p.multi) ne 5 then message,'Bogus !p.multi; aborting.' nplots[*,level] = !p.multi[1:2] > 1 if keyword_set(rowmajor) then colmajor[level] = 0 else colmajor[level] = !p.multi[4] eq 0 end 2:begin nplots[*,level] = pmulti colmajor[level] = not keyword_set(rowmajor) ; D=colmajor: left to rt 1st end 5:begin nplots[*,level] = pmulti[1:2] if keyword_set(rowmajor) then colmajor[level] = 0 else colmajor[level] = pmulti[4] eq 0 end else: message,'pmulti can only have 0, 2, or 5 elements.' endcase pposition[*,level] = !p.position ; save sysvar to be altered if level eq 0 then begin xtickname = !x.tickname ytickname = !y.tickname xtickformat = !x.tickformat ytickformat = !y.tickformat pdotmulti = !p.multi endif nleft[level] = nplots[0,level]*nplots[1,level] ; total # of plots !p.multi = 0 ; set window & region if n_elements(xmargin) eq 2 then xmar=xmargin else xmar=!x.margin if n_elements(ymargin) eq 2 then ymar=ymargin else ymar=!y.margin if n_elements(position) ne 0 then begin xypos=position plot,/nodata,xstyle=4,ystyle=4,!x.range,!y.range,/noera,position=xypos end else plot,/nodata,xstyle=4,ystyle=4,!x.range,!y.range,/noera,xmar=xmar,ymar=ymar ;text margins if level gt 0 then begin if total(xmar) eq 0 and total(ymar) eq 0 then goto,end_mar xcs=xmar*!d.x_ch_size/float(!d.x_size) & xcs[1]=xcs[1]*(-1) ycs=ymar*!d.y_ch_size/float(!d.y_size) & ycs[1]=ycs[1]*(-1) !x.window=!x.window+xcs !y.window=!y.window+ycs end_mar : endif if n_elements(aspect) gt 0 then begin dx=!x.window(1)-!x.window(0) dy=!y.window(1)-!y.window(0) dx=float(dx)*!d.x_vsize dy=float(dy)*!d.y_vsize ndx=dx/nplots(0,level) mdy=dy/nplots(1,level) xdy=ndx/mdy if xdy gt aspect(0) then begin xdy=!x.window(1)-!x.window(0)-aspect(0)*mdy*nplots(0,level)/!d.x_vsize if keyword_set(right) then !x.window(0)=!x.window(0)+xdy else $ !x.window(1)=!x.window(1)-xdy endif else begin xdy=!y.window(1)-!y.window(0)-ndx*nplots(1,level)/aspect(0)/!d.y_vsize if keyword_set(top) then !y.window(0)=!y.window(0)+xdy else $ !y.window(1)=!y.window(1)-xdy endelse end if n_elements(title) ne 0 then begin xdy=[!x.window(0),!y.window(0),!x.window(1),!y.window(1)] plot,/nodata,xstyle=4,ystyle=4,!x.range,!y.range,/noera,position=xdy,tit=title(0) end margins[*,level] = [(!x.window(1)-!x.window(0))/nplots[0,level],$ (!y.window(1)-!y.window(0))/nplots[1,level], $ !x.window(0),!y.window(0)] pnoerase = !p.noerase !p.noerase = 1 ; !p.multi does the same if keyword_set(verbose) then begin major = ['across then down (column major).','down then across (row major).'] if colmajor[level] ne 0 then index = 0 else index = 1 message,/inform,'Initialized for '+strtrim(nplots[0,level],2) $ +'x'+strtrim(nplots[1,level],2)+', plotted '+major[index] $ +' level #'+strtrim(string(level),2) endif if keyword_set(initialize) then return endif ; ; =====>> Define the plot region without using !p.multi. ; if n_elements(pposition) ne 12 then message,'You must initialize MULTIPLOT routine' cols = nplots[0,level] ; for convenience rows = nplots[1,level] nleft[level] = nleft[level] - 1 >0 ; decrement plots remaining cur = cols*rows - nleft[level] ; current plot #: 1 to cols*rows if colmajor[level] ne 0 then begin ; location in matrix of plots col = cur mod cols if col eq 0 then col = cols row = (cur-1)/cols + 1 endif else begin ; here (1,2) is 1st col, 2nd row row = cur mod rows if row eq 0 then row = rows col = (cur-1)/rows + 1 endelse pos = [(col-1)*margins[0,level],(rows-row)*margins[1,level],$ col*margins[0,level],(rows-row+1)*margins[1,level]] $ + [margins[2,level],margins[3,level],margins[2,level],margins[3,level]] ;print,row,col,rows,cols,pos ; ; =====>> Finally set the system variables; user shouldn't change them. ; if n_elements(margin) eq 4 then begin mar=float(margin)*!d.x_ch_size mar(0)=mar(0)/float(!d.x_size) mar(2)=-mar(2)/float(!d.x_size) mar(1)=mar(1)/float(!d.y_size) mar(3)=-mar(3)/float(!d.y_size) pos=pos+mar end !p.position = pos onbottom = (row eq rows) or (rows eq 1) onleft = (col eq 1) or (cols eq 1) if onbottom then !x.tickname = xtickname else !x.tickname = replicate(' ',30) if onleft then !y.tickname = ytickname else !y.tickname = replicate(' ',30) if onbottom then !x.tickformat = xtickformat else !x.tickformat = '' if onleft then !y.tickformat = ytickformat else !y.tickformat = '' if keyword_set(verbose) then begin coords = '['+string(pos,form='(3(f4.2,","),f4.2)')+']' plotno = 'Setup for plot ['+strtrim(col,2)+','+strtrim(row,2)+'] of ' $ +strtrim(cols,2)+'x'+strtrim(rows,2) print,'level=',level,' nleft=',nleft[level>0] message,/inform,plotno+' at '+coords endif ;stop return end -####################################################### # pro mvcsun, hdr,dx,dy xcun=fxpar(hdr,'CRVAL1') ycun=fxpar(hdr,'CRVAL2') xcun=xcun+dx ycun=ycun+dy sxaddpar,hdr,'CRVAL1',xcun sxaddpar,hdr,'CRVAL2',ycun end -####################################################### # pro mycolor tvlct,rr,gg,bb,/get n=n_elements(rr)-2 gg(n)=100&rr(n)=255&bb(n)=100 n=n_elements(gg)-4 gg(n)=100&rr(n)=100&bb(n)=255 n=n_elements(gg)-3 bb(n)=100&rr(n)=100&gg(n)=255 tvlct,rr,gg,bb end -####################################################### # function norm,image mx=max(float(image),min=mn) if mx eq 0 then mx=1. if mn eq 0 then mn=1. return, (image>0)/mx+(image<0)/abs(mn) end -####################################################### # function norm1,data mx=max(data,min=mn) if mx eq mn then return, data/data return,(data-mn)/float(mx-mn) end -####################################################### # function norm3d,img image=reform(img) n=size(image) if n(0) eq 3 then begin out=float(image) for i=0,n(3)-1 do begin mx=max(float(out(*,*,i)),min=mn) if mx eq 0 then mx=1. if mn eq 0 then mn=1. out(*,*,i)=(out(*,*,i)>0)/mx+(out(*,*,i)<0)/abs(mn) end return,out endif else begin mx=max(float(image),min=mn) if mx eq 0 then mx=1. if mn eq 0 then mn=1. return, (image>0)/mx+(image<0)/abs(mn) end end -####################################################### # pro plotbox, x,y,w,h,color=color,scale=scale,lines=lines,device=device,x0x1=x0x1 if n_params(0) lt 1 then begin print,'Usage : plotbox,x0,y0,w,h,color=color,scale=scale,lines=lines,$' print,' device=device,x0x1=x0x1' print,' plotbox,[x0,y0,x1,y1],color=color,scale=scale,lines=lines' print,' plotbox,[x0,x1],[y0,y1],color=color,scale=scale,lines=lines' return end if n_elements(color) eq 1 then xx=color else xx=!p.color if n_elements(scale) eq 1 then zx=scale else zx=1.0 if n_elements(lines) ne 0 then lin=lines(0) else lin=0 if n_elements(x) eq 4 then begin if keyword_set(x0x1) then begin x0=x(0) & y0=x(2) & x1=x(1) & y1=x(3) endif else begin x0=x(0) & y0=x(1) & x1=x(2) & y1=x(3) end endif else $ if n_elements(x) eq 2 and n_elements(y) eq 2 then begin x0=x(0) & y0=y(0) & x1=x(1) & y1=y(1) endif else begin& x0=x & y0=y & x1=x+w & y1=y+h &end if keyword_set(device) then $ plots,[x0,x0,x1,x1,x0]*zx,[y0,y1,y1,y0,y0]*zx,color=xx,lines=lin,/dev else $ plots,[x0,x0,x1,x1,x0]*zx,[y0,y1,y1,y0,y0]*zx,color=xx,lines=lin,/data end -####################################################### # pro printcontours,_imgs,fits=fits,multi=multi,file=file,legend=legend,hdr=hdr,$ title=title,xsize=xsize,ysize=ysize,color=color,grid=grid,negative=negative,$ view=view,backimage=backimage,backhdr=backhdr,plevel=plevel,range=range,$ backr=backr multiplot,/def if (n_params(0) eq 0) and (n_elements(fits) eq 0) then begin print,'Usage: printcontours,imgs,fits=fits,multi=multi,file=file,$' print,' legend=legend,title=title,xsize=xsize,ysize=ysize,$' print,' color=color,hdr=hdr,grid=grid,/view,plevel=plevel,backr=backr, $' print,' backimages=backimages,backhdr=backhdr,/negative,range=range' print,' hdr - FITS header or /hdr' print,' gird - array [b,dx,dy,Rsun]' return end if n_elements(title) eq 0 then _tit='' else _tit=title(0) if n_elements(multi) ne 2 then _mul=[4,6] else _mul=multi if n_elements(xsize) eq 0 then xs=18 else xs=xsize(0) if n_elements(ysize) eq 0 then ys=24 else ys=ysize(0) if n_elements(file) eq 0 then outfile='idl.ps' else outfile=file(0) if n_elements(negative) eq 0 then ii=1. else ii=-1. if n_elements(legend) eq 0 then lg=0 else lg=1 if n_elements(backhdr) eq 0 then bhdr=0 else bhdr=backhdr if n_elements(backr) eq 0 then b_r='SOLR' else b_r=backr(0) if n_elements(hdr) eq 0 then _hdr=0 else begin jj=size(hdr) i=n_elements(jj)-2 if jj(i) ne 7 then _hdr=0 else _hdr=hdr end jj=0 nn=size(_imgs) if nn(0) eq 0 then begin jj=1 xx=findfile(fits) nn=n_elements(xx) if nn eq 0 then return endif else begin imgs=reform(_imgs) nn=size(imgs) nn=nn(3) help,imgs end sz=_mul(0)*_mul(1) ; if n_elements(view) eq 0 then begin set_plot,'PS' device,file=outfile,xsize=xs,ysize=ys,xof=1,yof=1,/color,$ bits_per_pixel=8 !p.font=0 end if n_elements(color) eq 0 then loadct,0 else loadct,color(0)>0<40 if n_elements(grid) eq 4 then rsun=grid(3) else rsun=0 ; for i=0,nn-1 do begin if jj eq 0 then begin img=imgs(*,*,i) if lg eq 0 then text=string(i) else text=string(legend(i)) endif else begin img=readfits(xx(i),hdr1,/sil) if lg eq 0 then text=string(sxpar(hdr1,'TIME-OBS')) else text=string(legend(i)) if n_elements(hdr) ne 0 then _hdr=hdr1 endelse text=strtrim(text,2) if (i mod sz) eq 0 then multiplot,_mul,title=_tit,asp=1. if n_elements(backimage) eq 0 then $ fitstvscl,float(img)*ii,_hdr,/notickn,/noimage,solr=rsun,range=range else $ fitstvscl,backimage,bhdr,/notickn,range=range,solr=b_r if n_elements(plevel) eq 0 then fitscontour,float(img)*ii,_hdr,solr=rsun else $ fitscontour,float(img)*ii,_hdr,plevel=plevel,solr=rsun if n_elements(grid) gt 2 then if grid(1)*grid(2) ne 0 then solargrid,grid(0),dx=grid(1),dy=grid(2) legend,text,box=0,marg=0 multiplot end ; multiplot,/def if n_elements(view) eq 0 then begin device,/close print,outfile,' was created' end if !version.os eq 'Win32' then set_plot,'win' else set_plot,'x' !p.font=-1 end -####################################################### # pro printimages,_imgs,fits=fits,multi=multi,file=file,legend=legend,hdr=hdr,$ title=title,xsize=xsize,ysize=ysize,color=color,negative=negative,$ grid=grid,view=view,range=range,contours=contours multiplot,/def if (n_params(0) eq 0) and (n_elements(fits) eq 0) then begin print,'Usage: printimages,imgs,fits=fits,multi=multi,file=file,$' print,' legend=legend,title=title,xsize=xsize,ysize=ysize,/contours, $' print,' color=color,/negative,hdr=hdr,grid=grid,/view,range=range' print,' hdr - FITS header or /hdr' print,' gird - array [b,dx,dy,Rsun]' return end if n_elements(title) eq 0 then _tit='' else _tit=title(0) if n_elements(multi) ne 2 then _mul=[4,6] else _mul=multi if n_elements(xsize) eq 0 then xs=18 else xs=xsize(0) if n_elements(ysize) eq 0 then ys=24 else ys=ysize(0) if n_elements(file) eq 0 then outfile='idl.ps' else outfile=file(0) if n_elements(negative) eq 0 then ii=1. else ii=-1. if n_elements(legend) eq 0 then lg=0 else lg=1 if n_elements(hdr) eq 0 then _hdr=0 else begin jj=size(hdr) i=n_elements(jj)-2 if jj(i) ne 7 then _hdr=0 else _hdr=hdr end jj=0 nn=size(_imgs) if nn(0) eq 0 then begin jj=1 xx=findfile(fits) nn=n_elements(xx) if nn eq 0 then return endif else begin imgs=reform(_imgs) nn=size(imgs) nn=nn(3) help,imgs end sz=_mul(0)*_mul(1) ; if n_elements(view) eq 0 then begin set_plot,'PS' device,file=outfile,xsize=xs,ysize=ys,xof=1,yof=1,/color,$ bits_per_pixel=8 !p.font=0 end if n_elements(color) eq 0 then loadct,0 else loadct,color(0)>0<40 ; if n_elements(grid) eq 4 then rsun=grid(3) else rsun=0 for i=0,nn-1 do begin if jj eq 0 then begin img=imgs(*,*,i) if lg eq 0 then text=string(i) else text=string(legend(i)) endif else begin img=readfits(xx(i),hdr1,/sil) if lg eq 0 then text=string(sxpar(hdr1,'TIME-OBS')) else text=string(legend(i)) if n_elements(hdr) ne 0 then _hdr=hdr1 endelse text=strtrim(text,2) if (i mod sz) eq 0 then multiplot,_mul,title=_tit,asp=1. fitstvscl,float(img)*ii,_hdr,/notickn,solr=rsun,range=range if n_elements(contours) ne 0 then fitscontour,float(img)*ii,_hdr,solr=rsun if n_elements(grid) gt 2 then if grid(1)*grid(2) ne 0 then solargrid,grid(0),dx=grid(1),dy=grid(2) legend,text,box=0,marg=0 multiplot end ; multiplot,/def if n_elements(view) eq 0 then begin device,/close print,outfile,' was created' end if !version.os eq 'Win32' then set_plot,'win' else set_plot,'x' !p.font=-1 end -####################################################### # if n_elements(ndir) eq 0 then ndir='ffi' if n_elements(ipz) lt 10 then begin nf=findfile(ndir+'/ipz0*') if n_elements(indx) eq 0 then mreadfits,nf,hdr,ipz else mreadfits,nf(indx),hdr,ipz end if n_elements(i34) lt 5 then i34=total_flux(ipz,freq=34,pix=2.4555) tt=str2sec(hdr.time_d$obs) i=n_elements(tt) k=i/14 ii=indgen(15)*k !p.charsize=1.0 multiplot,/def if n_elements(z) lt 10 then z=varmap(ipz) multiplot,[4,4],asp=1 fitstvscl,-z^0.5,hdr,psgrid=200 legend,box=0,'Var.Map',textc=0 multiplot for i=0,14 do begin fitstvscl,-(ipz(*,*,ii(i))>1e3)^0.5,hdr,psgrid=200 solargrid,hdr(0).solb,dx=5,dy=5 legend,box=0,strmid(hdr(ii(i)).time_d$obs,0,8),textc=0 multiplot end plot,tt,i34,xsty=1,/yno,xtickf='hmsticks',xticks=6,pos=[0.1,0.8,0.95,0.95],/noeras,$ titl='34GHz time profile and images at '+hdr(k).date_d$obs,ytit='Flux, sfu', xtit='Time, UT' end -####################################################### # function readform, file ;+ Performs formatted reading ; of the string-type array from a file ;- ;if n_elements(file) le 0 then $ ;file = pickfile(/read) if file eq '' then return, '' widget_control, /hour openr, lun, file, /get st = fstat(lun) data = bytarr(st.size) readu, lun, data point_lun, lun, 0 iii = where(data eq '0A'xB, N) data = strarr(N) readf, lun, data st = fstat(lun) if (st.cur_ptr + 1) lt st.size then begin tmp = '' readf, lun, tmp data = [data, tmp] endif free_lun, lun return, data end -####################################################### # function sec2date,sec,dy=dy if n_elements(dy) eq 0 then _dy=0 else _dy=dy(0) d=fix(sec/86400.d) d=40587L+d mjd2date,d,yy,mm,dd x=string(yy+_dy,mm,dd,format="(i4.4,'-',i2.2,'-',i2.2)") return,x+'T'+sec2hms(sec mod 86400.d) end -####################################################### # function sec2hms,value,nosec=nosec,msec=msec,nodel=nodel xx=value mod 86400. xx=xx+86400.*(xx lt 0) hh=fix(xx/3600) mm=fix((xx-3600.*hh)/60) ss=xx mod 60. n=n_elements(xx) str=strarr(n) zz=1 if keyword_set(nosec) then zz=0 if keyword_set(msec) then zz=2 if keyword_set(node) then zz=3 case zz of 0 : for i=0L,n-1 do str(i)=string(hh(i),mm(i),format="(i2.2,':',i2.2)") 1 : for i=0L,n-1 do str(i)=string(hh(i),mm(i),ss(i),format="(i2.2,':',i2.2,':',i2.2)") 2 : for i=0L,n-1 do str(i)=string(hh(i),mm(i),ss(i),format="(i2.2,':',i2.2,':',f4.1)") 3 : for i=0L,n-1 do str(i)=string(hh(i),mm(i),ss(i),format="(i2.2,i2.2,i2.2)") else: endcase if n eq 1 then str=str(0) return, str end -####################################################### # pro set0ps device,/close set_plot,'x' !p.font=-1 !p.thick=1.0 !x.thick=1.0 !y.thick=1.0 !p.charthick=1.0 !p.charsize=1. end -####################################################### # pro set1ps,file,color=color,nocolor=nocolor,xsize=xsize,ysize=ysize,bits=bits,help=help,eps=eps if keyword_set(help) then begin print,'Usage: set1ps,file,color=color,xsize=xsize,ysize=ysize,/help,/eps,/nocolor' return end set_ps,1 if n_elements(xsize) eq 0 then xs=20 else xs=xsize(0)>1 if n_elements(ysize) eq 0 then ys=20 else ys=ysize(0)>1 if n_elements(file) eq 0 then file='idl.ps' if n_elements(color) eq 0 then xx=-1 else xx=color(0)>0 if n_elements(bits) eq 0 then bits=8 if n_elements(eps) eq 0 then $ device,file=file,xsize=xs,ysize=ys,xof=1,yof=1,/color,bits_per_pixel=8 else $ device,file=file,xsize=xs,ysize=ys,xof=1,yof=1,/color,bits_per_pixel=8,/encaps if (xx lt 50) then $ if n_elements(nocolor) eq 0 then if (xx eq (-1)) then loadrb else loadct,xx end -####################################################### # pro set_ps,ff if ff ne 0 then begin set_plot,'PS' !p.font=0 !p.thick=3.0 !x.thick=3.0 !y.thick=3.0 !p.charthick=3.0 !p.charsize=1.2 end else begin device,/close set_plot,'x' !p.font=-1 !p.thick=1.0 !x.thick=1.0 !y.thick=1.0 !p.charthick=1.0 !p.charsize=1. end end -####################################################### # pro shift_image,in_image,out_image,shift ; shift image by SHIFT=FLTARR(2) pixels using poly_2d IF (n_params(0) LT 1) THEN BEGIN print,'' print,' USAGE: shift_image, in_image, out_image, [x_shift, y_shift]' print,'' print,' Shifts IN_IMAGE to right by X_SHIFT pixels and up by ' print,' Y_SHIFT pixels using poly_2d function.' print,' Shifts less than 0.1 pixels are ignored. ' return end if ((abs(float(shift[0])) ge 0.1) or (abs(float(shift[1])) ge 0.1)) then begin p = [-shift[0],0,1,0] q = [-shift[1],1,0,0] out_image=poly_2d(in_image, p, q, cubic=-0.5, missing=0.0) endif else out_image=in_image return end -####################################################### # ;+ ; NAME: ; SOLARGRID ; Purpose: ; The SOLARGRID procedure draws the graticule of parallels and meridians; ; ; CALLING SEQUENCE: ; solargrid,b0,dx=dx, dy=dy, p0=p0, rsun=rsun,$ ; labels=[long,lat], /nolong, /nolat,/nsew,$ ; color=color, range=range, linestyle=linestyle, cx=cx,cy=cy ; INPUTS: ; b0 = solar B0 or date string (for ex. '1999-05-25') ; ; OPTIONAL INPUT KEYWORDS: ; p0 - solar position angle ; rsun - solar radius, default=960 arcsec ; dx - longitude increment, default=10 degree ; dy - latitude increment, default=10 degree ; cx,cy - solar center, default 0,0 ; range - grid range [x0,y0,x1,y1] ; labels - draw grid labels ; /nsew - print labels with N,S,E,W marks ; /nolong - draw only latitude lines ; /nolat - draw only longitude lines ; ; ; MODIFICATION HISTORY: ; Written by: Vladimir Garaimov, May 2002 ;- pro sunadtoxy,a,d,b0,p0,x,y,z=z a1=a*!dtor d1=d*!dtor y=sin(d1) x=sin(a1)*cos(d1) z=cos(d1)*cos(a1) if b0 ne 0 then begin b=-b0*!dtor z1=z & y1=y z=z1*cos(b)-y1*sin(b) y=z1*sin(b)+y1*cos(b) end i=where(z gt 0) if i(0) ne (-1) then begin x=x(i) & y=y(i) endif else begin x=-2 & y=-2 &return end if p0 ne 0 then begin x1=x &y1=y p=-p0*!dtor x=x1*cos(p)-y1*sin(p) y=x1*sin(p)+y1*cos(p) end end pro solargrid,_b0,dx=dx,dy=dy,labels=labels,color=color,$ p0=p0,rsun=rsun,linestyle=linestyle,range=range,nsew=nsew,$ cx=cx,cy=cy, nolat=nolat, nolong=nolong if n_params(0) eq 0 then begin doc_library,'solargrid' return end b0=_b0 sx=size(b0) sx=sx(n_elements(sx)-2) if sx eq 7 then begin b0=(pb0r(b0(0)))(1) print,'b0=',b0 end if n_elements(rsun) eq 0 then _rsun=960. else _rsun=float(rsun(0)) if n_elements(dx) eq 0 then _xstep=10. else _xstep=float(dx(0)) if n_elements(dy) eq 0 then _ystep=10. else _ystep=float(dy(0)) if n_elements(p0) ne 0 then _p0=float(p0(0)) else _p0=0. if n_elements(cx) eq 0 then sx=0. else sx=float(cx(0)) if n_elements(cy) eq 0 then sy=0. else sy=float(cy(0)) if n_elements(color) eq 0 then col=!p.color else col=color(0) if n_elements(linestyle) eq 0 then ls=1 else ls=linestyle(0) if n_elements(range) ne 4 then begin x0=-180. & x1=180. & y0=-90. & y1=90. &ks=1. endif else begin ks =0. range=float(range) x0=range(0)>(-180) & x1=range(2)<180 y0=range(1)>(-90) & y1=range(3)<90 if x0 ge x1 then begin &x0=-180.&x1=180.& end if y0 ge y1 then begin &y0=-90.& y1=90.& end endelse xl=500 & yl=500 if keyword_set(labels) then begin if n_elements(labels) eq 2 then begin if abs(labels(0)) lt 90 then xl=labels(0) if abs(labels(1)) lt 90 then yl=labels(1) endif else begin xl=(x1+x0)/2 yl=(y1+y0)/2 endelse end nn=fix((x1-x0)/_xstep)+1 mm=fix((y1-y0)/_ystep)+1 if keyword_set(nolat) then goto, xlat yy=fltarr(nn) for i=y0+ks*_ystep,y1-_ystep*ks,_ystep do begin xx=findgen(nn)*_xstep+x0 yy(*)=float(i) sunadtoxy,xx,yy,b0,_p0,zx,zy if zx(0) ne -2 then begin zx=zx*_rsun &zy=zy*_rsun plots,zx+sx,zy+sy,color=col,lines=ls,noclip=0 end if xl ne 500 then begin sunadtoxy,xl+_xstep/3.,i,b0,_p0,zx,zy if zx(0) ne -2 then begin zx=zx*_rsun &zy=zy*_rsun if keyword_set(nsew) then begin j=strtrim(string(fix(abs(i))),2) case 1 of i lt 0: j='S'+j i gt 0: j='N'+j else: endcase endif else j=strtrim(string(fix(i)),2) if (zx(0) le !x.crange(0)) or (zx(0) ge !x.crange(1)) then goto, xl_end if (zy(0) le !y.crange(0)) or (zy(0) ge !y.crange(1)) then goto, xl_end xyouts,zx,zy,j,col=col,noclip=0 end xl_end: end end xlat: if keyword_set(nolong) then goto,xend xx=fltarr(mm) for i=x0+ks*_xstep,x1-_xstep*ks,_xstep do begin yy=findgen(mm)*_ystep+y0 xx(*)=float(i) sunadtoxy,xx,yy,b0,_p0,zx,zy if zx(0) ne -2 then begin zx=zx*_rsun &zy=zy*_rsun plots,zx+sx,zy+sy,color=col,lines=ls,noclip=0 end if yl ne 500 then begin sunadtoxy,i,yl+_ystep/4.,b0,_p0,zx,zy if zx(0) ne -2 then begin zx=zx*_rsun &zy=zy*_rsun if keyword_set(nsew) then begin j=strtrim(string(fix(abs(i))),2) case 1 of i lt 0: j='E'+j i gt 0: j='W'+j else: endcase endif else j=strtrim(string(fix(i)),2) if (zx(0) le !x.crange(0)) or (zx(0) ge !x.crange(1)) then goto, yl_end if (zy(0) le !y.crange(0)) or (zy(0) ge !y.crange(1)) then goto, yl_end xyouts,zx,zy,j,col=col,noclip=0 end yl_end: end end xend: empty end -####################################################### # function str2sec,str,nospace=nospace nn=n_elements(str) if nn lt 1 then return,(-1) xx=dblarr(nn) for i=0,nn-1 do begin if keyword_set(nospace) then reads,str(i),hh,mm,ss,format='(i2,i2,f)' $ else reads,str(i),hh,mm,ss,format='(i2,1x,i2,1x,f)' xx(i)=ss+60.*mm+3600.*hh end if nn eq 1 then xx=xx(0) return,xx end -####################################################### # pro sunad2xy,a,d,b0,p0,x,y,z=z a1=a*!dtor d1=d*!dtor y=sin(d1) x=sin(a1)*cos(d1) z=cos(d1)*cos(a1) if b0 ne 0 then begin b=-b0*!dtor z1=z & y1=y z=z1*cos(b)-y1*sin(b) y=z1*sin(b)+y1*cos(b) end i=where(z gt 0) if i(0) ne (-1) then begin x=x(i) & y=y(i) endif else begin x=-2 & y=-2 &return end if p0 ne 0 then begin x1=x &y1=y p=-p0*!dtor x=x1*cos(p)-y1*sin(p) y=x1*sin(p)+y1*cos(p) end end -####################################################### # function sunrotate,sun,x0_,y0_,r0,b0,p0,rdeg,sld,b1=b1,noint=noint dim=size(sun) rsun=float(sun) image=rsun zmin=min(rsun) nx=dim(1) ny=dim(2) if n_elements(noint) ne 0 then nint=noint(0) else nint=0 if n_elements(b1) ne 0 then b1=b1(0) else b1=b0 l0=double(rdeg)/24.0d*360.0d/27.2753d x0 =x0_-1. ;IDL convention y0 =y0_-1. ;IDL convention ir =r0 ;solar radius in units of EW pixels pi =acos(-1.) ix =findgen(nx) for iy=0,ny-1 do begin ; if (long(iy/50) eq float(iy)/50.) then PRINT,'processing line =',iy yy =iy xx =ix ind =where((xx-x0)^2+(yy-y0)^2 lt (ir^2)) if (ind(0) ne -1) then begin x =xx(ind) heliotrans,x0,y0,0.0,p0,b1,0.0,x,yy,ir,hlong,hlat diffrot=sld*l0*(3.0/13.45)*(sin(hlat*pi/180.))^2 hlong =hlong+diffrot ;differential rotation + rotation heliotrans2,x0,y0,0.0,0.0,b0,l0,hlong,hlat,ir,ix2,iy2 if nint eq 1 then begin ix2=round(ix2+1) & iy2=round(iy2+1) ix2=ix2>00 0 &i2=i1+1 < (nx-1) j1=long(iy2-0.5) > 0 &j2=j1+1 < (ny-1) z1=image(i1,j1) &z2=image(i2,j1) z3=image(i2,j2) &z4=image(i1,j2) t =ix2-0.5-float(i1) &u=iy2-0.5-float(j1) zz=(1-t)*(1-u)*z1+t*(1-u)*z2+t*u*z3+(1-t)*u*z4 ;bilinear interpol. rsun(ind,iy)=float(zz) endelse endif endfor return,rsun end -####################################################### # pro sunxy2ad,_x,_y,b0,p0,a,d,r0=r0 if n_params(0) ne 6 then begin print,'Usage: sunxy2ad,x,y,b0,p0,a,d,r0=r0' return end x=_x &y=_y if n_elements(r0) ne 0 then if r0 gt 0 then begin x=_x/double(r0) & y=_y/double(r0) end a=x d=y x=x>(-1)<1. y=y>(-1)<1. if p0 ne 0 then begin sina=sin(-p0*!dtor) cosa=cos(-p0*!dtor) x1=cosa*x+sina*y y1=cosa*y-sina*x end else begin x1=x &y1=y end z=sqrt(1.-x^2-y^2) d=z*sin(b0*!dtor)+y*cos(b0*!dtor) d=asin(d) i=where(abs(d) lt !dpi/2.) a(*)=0 if i(0) ge 0 then begin a=x/cos(d) a=asin(a) end a=a/!dtor d=d/!dtor end -####################################################### # function sx_par,str,tag, count=count count=0 i=size(str) if i(i(0)+1) eq 7 then return, sxpar(str,tag,count=count) if i(i(0)+1) ne 8 then return,0 x=strupcase(tag_names(str(0))) j=where(x eq strupcase(tag)) if j(0) lt 0 then return,0 count=1 j=execute('x=str(0).'+tag) return,x end -####################################################### # pro timeprof, Array, device=device, data=data, $ logarithmic=log, ynozero = ynozero ;+ ; NAME: ; TIMEPROF ; ; PURPOSE: ; Interactively plot profile of a 3-dimensional array along the ; third dimension through the pixel where the cursor is currently ; placed. The profile is displayed in a separate window. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; TIMEPROF, Array ; ; INPUTS: ; Array: The array to be analyzed. This array may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; DATA: If set and non-zero, data coordinate system is processed. ; DEVICE: If set and non-zero, device coordinate system is processed ; (by default). ; LOGARITHMIC: If set and non-zero, Y axis is of logarithmic type. ; YNOZERO: If set and non-zero, prevents setting the minimum Y axis ; value to zero. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; A new window is created and used for the profile. When done, ; the new window is deleted. ; The X and Y of the pixel under the cursor are continuously ; displayed. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Press the right mouse button to exit the procedure. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, 1998. ; Victor Grechnev (grechnev@iszf.irk.ru) ; ;- Sz=size(Array) orig_win=!d.window X_orig = !X Y_orig = !Y wset,orig_win tvcrs,Sz(1)/2,Sz(2)/2,/dev window,/free new_win=!d.window amax=max(Array, min=amin) if keyword_set(log) then begin if amax le 0 then amax = amax > 1 if amin le 0 then amin = amin > 1 endif old_font=!p.font !p.font = 0 vecx = findgen(Sz(3)) old_data=' ' while 1 do begin wset,orig_win ;Image window !X = X_orig !Y = Y_orig if keyword_set(data) then cursor,x,y,2,/data else $ cursor,x,y,2,/dev ;Read position first=1 wset,new_win plot,[0, Sz(3)-1],[amax, amin],/nodata,title='Time Profile', ytype= $ keyword_set(log), ynozero = keyword_set(ynozero), $ col = !d.table_size-1 prof=Array(x > 0 < (Sz(1)-1), y > 0 < (Sz(2)-1), *) if !err eq 4 then begin ;Quit wset,orig_win tvcrs,Sz(1)/2, Sz(2)/2,/dev ;curs to old window tvcrs,0 ;Invisible wdelete, new_win !p.font = old_font !X = X_orig !Y = Y_orig print,x,y return endif if first eq 0 then plots, vecx, prof, col=0 else first=0 plots, vecx, prof, $ col = !d.table_size-1 Yout = (Xout=3) aa = string(x > 0 < (Sz(1)-1), y > 0 < (Sz(2)-1), format = '(i6, i6)') xyouts, Xout, Yout, old_data, /dev, font=0, col=!p.background xyouts, Xout, Yout, aa, /dev, font=0, col = !d.table_size-1 old_data=aa endwhile end -####################################################### # function total_flux, x, pixel_size = pixel_size, frequency = frequency ;+ ; NAME: ; TOTAL_FLUX ; ; PURPOSE: ; Returns vector of totals over each frame in 3-dimensional array. ; When both PIXEL_SIZE and FREQUENCY are specified, the output ; value is expressed in Solar Flux Units. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; TF = TOTAL_FLUX(Array [, PIXEL_SIZE=PIXEL_SIZE, FREQUENCY=FREQUENCY]) ; ; INPUTS: ; Array: The array to be analyzed. This array may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; PIXEL_SIZE: Size of pixels of the Array expressed in arc seconds. ; Pixels are intended to be square-shaped. ; FREQUENCY: Working frequency expressed in GHz. ; ; ; OUTPUTS: ; Total over two dimensions: total(total(Array, 1), 1). ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; Both keyword parameters PIXEL_SIZE and FREQUENCY must be specified ; to cause output to be expressed in s.f.u. ; ; PROCEDURE: ; Straightforward. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, 1999. ; Victor Grechnev (grechnev@iszf.irk.ru) ; ISTP SD RAS, 2000, Jan. ; Victor Grechnev (grechnev@iszf.irk.ru) ; Keyword parameters FREQUENCY and PIXEL_SIZE have been added. ; ;- k_B = 1.3804200e-23 ; Boltzmann constant c = 2.9979250e+08 ; Speed of light tf = total(total(x, 1), 1) CASE 1 OF keyword_set(pixel_size) and keyword_set(frequency): begin lam = c/(frequency*1d9) ; Wave length sfu=float(2*k_B/lam^2*(pixel_size/3600d0*!dtor)^2*1d22) tf = tf*sfu end (keyword_set(pixel_size) and not(keyword_set(frequency))) or $ (not(keyword_set(pixel_size)) and keyword_set(frequency)): $ begin print, 'Both Frequency and Pixel_size must be specified. ' print, 'Returning no-normalized total only.' end ELSE: ENDCASE return, tf end -####################################################### # pro traceprep,files,data,outhdr=outhdr,clean=clean,noise=noise,unspike=unspike if n_params(0) ne 2 then begin print,'Usage: traceprep,files,outdata,[outhdr=outhdr,/clean,/noise,unspike=unspike]' print,' files - string array of TRACE file names or mask of these files' print,' outdata - prepared data array' print,' unspike - can be number bigger than 1' data=0 return end nn=n_elements(files) if nn eq 1 then x=findfile(files) else x=files if x(0) eq '' then return data=readfits(x(0),outhdr) nn=n_elements(x)-1 i=size(data) data=fltarr(i(1),i(2),nn+1) for i=0,nn do begin image0=readfits(x(i),hdr,/sil) mmp = where(image0 eq 0, mcnt) ; find missing pixels if (mcnt ne 0) then begin ; replace if there are any missing nnp = where(image0 gt 0, ncnt) ; find pixels for average if (ncnt ne 0) then begin mean = total(image0(nnp))/n_elements(nnp) ; find mean of image if (mean gt 32767. or mean lt -32768.) then mean = 0.0 endif else message, /info, 'All pixels = 0' ; all pixels = 0 image0(mmp) = fix(mean) ; replace missing pixels with I*2 mean value n_pixel = mcnt ssp = where(image0 ge 4000, scnt) ; find pixels near saturation if (scnt gt 0) then image0(ssp) = 4400 ; replace saturated pixels with large value, so that endif image0=image0-min(image0) if n_elements(unspike) gt 0 then for j=1,unspike(0) do $ image0 = trace_unspike(temporary(image0), /cleanjpg) if keyword_set(clean) then image0 = trace_cleanjpg(tracedespike(temporary(image0))) image0 = trace_destreak(temporary(image0)) if keyword_set(noise) then image0 = trace_knoise(temporary(image0)) exptime = gt_tagval(hdr,/SHT_MDUR) if (exptime(0) eq -1 ) then exptime = gt_tagval(hdr,/EXPTIME) if (exptime(0) gt 0.) then image0 = image0 / exptime(0) data(*,*,i)=image0 print,'Image #'+string(i)+' of '+string(nn)+' is prepared' end end -####################################################### # pro tvfits,nfile,fitsarr=fitsarr,fitshdr=fitshdr,log=log,hist=hist,$ power=power,mindata=mindata,maxdata=maxdata if(n_params(0) lt 1 ) then begin print,'Usage: tvfits,nfile,fitsarr=fitsarr,fitshdr=fitshdr,$' print,' mindata=mindata,maxdata=maxdata,/log,/hist,/power' return end if nfile eq '' then return nfil=(findfile(nfile))(0) if nfil eq '' then begin print,'File ''',nfile,''' not found' return end fitsarr=readfits(nfil,fitshdr) if n_elements(mindata) gt 0 then fitsarr=fitsarr>mindata(0) if n_elements(maxdata) gt 0 then fitsarr=fitsarr1) else $ if keyword_set(hist) then aa=hist_equal(fitsarr) else $ if keyword_set(power)then begin pw=float(power(0)) if pw eq 1. then pw=0.25 aa=(fitsarr>0.)^pw -(-fitsarr>0.)^pw endif else aa=fitsarr fitstvscl,aa,fitshdr,title=nfil(0),/aspect end -####################################################### # pro tvmov,img,log=log,sqrt=sqrt,dispmin=dispmin,dispmax=dispmax,title=title,bw=bw IF (n_params(0) LT 1) THEN BEGIN print,' Usage: tvmov,im_cube,[/log,/sqrt],dispmin=dispmin,dispmax=dispmax,title=title,/bw' print,' ' print,' where im_cube is a cube of images with the last argument' print,' the image index. Displays sequence of images.' print,' /log will do log scaling' print,' /sqrt will do sqrt scaling' print,' /bw will do loadct,0, otherwise use color table 3' print,' dispmin,dispmax set TV bytscaling for linear display only.' print,' title is an alternative string array used to label images.' goto,last endif set_plot,'X' if keyword_set(bw) then loadct,0 sz=size(img) maxdim=max([sz(1),sz(2)]) factor=512./maxdim xs=fix(factor*sz(1)) ys=fix(factor*sz(2)) window,0,xs=xs,ys=ys if (sz(0) eq 3) then nims=sz(3) else nims=1 if keyword_set(title) then begin ; make sure the title array is a tsz=size(title) ; string array of the correct size if (tsz[2] ne 7 or tsz[1] ne nims) then begin print,'Title array not correct: using replacement.' title=strarr(nims) for j=0,nims-1 do begin m1=max([max(img[*,*,j]),-min(img[*,*,j])]) if (m1 ne max(img(*,*,j))) then m1=-m1 title[j]='Seq '+strtrim(string(j),2)+': Max = '+string(m1) end endif endif else begin title=strarr(nims) if (nims eq 1) then begin m1=max([max(img),-min(img)]) if (m1 ne max(img)) then m1=-m1 title[0]='Max = '+string(m1) endif else begin for j=0,nims-1 do begin m1=max([max(img[*,*,j]),-min(img[*,*,j])]) if (m1 ne max(img(*,*,j))) then m1=-m1 title[j]='Seq '+strtrim(string(j),2)+': Max = '+string(m1) end endelse endelse if (sz(0) eq 2) then begin ; single image j=0 if (keyword_set(log)) then begin ; case log display ; limit dynamic range to 200 a=alog(img>(max(img/200.))) b=congrid(a,xs,ys,cubic=-0.5) tvscl,b xyouts,xs/2,ys-20,title[j],alignment=0.5,color=255,device=1 endif else if (keyword_set(sqrt)) then begin a=sqrt(img>0.) b=congrid(a,xs,ys,cubic=-0.5) tvscl,b xyouts,xs/2,ys-20,title[j],alignment=0.5,color=255,device=1 endif else begin b=congrid(img,xs,ys,cubic=-0.5) if not keyword_set(dispmin) then dmin=min(b) else dmin=dispmin if not keyword_set(dispmax) then dmax=max(b) else dmax=dispmax tv,!d.table_size*bytscl(b,min=dmin,max=dmax)/256. xyouts,xs/2,ys-20,title[j],alignment=0.5,color=255,device=1 endelse goto,last endif for j=0,nims-1 do begin ; do each image in sequence if (keyword_set(log)) then begin ; case log display ; limit dynamic range to 200 a=alog(img(*,*,j)>(max(img(*,*,j)/200.))) b=congrid(a,xs,ys,cubic=-0.5) tvscl,b xyouts,xs/2,ys-20,title[j],alignment=0.5,color=255,device=1,charsize=2 endif else if (keyword_set(sqrt)) then begin a=sqrt(img(*,*,j)>0.) b=congrid(a,xs,ys,cubic=-0.5) tvscl,b xyouts,xs/2,ys-20,title[j],alignment=0.5,color=255,device=1,charsize=2 endif else begin b=congrid(img(*,*,j),xs,ys,cubic=-0.5) if not keyword_set(dispmin) then dmin=min(b) else dmin=dispmin if not keyword_set(dispmax) then dmax=max(b) else dmax=dispmax tv,!d.table_size*bytscl(b,min=dmin,max=dmax)/256. xyouts,xs/2,ys-20,title[j],alignment=0.5,color=255,device=1,charsize=2 endelse endfor last: return end -####################################################### # pro tvpics,nfile,array=array,revers=revers,colortab=colortab if(n_params(0) lt 1 ) then begin print,'Usage: tvpics,nfile,array=array,/revers,colortab=colortab' return end if nfile eq '' then return nfil=(findfile(nfile))(0) if nfil eq '' then begin print,'File ''',nfile,''' not found' return end if query_image(nfil) eq 1 then array=read_image(nfil,rr,gg,bb) else begin print,'Unknow file format' return end if total(rr+gg+bb) eq 0 then colortab=3 if n_elements(colortab) gt 0 then loadct,colortab(0) else tvlct,rr,gg,bb nn=size(array) i=nn(1)&j=nn(2)& b24=0 if nn(0) eq 3 then case 3 of nn(1): begin& i=nn(2)&j=nn(3)&b24=1&end nn(2): begin& i=nn(1)&j=nn(3)&b24=2&end else : begin& i=nn(1)&j=nn(2)&b24=3&end endcase if keyword_set(revers) and b24 eq 0 then array=reverse(array,2) window,/free,title=nfil,xs=i,ys=j,ret=2 if b24 ne 0 then tv,array,true=b24 else tv,array end -####################################################### # function varmap, x, max=max, slow=slow Sz = size(x) if Sz(0) ne 3 then begin print, 'Argument must be 3-D array' return,-1 end if keyword_set(max) then begin x1=total(x, 3)/Sz(3) x0=abs(x(*,*,0)-x1) for i=1, Sz(3)-1 do x0 = x0 > abs(x(*,*,i) - x1) return,float(x0) endif else if keyword_set(slow) then begin x1=double(x(*,*,0)) &x1(*)=0. for i=0,Sz(3)-1 do x1=x1+x(*,*,i)^2 return,float( sqrt(x1/Sz(3) - total(x, 3)^2/Sz(3)^2)) endif else return,float( sqrt(total(x^2, 3)/Sz(3) - total(x, 3)^2/Sz(3)^2)) end -####################################################### # function varmapd, xx, max=max, deriv=deriv Sz = size(xx) if Sz(0) ne 3 then begin print, 'Argument must be 3-D array' return,-1 end x=double(xx) if keyword_set(deriv) then begin Sz(3)=Sz(3)-1 for i=0,Sz(3)-1 do x(*,*,i)=x(*,*,i+1)-x(*,*,i) x=x(*,*,0:Sz(3)-1) endif if keyword_set(max) then begin x1=total(x, 3)/Sz(3) x0=abs(x(*,*,0)-x1) for i=1, Sz(3)-1 do x0 = x0 > abs(x(*,*,i) - x1) return,float(x0) endif else return,float( sqrt(total(x^2, 3)/Sz(3) - total(x, 3)^2/Sz(3)^2)) end -####################################################### # pro loadxfile,file,gview,txt gview.n=0 txt=readform(file) gview.file=file gview.nn=n_elements(txt) if gview.nn lt 1 then begin txt='' &gview.file='' &gview.nn=0 end end function decode,txt,code cidl=byte('ABCDEFGHIJKLMNOPQRSTUVWXYZ#[]%"_abcdefghijklmnopqrstuvwxyz<>@\^;') ctab=bytarr(3,64) ctab(2,*)=[bindgen(48)+128b,bindgen(16)+224b];ALT ctab(1,*)=bindgen(64)+192b;WIN ctab(0,*)=[225b, 226b, 247b, 231b, 228b, 229b, 246b, 250b, 233b, 234b, 235b,$ 236b, 237b, 238b, 239b, 240b, 242b, 243b, 244b, 245b, 230b, 232b,$ 227b, 254b, 251b, 253b, 223b, 249b, 248b, 252b, 224b, 241b, 193b,$ 194b, 215b, 199b, 196b, 197b, 214b, 218b, 201b, 202b, 203b, 204b,$ 205b, 206b, 207b, 208b, 210b, 211b, 212b, 213b, 198b, 200b, 195b,$ 222b, 219b, 221b, 223b, 217b, 216b, 220b, 192b, 209b] ;KOI btxt='' rtxt=txt+string(byte(25)) for i=0,n_elements(rtxt)-1 do btxt=btxt+rtxt(i) ii=0 btxt=byte(btxt) n=n_elements(btxt) rtxt=byte(' !16') rr=byte(' !16') ee=byte('!3') bb=byte(' !c') yy=byte('!') yy=yy(0) pp=byte(' ') &pp=pp(0) for i=0,n-1 do begin if btxt(i) eq 25b then rtxt=[rtxt,bb] else $ if btxt(i) eq yy then rtxt=[rtxt,yy,yy] else $ if ii eq 0 then begin if btxt(i) gt 127 or btxt(i) eq pp then rtxt=[rtxt,btxt(i)] else begin ii=1& rtxt=[rtxt,ee,btxt(i)]& end end else begin if btxt(i) lt 128 then rtxt=[rtxt,btxt(i)] else begin ii=0& rtxt=[rtxt,rr,btxt(i)]& end end end if ((code le 0) or (code gt 3)) then return, string(rtxt) ii=code-1>0 for i=0,63 do begin j=where(rtxt eq ctab(ii,i)) if j(0) ne -1 then rtxt(j)=cidl(i) end rtxt=rtxt>pp <127b rtxt=string(rtxt) return,rtxt end pro view_event,ev common text_view,gview,scbase,draw_txt,rr,gg,bb WIDGET_CONTROL,ev.id,GET_UVALUE = wuv CASE wuv OF "QUIT" : begin WIDGET_CONTROL,ev.top,/DESTROY return end "File" : begin file=dialog_pickfile(/read) if file eq '' then return loadxfile,file,gview,draw_txt end "Save" : begin if gview.nn lt 1 then return ii=gview.n & file=gview.file kode=gview.kode save,ii,file,kode,file=gview.save return end "Base" : begin ; if (findfile(gview.save))(0) eq '' then return restore,gview.save if (findfile(file))(0) eq '' then return loadxfile,file,gview,draw_txt gview.n=ii & gview.kode=kode case kode of 1: widget_control,scbase.koi,/set_but 2: widget_control,scbase.win,/set_but 3: widget_control,scbase.alt,/set_but else: widget_control,scbase.engl,/set_but endcase end "txtENG": gview.kode=0 "txtKOI": gview.kode=1 "txtWIN": gview.kode=2 "txtALT": gview.kode=3 "Begin" : gview.n=0 "Prev" : gview.n=gview.n-gview.dy >0 "Next" : gview.n=gview.n+gview.dy < (gview.nn-gview.dy) "End" : gview.n=gview.nn-gview.dy >0 else: return endcase if gview.nn lt 1 then return widget_control, scbase.draw, get_val=tmp wset,tmp tvlct,rr,gg,bb erase,35 if gview.n ge gview.nn then return ii=gview.n+gview.dy+10,60) tmp=tmp+': l='+strtrim(string(gview.n),2)+' ' tmp=tmp+strtrim(string(fix(100*gview.n/gview.nn)<100),2)+'%' widget_control,scbase.label,set_value=tmp ii=draw_txt(gview.n:ii) xyouts,0.01,0.95,decode(ii,gview.kode),chars=1.4,/nor end pro view, file=file common text_view,gview,scbase,draw_txt,rr,gg,bb gview={nn:0L,n:0L,dy:40L,kode:0L,save:'~/.idl_view.sav',file:''} scbase={main:0L,draw:0L,label:0L,engl:0L,koi:0L,win:0L,alt:0L} draw_txt='' if n_elements(file) lt 0 then begin if findfile(file) ne '' then loadxfile,file,gview,draw_txt end scbase.main= widget_base(title='Text view',GROUP_LEADER=0L, /column) menubase=widget_base(scbase.main, /row) button=widget_button(menubase, val="QUIT", uval="QUIT") button=widget_button(menubase, val="New file", uval="File") button=widget_button(menubase, val="Load file", uval="Base") button=widget_button(menubase, val="Save", uval="Save") ii=widget_base(menubase,/row,/exclusive,/frame) scbase.engl=widget_button(ii,val='none',uval='txtENG',/no_rel) scbase.koi=widget_button(ii,val='Koi',uval='txtKOI',/no_rel) scbase.win=widget_button(ii,val='Win',uval='txtWIN',/no_rel) scbase.alt=widget_button(ii,val='Alt',uval='txtALT',/no_rel) button=widget_button(menubase, val='<<',uval='Begin') button=widget_button(menubase, val='0)) end function data2id,data,i reads,data(0),yy,mm,dd,format='(2x,i2,1x,i2,1x,i2)' x=yy*1000000L+mm*10000L+dd*100+i return,x end function hessi2str,data n=n_elements(data)-1 x=strarr(n+1) j=bytarr(12) &j(*)=32 for i=0,n do begin x(i)='200'+strtrim(string(data(i).id_number),2)+' ' ; x(i)=x(i)+'dd-mmm-yyyy'+' ' x(i)=x(i)+sec2hms(data(i).start_time mod 86400.)+' ' x(i)=x(i)+sec2hms(data(i).peak_time mod 86400.)+' ' x(i)=x(i)+sec2hms(data(i).end_time mod 86400.)+' ' x(i)=x(i)+string(long(data(i).end_time-data(i).start_time))+' ' x(i)=x(i)+string(long(data(i).peak_countrate))+' ' x(i)=x(i)+string(long(data(i).total_counts)) z=strtrim(string(fix(data(i).energy_hi)),2) z=z(0)+'-'+z(1) k=string(j) i0=12-strlen(z) strput,k,z,i0 x(i)=x(i)+k end if n eq 0 then x=x(0) return,x end pro xhessilist_event,ev common hessi_bd, pngdb, flarelist, dbwin, chlist, cpimg WIDGET_CONTROL,ev.id,GET_UVALUE = wuv, /hour i=where(dbwin.kev eq ev.id) if i(0) gt 0 then dbwin.kstat(i)=ev.select CASE wuv OF "QUIT" : begin WIDGET_CONTROL,ev.top,/DESTROY if (findfile('idl.ps'))(0) ne '' then file_delete,'idl.ps' end "SAVE" : begin if chlist(0) lt 0 then return file=dialog_pickfile(/write) if file eq '' then return openw, lun, file, /get ltmp=hessi2str(flarelist(chlist)) n=n_elements(ltmp) printf,lun,string(n)+' flares selected' i=' Flare Start Peak End Dur' i=i+' Peak Total Energy' printf,lun,i i=' date+N time time time s' i=i+' c/s Counts keV' printf,lun,i for j=0, n-1 do printf, lun, ltmp(j) free_lun, lun end "CALC" : begin chlist=lindgen(n_elements(flarelist)) widget_control,dbwin.bdate,get_val=bdate minid=data2id(bdate,0) widget_control,dbwin.edate,get_val=edate maxid=data2id(edate,99) widget_control,dbwin.btime,get_val=btime mintime=str2sec(strtrim(btime,2)) widget_control,dbwin.etime,get_val=etime maxtime=str2sec(strtrim(etime,2)) widget_control,dbwin.bdur,get_val=mindur mindur=double(mindur(0)) widget_control,dbwin.edur,get_val=maxdur maxdur=double(maxdur(0)) widget_control,dbwin.bpeak,get_val=minpeak minpeak=float(minpeak(0)) widget_control,dbwin.epeak,get_val=maxpeak maxpeak=float(maxpeak(0)) ;-------------------- i=where(flarelist(chlist).id_number ge minid) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) i=where(flarelist(chlist).id_number le maxid) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) i=where((flarelist(chlist).start_time mod 86400.) ge mintime) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) i=where((flarelist(chlist).end_time mod 86400.) le maxtime) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) z=flarelist(chlist).end_time - flarelist(chlist).start_time i=where((z mod 86400.) ge mindur) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) z=flarelist(chlist).end_time - flarelist(chlist).start_time i=where((z mod 86400.) le maxdur) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) i=where(flarelist(chlist).peak_countrate le maxpeak) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) i=where(flarelist(chlist).peak_countrate ge minpeak) if i(0) lt 0 then begin &chlist=-1& goto,hxtstr& end chlist=chlist(i) hxtstr: if chlist(0) ge 0 then begin ltmp=hessi2str(flarelist(chlist)) widget_control,dbwin.list,set_val=ltmp z=string(n_elements(chlist))+' flares found' end else z='No FLARE for this selection' widget_control,dbwin.status,set_val=z end "PLOT" : begin i=widget_info(dbwin.list,/list_select) if i lt 0 then return z=id2png(flarelist(chlist(i)),pngdb) widget_control,dbwin.status,set_val=z if query_image(z) eq 1 then array=read_image(z,rr,gg,bb) else return cpimg=z window,7,xs=640,ys=480,ret=2,titl=z z=array array(*)=255 i=where(z eq 255) if i(0) ge 0 then array(i)=0 for j=0,8 do begin if dbwin.kstat(j) ne 0 then begin i=where(z eq j+1) if i(0) ge 0 then array(i)=j+1 end end i=where(array eq 1) if i(0) ge 0 then array(i)=0 tvlct,rr,gg,bb tv,array end "PRNT" : begin if cpimg eq '' then return if query_image(cpimg) eq 1 then array=read_image(cpimg,rr,gg,bb) $ else return z=array array(*)=255 i=where(z eq 255) if i(0) ge 0 then array(i)=0 for j=0,8 do begin if dbwin.kstat(j) ne 0 then begin i=where(z eq j+1) if i(0) ge 0 then array(i)=j+1 end end i=where(array eq 1) if i(0) ge 0 then array(i)=0 set1ps,/nocol tvlct,rr,gg,bb fitstvscl,array,/asp,/tv,psgrid=640,/noint,/notick,tickl=1e-5 set_ps,0 widget_control,dbwin.lpr,get_val=z widget_control,dbwin.status,set_val='Print image by the next command: '+z(0) spawn,z+' idl.ps' end "COPY" : begin if cpimg eq '' then return z=dialog_pickfile(/dir) if z ne '' then spawn,'cp '+cpimg+' '+z end ELSE: ENDCASE end pro xhessilist,fitsname=fitsname,metadata=metadata print,'Usage: xhessilist,[fitsname=fitsname,metadata=metadata,lpr=lpr]' print,' fitsname - name of the database FITS file' print,' metadata - root directory of the RHESSI metadata' common hessi_bd, pngdb, flarelist, dbwin, chlist,cpimg chlist=-1 cpimg='' dbwin={cbase:0L, list:0L, bdate:0L, edate:0L, btime:0L, etime:0L, $ edur:0L, bdur:0L, epeak:0L, bpeak:0L, status:0L, lpr:0L,kev:lonarr(9),kstat:intarr(9)} dbwin.kstat(*)=1 if n_elements(fitsname) ne 0 then nfits=fitsname(0) $ else nfits='/solardb/rhessi/dbase/hessi_flare_list.fits' if n_elements(metadata) ne 0 then pngdb=metadata(0) $ else pngdb='/solardb/rhessi/metadata' flarelist=mrdfits(nfits,3,i,status=j,/sil) if j lt 0 then return j=fxpar(i,'EXTNAME') if string(j) ne 'HSI_FLARELISTDATA' then return IF(XRegistered("xhessilist") NE 0) THEN return device,get_scr=scr dbwin.cbase= widget_base(title='HESSI Flare List', /column) menubase=widget_base(dbwin.cbase, /row) button=widget_button(menubase, val="QUIT", uval="QUIT") mbase=widget_base(dbwin.cbase, /row,/frame) menubase=widget_base(mbase, /column,/frame) button=widget_label(menubase,val='Start date') dbwin.bdate=widget_text(menubase, val='2002-03-01',/edit,uval='e') button=widget_label(menubase,val='End date') dbwin.edate=widget_text(menubase, val='2002-12-31',/edit,uval='e') menubase=widget_base(mbase, /column,/frame) button=widget_label(menubase,val='Start time') dbwin.btime=widget_text(menubase, val='00:00:00',/edit,uval='e') button=widget_label(menubase,val='End time') dbwin.etime=widget_text(menubase, val='24:00:00',/edit,uval='e') menubase=widget_base(mbase, /column,/frame) button=widget_label(menubase,val='Min duration') dbwin.bdur=widget_text(menubase, val='0',/edit,uval='e') button=widget_label(menubase,val='Max duration') dbwin.edur=widget_text(menubase, val='1000',/edit,uval='e') menubase=widget_base(mbase, /column,/frame) button=widget_label(menubase,val='Min peak counts') dbwin.bpeak=widget_text(menubase, val='0',/edit,uval='e') button=widget_label(menubase,val='Max peak counts') dbwin.epeak=widget_text(menubase, val='1000',/edit,uval='e') menubase=widget_base(mbase, /column) button=widget_button(menubase, val="Run request", uval="CALC") button=widget_button(menubase, val="Save As Text", uval="SAVE") menubase=widget_base(dbwin.cbase, /row) button=widget_button(menubase, val="View Time profile", uval="PLOT") button=widget_button(menubase, val="Copy Image ...", uval="COPY") button=widget_button(menubase, val="Print time profile", uval="PRNT") button=widget_label(menubase,/ALIGN_LEFT, val=' Print command :') dbwin.lpr=widget_text(menubase, val='lpr',/edit,uval='e') menubase=widget_base(dbwin.cbase, /row,/nonexc,title='print options',/frame) dbwin.kev[0]=widget_button(menubase, val='3-6keV', uval="k3") dbwin.kev[1]=widget_button(menubase, val='6-12keV', uval="k6") dbwin.kev[2]=widget_button(menubase, val='12-25keV', uval="k12") dbwin.kev[3]=widget_button(menubase, val='25-50keV', uval="k25") dbwin.kev[4]=widget_button(menubase, val='50-100keV', uval="k50") dbwin.kev[5]=widget_button(menubase, val='100-300keV', uval="k100") dbwin.kev[6]=widget_button(menubase, val='300-800keV', uval="k300") dbwin.kev[7]=widget_button(menubase, val='0.8-7MeV', uval="k800") dbwin.kev[8]=widget_button(menubase, val='7-20MeV', uval="k7000") widget_control,menubase,/set_butt i=' Flare Start Peak End Dur' i=i+' Peak Total Energy' button=widget_label(dbwin.cbase,/ALIGN_LEFT, val=i) i=' date+N time time time s' i=i+' c/s Counts keV' button=widget_label(dbwin.cbase,/ALIGN_LEFT, val=i) i=hessi2str(flarelist) dbwin.list = WIDGET_list(dbwin.CBASE,/frame, value=i,uval='LIST',ysize=20) dbwin.status=widget_label(dbwin.cbase,/ALIGN_LEFT, val=' ',/dynamic_res) WIDGET_CONTROL, dbwin.cbase, /realize, /hourglass xmanager,'xhessilist', dbwin.CBASE, GROUP_LEADER = GROUP_LEADER, /no_block end -####################################################### # pro xtext_event,ev common Exch_xtext,scbase,Txt,Out_Text,lun,Filename goto, obh_print CASE !version.OS OF 'windows': prn_funct='copy '+Filename+' prn:' 'Win32': prn_funct='copy '+Filename+' prn:' ELSE: prn_funct='lpr '+Filename ENDCASE obh_print: WIDGET_CONTROL,ev.id,GET_UVALUE = wuv, /hour CASE wuv OF "QUIT" : WIDGET_CONTROL,ev.top,/DESTROY "File" : begin file=dialog_pickfile(/read) if file eq '' then return WIDGET_CONTROL,ev.top,/DESTROY xtext, File=File end "PRINT" : IF Filename ne '' THEN begin flush,lun if strmid(!version.release,0,1) lt 5 then spawn, prn_funct else begin ; set_plot,'printer' ;device,filename=filename,/close_document a = execute('f=dialog_printersetup()') if a eq 0 then return else begin file = 'idl.' + STRLOWCASE(!D.NAME) ;stop ;file = 'idl.' + string(filename) ;cmd = 'lpr ' + file ;cmd = cmd + '; ;SPAWN, cmd spawn, prn_funct endelse endelse ;if strmid(!version.release,0,1) lt 5 then spawn, prn_funct else f=dialog_printersetup() wait,1 endif 'INPUT': begin widget_control, ev.id, get_val = n_line pos = long(n_line(0)) widget_control, ev.id, set_text_top_line = pos, $ set_text_select = [pos,40] end ELSE: ENDCASE end pro xtext,Text=Text,File=File,group_leader=group_leader, $ identifier=identifier, numbers = numbers, one_argument ; Displays interactively a text. xtext is similar to XDISPLAYFILE. common Exch_xtext,scbase,Txt,Out_Text,lun,Filename IF(XRegistered("xtext") NE 0) THEN return device,get_scr=scr if n_elements(group_leader) le 0 then group_leader=0L CASE 1 OF n_params() eq 1: Out_text = one_argument n_params() eq 0 and n_elements(Text) gt 0: Out_text = Text n_params() eq 0 and n_elements(File) gt 0: Out_text = readform(file) ELSE: ENDCASE goto, obh_new if n_elements(File) le 0 then begin if n_elements(Text) le 0 then Out_text=' ' else Out_text=Text Filename='prn_file.tmp' openw,lun,Filename,/get for j=0, n_elements(Out_text)-1 do printf, lun, Out_text(j) flush, lun ;free_lun,lun close, lun endif else begin widget_control,/hour Filename=File ;Out_text = readform(file) if file eq '' then Out_text ='' widget_control, /hour openr, lun, file, /get st = fstat(lun) data = bytarr(st.size) readu, lun, data point_lun, lun, 0 iii = where(data eq '0A'xB) N = n_elements(iii) data = strarr(N) readf, lun, data st = fstat(lun) if (st.cur_ptr + 1) lt st.size then begin tmp = '' readf, lun, tmp data = [data, tmp] endif close, lun Out_text=data ;---- obh: endelse obh_new: N = n_elements(Out_text) if keyword_set(numbers) then begin n_signs = ceil(alog10(N)) Out_text = strmid(sindgen(N), 12-n_signs, n_signs)+' '+Out_text endif scbase= widget_base(title='xtext', group_leader=group_leader, /column) menubase=widget_base(scbase, /row) button=widget_button(menubase, val="QUIT", uval="QUIT") button=widget_button(menubase, val="Load", uval="File") ;button=widget_button(menubase, val="Print", uval="PRINT") ;input=widget_text(menubase, val=string(N), uval="INPUT", /edit) Txt = WIDGET_TEXT(SCBASE,/frame, Ysize = N < scr(1)/24 < 30 > 4, $ value=Out_text,/scroll,uvalue='', xsize=max(strlen(Out_text)) +2 > 10) WIDGET_CONTROL, scbase, /realize, /hourglass identifier=scbase xmanager,'xtext', SCBASE, GROUP_LEADER = GROUP_LEADER, /no_block end -####################################################### # ;+ ; function GREP,strarray,strin,pos=pos,ignore=ignore ; return: index array of string contained STRIN ; /ignore - ignore upper/lower case distinction during comparisons. ; ; Ex: aa=string(indgen(10)*4) ; print,grep(aa,'8',pos=i),i ;- function _grep,strarray,strmask,pos=pos,ignore=ignore if keyword_set(ignore) then begin strar=strupcase(strarray) strm=strupcase(strmask) endif else begin strar=strarray & strm=strmask end pos =-1 nst=strpos(strar,strm) ii=nst nst=where(ii ne (-1)) if nst(0) eq (-1) then goto,aaa pos=ii(nst) aaa:return,nst end -####################################################### # &&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& pro add_eof,Filename ;+ ; NAME: ; ADD_EOF ; ; PURPOSE: ; ADD_EOF writes the END OF FILE marker ('1A'XB) into the given file. ; ; CALLING SEQUENCE: ; ADD_EOF, [FileName] ; ; OPTIONAL INPUT: ; Filename: The name of the file to be processed of (string type). ; If no Filename is specified, then thr function PICKFILE is called. ; ; ; OUTPUT: None. ; ; SIDE EFFECT: The file is overwritten. ; ; RESTRICTIONS: None. ; ; REVISION HISTORY: ; Written by V.Grechnev, ISTP. 1994. ;- if n_params() le 0 then Filename=pickfile() if Filename eq '' then goto,exit openr,lun,Filename,/get_lun a=fstat(lun) data=bytarr(a.size) readu,lun,data free_lun,lun j=a.size repeat j=j-1 until (j eq 0) or $ ((data(j) ne '0A'xb) and $ (data(j) ne '0D'xb) and $ (data(j) ne '1A'xb) and $ (data(j) ne '20'xb)) openw,lun,Filename,/get_lun writeu,lun,data(0L:j),'1A'xb free_lun,lun flush,lun print,'OK.' exit: end ####################################################### pro add_lf,filter=filter,overwrite=overwrite,file=file, $ all_files=all_files,path=path,confirm=confirm ; Adds the Line Feed codes to any CR codes containing in the file. ; This routine is used to convert files from UNIX to MS WINDOWS ; format. if n_elements(filter) le 0 then begin if keyword_set(all_files) then filter='*.*' else filter='*.pro' endif if n_elements(all_files) le 0 then all_files=0 if n_elements(file) le 0 then file='' else begin if n_elements(path) le 0 then path=subdir(file) endelse if !version.OS eq 'windows' or !version.OS eq 'Win32' $ then Delim='\' else Delim='/' if n_elements(path) le 0 and file eq '' then path=''; getenv('gr_prg') ;'' CR='0A'xb & LF='0D'xb if keyword_set(all_files) then begin path=subdir(pickfile(filt=filter,tit='Please select a file for converting')) if path ne '' then Files=findfile((path)+Delim+filter) else $ Files=findfile(filter) ; ****************** Excluding subdirectories ************** Files=Files(sort(Files)) & Sz=size(Files) if (Sz)(0) gt 0 then Sz=Sz(1) else Sz=0 for j=0,Sz-1 do if strmid(Files(j),strlen(Files(j))-1,1) eq '\' then $ if n_elements(b) le 0 then b=j else b=[b,j] N_b=n_elements(b) if N_b gt 0 then begin Files_save=Files(b) for j=0,N_b-1 do Files=Files(where(Files ne Files_save(j))) endif ; *********************************************************** IF keyword_set(confirm) THEN BEGIN Print,'y/n:' N_b=n_elements(Files) index=intarr(N_b) for j=0,N_b-1 do begin print,Files(j)+'?' tmp=strlowcase(get_kbrd(1)) index(j)=tmp eq 'y' endfor Files=Files(where(index)) ENDIF ELSE BEGIN a='' xquestion,a,text='You are processing all the files '+path+'\'+filter, $ select=['OK','Cancel'] if a ne 'OK' then begin print,'Operation is canceled' goto,exit endif ENDELSE endif else begin if path ne '' then Files=pickfile(tit='Please select a file for converting', $ filt=filter, file=file, path=path) else $ Files=pickfile(tit='Please select a file for converting', $ filt=filter, file=file) if Files eq '' then goto,exit endelse Loop: for k=0,n_elements(Files)-1 do begin openr,lun,Files(k),/get_lun a=fstat(lun) if a.size eq 0 then goto,No_operation x=bytarr(a.size) readu,lun,x free_lun,lun if x(a.size-1) ne CR then x=[x,CR] WIDGET_CONTROL,/hourglass x=x(where(x ne LF)) i=where(x eq CR) if not keyword_set(overwrite) then $ Newfilename=path+Delim+(name_extract(Files(k)))(1)+'.lfa' $ else Newfilename=Files(k) openw,lun,Newfilename,/get_lun writeu,lun,x(0:i(0)-1 > 0),LF,CR for j=0L,n_elements(i)-2 do if i(j)+1 ne i(j+1) then $ writeu,lun,x(i(j)+1:i(j+1)-1),LF,CR $ else writeu,lun,LF,CR free_lun,lun print,'File '+Newfilename+' is recorded.' No_operation: endfor exit: end ####################################################### pro add_ssw !path=!path+':/home/Grechnev/idl_lib/ssw_com' print, 'Path to SSW partial set added.' end ####################################################### pro adj_cir_event, ev common adj_cir, ID, data, R, a, b, c if ev.id eq ID.Draw then begin if (ev.press eq 1) then data.press=1 if (ev.release eq 1) then data.press=0 if ev.press then begin data.Current=[ev.x, ev.y] return endif if data.press then begin widget_control, ID.Label, set_val = "Center: "+ $ string(data.Center(0), data.Center(1), format='(i5, ", ",i5)') if data.first then begin data.Current=[ev.x, ev.y] data.first=0 return endif device, set_gr=6 plots, data.x, data.y shift_x=ev.x-Data.Current(0) shift_y=ev.y-Data.Current(1) data.x=data.x+shift_x data.y=data.y+shift_y data.Center=data.Center+[shift_x, shift_y] plots, data.x, data.y data.Current=[ev.x, ev.y] endif device, set_gr=3 return endif widget_control, ev.id, get_uval=uv CASE uv OF 'Done': widget_control, ev.top, /destroy 'Colors': xloadct 'Plus': R=R+1. 'Minus':R=R-1. ELSE: ENDCASE empty end pro adj_cir, array, Radius, Output common adj_cir, ID, data, R, a, b, c if n_params() lt 2 then begin print, 'Insufficient number of arguments. Returning...' return endif R=Radius Sz=size(array) Center=[Sz(1)/2., Sz(2)/2.] t=findgen(200)/199*2*!pi x=cos(t)*Radius+Center(0) y=sin(t)*Radius+Center(1) x0=cos(t)*Sz(1)/2.+Center(0) y0=sin(t)*Sz(2)/2.+Center(1) Data={Radius:Radius, Center:Center, array:array, x:x, y:y, press:0, $ Current:[0,0], first:1} ID={Draw:0L, Label:0L} base=widget_base(/colu, tit='Adjustment of a disk') menubase=widget_base(base, /row) button=widget_button(menubase, val='Done', uval='Done') button=widget_button(menubase, val='Tools', /menu) button1=widget_button(button, val='Colors', uval='Colors') button2=widget_button(button, val='Plus', uval='Plus') button3=widget_button(button, val='Minus', uval='Minus') ID.draw=widget_draw(base, xs=Sz(1), ys=sz(2), /button_events, /motion_events, /fra) if !version.release lt 4 then $ ID.Label=widget_label(base, /fra, val='', uval='') else $ ID.Label=widget_label(base, /fra, val='', uval='',/dynam) widget_control, base, /real, /hour widget_control, ID.draw, get_val=tmp widget_control, ID.Label, set_val = "Center: "+ $ string(data.Center(0), data.Center(1), format='(i5, ", ",i5)') wset, tmp tvscl, array plot, x0, y0, xst=5, yst=5, xmar=[0,0], ymar=[0,0], /noerase, /nod device, set_gr=6 plots, data.x, data.y device, set_gr=3 empty xmanager, 'adj_cir', base, /modal print,data.Center Output=Data.Center end ####################################################### function alfven, B, n ;+ Calculates Alfven velocity (cm/sec) ; B - magnetic field (Gauss) ; n - plasma desity (cm^-3) ; ; Calling sequence: print, alfven(B, n) ;- if n(0) lt 0 then message, 'Please specify N as a floating-point value' me = 9.1085d-28 return, float(double(B)/sqrt(4*!dpi*me*1837.*n)) end ####################################################### function align,iew,Date,time_sec,Receiver,Dt,Dir, $ fast=fast,single=single,interpolate=interpolate, $ start_time=start_time,SUN=SUN,Channel=Channel, $ keep=keep,order=order,polarisation=polarisation, $ C_shift=C_shift,gate=gate if n_elements(gate) le 0 then Gate=5 if n_elements(Channel) le 0 then amax=max(iew(*,0),Channel) D=4.9D0 & C=2.997925D8 & Fi=51.7575D0*!DPi/180 Sum_chan=[176,192] WIDGET_CONTROL,/HOUR N=Sum_chan(Receiver) vew=0 N_scans=(size(iew))(2) if n_elements(start_time) le 0 then $ start_time=time_sec(0)+Dt*(N_scans-1)/2. suneph,Date,smh(time_sec(0),ms=3),SUN SUNs=SUN type=size(start_time) type=type(n_elements(type)-2) if type eq 7 then $ reference_time=start_time else reference_time=smh(start_time,ms=3) suneph,Date,reference_time,SUNs INT_ORD,dir,Receiver,SUN,P,Nord,Ord0,Chan INT_ORD,dir,Receiver,SUNs,Ps,Nords,Ords,Chans C_shift_start=Chan(1,0)-Chans(1,0) Chan_cur=Channel+C_shift_start Ord=ORD_RECOGNIZE(Chan_cur,Nord,Ord0,Chan) P0=acos(Ord*C/(chanfreq(Chan_cur,Receiver)*D) > (-1) < 1) Chan_cur=Channel+C_shift_start-Gate Ord1=ORD_RECOGNIZE(Chan_cur,Nord,Ord0,Chan) P01=acos(Ord1*C/(chanfreq(Chan_cur,Receiver)*D) > (-1) < 1) Chan_cur=Channel+C_shift_start+Gate Ord2=ORD_RECOGNIZE(Chan_cur,Nord,Ord0,Chan) P02=acos(Ord2*C/(chanfreq(Chan_cur,Receiver)*D) > (-1) < 1) Chan_cur=p_to_chan(P0,Dir,Receiver, SUN=SUN, Order=Ord) Chan_cur1=p_to_chan(P01,Dir,Receiver, SUN=SUN, Order=Ord1) Chan_cur2=p_to_chan(P02,Dir,Receiver, SUN=SUN, Order=Ord2) Order0=(find_equal(Ord,Ord1,Ord2))(0) N_o=where(Ord0 eq Order0) Chan_ref=Chan(*,N_o(0) > 0) factor=(Chan_ref(2)-Chan_ref(0))/(Chans(2,0)-Chans(0,0)) Chan_cur=chanfreq((C/(D*cos(P0))*Order0),Receiver) C_shift_start=(Chan_cur-Channel)(0) Fmin_max=chanfreq([1,([180,192])(Receiver)],Receiver) Df0=Fmin_max(1)-Fmin_max(0) F0=(Fmin_max(1)+Fmin_max(0))/2. C_shift0=F0/(Df0/(N-1))*SUN.W0 CASE dir OF 0: C_shift=C_shift0/tan(SUN.H)* $ (dindgen(N_scans)-0.5*(N_scans-1))*dt-C_shift_start 1: C_shift=-C_shift0*sin(SUN.H)/(cos(SUN.H)-tan(SUN.Decl)/tan(Fi))* $ (dindgen(N_scans)-0.5*(N_scans-1))*dt-C_shift_start ELSE: begin print,'Incorrect input of the interferometer' stop return,0 end ENDCASE CASE 1 OF keyword_set(fast): begin scan=iew for i=0,N_scans-1 do scan(*,i)=shift(scan(*,i), c_shift(i)) end keyword_set(interpolate): begin scan=iew if keyword_set(polarisation) then amin=0 else amin=min(scan) amin=-32000 Argument=float(findgen(N+2)*factor+(N-1)*(1-factor)/2.) for i=0,N_scans-1 do scan(*,i)=(interpolate([amin,scan(*,i),amin], $ Argument-c_shift(i)))(1:N) end keyword_set(single): begin s=10 shift_min=min(c_shift,max=shift_max) scan=fltarr((N-1+abs(shift_min-1)+(shift_max+1))*s+1) number=intarr((N-1+abs(shift_min-1)+(shift_max+1))*s+1) register=findgen((N-1+abs(shift_min-1)+(shift_max+1))*s+1) register0=findgen(N) for j=0,n_scans-1 do begin channels=float((C_shift(j)-shift_min)*s)+register i=long(channels(register0*s)+0.5) scan(i)=scan(i)+iew(*,j) number(i)=number(i)+1 endfor index=where(number ne 0) scan(index)=scan(index)/number(index) end ELSE: ENDCASE C_shift=C_shift_start return,scan end ####################################################### ; ALIGN_CUBE at end ; PRO ALIGN_CUBE, IN_CUBE, OUT_CUBE, DMAX=DMAX, SHIFTS=SHIFTS, $ ; INSHIFTS=INSHIFTS FUNCTION MAXLOC,ARRAY,MAX_ARRAY ;+ ; NAME: ; MAXLOC ; ; PURPOSE: ; Find the position of maximum in a two dimensional array. ; ; CALLING SEQUENCE: ; Result = MAXLOC(ARRAY,MAX_ARRAY) ; ; INPUTS: ; ARRAY = a two dimensional array. ; ; OUTPUTS: ; Result = a vector containing the X,Y coordinates of maximum. ; ; OPTIONAL OUTPUT: ; MAX_ARRAY = value of the array at X,Y. ; ; SIDE EFFECTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Straightforward. ; ; MODIFICATION HISTORY: ; Written by Roberto Molowny-Horas, 1991. ; MAX_ARRAY added in March 1994, RMH ; ;- ON_ERROR,2 s = SIZE(array) ;Size of input array. IF s(0) NE 2 THEN MESSAGE,'Input array must be two dimensional' max_array = MAX(array,n) ;Finds maximum. RETURN,[n MOD s(1),n/s(1)] ;Output as a vector. END ;------------------------------------------------------------------------ PRO FIVEPOINT,CC,X,Y ;+ ; NAME: ; FIVEPOINT ; ; PURPOSE: ; Measure the position of minimum or maximum in a 3x3 matrix. ; ; CALLING SEQUENCE: ; FIVEPOINT,CC,X,Y ; ; INPUTS: ; CC = Cross correlation function. It must have dimensions like ; CC(3,3), CC(*,3,3) or CC(*,*,3,3) ; ; OUTPUTS: ; X & Y = Position of the minimum, taking cc(*,*,1,1) as centre. ; ; SIDE EFFECTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Simple interpolation with a 2-rd polynomial in X and Y. ; ; MODIFICATION HISTORY: ; Written by Roberto Luis Molowny Horas, Institute of Theoretical ; Astrophysics, University of Oslo. August 1991. ;- ; ON_ERROR,2 IF N_PARAMS(0) LT 3 THEN MESSAGE,'Wrong number of parameters.' n = SIZE(cc) IF n(0) LT 2 OR n(0) GT 4 THEN MESSAGE,'Wrong input array' IF n(n(0)-1) NE 3 OR n(n(0)) NE 3 THEN MESSAGE,$ 'Array must be CC(*,*,3,3)' CASE 1 OF n(0) EQ 4: BEGIN y = 2.*cc(*,*,1,1) x = (cc(*,*,0,1)-cc(*,*,2,1))/(cc(*,*,2,1)+ $ cc(*,*,0,1)-y)*.5 y = (cc(*,*,1,0)-cc(*,*,1,2))/(cc(*,*,1,2)+ $ cc(*,*,1,0)-y)*.5 END n(0) EQ 3: BEGIN y = 2.*cc(*,1,1) x = (cc(*,0,1)-cc(*,2,1))/(cc(*,2,1)+cc(*,0,1)-y)*.5 y = (cc(*,1,0)-cc(*,1,2))/(cc(*,1,2)+cc(*,1,0)-y)*.5 END n(0) EQ 2: BEGIN y = 2.*cc(1,1) x = (cc(0,1)-cc(2,1))/(cc(2,1)+cc(0,1)-y)*.5 y = (cc(1,0)-cc(1,2))/(cc(1,2)+cc(1,0)-y)*.5 END ENDCASE END ;------------------------------------------------------------------------ FUNCTION COALIGN,A,B ;+ ; NAME: ; ALIGN ; ; PURPOSE: ; Compute the shift image B has to be given to match image A. ; ; CALLING SEQUENCE: ; Result = ALIGN(A,B) ; ; INPUTS: ; A = reference image. ; ; B = image to be aligned. ; ; OUTPUTS: ; Result = Shift in X,Y to give image B to match A. ; ; SIDE EFFECTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; RESTRICTIONS: ; IF dimensions of images are not a power of 2, algorithm can be ; slow. ; ; PROCEDURE: ; It uses the properties of the Fourier transform to compute the ; cross correlation between the two images. ; ; MODIFICATION HISTORY: ; Written by Roberto Luis Molowny Horas, July 1992. ; ;- ; ON_ERROR,2 sa = SIZE(a) sb = SIZE(b) IF sa(0) NE 2 THEN MESSAGE,'Image must be 2-D' IF sa(1) NE sb(1) OR sa(2) NE sb(2) THEN $ MESSAGE,'Images must have same dimensions' cc = SHIFT(FLOAT(FFT(FFT(a,-1)*$ ;Cross correlation. CONJ(FFT(b,-1)),1)),sa(1)/2,sa(2)/2) xy = MAXLOC(cc) ;Finding the maximum. IF xy(0) EQ 0 OR xy(0) EQ sa(1)-1 OR xy(1) EQ 0 OR xy(1) EQ sa(2)-1 $ THEN BEGIN PRINT,' >>>> Shift too large! ' x = 0 & y = 0 ;Outside image. ENDIF ELSE BEGIN cc = cc(xy(0)-1:xy(0)+1,xy(1)-1:xy(1)+1);Maximum in centre. FIVEPOINT,cc,x,y x = xy(0) - sa(1)/2 + x ;Centering. y = xy(1) - sa(2)/2 + y ENDELSE RETURN,[x,y] END ;--------------------------------------------------------------------- function shift_align,a,b,inshift=inshift,outshift=outshift ; shifts b to match a: uses coalign to get shift, ; shift_image to shift ; shift is alternative shift supplied asz=size(a) bsz=size(b) if ((asz[0] ne bsz[0]) or (asz[1] ne bsz[1]) or (asz[2] ne bsz[2])) $ then begin print,'Dimensions must be the same.' return,-1 endif ; inshift is the shift to be given to b to match a if not keyword_set(inshift) then sh=coalign(a,b) else sh=inshift print,'Shift in pixels is ',sh if keyword_set(outshift) then outshift=sh shift_image,b,shift_im,sh return,shift_im end ; ------------------------------------------------------------------------- ; increase nex in shift_align for large shifts PRO ALIGN_CUBE, IN_CUBE, OUT_CUBE, DMAX=DMAX, SHIFTS=SHIFTS, $ INSHIFTS=INSHIFTS, FIRST=FIRST, REVERSE=REVERSE IF (n_params(0) LT 1) THEN BEGIN print,'Usage: ALIGN_CUBE, IN_CUBE, OUT_CUBE, [DMAX=DMAX, /FIRST],' print,' [SHIFTS=SHIFTS, INSHIFTS=INSHIFTS]' print,'' print,'Aligns sequence of images in IN_CUBE and creates aligned array' print,' in OUT_CUBE. DMAX is optinal maximum for correlation range.' print,' The shift is cumulative so alignment is to first image.' print,'SHIFTS is optional array to return calculated shifts.' print,'INSHIFTS is optional array to supply shifts to be applied: if supplied,' print,' new shifts are not calculated.' print,'If /FIRST, all images are co-aligned with the first image in cube' print,'If FIRST=IMAGE, all images are co-aligned with IMAGE' print,'If /REVERSE, starts with last image and works backwards.' RETURN END ; align using data range in first image IF not keyword_set(dmax) then dmax=0.9*max(IN_CUBE) IF KEYWORD_SET(FIRST) THEN $ if (n_elements(first) eq 1) then test=IN_CUBE[*,*,0] $ else test=first OUT_CUBE = IN_CUBE sz=size(in_cube) nim=sz[3] shifts=0.0*fltarr(2,nim) sh=fltarr(2) ; if applying supplied shifts, must do every image if keyword_set(inshifts) then $ for i=0,nim-1 do $ OUT_CUBE[*,*,i]=shift_align(OUT_CUBE[*,*,i],IN_CUBE[*,*,i], $ inshift=inshifts[*,i]) $ else begin for i=1,nim-1 do begin IF NOT KEYWORD_SET(REVERSE) THEN BEGIN ; first derive shifts using clipped data ; shift relative to first image made cumulative by using shifted image if not keyword_set(first) then test=OUT_CUBE[*,*,i-1] OUT_CUBE[*,*,i]=shift_align(TEST 1) readf,lun,Out_text free_lun,lun endelse scbase= widget_base(title='a_issue_txt', group_leader=group_leader, /column) menubase=widget_base(scbase, /row) button=widget_button(menubase, val="QUIT", uval="QUIT") button=widget_button(menubase, val="Load", uval="File") button=widget_button(menubase, val="Print", uval="PRINT") Txt = WIDGET_TEXT(SCBASE,/frame,Ysize=n_elements(Out_text) < scr(1)/24 < 30 > 4, $ value=Out_text,/scroll,uvalue='', xsize=max(strlen(Out_text)) +2 > 10) WIDGET_CONTROL,scbase, /realize, /hourglass identifier=scbase xmanager,'a_issue_txt',SCBASE, GROUP_LEADER = GROUP_LEADER end pro cur_date_save, entry, file openw, lun, file, /get printf, lun, 'Data for '+entry.Date printf, lun, '____________________________________' printf, lun, 'Time: ', entry.time printf, lun, 'Pos. angle: ',strtrim(string(entry.PA, format='(f5.1)'),2) printf, lun, "Lat. of the Sun's center: ", strtrim(string(entry.B0, format='(f4.1)'),2) printf, lun, 'Number of active regions: ', strtrim(string(entry.Nar, format='(i2)'),2) printf, lun, 'Ipeak - I_Tb: ', strtrim(string(entry.map.ipeak.itb, format='(g9.3)'),2)+ ', '+ $ strtrim(string(entry.map.ipeak.vtb/(entry.map.ipeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' printf, lun, 'Vpeak - V_Tb: ', strtrim(string(entry.map.vpeak.vtb, format='(g10.3)'),2)+ ', '+ $ strtrim(string(entry.map.vpeak.vtb/(entry.map.vpeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' printf, lun, '____________________________________' printf, lun, '____________________________________' printf, lun, '__________Active regions ___________' if entry.nar lt 1 then begin printf, lun, 'No data about active regions' flush, lun free_lun, lun return endif for j=0,entry.nar-1 do begin printf, lun, '____________________________________' printf, lun, 'NOAA '+strtrim(entry.region(j).name,2) printf, lun, '_____________________' printf, lun, 'Area: ', entry.region(j).area printf, lun, 'Type: ', entry.region(j).type printf, lun, 'Carr. Long: ', entry.region(j).carrlng printf, lun, 'Location: ' printf, lun, ' Latitude: ', entry.region(j).location.lat printf, lun, ' Longitude: ', entry.region(j).location.lng printf, lun, ' X: ', entry.region(j).location.X printf, lun, ' Y: ', entry.region(j).location.Y printf, lun, 'Leader: ' printf, lun, ' Ipeak : ' printf, lun, ' I_Tb : ' , entry.region(j).leader.ipeak.itb printf, lun, ' V_Tb : ' , entry.region(j).leader.ipeak.vtb printf, lun, ' X : ' , entry.region(j).leader.ipeak.X printf, lun, ' Y : ' , entry.region(j).leader.ipeak.Y printf, lun, ' Vpeak : ' printf, lun, ' I_Tb : ' , entry.region(j).leader.vpeak.itb printf, lun, ' V_Tb : ' , entry.region(j).leader.vpeak.vtb printf, lun, ' X : ' , entry.region(j).leader.vpeak.X printf, lun, ' Y : ' , entry.region(j).leader.vpeak.Y printf, lun, ' Mag.field : ' , entry.region(j).leader.kgauss*0.1 printf, lun, 'Follower: ' printf, lun, ' Ipeak : ' printf, lun, ' I_Tb : ' , entry.region(j).follower.ipeak.itb printf, lun, ' V_Tb : ' , entry.region(j).follower.ipeak.vtb printf, lun, ' X : ' , entry.region(j).follower.ipeak.X printf, lun, ' Y : ' , entry.region(j).follower.ipeak.Y printf, lun, ' Vpeak : ' printf, lun, ' I_Tb : ' , entry.region(j).follower.vpeak.itb printf, lun, ' V_Tb : ' , entry.region(j).follower.vpeak.vtb printf, lun, ' X : ' , entry.region(j).follower.vpeak.X printf, lun, ' Y : ' , entry.region(j).follower.vpeak.Y printf, lun, ' Mag.field : ' , entry.region(j).follower.kgauss*0.1 endfor flush, lun free_lun, lun end pro AR_data_save, file, data_array, AR_name common ardb, db, image_I, image_V, instance, exhaustive, header_I, header_V N=n_elements(exhaustive(*,0)) openw, lun, file, /get printf, lun, 'Data for NOAA '+AR_name for j=0, N-1 do begin printf, lun, '____________________________________' printf, lun, 'Date: ', db(exhaustive(j,0)).date printf, lun, 'Time: ', db(exhaustive(j,0)).time printf, lun, 'Area: ', data_array(j).area printf, lun, 'Type: ', data_array(j).type printf, lun, 'Carr. Long: ', data_array(j).carrlng printf, lun, 'Location: ' printf, lun, ' Latitude: ', data_array(j).location.lat printf, lun, ' Longitude: ', data_array(j).location.lng printf, lun, ' X: ', data_array(j).location.X printf, lun, ' Y: ', data_array(j).location.Y printf, lun, 'Leader: ' printf, lun, ' Ipeak : ' printf, lun, ' I_Tb : ' , data_array(j).leader.ipeak.itb printf, lun, ' V_Tb : ' , data_array(j).leader.ipeak.vtb printf, lun, ' X : ' , data_array(j).leader.ipeak.X printf, lun, ' Y : ' , data_array(j).leader.ipeak.Y printf, lun, ' Vpeak : ' printf, lun, ' I_Tb : ' , data_array(j).leader.vpeak.itb printf, lun, ' V_Tb : ' , data_array(j).leader.vpeak.vtb printf, lun, ' X : ' , data_array(j).leader.vpeak.X printf, lun, ' Y : ' , data_array(j).leader.vpeak.Y printf, lun, ' Mag.field : ' , data_array(j).leader.kgauss*0.1 printf, lun, 'Follower: ' printf, lun, ' Ipeak : ' printf, lun, ' I_Tb : ' , data_array(j).follower.ipeak.itb printf, lun, ' V_Tb : ' , data_array(j).follower.ipeak.vtb printf, lun, ' X : ' , data_array(j).follower.ipeak.X printf, lun, ' Y : ' , data_array(j).follower.ipeak.Y printf, lun, ' Vpeak : ' printf, lun, ' I_Tb : ' , data_array(j).follower.vpeak.itb printf, lun, ' V_Tb : ' , data_array(j).follower.vpeak.vtb printf, lun, ' X : ' , data_array(j).follower.vpeak.X printf, lun, ' Y : ' , data_array(j).follower.vpeak.Y printf, lun, ' Mag.field : ' , data_array(j).follower.kgauss*0.1 endfor flush, lun free_lun, lun end function ardb_read_image,ID,path, error, header, polariz=polariz error=0 V=strtrim(keyword_set(polariz),2) CASE !version.OS OF 'windows': begin Delim='\' wildcard=V+'.fit' end 'Win32': begin Delim='\' wildcard=V+'.fit' end ELSE: begin Delim='/' if fix(V) then wildcard='*scp.fits' else wildcard='*acp.fits' end ENDCASE dir=strmid(ID.Date,0,2)+strmid(ID.Date,3,2) dir_hp='19'+strmid(ID.Date,0,2) file=findfile(ID.path+'f'+dir+Delim+'s'+dir+strmid(ID.Date,6,2)+wildcard) if file(0) eq '' then begin file=findfile(ID.path+dir_hp+Delim+'s'+dir+strmid(ID.Date,6,2)+wildcard) source='HOMEPAGE' endif else source='CDROM' if file(0) eq '' then begin error=1 widget_control, ID.Info_Label, set_val='Image file not found.' return, 0 endif ; CASE strmid(strlowcase(!version.OS),0,3) OF CASE !version.OS OF ;'win': begin ;if source eq 'CDROM' then file=ID.path+'f'+dir+Delim+file(0) else $ ; file=ID.path+dir_hp+Delim+file(0) ; end 'windows': begin if source eq 'CDROM' then file=ID.path+'f'+dir+Delim+file(0) else $ file=ID.path+dir_hp+Delim+file(0) end 'Win32': begin file=file(0) end ELSE: ENDCASE return,rfits(file(0), head=header) end pro plot_map_grid, ID, entry, I_image, I_header, V_image, V_header, $ noerase=noerase, error=error Version=strmid(!version.release,0,3) gt 3.5 error=1 if not keyword_set(noerase) then begin for jj=0,1 do begin wset,ID.Win(jj) erase endfor endif widget_control, ID.text(0), $ set_val=ID.Date widget_control, ID.Text(1), $ set_val=' '+strtrim(string(entry.PA, format='(f5.1)'),2) widget_control, ID.Text(2), $ set_val=' '+strtrim(string(entry.B0, format='(f4.1)'),2) widget_control, ID.Text(3), $ set_val=' '+strtrim(string(entry.Nar, format='(i2)'),2) widget_control, ID.Text(4), $ set_val=' '+strtrim(string(entry.map.ipeak.itb, format='(g9.3)'),2)+ ', '+ $ strtrim(string(entry.map.ipeak.vtb/(entry.map.ipeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' widget_control, ID.Text(5), $ set_val=' '+strtrim(string(entry.map.vpeak.vtb, format='(g10.3)'),2)+ ', '+ $ strtrim(string(entry.map.vpeak.vtb/(entry.map.vpeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' widget_control, ID.Text(6), $ set_val=' '+strtrim(string(entry.map.Kgauss*0.1, format='(f5.2)'),2) for jj=0,1 do begin wset,ID.Win(jj) if ID.Show_Map then begin image=ardb_read_image(ID, path, error, header, polar=jj) ID.No_Image=error if error then begin widget_control, ID.Info_Label, set_val='Image file not found.' erase endif else begin tvscl,image > 0 if jj then begin V_image=image V_header=header endif else begin I_image=image I_header=header endelse endelse endif plots, entry.map.ipeak.x, entry.map.ipeak.y, $ /dev, col=!d.n_colors-1, syms=1, psym=8 plots, entry.map.vpeak.x, entry.map.vpeak.y, $ /dev, col=!d.n_colors-1, syms=2, psym=1 !x.style=(!y.style=1) Radius=entry.rsun/entry.pixsz !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,entry.B0,0,0, $ ;/grid, glinestyle=1, $ /ortho, /noerase, pos=[0,0,1,1], /nobor;, latdel=10, londel=10 !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, LATDEL=10, LONDEL=10 !P.clip=P_clip_save !x.style=(!y.style=(!x.range=(!y.range=0))) scale,tmp,/mem if Version then widget_control, ID.Draw(jj), set_uval=tmp, /no_copy else $ widget_control, ID.Draw(jj), set_uval=tmp ;************************* widget_control,ID.buttonbase, get_uval=a if ID.Zoom_state ne 1 then bias=[0,0] else bias=[a.xy(0,0), a.xy(0,1)] if ID.Show_Num then for j=0,entry.nar-1 do begin xr=(entry.region(j).location.x-bias(0))*float(ID.Factor) yr=(entry.region(j).location.y-bias(1))*float(ID.Factor) dx=1 if (xr gt dx) and (yr gt dx) $ and (xr lt (!d.x_size-dx)) and (yr lt (!d.y_size-dx)) then $ xyouts,xr,yr,entry.region(j).name, align=0.5, /dev, font=0;,col=0 endfor ;****************************** empty endfor end pro ardb_event, ev common ardb, db, image_I, image_V, instance, exhaustive, header_I, header_V Version=strmid(!version.release,0,3) gt 3.5 uv='' CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE widget_control,ev.top, get_uval=ID Win=1-(ev.id eq ID.Draw(0)) if (ev.id eq ID.Draw(0)) or (ev.id eq ID.Draw(1)) then begin widget_control, ID.Draw(Win), get_uval=Ax wset,ID.Win(Win) scale,Ax,/rec widget_control,ID.buttonbase, get_uval=wbc_state if ID.Zoom_state ne 1 then begin tmp=wbc_state.a w_box_cursor,ev,xy,init=wbc_state.init,cur=tmp wbc_state.a=tmp wbc_state.init=0 wbc_state.xy=xy if Version then widget_control,ID.buttonbase, set_uval=wbc_state, /no_copy $ else widget_control,ID.buttonbase, set_uval=wbc_state ; !!!!!!!!!!!!!!!!! Questionable if (xy(1,0)-xy(0,0) ne 0) and (xy(1,1)-xy(0,1) ne 0) then $ widget_control, ID.Info_Label, set_val=' ' bias=[0,0] endif else bias=[wbc_state.xy(0,0), wbc_state.xy(0,1)] x=convert_coord(ev.x, ev.y, /dev, /to_data) > (-90) < 90 Xd=float(ev.x)/ID.Factor+bias(0) Yd=float(ev.y)/ID.Factor+bias(1) if ID.Input_path ne 1 then widget_control, ID.Coord, set_val= $ string(Xd, Yd, fix(x(0)), fix(x(1)), $ format='(i3,", ",i3,"; ", i3,", ", i3)') if (ID.Show_Map eq 0) or (ID.No_Image eq 1) then Tb=' ' else Tb= $ string(Image_I(Xd > 0 < 511, Yd > 0 < 511), format='(g10.3)')+ ', '+$ string(Image_V(Xd > 0 < 511, Yd > 0 < 511), format='(g10.3)') widget_control, ID.Tb_Label, set_val=Tb IF ev.press THEN BEGIN entry=db(ID.Number) R=fltarr(db(ID.Number).nar > 1) for j=0,entry.nar-1 do begin xr=float(entry.region(j).location.x) yr=float(entry.region(j).location.y) R(j)=sqrt((Xd-xr)^2+(Yd-yr)^2) endfor rmin=min(R, index) widget_control, ID.ar_data(0), set_val= $ strtrim(string(entry.region(index).Name),2) Lng=entry.region(index).location.Lng Lat=entry.region(index).location.Lat if Lng lt 0 then EW='E' else EW='W' if Lat lt 0 then SN='S' else SN='N' widget_control, ID.ar_data(1), set_val= $ strtrim(string(EW, abs(Lng), SN, abs(Lat), $ format="(a1, f6.1, '; ', a1, f5.1)") ,2) widget_control, ID.ar_data(2), set_val= $ strtrim(string(entry.region(index).Area),2) widget_control, ID.ar_data(3), set_val= $ strtrim(string(entry.region(index).Type),2) widget_control, ID.ar_data(4), set_val= 'I: '+ $ strtrim(string(entry.region(index).Leader.ipeak.x),2)+ $ ', '+strtrim(string(entry.region(index).Leader.ipeak.y),2)+ $ '; V: '+ $ strtrim(string(entry.region(index).Leader.vpeak.x),2)+ $ ', '+strtrim(string(entry.region(index).Leader.vpeak.y),2) widget_control, ID.ar_data(5), set_val= ' '+$ strtrim(string(entry.region(index).Leader.ipeak.itb, $ format='(g9.3)'),2)+ ', '+ $ strtrim(string(entry.region(index).Leader.ipeak.vtb/ $ (entry.region(index).Leader.ipeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' widget_control, ID.ar_data(6), set_val= ' '+$ strtrim(string(entry.region(index).Leader.vpeak.itb, $ format='(g9.3)'),2)+ ', '+ $ strtrim(string(entry.region(index).Leader.vpeak.vtb/ $ (entry.region(index).Leader.vpeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' widget_control, ID.ar_data(7), set_val= $ strtrim(string(entry.region(index).leader.Kgauss*0.1, format='(f5.2)'),2) widget_control, ID.ar_data(8), set_val= 'I: '+ $ strtrim(string(entry.region(index).Follower.ipeak.x),2)+ $ ', '+strtrim(string(entry.region(index).Follower.ipeak.y),2)+ $ '; V: '+ $ strtrim(string(entry.region(index).Follower.vpeak.x),2)+ $ ', '+strtrim(string(entry.region(index).Follower.vpeak.y),2) widget_control, ID.ar_data(9), set_val= ' '+$ strtrim(string(entry.region(index).Follower.ipeak.itb, $ format='(g9.3)'),2)+ ', '+ $ strtrim(string(entry.region(index).Follower.ipeak.vtb/ $ (entry.region(index).Follower.ipeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' widget_control, ID.ar_data(10), set_val= ' '+$ strtrim(string(entry.region(index).Follower.vpeak.itb, $ format='(g9.3)'),2)+ ', '+ $ strtrim(string(entry.region(index).Follower.vpeak.vtb/ $ (entry.region(index).Follower.vpeak.itb > 100)*100, $ format='(f6.1)'),2)+'%' widget_control, ID.ar_data(11), set_val= $ strtrim(string(entry.region(index).follower.Kgauss*0.1, format='(f5.2)'),2) widget_control, ID.ar_data(12), set_val= $ strtrim(string(entry.region(index).Carrlng),2) for j=0,1 do widget_control,ID.togglebase(j), map=1-j ENDIF goto,return1 endif if ev.id eq ID.Draw(2) then begin widget_control, ID.Draw(2), get_uval=Ax wset,ID.Win(2) scale,Ax,/rec x=convert_coord(ev.x, ev.y, /dev, /to_data) N=n_elements(exhaustive) if N eq 0 then goto,return1 monthnames= ['Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun', $ 'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec'] index=exhaustive(fix(x(0)+0.5 > 0 < (N/2-1))) date=strtrim(db(index,0).date,2) date=strmid(date,6,2)+' '+monthnames(fix(strmid(date,3,2))-1) if ID.Input_path ne 1 then widget_control, ID.Coord, set_val= $ date+'; '+strcompress(string(x(1), format='(g10.3)')) goto, return1 endif widget_control, ev.id, get_uval=uv, /hour CASE uv OF "DONE": begin widget_control, ev.top, /dest CASE 1 OF equiv(instance, [1,0]) and (ID.Instance ge 0): instance=[0,0] equiv(instance, [1,1]) and (ID.Instance ge 0): instance=[1,0] ELSE: ENDCASE end 'Viewer': begin file=pickfile(/read) if file eq '' then return a_issue_txt,file=file end 'Help': begin file=findfile('ardb.hlp') if file(0) eq '' then begin widget_control, ID.Info_Label, set_val='Help file not found.' return endif a_issue_txt,file=file(0) end 'Header': begin if n_elements (Header_I) le 0 then return a_issue_txt,text=header_I end "Date": begin widget_control, ev.id, get_val=tmp ID.Date=strtrim(tmp(0),2) widget_control, ev.id, set_val=ID.date n=(where(db.date eq ID.date))(0) error=n lt 0 ID.Number=n > 0 if error then err_mess=' This date is beyond the database' else err_mess='' widget_control, ID.Info_Label, set_val=err_mess if error then goto, return1 widget_control,ID.buttonbase, get_uval=wbc_state wbc_state.init=1 if Version then widget_control, ID.buttonbase, set_uval=wbc_state, /no_copy $ else widget_control,ID.buttonbase, set_uval=wbc_state widget_control, ID.Info_Label, set_val='' plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) end 'Day before': begin error=(ID.Number eq 0) if error then err_mess=' This date is beyond the database' else err_mess='' widget_control, ID.Info_Label, set_val=err_mess if error then return widget_control,ID.buttonbase, get_uval=wbc_state wbc_state.init=1 if Version then widget_control, ID.buttonbase, set_uval=wbc_state, /no_copy $ else widget_control,ID.buttonbase, set_uval=wbc_state n=(ID.Number=ID.Number-1 > 0) ID.Date=db(ID.Number).Date widget_control, ID.Info_Label, set_val='' plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) end 'Day after': begin error=ID.Number eq (n_elements(db)-1) if error then err_mess=' This date is beyond the database' else err_mess='' widget_control, ID.Info_Label, set_val=err_mess if error then return widget_control,ID.buttonbase, get_uval=wbc_state wbc_state.init=1 if Version then widget_control, ID.buttonbase, set_uval=wbc_state, /no_copy $ else widget_control,ID.buttonbase, set_uval=wbc_state ID.Number=ID.Number+1 < (n_elements(db)-1) ID.Date=db(ID.Number).Date widget_control, ID.Info_Label, set_val='' plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) end 'Xloadct': Xloadct 'Criterion': begin widget_control, ID.Criterion_List, sens=0 if ID.All_Criteria(ev.index) eq 'Tbr' then begin widget_control, ID.Tbr_type_button, sens=1 for j=0,2 do widget_control,ID.typebase(j),map=([1,0,0])(j) return endif if ID.All_Criteria(ev.index) eq 'Polarization' then begin widget_control, ID.Pol_type_button, sens=1 for j=0,2 do widget_control,ID.typebase(j),map=([0,1,0])(j) return endif if ID.All_Criteria(ev.index) eq 'Magnetic field' then begin widget_control, ID.MF_type_button, sens=1 for j=0,2 do widget_control,ID.typebase(j),map=([0,0,1])(j) ID.Bounds=ID.Bounds*10 goto, return1 endif Flag = ID.All_Criteria(ev.index) eq 'Name' widget_control, ID.Itb_button, sens=Flag widget_control, ID.Area_button, sens=Flag widget_control, ID.Pol_button, sens=Flag widget_control, ID.Lat_button, sens=Flag widget_control, ID.Kgauss_button, sens=Flag ID.Input=[0,0] ID.Bounds=ID.Bounds(sort(ID.Bounds)) subscript=db_filter(db, ID.All_Criteria(ev.index), ID.Bounds, error=error, $ inverse=ID.Inverse, exhaustive=exhaustive, absolute=ID.Abs_val, $ exclusiv=ID.Exclusively) N_s=n_elements(subscript) N_e=n_elements(ID.Entries) ID.Entries(*)=0 ID.Entries(0:(N_s-1)> 0 <(N_e-1))= subscript(0:(N_s-1)> 0 <(N_e-1)) if error then begin widget_control, ID.Info_Label, set_val= 'No entries.' widget_control, ID.List, set_val=[''] return endif else begin widget_control, ID.Info_Label, set_val= strtrim(N_s, 2)+' entries found.' widget_control, ID.List, set_val=strtrim(db(subscript).date,2) endelse end 'Bound0': begin widget_control, ev.id, get_val=tmp lower=tmp(0) bf=byte(lower) digit=where(bf le 57 and bf ge 48) if digit(0) lt 0 then begin lower=strmid(strcompress(strupcase(lower), /rem),0,1) ar_type=['A', 'B', 'G', 'D'] lower=(where(lower eq ar_type))(0) endif ID.Bounds(0)=strcompress(lower,/rem) widget_control, ID.Search_Data(1), /inp ID.Input(0)=1 widget_control, ID.Criterion_List, sens=equiv(ID.Input, [1,1]) end 'Bound1': begin widget_control, ev.id, get_val=tmp upper=tmp(0) bf=byte(upper) digit=where(bf le 57 and bf ge 48) if digit(0) lt 0 then begin upper=strmid(strcompress(strupcase(upper), /rem),0,1) ar_type=['A', 'B', 'G', 'D'] upper=(where(upper eq ar_type))(0) endif ID.Bounds(1)=strcompress(upper, /rem) widget_control, ID.Search_Data(0), /inp ID.Input(1)=1 widget_control, ID.Criterion_List, sens=equiv(ID.Input, [1,1]) end 'Inverse': ID.Inverse=ev.select 'Abs_val': ID.Abs_val=ev.select 'Exclusively': ID.Exclusively=ev.select 'Go to': begin ID.Number=ID.entries(ev.index > 0) widget_control, ID.Info_Label, set_val='' ID.Date=db(ID.Number).Date plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) end 'Calculator': Wcalc 'Plot_b': begin for j=0,2 do widget_control,ID.drawbase(j), map=([0,0,1])(j) wset,ID.Win(2) end 'Map_bI': begin for j=0,2 do widget_control,ID.drawbase(j), map=([1,0,0])(j) wset,ID.Win(0) end 'Map_bV': begin for j=0,2 do widget_control,ID.drawbase(j), map=([0,1,0])(j) wset,ID.Win(1) end 'Current date': for j=0,1 do widget_control,ID.togglebase(j), map=1-j 'Search': for j=0,1 do widget_control,ID.togglebase(j), map=j 'Show AR': for j=0,db(ID.Number).nar-1 do $ xyouts, db(ID.Number).region(j).location.x, $ db(ID.Number).region(j).location.y, $ db(ID.Number).region(j).name, /dev "Don't show AR": begin ID.Show_Num=0 val='Show AR always' widget_control, ID.Show_AR(1), set_val=val, set_uval=val widget_control, ID.Show_AR(0), sens=1 end 'Show AR always': begin ID.Show_Num=1 val="Don't show AR" widget_control, ID.Show_AR(1), set_val=val, set_uval=val widget_control, ID.Show_AR(0), sens=0 for j=0,db(ID.Number).nar-1 do begin xr=db(ID.Number).region(j).location.x yr=db(ID.Number).region(j).location.y xyouts,xr,yr,db(ID.Number).region(j).name,/dev endfor end 'Show Image': begin if ID.path eq '' then begin widget_control, ID.Info_Label,set_val='Please indicate a path (File - Image path)' return endif ID.Show_Map=1 plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) ID.Show_Map=0 ;endif end "Don't show image": begin ID.Show_Map=0 val='Show Image always' widget_control, ID.Show_Image(1), set_val=val, set_uval=val widget_control, ID.Show_Image(0), sens=1 end 'Show Image always': begin ID.Show_Map=1 if ID.path eq '' then begin widget_control, ID.Info_Label,set_val='Please indicate a path (File - Image path)' goto, return1 endif val="Don't show image" widget_control, ID.Show_Image(1), set_val=val, set_uval=val widget_control, ID.Show_Image(0), sens=0 plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) end 'Nest': ardb 'Polarization': begin N=n_elements(exhaustive) if N eq 0 then return profile_F=(profile_L=fltarr(N/2)) for j=0,N/2-1 do begin profile_L(j)= db(exhaustive(j,0)).region(exhaustive(j,1)).leader.ipeak.vtb/ $ (db(exhaustive(j,0)).region(exhaustive(j,1)).leader.ipeak.itb > 400) profile_F(j)= db(exhaustive(j,0)).region(exhaustive(j,1)).follower.ipeak.vtb/ $ (db(exhaustive(j,0)).region(exhaustive(j,1)).follower.ipeak.itb > 400) endfor amax=max(profile_L, min=amin_L) > max(profile_F, min=amin_F) amin=amin_L < amin_F wset,ID.Win(2) plot, profile_L, back=!d.n_colors-1, col=0, yran=[amin, amax], tit= $ strcompress('NOAA'+string(fix(ID.Bounds(0))))+$ ', degree of polarization', psym=-1, /noc oplot, profile_F, col=0, linest=1, psym=-5, /noc plots, !x.crange, [0,0], linest=3, col=0 scale,tmp,/mem empty if Version then widget_control, ID.Draw(2), set_uval=tmp, /no_copy $ else widget_control,ID.Draw(2), set_uval=tmp end 'I_Tb': begin N=n_elements(exhaustive) if N eq 0 then return profile_F=(profile_L=fltarr(N/2)) for j=0,N/2-1 do begin profile_L(j)=db(exhaustive(j,0)).region(exhaustive(j,1)).leader.ipeak.itb profile_F(j)=db(exhaustive(j,0)).region(exhaustive(j,1)).follower.ipeak.itb endfor amax=max(profile_L, min=amin_L) > max(profile_F, min=amin_F) amin=amin_L < amin_F wset,ID.Win(2) plot, profile_L, back=!d.n_colors-1, col=0, yran=[amin, amax] > 0, tit= $ strcompress('NOAA'+string(fix(ID.Bounds(0))))+$ ', brightness temperature', psym=-1, /noc oplot, profile_F, col=0, linest=1, psym=-5, /noc scale,tmp,/mem empty if Version then widget_control, ID.Draw(2), set_uval=tmp, /no_copy $ else widget_control,ID.Draw(2), set_uval=tmp end 'Kgauss_plot': begin N=n_elements(exhaustive) if N eq 0 then return profile_F=(profile_L=fltarr(N/2)) for j=0,N/2-1 do begin profile_L(j)=db(exhaustive(j,0)).region(exhaustive(j,1)).leader.kgauss*0.1 profile_F(j)=db(exhaustive(j,0)).region(exhaustive(j,1)).follower.kgauss*0.1 endfor amax=max(profile_L, min=amin_L) > max(profile_F, min=amin_F) amin=amin_L < amin_F wset,ID.Win(2) plot, profile_L, back=!d.n_colors-1, col=0, yran=[amin, amax], tit= $ strcompress('NOAA'+string(fix(ID.Bounds(0))))+$ ', magnetic field', psym=-1, /noc oplot, profile_F, col=0, linest=1, psym=-5, /noc scale,tmp,/mem empty if Version then widget_control, ID.Draw(2), set_uval=tmp, /no_copy $ else widget_control,ID.Draw(2), set_uval=tmp end 'Area': begin N=n_elements(exhaustive) if N eq 0 then return profile=fltarr(N/2) for j=0,N/2-1 do profile(j)=db(exhaustive(j,0)).region(exhaustive(j,1)).area wset,ID.Win(2) plot, profile, back=!d.n_colors-1, col=0, tit= $ strcompress('NOAA'+string(fix(ID.Bounds(0))))+ $ ', area', psym=-1, /noc scale,tmp,/mem empty if Version then widget_control, ID.Draw(2), set_uval=tmp, /no_copy $ else widget_control,ID.Draw(2), set_uval=tmp end 'Latitude_plot': begin N=n_elements(exhaustive) if N eq 0 then return profile=fltarr(N/2) for j=0,N/2-1 do $ profile(j)=db(exhaustive(j,0)).region(exhaustive(j,1)).location.lat wset,ID.Win(2) plot, profile, back=!d.n_colors-1, col=0, tit= $ strcompress('NOAA'+string(fix(ID.Bounds(0))))+ $ ', latitude', psym=-1, /yno, /noc scale,tmp,/mem empty if Version then widget_control, ID.Draw(2), set_uval=tmp, /no_copy $ else widget_control,ID.Draw(2), set_uval=tmp end 'Zoom': begin widget_control,ID.buttonbase, get_uval=a if (a.xy(1,0)-a.xy(0,0) eq 0) or (a.xy(1,1)-a.xy(0,1) eq 0) then begin widget_control, ID.Info_Label, set_val='Please mark an area' goto, return1 endif ID.Zoom_state=1 device, /cursor_cross widget_control, ID.Zoom, set_val='Unzoom', set_uval='Unzoom' ID.Factor=!d.x_size/(a.xy(1,0)-a.xy(0,0)) < !d.y_size/(a.xy(1,1)-a.xy(0,1)) FOR Win=0,1 DO BEGIN wset,ID.Win(Win) erase if ID.No_Image ne 1 then begin if Win then Image=Image_V else Image=Image_I tvscl,rebin(image(a.xy(0,0):a.xy(1,0),a.xy(0,1):a.xy(1,1)), $ (a.xy(1,0)-a.xy(0,0)+1)*ID.Factor, (a.xy(1,1)-a.xy(0,1)+1)*ID.Factor) endif !x.style=(!y.style=1) entry=db(ID.number) Center=[256-a.xy(0,0), 256-a.xy(0,1)]*ID.Factor Radius=entry.rsun/entry.pixsz*ID.factor !x.range=([0., !d.x_size]-Center(0))/Radius !y.range=([0., !d.y_size]-Center(1))/Radius map_set,entry.B0,0,0, $ ;/grid, glinestyle=1, $ /ortho, /noerase, pos=[0,0,1,1], /nobor;, latdel=10, londel=10 !x.s=[Center(0), Radius] / float(!d.x_size) !y.s=[Center(1), Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, LATDEL=10, LONDEL=10 !P.clip=P_clip_save !x.style=(!y.style=(!x.range=(!y.range=0))) bias=[a.xy(0,0), a.xy(0,1)] if ID.Show_Num then for j=0,entry.nar-1 do begin xr=(entry.region(j).location.x-bias(0))*float(ID.Factor) yr=(entry.region(j).location.y-bias(1))*float(ID.Factor) dx=1 if (xr gt dx) and (yr gt dx) $ and (xr lt (!d.x_size-dx)) and (yr lt (!d.y_size-dx)) then $ xyouts,xr,yr,entry.region(j).name, align=0.5, /dev endfor scale,tmp,/mem if Version then widget_control, ID.Draw(Win), set_uval=tmp, /no_copy $ else widget_control,ID.Draw(Win), set_uval=tmp a.init=1 widget_control,ID.buttonbase, set_uval=a ENDFOR empty end 'Unzoom': begin widget_control, ID.Zoom, set_val='Zoom', set_uval='Zoom' widget_control,ID.buttonbase, get_uval=wbc_state wbc_state.init=1 if Version then widget_control, ID.buttonbase, set_uval=wbc_state, /no_copy $ else widget_control,ID.buttonbase, set_uval=wbc_state ID.Zoom_state=0 ID.Factor=1 plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif end 'Gif': begin if !d.window eq ID.Win(0) then $ F_name=strmid(ID.Date,0,2)+strmid(ID.Date,3,2)+strmid(ID.Date,6,2) $ else F_name=strtrim(db(exhaustive(0,0)).region(exhaustive(0,1)).name,2) file=pickfile(/write, filt='*.gif', file=F_name+'.gif') if file eq '' then return widget_control,/hour write_gif,file,tvrd() end 'Window': begin win=!d.window if win eq ID.Win(0) then $ F_name=strmid(ID.Date,0,2)+strmid(ID.Date,3,2)+strmid(ID.Date,6,2) $ else F_name='NOAA'+strtrim(db(exhaustive(0,0)).region(exhaustive(0,1)).name,2) window,/free,xs=512,ys=512,tit=F_name device, copy=[0,0,512,512,0,0,win] end 'Image path': begin path=pickfile(tit='Please select a file to indicate path', path=ID.Path) if path eq '' then return widget_control, ID.Info_Label,set_val=subdirec(subdirec(path)),/input widget_control, ID.Coord,set_val='Please confirm' ID.Input_Path=1 end 'Input Image path': begin if ID.Input_Path ne 1 then return widget_control, ID.Info_Label,get_val=path image_path=strcompress(path(0),/rem) widget_control, ID.Info_Label,set_val='Path: '+image_path, input=0 widget_control, ID.Coord,set_val=' ' ID.Path=image_path+Delim ID.Input_Path=0 Ini_File=(findfile('ardb.ini'))(0) IF Ini_File ne '' THEN BEGIN openr,lun, Ini_File, /get_lun temp='' j=-1 while not EOF(lun) do begin j=j+1 readf,lun, temp if j eq 0 then s=temp else s=[s, temp] endwhile free_lun, lun ind=(where(strlowcase(strmid(s,0,10)) eq 'image_path'))(0) > 0 ENDIF ELSE BEGIN s=strarr(1) ind=0 ENDELSE s(ind)='IMAGE_PATH '+image_path openw, lun, 'ardb.ini', /get for j=0, n_elements(s)-1 do printf,lun,s(j) free_lun,lun end 'Cur_date_save': begin Dat_name=strmid(ID.Date,0,2)+strmid(ID.Date,3,2)+strmid(ID.Date,6,2) file=pickfile(tit='Enter a filename to record text data', $ file=Dat_name+'.dte', filt='*.dte') if file eq '' then return entry=db(ID.Number) Cur_date_save, entry, file end 'AR_save': begin if n_elements(exhaustive) lt 2 then begin widget_control, ID.Info_Label, set_val='You should previously specify AR!' return endif N=n_elements(exhaustive(*,0)) data_array=replicate(db(0).region(0), N) for j=0,N-1 do data_array(j)=db(exhaustive(j,0)).region(exhaustive(j,1)) AR_name=strtrim(data_array(0).name,2) file=pickfile(tit='Enter a filename to record text data', $ file=AR_name+'.ar', filt='*.ar') if file eq '' then return AR_data_save, file, data_array, AR_name end ELSE: ENDCASE stm=strmid(uv, 0, 2) if stm eq 'L_' or stm eq 'F_' or stm eq 'M_' then begin type=strmid(uv, 2,2) ID.Input=[0,0] ID.Bounds=ID.Bounds(sort(ID.Bounds)) CASE 1 OF strlen(uv) eq 4: crit='brig' strmid(uv,2,1) eq 'K': crit='magn' ELSE: crit='polarization' ENDCASE widget_control, ID.Tbr_type_button, sens=0 widget_control, ID.Pol_type_button, sens=0 widget_control, ID.MF_type_button, sens=0 subscript=db_filter(db, crit, ID.Bounds, type=type, error=error, $ inverse=ID.Inverse, exhaustive=exhaustive, absolute=ID.Abs_val, $ leader=stm eq 'L_', follower=stm eq 'F_', map=stm eq 'M_') N_s=n_elements(subscript) N_e=n_elements(ID.Entries) ID.Entries(*)=0 ID.Entries(0:(N_s-1)> 0 <(N_e-1))= subscript(0:(N_s-1)> 0 <(N_e-1)) if error then begin widget_control, ID.Info_Label, set_val= 'No entries.' widget_control, ID.List, set_val=[''] goto, return1 endif else begin widget_control, ID.Info_Label, set_val= strtrim(N_s, 2)+' entries found.' widget_control, ID.List, set_val=strtrim(db(subscript).date,2) endelse endif return1: if uv ne "DONE" then if Version then $ widget_control,ev.top, set_uval=ID, /no_copy else $ widget_control,ev.top, set_uval=ID empty end pro ardb common ardb, db, image_I, image_V, instance, exhaustive, header_I, header_V Version=strmid(!version.release,0,3) gt 3.5 Image_I=(Image_V=fltarr(512,512)) all_files=['ardb.hlp', 'w_box_cursor.pro', 'db_filter.pro', 'rfits.pro', $ 'mkkey_struct.pro', 'dg_make_struct.pro'] N_files=n_elements(all_files) error=strarr(N_files) for j=0, N_files-1 do error(j)=findfile(all_files(j)) err_ind=where(error eq '') if err_ind(0) ge 0 then begin print print,'Error - missing files:' print for j=0, n_elements(err_ind)-1 do print,all_files(err_ind(j)) print print,'Please place these files into the current directory.' print return endif s=dg_make_struct() if n_elements(db) lt 10 then begin db_file=(findfile('db.sav*'))(0) if db_file eq '' then begin print,'Error: missing database file "db.save". Bye!' return endif restore,db_file endif if n_elements(instance) le 0 then begin instance=[0,0] ;Image_I=(Image_V=fltarr(512,512,2)) endif CASE 1 OF equiv(instance, [0,0]): begin instance=[1,0] Flag=0 ; Image_I=(Image_V=fltarr(512,512,2)) end equiv(instance, [1,0]): begin instance=[1,1] Flag=1 ; Image_I(*,*,1)=(Image_V(*,*,1)=fltarr(512,512)) end equiv(instance, [1,1]): begin Flag=-1 end ELSE: ENDCASE ID={Draw:lonarr(3), Win:lonarr(3), Coord:0L, Text:lonarr(10), Drawbase:lonarr(3), $ tog_button:0L, togglebase:[0L,0L], textbase:[0L,0L], $ text_button:lonarr(4), ar_data:lonarr(13), Info_Label:0L, $ Show_AR:lonarr(3), Show_Image:lonarr(3), $ Search_label:[0L,0L], Search_data:[0L,0L], $ List:0L, Criterion_List:0L, Tb_Label:0L, $ Tbr_type_button:0L, Pol_type_button:0L, MF_type_button:0L, $ buttonbase:0L, Zoom:0L, typebase: [0L, 0L, 0L], $ Itb_button:0L, Area_button:0L, $ Pol_button:0L, Lat_button:0L, Kgauss_button:0L, $ Date:'92/07/01', Number:0L, Show_Num:0, Show_Map:0, $ Criterion:'', Bounds:[0d0,0d0], Inverse:0, Abs_val:0, Exclusively:0, $ Entries:lonarr(n_elements(db)), Input:[0,0], Path:'', $ Instance:Flag, Factor:1, Zoom_state:0, No_Image:1, $ Input_path:0, $ All_Criteria: $ ['Name', 'Area', 'Type', 'Latitude', 'CarrLng','Longitude', $ 'Polarization', 'Tbr', 'Magnetic field']} Ini_File=(findfile('ardb.ini'))(0) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE IF Ini_File ne '' THEN BEGIN openr,lun, Ini_File, /get_lun temp='' j=-1 while not EOF(lun) do begin j=j+1 readf,lun, temp if j eq 0 then s=temp else s=[s, temp] endwhile free_lun, lun ind=(where(strlowcase(strmid(s,0,10)) eq 'image_path'))(0) > 0 ID.path=strcompress(strmid(s(ind), 11, strlen(s(ind))-10),/rem)+Delim ENDIF Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} init_structure={w_b_state, $ x:0, y:0, press:0, first:1, Xc:[0.,0.], Yc:[0.,0.], $ Output:intarr(2,2), stretch:0., move:0.} wbc_state={init:1, xy:intarr(2,2), a:init_structure} left_button=[[000B, 000B],$ [000B, 001B],$ [128B, 000B],$ [064B, 000B],$ [032B, 000B],$ [016B, 000B],$ [008B, 000B],$ [004B, 000B],$ [008B, 000B],$ [016B, 000B],$ [032B, 000B],$ [064B, 000B],$ [128B, 000B],$ [000B, 001B],$ [000B, 000B],$ [000B, 000B] ] right_button=[[000B, 000B],$ [128B, 000B],$ [000B, 001B],$ [000B, 002B],$ [000B, 004B],$ [000B, 008B],$ [000B, 016B],$ [000B, 032B],$ [000B, 016B],$ [000B, 008B],$ [000B, 004B],$ [000B, 002B],$ [000B, 001B],$ [128B, 000B],$ [000B, 000B],$ [000B, 000B]] N=16 a=findgen(N)*(!Pi*2/(N-1)) usersym,cos(a),sin(a) emptys=string(replicate('20'xb,10)) emptys1_7=string(replicate('20'xb,17)) emptys2=string(replicate('20'xb,20)) emptys3=string(replicate('20'xb,30)) emptys4=string(replicate('20'xb,40)) device,get_scr=screen mainbase=widget_base(tit='Database of active regions', /colu, uval=ID) ID.buttonbase=widget_base(mainbase, /row, uval=wbc_state) butval=['DONE', 'File', 'Help'] junk=widget_button(ID.buttonbase, val='File', /menu) button=widget_button(junk, val='DONE', uval='DONE') button=widget_button(junk, val='Header', uval='Header') button=widget_button(junk, val='Image path', uval='Image path') junk1=widget_button(junk, val='Save', /menu) junk2=widget_button(junk1, val='Data', /menu) button=widget_button(junk2, val='Current date', uval='Cur_date_save') button=widget_button(junk2, val='Active region', uval='AR_save') junk2=widget_button(junk1, val='Image', /menu) button=widget_button(junk2, val='Gif', uval='Gif') button=widget_button(junk2, val='PS', uval='PS') button=widget_button(junk2, val='Window', uval='Window') button=widget_button(junk, val='Viewer', uval='Viewer') button=widget_button(ID.buttonbase, val='?', uval='Help') ID.Coord=widget_label(ID.buttonbase, val=emptys4, /fra) button0=widget_button(ID.buttonbase, val='Tools', /menu) button=widget_button(button0, val='Colors', uval='Xloadct') button=widget_button(button0, val='Calculator', uval='Calculator') ID.Show_AR(0)=widget_button(button0, val='Show AR', uval='Show AR') ID.Show_AR(1)=widget_button(button0, val='Show AR always', uval='Show AR always') ID.Show_Image(0)=widget_button(button0, val='Show Image', uval='Show Image') ID.Show_Image(1)=widget_button(button0, val='Show Image always', uval='Show Image always') ID.Zoom=widget_button(button0, val='Zoom', uval='Zoom') button=widget_button(button0, val='Nest', uval='Nest') ID.tog_button=widget_button(ID.buttonbase, val='Window', /menu) button=widget_button(ID.tog_button, val='Map I', uval='Map_bI') button=widget_button(ID.tog_button, val='Map V', uval='Map_bV') button=widget_button(ID.tog_button, val='Plot', uval='Plot_b') db_base=widget_base(mainbase, /row) Left_base=widget_base(db_base, /colu) Base_for_label=widget_base(Left_base,/row) plainbase0=widget_base(Left_base) right_base=widget_base(db_base,/colu) right_base1=widget_base(right_base,/colu) plainbase1=widget_base(right_base) for j=0,1 do begin if (screen(1) lt 700) then $ ID.togglebase(j)=widget_base(plainbase1, /colu, /scroll, $ y_scroll=screen(1)*0.7, x_scroll=screen(0)*0.28) else $ ID.togglebase(j)=widget_base(plainbase1, /colu) ID.textbase(j)=widget_base(ID.togglebase(j), /colu,/fra) widget_control,ID.togglebase(j), map=1-j endfor button=widget_button(ID.buttonbase, val='Panel', /menu) butval([0,1,2])=['Current date', 'Search', '3'] for j=0, 1 do $ ID.text_button(j)=widget_button(button, val=butval(j), uval=butval(j)) ID.Info_Label=widget_text(ID.buttonbase, val=emptys3,xs=50, /fra, /edit, $ uv='Input Image path') names=['Date', 'Pos. Ang.', 'B0', 'NAR', 'I_Tb_Peak', 'V_Tb_Peak', 'KGauss'] name_label=lonarr(n_elements(names)) for j=0,n_elements(names)-1 do begin junk=widget_base(([right_base1, ID.textbase(0)])(([0,1,1,1,1,1,1])(j)), /row, $ fra=([1,0,0,0,0,0,0])(j) ) if j eq 0 then left_but=widget_button(junk, val=left_button, uval='Day before') name_label(j)=widget_label(junk, val=emptys2) if j ne 0 then ID.text(j)=widget_text(junk, /edit, val=emptys2, uval=names(j)) $ else ID.text(j)=widget_text(junk, /edit, val=emptys, uval=names(j),xs=12) if j eq 0 then right_but=widget_button(junk, val=right_button, uval='Day after') endfor if screen(1) le 600 then Base_for_label=right_base1 Label_Base=widget_base(Base_for_label, /row) label=widget_label(Label_Base, val='I_Tb, V_Tb: ') ID.Tb_Label=widget_label(Label_Base, val=emptys2+emptys2, /fra) for j=0,2 do begin ID.drawbase(j)=widget_base(plainbase0, /colu) if j eq 2 then Drawbase1=widget_base(ID.Drawbase(j),/row) ID.draw(j)=widget_draw(ID.drawbase(j), xs=512, ys=512, /motion, /button, $ uval=Ax) widget_control,ID.drawbase(j), map=([1,0,0])(j) endfor ID.Itb_button=widget_button(Drawbase1, val='I_Tb', uval='I_Tb') ID.Area_button=widget_button(Drawbase1, val='Area', uval='Area') ID.Pol_button=widget_button(Drawbase1, val='Polarization', uval='Polarization') ID.Lat_button=widget_button(Drawbase1, val='Latitude', uval='Latitude_plot') ID.Kgauss_button=widget_button(Drawbase1, val='Kgauss', uval='Kgauss_plot') dummy_base=widget_base(ID.textbase(0), /row ,/fra) AR_names=['Name', 'Location', 'Area', 'Type', 'Leader:', $ ' I_Tb', ' V_Tb', 'KGauss', $ 'Follower:', $ ' I_Tb', ' V_Tb', 'KGauss', $ 'CarrLong'] AR_label=lonarr(n_elements(AR_names)) for j=0,n_elements(AR_names)-1 do begin junk=widget_base(ID.textbase(0), /row, fra=0) AR_label(j)=widget_label(junk, val=emptys1_7) ID.ar_data(j)=widget_text(junk, val=emptys, uval='',xs=24) endfor for j=0,1 do begin junk=widget_base(ID.textbase(1), /row, /fra) ID.Search_label(j)=widget_label(junk, val=(['Lower', 'Upper'])(j)+': ') ID.Search_data(j)=widget_text(junk, val=emptys, uval='Bound'+strtrim(j,2), /edit) endfor junk=widget_base(ID.textbase(1), /row) junk1=widget_base(junk, /colu) Crit_lab=widget_label(junk1, val=' Criterion: ') junk2=widget_base(junk1, /colu, /nonexcl) Inv_button=widget_button(junk2, val='Inverse', uval='Inverse') Abs_button=widget_button(junk2, val='Abs. value', uval='Abs_val') Exc_button=widget_button(junk2, val='Exclusively', uval='Exclusively') ID.Criterion_List=widget_list(junk, val=ID.All_Criteria, uval='Criterion', ys=1, /fra) widget_control, ID.Criterion_List, sens=0 Plainbuttonbase=widget_base(junk1) for j=0,2 do ID.typebase(j)=widget_base(Plainbuttonbase,/row) ID.Tbr_type_button=widget_button(ID.typebase(0), val='Type', /menu) button=widget_button(ID.Tbr_type_button, val='Leader', /menu) button1=widget_button(button, val='Ipeak', /menu) button2=widget_button(button1, val='I_Tb',uval='L_II') button2=widget_button(button1, val='V_Tb',uval='L_IV') button1=widget_button(button, val='Vpeak', /menu) button2=widget_button(button1, val='I_Tb',uval='L_VI') button2=widget_button(button1, val='V_Tb',uval='L_VV') button=widget_button(ID.Tbr_type_button, val='Follower', /menu) button1=widget_button(button, val='Ipeak', /menu) button2=widget_button(button1, val='I_Tb',uval='F_II') button2=widget_button(button1, val='V_Tb',uval='F_IV') button1=widget_button(button, val='Vpeak', /menu) button2=widget_button(button1, val='I_Tb',uval='F_VI') button2=widget_button(button1, val='V_Tb',uval='F_VV') button=widget_button(ID.Tbr_type_button, val='Map', /menu) button1=widget_button(button, val='Ipeak', /menu) button2=widget_button(button1, val='I_Tb',uval='M_II') button2=widget_button(button1, val='V_Tb',uval='M_IV') button1=widget_button(button, val='Vpeak', /menu) button2=widget_button(button1, val='I_Tb',uval='M_VI') button2=widget_button(button1, val='V_Tb',uval='M_VV') ID.Pol_type_button=widget_button(ID.typebase(1), val='Type', /menu) button=widget_button(ID.Pol_type_button, val='Leader', /menu) button1=widget_button(button, val='Ipeak',uval='L_I') button1=widget_button(button, val='Vpeak',uval='L_I') button=widget_button(ID.Pol_type_button, val='Follower', /menu) button1=widget_button(button, val='Ipeak',uval='F_I') button1=widget_button(button, val='Vpeak',uval='F_I') button=widget_button(ID.Pol_type_button, val='Map', /menu) button1=widget_button(button, val='Ipeak',uval='M_I') button1=widget_button(button, val='Vpeak',uval='M_I') ID.MF_type_button=widget_button(ID.typebase(2), val='Type', /menu) button=widget_button(ID.MF_type_button, val='Leader', uval='L_K') button=widget_button(ID.MF_type_button, val='Follower', uval='F_K') button=widget_button(ID.MF_type_button, val='Map', uval='M_K') widget_control, ID.Tbr_type_button, sens=0 widget_control, ID.Pol_type_button, sens=0 widget_control, ID.MF_type_button, sens=0 for j=0,2 do widget_control,ID.typebase(j),map=([1,0,0])(j) ID.List=widget_list(ID.textbase(1), val=replicate(' ',10), uval='Go to',/fra, ys=10) widget_control, mainbase, /real, /hour for j=0,n_elements(names)-1 do widget_control, name_label(j),set_val=names(j) for j=0,n_elements(AR_names)-1 do widget_control, AR_label(j),set_val=AR_names(j) widget_control, ID.Itb_button, sens=0 widget_control, ID.Area_button, sens=0 widget_control, ID.Pol_button, sens=0 widget_control, ID.Lat_button, sens=0 widget_control, ID.Kgauss_button, sens=0 for j=0,2 do begin widget_control, ID.draw(j), get_val=win ID.Win(j)=win endfor for j=0,1 do begin wset,ID.Win(j) plot_map_grid, ID, db(ID.number), I_Image, I_header, V_Image, V_header, error=error if error ne 1 then begin Image_I=I_Image Header_I=I_Header Image_V=V_Image Header_V=V_Header endif endfor ;if (ID.Instance ge 0) and ID.Show_Map then Image_I(*,*,ID.Instance)=temporary(Image) wset,ID.Win(2) plot,findgen(10),/nod,xst=4,yst=4,back=!d.n_colors-1 scale,tmp,/mem empty if Version then widget_control, ID.Draw(2), set_uval=tmp, /no_copy $ else widget_control, ID.Draw(2), set_uval=tmp widget_control, ID.text(0), set_val=ID.Date if Version then widget_control,mainbase, set_uval=ID, /no_copy else $ widget_control,mainbase, set_uval=ID xmanager, 'ardb', mainbase end ####################################################### pro a_v_file_read ; This routine performs reading from a specially-formed ; formatted data file with a header common array_view,ID,Data,Scales,info,P_save if Data.type eq 'Rud_Formatted' then filter='*.*' else $ filter='*.bmp *.gif *.fit *.fts *.tif' if ID.Filename ne '' then Filename= $ pickfile(/read, filt=filter,file=ID.Filename,path=subdir(ID.Filename)) $ else Filename=pickfile(/read, filt=filter) if Filename eq '' then begin Data.type='Nothing' return endif widget_control,/hour if Data.type eq 'Rud_Formatted' then begin array=rud_read(Filename,x,y,info,header) Data.type='Rud_Formatted' endif else begin Data.type=filetype(Filename) CASE Data.type OF 'FITS': begin index=-1 array=rfitsg(Filename,index=fnum,key_struct=hstruc,header=header,error=err, $ user_struct=ustruc,date_obs=date,time_obs=time,/sc) end 'GIF': begin read_gif,Filename,array,r,g,b if n_elements(r) gt 1 then tvlct,r,g,b header='' end 'BMP': begin array=bmp_read(Filename,r,g,b) if n_elements(r) gt 1 then tvlct,r,g,b header='' end 'TIFF': begin array = TIFF_READ(Filename,r,g,b) if n_elements(r) gt 1 then tvlct,r,g,b header='' end ELSE: begin xwarning,['Unrecognized file type.','Returning...'] Data.type='Nothing' return end ENDCASE endelse if (size(array))(0) le 1 then begin print,'Bye!' Data.type='Nothing' return endif ID={Filename:Filename,Draw:ID.Draw,Win:ID.Win,Mode:'Image', $ Coord_Label:ID.Coord_Label, Header_Label:ID.Header_Label, $ group_leader:ID.group_leader} Sz=size(array) if n_elements(x) le 0 then x=findgen(Sz(1)) if n_elements(y) le 0 then y=findgen(Sz(2)) Data={array:array, x:x, y:y, Header:Header, levels:Data.levels, $ follow:Data.follow, Preset:Data.Preset, type:Data.type, $ X_window:Data.X_window, Y_window:Data.Y_window, $ Position:Data.Position, Sel_arr:Data.Sel_arr} end pro a_v_image,interpol=interpol common array_view,ID,Data,Scales,info,P_save if (size(Data.array))(0) le 1 then return if n_elements(interpol) le 0 then interpol=0 ID.Mode='Image' widget_control,ID.Coord_Label(0),set_val=' ' if !d.name eq 'WIN' then wset,ID.win(0) contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,/nodata,XTICKL=-0.02,ytickl=-0.02, $ /xst,/yst,xtit=info.xtitle,ytit=info.ytitle,pos=Data.Position x_data=Data.Position([0,2])*!d.x_size y_data=Data.Position([1,3])*!d.y_size if Data.type ne 'GIF' and Data.type ne 'BMP' then $ tvscl,congridg(Data.array(*,*,Data.Sel_arr),(x_data(1)-x_data(0)),(y_data(1)-y_data(0)), $ int=interpol),x_data(0),y_data(0) else $ tv,congridg(Data.array(*,*,Data.Sel_arr),(x_data(1)-x_data(0)),(y_data(1)-y_data(0)), $ int=interpol),x_data(0),y_data(0) a_v_info_string Scale,temp,/mem & Scales.W0=temp end pro a_v_im_contour,interpol=interpol common array_view,ID,Data,Scales,info,P_save if (size(Data.array))(0) le 1 then return if n_elements(interpol) le 0 then interpol=0 ID.Mode='Image_cont' widget_control,ID.Coord_Label(0),set_val=' ' if !d.name eq 'WIN' then wset,ID.win(0) !P.position=Data.Position if not Data.Preset then $ im_contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ interp=interpol,xtit=info.xtitle,ytit=info.ytitle,nlev=15, $ fol=Data.follow $ else im_contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ interp=interpol,xtit=info.xtitle,ytit=info.ytitle, $ lev=Data.levels,fol=Data.follow a_v_info_string Scale,temp,/mem & Scales.W0=temp !P.position=0 end pro a_v_info_string common array_view,ID,Data,Scales,info,P_save IF ID.Filename eq '' or Data.type ne 'Rud_Formatted' THEN return a=strsplit(Data.Header) N=n_elements(a) ;xyouts,0.5,0.96,/nor, strcompress($ ; 'N!uo!n = '+string(a(0),format='(i4)')+', '+ $ ; 'N!dKar!n = '+string(a(1),format='(i4)')+', '+ $ ;Date_string(string(a(4),a(3),format='(2(i2.2," "))')+strmid(a(2),2,2))+', '+$ ; a(5)+'UT,!C'+'!4k!3!dKar!n = '+a(6)+', '+ $ ; 'N = '+string(info.Number,format='(i4)')+', '+ $ ; info.parameter_name+' = '+ string(info.parameter, $ ; format='(f6.1)')), $ ; align=0.5 xyouts,0.5,0.96,/nor, strcompress($ Data.Header +'!C'+ $ 'N = '+string(info.Number,format='(i4)')+', '+ $ info.parameter_name+' = '+ string(info.parameter, $ format='(f6.1)')), $ align=0.5 end pro array_view_event,ev common array_view,ID,Data,Scales,info,P_save common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr N_x=n_elements(Data.x) N_y=n_elements(Data.y) Sz=size(Data.Array) if ev.id eq ID.Draw(1) then begin if (size(Data.array))(0) le 1 then return window_set,ID.Win(1),scale=Scales.W1 coord=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) widget_control,ID.Coord_Label(1),set_val=string(coord(0),coord(1), $ format='(g11.3,"; ",g11.3)') return endif if ev.id eq ID.Draw(2) then begin if (size(Data.array))(0) le 1 then return window_set,ID.Win(2),scale=Scales.W2 coord=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) widget_control,ID.Coord_Label(2),set_val=string(coord(0),coord(1), $ format='(g11.3,"; ",g11.3)') return endif if ev.id eq ID.Draw(0) then begin if (size(Data.array))(0) le 1 then return Mode_2D=(ID.Mode eq 'Image_cont') or $ (ID.Mode eq 'Contour') or $ (ID.Mode eq 'Image') if Mode_2D then begin window_set,ID.Win(0),scale=Scales.W0 coord=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) x=(coord(0)-(Data.x)(0))/((Data.x)(N_x-1)-(Data.x)(0))*N_x > 0 < (Sz(1)-1) y=(coord(1)-(Data.y)(0))/((Data.y)(N_y-1)-(Data.y)(0))*N_y > 0 < (Sz(2)-1) widget_control,ID.Coord_Label(0),set_val=string(coord(0),coord(1), $ Data.array(x,y,Data.Sel_arr),format= $ '(g11.3,"; ",g11.3,"; value = ",g11.3)') if ev.press then begin wset,ID.Win(1) plot,Data.x,Data.array(*,y,Data.Sel_arr),/yno,/xst,xtickl=-0.02,ytickl=-0.02, $ xtit=info.xtitle,ytit=info.ztitle,tit=info.ytitle+' ='+ $ strcompress(string(coord(1),format='(g11.3)')) Scale,temp,/mem & Scales.W1=temp wset,ID.Win(2) plot,Data.array(x,*,Data.Sel_arr),Data.y,/yno,xticks=4,/yst,xtickl=-0.02,ytickl=-0.02, $ xtit=info.ztitle,ytit=info.ytitle,tit=info.xtitle+' ='+ $ strcompress(string(coord(0),format='(g11.3)')) Scale,temp,/mem & Scales.W2=temp empty endif endif return endif WIDGET_CONTROL,ev.id,GET_UVALUE = uv,/hour CASE uv OF 'DONE': begin WIDGET_CONTROL,ev.top,/destroy,/hour if ID.group_leader ne 0L then if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show !P=P_save loadct,0 ID=(Data=(Scales=(info=0))) end 'Header': xtext,text=Data.Header 'MSU': rem_lf,/over,filt='*.*',path=subdir(ID.Filename) 'UMS': add_lf,/over,filt='*.*',path=subdir(ID.Filename) "Select_array": begin SzArr=size(Data.array) if SzArr(0) lt 3 then return Data.Sel_arr=xselect(sindgen(SzArr(3))) > 0 end 'Window': begin wset,ID.Win(0) tmp=tvrd() device,get_scr=scr window,/free,xsi=scr(1)*0.8,ysi=scr(1)*0.8 tv,tmp empty end 'Rest_pal': begin !P.color=0 !P.background=!d.n_colors-1 loadct,0 for j=1,2 do begin wset,ID.Win(j) erase endfor empty end 'Invert_pal': begin r_curr=255b-r_curr g_curr=255b-g_curr b_curr=255b-b_curr color=!P.color background=!P.background !P.color=background !P.background=color tvlct, r_curr,g_curr,b_curr end 'Cont_pal': begin if (size(Data.array))(0) le 1 then return amax=max(Data.array(*,*,Data.Sel_arr),min=amin) CASE 1 OF (amax gt 0) and (amin lt 0): begin nc=!d.table_size p = (lindgen(nc) * 255) / (nc-1) n=256.*abs(amin)/(abs(amin)+amax) x=bytscl([findgen(n)*255./n,255b-findgen(255-n)*255/(255-n)]) x=x(p) r_curr=x g_curr=x b_curr=x tvlct, r_curr,g_curr,b_curr !p.background=n*(!d.n_colors-1)/256 !P.color=!d.n_colors-1 for j=1,2 do begin wset,ID.Win(j) erase endfor end ELSE: begin print, 'This array does not cross zero' return end ENDCASE end 'Sym_pal': begin if (size(Data.array))(0) le 1 then return amax=max(Data.array(*,*,Data.Sel_arr),min=amin) CASE 1 OF (amax gt 0) and (amin lt 0): begin nc=!d.table_size p = (lindgen(nc) * 255) / (nc-1) n=256.*abs(amin)/(abs(amin)+amax) if n lt 256/2 then m=n else m=255b-n x=findgen(255-m)*255/(255-m) nx=n_elements(x) y=bytscl([x(nx-m-1:*),255b-x]) y=y(p) if n gt 255/2 then y=reverse(y,1) r_curr=y g_curr=y b_curr=y tvlct, r_curr,g_curr,b_curr !p.background=n*(!d.n_colors-1)/256 !P.color=!d.n_colors-1 for j=1,2 do begin wset,ID.Win(j) erase endfor end ELSE: begin print, 'This array does not cross zero' return end ENDCASE end 'Open_Standard': begin Data.type = 'Standard' end 'Open_Rud_Formatted': begin Data.type = 'Rud_Formatted' end 'Archiver': spawn,'rar' 'Levels': begin if (size(Data.array))(0) le 1 then return if Data.Preset then begin levels=Data.Levels follow=Data.follow endif cont_setting,Data.array(*,*,Data.Sel_arr),follow=follow,levels=levels,group=ev.top Data={array:Data.array,x:Data.x,y:Data.y,Header:Data.Header, $ levels:levels,follow:follow, Preset:1, type:Data.type, $ X_window:Data.X_window, Y_window:Data.Y_window, $ Position:Data.Position, Sel_arr:Data.Sel_arr} c_linestyle=intarr(n_elements(levels)) c_thick=c_linestyle+1 if (where(levels lt 0))(0) ge 0 then c_linestyle(where(levels lt 0))=1 if (where(levels eq 0))(0) ge 0 then c_thick(where(levels eq 0))=2 wset,ID.Win(0) contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ /xst,/yst,xtit=info.xtitle,ytit=info.ytitle, $ lev=Data.levels,fol=Data.follow,c_linest=c_linestyle, $ c_thick=c_thick, pos=Data.Position Scale,temp,/mem & Scales.W0=temp a_v_info_string end 'GIF': begin if !version.OS eq 'windows' or !version.OS eq 'Win32' $ then Delim='\' else Delim='/' for j=0,2 do begin if strlen(ID.Filename) eq 0 then filename=pickfile(/write,filt='*.gif') else begin filename=strmid((name_extract(ID.Filename))(1),2,4)+(['a','b','c'])(j) path=subdir(ID.Filename) filename=path+Delim+newfilename(model=filename,filt='*.gif',path=path) endelse widget_control,/hour wset,ID.Win(j) write_gif,filename,tvrd() endfor end 'BMP': begin if !version.OS eq 'windows' or !version.OS eq 'Win32' $ then Delim='\' else Delim='/' for j=0,2 do begin if strlen(ID.Filename) eq 0 then filename=pickfile(/write,filt='*.bmp') else begin filename=strmid((name_extract(ID.Filename))(1),2,4)+(['a','b','c'])(j) path=subdir(ID.Filename) filename=path+Delim+newfilename(model=filename,filt='*.bmp',path=path) endelse widget_control,/hour wset,ID.Win(j) write_bmp,filename,tvrd() endfor end 'Calculator': wcalc 'OS': spawn 'VC': spawn,'vc' 'NC': spawn,'nc' 'I_Sample': a_v_image,int=0 'I_Interpolate': a_v_image,int=1 'IC_Sample': a_v_im_contour,int=0 'IC_Interpolate': a_v_im_contour,int=1 'Contour_pre': begin if (size(Data.array))(0) le 1 then return ID.Mode='Contour' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' if not Data.Preset then $ contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ nlev=15,/xst,/yst,xtit=info.xtitle,ytit=info.ytitle, $ pos=Data.Position else begin levels=Data.levels c_linestyle=intarr(n_elements(levels)) c_thick=c_linestyle+1 if (where(levels lt 0))(0) ge 0 then c_linestyle(where(levels lt 0))=1 if (where(levels eq 0))(0) ge 0 then c_thick(where(levels eq 0))=2 contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ /xst,/yst,xtit=info.xtitle,ytit=info.ytitle, $ lev=Data.levels,fol=Data.follow,c_linest=c_linestyle, $ c_thick=c_thick, pos=Data.Position endelse a_v_info_string Scale,temp,/mem & Scales.W0=temp end 'Contour_def': begin if (size(Data.array))(0) le 1 then return ID.Mode='Contour' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ nlev=15,/xst,/yst,xtit=info.xtitle,ytit=info.ytitle, $ pos=Data.Position a_v_info_string Scale,temp,/mem & Scales.W0=temp end 'Surface': begin if (size(Data.array))(0) le 1 then return ID.Mode='Surface' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' Surface,Data.array(*,*,Data.Sel_arr),Data.x,Data.y, $ XTICKL=-0.02,ytickl=-0.02, $ /xst,/yst,xtit=info.xtitle,ytit=info.ytitle,ztit=info.ztitle a_v_info_string Scale,temp,/mem & Scales.W0=temp end 'Surface_ho': begin if (size(Data.array))(0) le 1 then return ID.Mode='Surface' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' Surface,Data.array(*,*,Data.Sel_arr),Data.x,Data.y, $ XTICKL=-0.02,ytickl=-0.02,ztickl=-0.02,/xst,/yst,/ho, $ xtit=info.xtitle,ytit=info.ytitle,ztit=info.ztitle a_v_info_string Scale,temp,/mem & Scales.W0=temp end 'Shaded surface': begin if (size(Data.array))(0) le 1 then return wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' ID.Mode='Shade_Surf' Shade_Surf,Data.array(*,*,Data.Sel_arr),Data.x,Data.y, $ XTICKL=-0.02,ytickl=-0.02,ztickl=-0.02,/xst,/yst, $ xtit=info.xtitle,ytit=info.ytitle,ztit=info.ztitle Scale,temp,/mem & Scales.W0=temp a_v_info_string end 'XSurface': begin if (size(Data.array))(0) le 1 then return ID.Mode='XSurface' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' XSurface,Data.array(*,*,Data.Sel_arr) Scale,temp,/mem & Scales.W0=temp end 'Edges': begin if (size(Data.array))(0) le 1 then return ID.Mode='Contour' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' TMP=sobel(Data.array(*,*,Data.Sel_arr)) contour,abs(Data.array(*,*,Data.Sel_arr)) gt 0.1,Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ /xst,/yst,xtit=info.xtitle,ytit=info.ytitle,lev=0.5, $ pos=Data.Position a_v_info_string Scale,temp,/mem & Scales.W0=temp end 'Edges1': begin if (size(Data.array))(0) le 1 then return ID.Mode='Contour' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' minmax=max(Data.array(*,*,Data.Sel_arr),min=amin) minmax=fix([amin,minmax]) values=indgen(minmax(1)-minmax(0)+1)+minmax(0) for j=0,n_elements(values)-1 do begin ind=where((Data.array(*,*,Data.Sel_arr)) eq values(j)) tmp=make_array(size=size(Data.array(*,*,Data.Sel_arr)),value=1) if ind(0) ge 0 then tmp(ind)=0 contour,tmp gt 0.1,Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ /xst,/yst,xtit=info.xtitle,ytit=info.ytitle,lev=0.5, $ pos=Data.Position,noerase=j ne 0 endfor a_v_info_string Scale,temp,/mem & Scales.W0=temp end 'Xloadct': begin r_orig=r_curr g_orig=g_curr b_orig=b_curr xloadct,group=ev.top end 'Input': begin widget_control,ID.Text,get_val=ratio ratio=float(ratio(0)) if ratio le 1 then Data.position= $ [Data.X_window(0), $ Data.Y_window(0), $ Data.X_window(1), $ Data.Y_window(0)+(Data.Y_window(1)-Data.Y_window(0))*ratio] $ else Data.position= $ [Data.X_window(0), $ Data.Y_window(0), $ Data.X_window(0)+(Data.X_window(1)-Data.X_window(0))/ratio, $ Data.Y_window(1)] end 'Rest_Window': begin widget_control,ID.Text,set_val=string(1.,format='(f3.1)') Data.position= [Data.X_window(0), Data.Y_window(0), $ Data.X_window(1), Data.Y_window(1)] end 'Window': begin widget_control,/hour xwarning,['Please type Y/X ratio within the frame right from menu', $ 'and press ENTER'] end ELSE: ENDCASE if uv eq 'Open_Standard' or uv eq 'Open_Rud_Formatted' then begin a_v_file_read Data.Sel_arr=0 if Data.type eq 'Nothing' then return if (size(Data.array))(0) le 1 then return widget_control,ID.Header_Label, $ set_val='File: '+(name_extract(ID.Filename))(0) if Data.type eq 'Rud_Formatted' then begin ID.Mode='Contour' wset,ID.win(0) widget_control,ID.Coord_Label(0),set_val=' ' contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ nlev=15,/xst,/yst,xtit=info.xtitle,ytit=info.ytitle, $ pos=Data.Position endif else begin ID.Mode='Image' a_v_image,int=0 endelse a_v_info_string Scale,temp,/mem & Scales.W0=temp endif empty end pro array_view,array,x,y,group_leader=group_leader,no_file=no_file, $ image=image,contour=contour, message=message ;+ ; NAME: ; ARRAY_VIEW ; ; PURPOSE: ; Interactive viewing of a 2-dimensional array in brightness, ; contours, surface representations. ; ; CALLING SEQUENCE: ; ARRAY_VIEW, ARRAY ; ; INPUT: ; ARRAY: The name of the variable containing 2-d array ; ; OUTPUT: None. ; ; SIDE EFFECT: None. ; ; RESTRICTIONS: None. ; ; REVISION HISTORY: ; Written by V.Grechnev, ISTP. 1995. ;- common array_view,ID,Data,Scales,info,P_save common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr if xregistered('array_view') then return nc=!d.table_size p = (lindgen(nc) * 255) / (nc-1) r_curr=(g_curr=(b_curr=p)) r_orig=(g_orig=(b_orig=r_curr)) tvlct,r_curr,g_curr,b_curr P_save=!P Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} Scales={W0:Ax, W1:Ax, W2:Ax} Ax=0 if n_elements(group_leader) le 0 then group_leader=0L !p.color=0 !p.background=!d.n_colors-1 !P.position=0 ID={Filename:'',Draw:lonarr(4),Win:Lonarr(4),Mode:'Image', $ Coord_Label:Lonarr(3), Header_Label:0L,group_leader:group_leader, $ Text:0L} if n_elements(array) eq 0 then begin array=(x=(y=0)) endif else begin Sz=size(array) if n_elements(x) eq 0 then x=findgen(Sz(1)) if n_elements(y) eq 0 then y=findgen(Sz(2)) endelse Data= {array:array,x:x,y:y,Header:'',levels:0,follow:0, Preset:0, $ X_window:!x.window, Y_window:!y.window, Position:!P.position, $ type:'', Sel_arr:0} MainBase=widget_base(/colu,tit='2D Array Viewer', group=group_leader) UpperBase=widget_base(Mainbase,/row) RowBase=widget_base(Mainbase,/row) LeftBase=widget_base(RowBase,/colu) RightBase=widget_base(RowBase,/colu) ;if not keyword_set(no_file) then Open_string=' ;"Open" Open' $ ; else Open_string='' XPdMenu,['"DONE" DONE', $ '"File" {', $ '"Open" {', $ '"Standard" Open_Standard', $ '"Rud_Formatted" Open_Rud_Formatted', $ '}', $ '"Header" Header',$ '"Select array" Select_array', $ '"Convert" {', $ '"MS Windows ---> Unix" MSU',$ '"Unix ---> MS Windows" UMS',$ '}', $ '"Archiver" Archiver',$ '"Save" {', $ '"PS" PS', $ '"GIF" GIF', $ '"BMP" BMP', $ '"Window" Window', $ '}', $ '}', $ '"Mode" {', $ '"Image" {', $ '"Sample" I_Sample',$ '"Interpolate" I_Interpolate',$ '}', $ '"Contour" {', $ '"Default" Contour_def', $ '"Predefined" Contour_pre', $ '}', $ '"Surface" {', $ '"Wire Mesh" Surface', $ '"Horizontal" Surface_ho', $ '}', $ '"XSurface" XSurface', $ '"Image+Contour" {', $ '"Sample" IC_Sample',$ '"Interpolate" IC_Interpolate',$ '}', $ '"Edges" Edges', $ '"Edges1" Edges1', $ '"Zero line" Zero', $ '"Shaded surface" Shaded surface','}', $ '"Tools" {', $ '"Palette" {', $ '"Dual symmetric" Sym_pal',$ '"Dual contrast" Cont_pal',$ '"Initial" Rest_pal',$ '"Invert" Invert_pal',$ '"Adjust" Xloadct',$ '}', $ '"Contour levels" Levels',$ '"Window size" {', $ '"Resize" Window',$ '"Restore" Rest_Window',$ '}', $ '"Calculator" Calculator', $ '"Shell" {', $ '"OS" OS', $ '"NC" NC', $ '"VC" VC', $ '}', $ '}', $ '"Help" Help'], UpperBase label=widget_label(UpperBase,val='Y/X ratio:') ID.Text=widget_text(UpperBase,/fra,/edit,xs=10, uval='Input',val='1.0') device,get_scr=scr if n_elements(message) le 0 then Label_val=' ' else $ Label_val=message if strmid(!version.release,0,1) lt 5 then $ ID.Header_Label=widget_label(LeftBase,val=Label_val) else $ ID.Header_Label=widget_label(LeftBase,val=Label_val, /dynam) ID.Draw(0)=widget_draw(LeftBase,xsi=scr(1)*0.8,ysi=scr(1)*0.8,/fra, $ /motion,/button) for j=1,2 do begin ID.Draw(j)=widget_draw(RightBase,xsi=scr(0)-scr(1)*0.8-50,ysi=scr(1)*0.4,/fra, $ /motion,/button) if strmid(!version.release,0,1) lt 5 then $ ID.Coord_Label(j)=widget_label(RightBase,val=' ') else $ ID.Coord_Label(j)=widget_label(RightBase,val=' ', /dynam) endfor if strmid(!version.release,0,1) lt 5 then $ ID.Coord_Label(0)=widget_label(LeftBase,val=' ') else $ ID.Coord_Label(0)=widget_label(LeftBase,val=' ', /dynam) widget_control,MainBase,/realize,/hour if n_elements(Header) gt 0 then widget_control,ID.Header_Label, $ ; set_val='Header: '+Header set_val='File: '+(name_extract(ID.Filename))(0) for j=0,2 do begin WIDGET_CONTROL,ID.Draw(j),GET_VALUE=temp ID.Win(j)=temp wset,temp erase endfor !x.margin=[10,3] !y.margin=[4,3] !z.margin=[4,2] wset,ID.Win(1) plot,indgen(10),xst=5,yst=5,/nodata Scale,temp,/mem & Scales.W1=temp wset,ID.win(2) plot,indgen(10),xst=5,yst=5,/nodata Scale,temp,/mem & Scales.W2=temp wset,ID.win(0) Data.Position=[!x.window(0), !x.window(0), !x.window(1), !x.window(1)] Data.X_window=!X.window Data.Y_window=!X.window style=4-(n_params() gt 0)*4 contour,fltarr(10,10),indgen(10),indgen(10),/nodata, $ XTICKL=-0.02,ytickl=-0.02,xst=1+style,yst=1+style, $ pos=Data.Position info={XTITLE:'X', YTITLE:'Y', ZTITLE:'Z', PARAMETER_NAME:' ', $ PARAMETER:0, NUMBER: 0} if n_params() le 0 then xyouts,0.5,0.5,/nor,'Please load a file',align=0.5,font=0 $ else begin CASE 1 OF keyword_set(image): begin ID.Mode='Image' a_v_image,int=0 end ELSE: begin ID.Mode='Contour' contour,Data.array(*,*,Data.Sel_arr),Data.x,Data.y,XTICKL=-0.02,ytickl=-0.02, $ xst=1+style,yst=1+style,nlev=15, pos=Data.Position end ENDCASE endelse Scale,temp,/mem & Scales.W0=temp xmanager,'array_view',MainBase,group=group_leader end ####################################################### function arsh, X ;+ The ARSH function returns the value whose hyperbolic sine is X ;- (i.e., the area-sine). return, alog(X+sqrt(X^2+1)) end ####################################################### function arth, X ;+ The ARTH function returns the value whose hyperbolic tangent is X ;- (i.e., the area-tangent). return, 0.5*alog((1+X)/(1-X)) end ####################################################### function ar_to_st, x, form N=n_elements(x) if n_elements(form) gt 0 then sx=string(x, format=form) else $ sx=string(x) Sx=strcompress(Sx) tt=Sx(0)+', ' for j=1, N-2 do tt=tt+Sx(j)+', ' tt=tt+Sx(N-1) return,tt end ####################################################### function AXIS_DIV,Range,Nticks,Minor,Time=Time,Dt=Dt ; Returns suitable value of division for a coordinate axis. if n_elements(Time) le 0 then Time=0 if n_elements(Nticks) le 0 then Nticks=5 if n_elements(Dt) le 0 then Dt=1. if n_elements(Range) le 0 then begin print,'You must define range' return,0 endif Interval=ABS(Range(1)-Range(0))*Dt A=alog(Interval)/alog(10.) IA=fix(A)-1 IA=IA-(A Lt 0) Order=10.^float(IA) Tick=1. L1: IF((Tick*float(Nticks)) GE Interval/Order) then GOTO, L10 IF Tick lt 1.5 THEN BEGIN Tick=1.5 & Minor=3 & GOTO, L1 ENDIF ELSE IF Tick lt 2 THEN BEGIN Tick=2. & Minor=4 & GOTO, L1 ENDIF ELSE IF Tick lt 2.5 THEN BEGIN Tick=2.5 & Minor=5 & GOTO, L1 ENDIF ELSE IF Tick lt 3 THEN BEGIN Tick=3. & Minor=3 & GOTO, L1 ENDIF ELSE IF Tick LT 5 THEN BEGIN Tick=5. & Minor=5 ENDIF ELSE BEGIN Tick=1. & Order=Order*10. ENDELSE GOTO, L1 L10: Tick=Tick*Order IF Time THEN BEGIN IF Tick GE 25 then Minor=6 CASE Tick OF 25: Tick=30. 50: Tick=60. 100: Tick=120. 150: Tick=180. 200: Tick=300. 250: Tick=300. 500: Tick=600. 1000: Tick=1200. 1500: Tick=1800. 2000: Tick=3600. 2500: Tick=3600. 5000: Tick=7200. ELSE: ENDCASE ENDIF IF Time AND (Tick GE 240) then Minor=5 Tick=Tick/Dt Nticks=fix((range(1)-range(0))/Tick) > 1 RETURN,Tick END ####################################################### function bend, x, width, derivative=derivative ; Returns bending curve for a given (modulated) curve. ; The result is likely to the detection process on radio signals. N=n_elements(x) if n_elements(width) le 0 then width=N/10 k=1-1./width if keyword_set(derivative) then y=smooth(abs(deriv(x)), width) else begin y=fltarr(N) for j=1L,N-1 do y(j)=y(j-1)*k*(x(j) lt y(j-1))+x(j)*(x(j) ge y(j-1)) endelse y_mean=mean(y) FFT_y=fft(temporary(y-y_mean),-1) FFT_y(float(N)/width:N-float(N)/width-1)=0 y=float(fft(temporary(FFT_y),1))+y_mean > 0 y=total(abs(x))/total(y)*y*sqrt(2.) return,y end ####################################################### function bin_time, tme_dat ;+ ; calculates time in 10usec since 00 ut on 1st of jan. 1991 ; from SMS time vector t, where t = [t0,t1,t2,t3] is the time ; vector in fdas format. Each element is a short integer. ; ; usage: 10_usec = bin_time(t) ;- tme = long(tme_dat) and '0000ffff'x ; get rid of sign tusec = tme(0) * 281474976710656.d00 $ ; times 2**48 + tme(1) * 4294967296.d00 $ ; times 2**32 + tme(2) * 65536.d00 $ ; times 2**16 + tme(3) return, tusec end ####################################################### function bit_to_byte,x N=n_elements(x) if N eq 0 then begin message,'You should define argument.' return,0b endif mask=2b^(7b-bindgen(8)) i=lindgen(N) y=bytarr(N*8) for j=0,7 do y(i*8+j)=(x and mask(j)) ne 0 i=0 y=ishft(temporary(y),7) return, y end ####################################################### PRO BLINK1, wndw, t ;+ ; NAME: ; BLINK ; PURPOSE: ; To allow the user to alternatively examine two or more windows within ; a single window. ; ; CALLING SEQUENCE: ; BLINK, Wndw [, T] ; ; INPUTS: ; Wndw A vector containing the indices of the windows to blink. ; T The time to wait, in seconds, between blinks. This is optional ; and set to 1 if not present. ; ; OUTPUTS: ; None. ; ; PROCEDURE: ; The images contained in the windows given are written to a pixmap. ; The contents of the the windows are copied to a display window, in ; order, until a key is struck. ; ; EXAMPLE: ; Blink windows 0 and 2 with a wait time of 3 seconds ; ; IDL> blink, [0,2], 3 ; ; MODIFICATION HISTORY: ; Written by Michael R. Greason, STX, 2 May 1990. ; Allow different size windows Wayne Landsman August, 1991 ;- ; Check the parameters. ; On_error,2 ;Return to caller n = n_params(0) cflg = 0 IF (n LT 2) THEN BEGIN IF (n LT 1) THEN cflg = 1 t = 1.0 ENDIF IF (cflg NE 1) THEN BEGIN s = size(wndw) cflg = 2 IF (s(0) GT 0) THEN BEGIN IF (s(1) GT 1) THEN cflg = 0 n_wndw = s(1) ENDIF ENDIF ; ; Check to see if a window is open. If so, save the ; index for later use. ; IF (cflg EQ 0) THEN BEGIN whld = !d.window IF (whld LT 0) THEN cflg = 3 ENDIF ; ; If not enough or incorrect parameters were given, ; complain and return. ; IF (cflg NE 0) THEN BEGIN IF (cflg EQ 1) THEN BEGIN print, " Insufficient parameters given to BLINK." print, " Syntax: BLINK, WIN_INDICES [, TIME]" ENDIF IF (cflg EQ 2) THEN print, " The array of window indices is invalid." IF (cflg EQ 3) THEN print, " No windows are open." ENDIF ELSE BEGIN ; ; ; Get the size of each window in the array. ; device, window = opnd ncol = intarr(n_wndw) nrow = ncol for i=0,n_wndw-1 do begin if not opnd(wndw(i)) then $ message,'ERROR - Window '+ strtrim(wndw(i),2) + ' is not open' wset, wndw(i) ncol(i) = !d.x_vsize nrow(i) = !d.y_vsize endfor ; ; Write a message explaining how to terminate BLINK. ; print, " " print, "To exit BLINK, strike any key." print, " " ; ; Create the display window and display the images. ; window, /free, retain=2, xsize = max(ncol), ysize=max(nrow), $ xpos=0, ypos=0, $ title="Blink window - Press any key to exit" whd = !d.window i = 0L a = get_kbrd(0) EQ '' ; WHILE (get_kbrd(0) EQ '') DO BEGIN WHILE (get_kbrd(0) NE ' ') DO BEGIN device, copy=[0, 0, ncol(i), nrow(i), 0, 0, wndw(i)] i = (i + 1) mod n_wndw wait, t ENDWHILE ; ; Clear up and terminate. Close windows/pixmaps and ; restore the originally active window. ; wdelete, whd wset, whld ENDELSE ; RETURN END ####################################################### FUNCTION BMP_READ, File, Red, Green, Blue, Ihdr ; Copyright (c) 1993, Research Systems, Inc. All rights reserved. ; Unauthorized reproduction prohibited. ;+ ; NAME: ; BMP_READ ; ; PURPOSE: ; This function reads a Microsoft Windows Version 3 device ; independent bitmap file (.BMP). ; ; CATEGORY: ; Input/Output ; ; CALLING SEQUENCE: ; Result = BMP_READ(File [, R, G, B [, IHDR]]) ; ; INPUTS: ; File: The full path name of the bitmap file to read. ; ; OUTPUTS: ; This function returns a byte array containing the image ; from the bitmap file. In the case of 4-bit or 8-bit images, ; the dimensions of the resulting array are (biWidth, biHeight); ; for 24-bit images the dimensions are (3, biWidth, biHeight). ; Dimensions are taken from the BITMAPINFOHEADER of the file. ; NOTE: for 24 bit images, color interleaving is blue, green, red; ; i.e. result(0,i,j) = blue, result(1,i,j) = green, etc. ; ; OPTIONAL OUTPUTS: ; R, G, B: Color tables from the file. There 16 elements each for ; 4 bit images, 256 elements each for 8 bit images. Not ; defined or used for 24 bit images. ; Ihdr: A structure containing BITMAPINFOHEADER from file. ; Tag names are as defined in the MS Windows Programmer's ; Reference Manual, Chapter 7. ; ; SIDE EFFECTS: ; IO is performed. ; ; RESTRICTIONS: ; DOES NOT HANDLE: Compressed images. ; Is not fast for 4 bit images. Works best on images where the ; number of bytes in each scan-line is evenly divisible by 4. ; ; PROCEDURE: ; Straightforward. Will work on both big endian and little endian ; machines. ; ; EXAMPLE: ; TV, BMP_READ('c:\windows\party.bmp', r, g, b) ;Read & display image ; TVLCT, r, g, b ;Load it's colors ; ; MODIFICATION HISTORY: ; DMS, RSI. March 1993. Original version. ; DMS, RSI. May, 1993. Now works on all machines... ; V.Grechnev, ISTP. February, 1996. Handling of monochrome images added. ;- on_ioerror, bad on_error, 2 ;Return on error if (!d.flags and 2L^16) ne 0 then widget_control,/hourglass openr, unit, file, /GET_LUN fhdr = { BITMAPFILEHEADER, $ bftype: bytarr(2), $ ;A two char string bfsize: 0L, $ bfreserved1: 0, $ bfreserved2: 0, $ bfoffbits: 0L $ } readu, unit, fhdr ;Read the bitmapfileheader if string(fhdr.bftype) ne "BM" then $ message, 'File '+file+' is not in bitmap file format' ihdr = { BITMAPINFOHEADER, $ bisize: 0L, $ biwidth: 0L, $ biheight: 0L, $ biplanes: 0, $ bibitcount: 0, $ bicompression: 0L, $ bisizeimage: 0L, $ bixpelspermeter: 0L, $ biypelspermeter: 0L, $ biclrused: 0L, $ biclrimportant: 0L $ } readu, unit, ihdr if (byte(1,0,2))(0) eq 0b then begin ;Big endian machine? fhdr = swap_endian(fhdr) ;Yes, swap it ihdr = swap_endian(ihdr) endif if ihdr.bibitcount eq 1 then begin point_lun,unit,fhdr.bfoffbits status=fstat(unit) N_rows=(status.size-fhdr.bfoffbits)/ihdr.biheight array=bytarr(N_rows,ihdr.biheight) readu,unit,array free_lun, unit i=lindgen(N_rows*ihdr.biheight) y=bytarr(N_rows*ihdr.biheight*8) mask1=2b^(7b-bindgen(8)) for j=0,7 do y(i*8+j)=(array and mask1(j)) ne 0 i=0 array=0 y=reform(y,N_rows*8,ihdr.biheight)*255b return, y(0:ihdr.biwidth-1,*) endif if ihdr.bicompression ne 0 then $ message, 'Can''t handle compressed images' if ihdr.bibitcount ne 24 then begin ;Pseudo color? colors = bytarr(4, 2^ihdr.bibitcount) readu, unit, colors ;Read colors red = reform(colors(2, *)) ;Decommutate colors green = reform(colors(1, *)) blue = reform(colors(0, *)) endif nx = ihdr.biwidth ny = ihdr.biheight point_lun, unit, fhdr.bfoffbits ;Point to data... if ihdr.bibitcount eq 4 then begin ;4 bits/pixel? a = bytarr(nx, ny, /nozero) buff = bytarr(nx/2, /nozero) ;Line buffer even = lindgen(nx/2) * 2 odd = even + 1 if nx and 1 then pad = 0B ;interbyte padding i = (n_elements(buff) + n_elements(pad)) and 3 ;bytes we have if i ne 0 then pad = bytarr(4-i+n_elements(pad)) for i=0, ny-1 do begin if n_elements(pad) ne 0 then readu, unit, buff, pad $ else readu, unit, buff a(even, i) = ishft(buff, -4) a(odd, i) = buff and 15b if nx and 1 then a(nx-1, i) = ishft(pad(0), -4) ;Last odd byte? endfor endif else if ihdr.bibitcount eq 8 then begin ;8 bits/pixel? a = bytarr(nx, ny, /nozero) if (nx and 3) eq 0 then readu, unit, a $ ;Slam dunk it else begin ;Must read line by line... pad = bytarr(4 - (nx and 3)) buff = bytarr(nx, /nozero) for i=0, ny-1 do begin ;Each line readu, unit, buff, pad a(0,i) = buff endfor endelse endif else begin ;24 bits / pixel.... a = bytarr(3, nx, ny, /nozero) if ((3 * nx) and 3) eq 0 then readu, unit, a $ ;Again, dunk it. else begin pad = bytarr(4 - ((3 * nx) and 3)) buff = bytarr(3, nx, /nozero) for i=0, ny-1 do begin readu, unit, buff, pad a(0,0, i) = buff ;Insert line endfor endelse endelse free_lun, unit return, a bad: if n_elements(unit) gt 0 then free_lun, unit Message, 'Can''t open (or read)' + file return, 0 end ####################################################### ; bso_bst close,/al CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Name_in=pickfile(/read,filt='*.bso',path=getenv('spk_dat')) Name_out=subdir(name_in)+delim+(name_extract(name_in))(1)+'.bst' openr,Lun_in,Name_in,/get_lun BlockAOR0=SSRT_file_struc(LUN_in,Fileformat=Fileformat, $ Offset=Offset, Dt=Dt, Date=Date, Length=Length) x=assoc(Lun_in,BlockAOR0,Offset) N_blocks=length/32 ScansetAOR1={ScansetAOR1, AttrEW:0B, LEW:bytarr(192), $ REW:bytarr(192), AttrSN:0B, LSN:bytarr(192), RSN:bytarr(192)} Sum_chan=[180,192] Offset1=(4L+2*2L*Sum_chan(1)) Pattern=make_array(192,2,/int,val=128) Fyear=fix('19'+strmid(date,6,2)) Fdate=[byte(fix(strmid(date,0,2))),byte(fix(strmid(date,3,2)))] openw,Lun_Out,Name_out,/get_lun writeu,LUN_Out,Fyear,Fdate,Pattern BlockAOR1={time:0L, Set32:replicate(ScansetAOR1,32)} y=assoc(Lun_Out,BlockAOR1,Offset1) FOR j=0,N_blocks-1 DO BEGIN print,'Block No ',strtrim(j+1,2),' of ',strtrim(N_blocks,2),' processed' tmp0=x(j) tmp1=BlockAOR1 tmp1.time=tmp0.time FOR k=0,31 DO BEGIN tmp1.set32(k)={ScansetAOR1,AttrEW:(tmp0.set32.attr)(k), $ LEW:((tmp0.set32.i)(*,k)-(tmp0.set32.v)(*,k))/2b, $ REW:((tmp0.set32.i)(*,k)+(tmp0.set32.v)(*,k))/2b, $ AttrSN:0B, $ LSN:bytarr(192), $ RSN:bytarr(192)} ENDFOR y(j)=tmp1 ENDFOR free_lun,Lun_Out free_lun,Lun_In end ####################################################### function calcsurf, z, kx degree=1 s = size(z) nx = s(1) ny = s(2) m = nx * ny ;# of points to fit n2=(degree+1)^2 ;# of coefficients to solve x = findgen(nx) # replicate(1., ny) ;X values at each point y = replicate(1.,nx) # findgen(ny) return, kx(0,0)+x*kx(0,1)+y*kx(1,0)+x*y*kx(1,1) end ####################################################### function CALDATG, Julian, form=form, separator=separator ;+ ; NAME: ; CALDATG ; ; PURPOSE: ; Return the month, day and year corresponding to a given julian date. ; This is the inverse of the function JULDAY. ; CATEGORY: ; Misc. ; ; CALLING SEQUENCE: ; CALDAT, Julian, Month, Day, Year ; ; INPUTS: ; JULIAN contains the Julian Day Number (which begins at noon) of the ; specified calendar date. It should be a long integer. ; OUTPUTS: ; MONTH: Number of the desired month (1 = January, ..., 12 = December). ; ; DAY: Number of day of the month. ; ; YEAR: Number of the desired year. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; ; MODIFICATION HISTORY: ; Translated from "Numerical Recipies in C", by William H. Press, ; Brian P. Flannery, Saul A. Teukolsky, and William T. Vetterling. ; Cambridge University Press, 1988 (second printing). ; ; ; DMS, July, 1992. ; ; ISTP, Corrected by V.Grechnev to process arrays. Now it is called as a function ; returning DATE - string-type array. ;- ; ON_ERROR, 2 ; Return to caller if errors IGREG = 2299161L ;Beginning of Gregorian calendar julian = long(julian) ;Better be long jalpha = long(((julian - 1867216) - 0.25d0) / 36524.25) ja = julian + ( 1 + jalpha - long(0.25d0 * jalpha) )*( julian ge igreg ) jalpha=0 jb = temporary(ja) + 1524 jc = long(6680.0 + ((jb-2439870)-122.1)/365.25) jd = long(365 * jc + (0.25 * jc)) je = long((jb - jd) / 30.6001) day = fix(temporary(jb) - temporary(jd) - long(30.6001 * je)) month = fix(temporary(je) -1) month=month - 12*(month gt 12) year = fix(temporary(jc) - 4715) year=year-(month gt 2) year=year-(year le 0) if n_elements(form) le 0 then form='yyyymmdd' if n_elements(separator) le 0 then separator='/' space=(byte(' '))(0) year=byte(strmid(string(year), 4, 4)) index=where(year eq space) if index(0) ge 0 then year(index)=(byte('0'))(0) index=0 year=string(year) month=byte(strmid(string(month), 6, 2)) index=where(month eq space) if index(0) ge 0 then month(index)=(byte('0'))(0) index=0 month=string(month) day=byte(strmid(string(day), 6, 2)) index=where(day eq space) if index(0) ge 0 then day(index)=(byte('0'))(0) index=0 day=string(day) CASE strlowcase(form) OF 'yyyymmdd': Output=year+separator+month+separator+day 'yymmdd': Output=strmid(year, 2, 2)+separator+month+separator+day 'ddmmyyyy': Output=day+separator+month+separator+year 'ddmmyy': Output=day+separator+month+separator+strmid(year, 2, 2) 'mmddyyyy': Output=month+separator+day+separator+year 'mmddyy': Output=month+separator+day+separator+strmid(year, 2, 2) ELSE: message, 'Unknown form. Returning...' ENDCASE if n_elements(Output) eq 1 then Output=Output(0) return, Output end ####################################################### pro cal_sun, image, sky, quiet_sun, Range imagemax=max(image, min=imagemin) if n_elements(Range) le 0 then Range=2.e4 < (imagemax-imagemin) data=(smooth(float(image),3)-imagemin)/(imagemax-imagemin)*Range hist=histogram(temporary(data), omin=omin,omax=omax) N=n_elements(hist) Nsm=fix(N/200. > 5 < 50) h2=smooth(median(float(temporary(hist)),3), Nsm) amax=max(h2) area=total(h2)/amax WM=wgtmax(h2) Napp=[WM-3*area > 0, WM+3*area < (N-1)] h2extr=h2(Napp(0):Napp(1)) Nextr=Napp(1)-Napp(0)+1 Npoints=128. for_approx=h2extr(findgen(Npoints)*Nextr/Npoints) spec=fft(for_approx-mean(for_approx), -1) spec(16:111)=0 filtered=float(fft(spec, 1)) peaks=find_peaks(filtered) peaks=(reverse(peaks(sort(filtered(peaks)))))([0,1]) peaks=peaks(sort(peaks)) amin=min(filtered(peaks(0):peaks(1)), imin) border=peaks(0)+imin peaks0=Napp(0)+peaks*Nextr/Npoints border0=Napp(0)+border*Nextr/Npoints thres=h2(border0) h3=h2*(h2 ge thres) sky=Napp(0)+wgtmax(h3(Napp(0):border0))+omin quiet_sun=border0+wgtmax(h3(border0:Napp(1)))+omin sky=imagemin+sky/Range*(imagemax-imagemin) quiet_sun=imagemin+quiet_sun/Range*(imagemax-imagemin) image=(image-sky)/(quiet_sun-sky)*16e3 end ####################################################### pro cal_sun34, image, sky, quiet_sun, Range ;, frequency = frequency ;if n_elements(frequency) lt 0 then frequency = 34 imagemax=max(image, min=imagemin) if n_elements(Range) le 0 then Range=2.e4 data=(smooth(float(image),3)-imagemin)/(imagemax-imagemin)*Range hist=histogram(temporary(data), omin=omin,omax=omax) N=n_elements(hist) Nsm=fix(N/200. > 5 < 50) h2=smooth(median(float(temporary(hist)),3), Nsm) amax=max(h2) area=total(h2)/amax WM=wgtmax(h2) Napp=[WM-3*area > 0, WM+3*area < (N-1)] if n_elements(frequency) gt 0 then if frequency eq 34 then $ Napp = [0, n_elements(h2)-1] h2extr=h2(Napp(0):Napp(1)) Nextr=Napp(1)-Napp(0)+1 Npoints=128. Npoints=512.*2 N0=16 ;N0 = Npoints/8 for_approx=h2extr(findgen(Npoints)*Nextr/Npoints) spec=fft(for_approx-mean(for_approx), -1) spec(N0:Npoints-N0-1)=0 filtered=float(fft(spec, 1)) peaks=find_peaks(filtered) peaks=(reverse(peaks(sort(filtered(peaks)))))([0,1]) peaks=peaks(sort(peaks)) amin=min(filtered(peaks(0):peaks(1)), imin) border=peaks(0)+imin peaks0=Napp(0)+peaks*Nextr/Npoints ;border0=Napp(0)+border*Nextr/Npoints ;thres=h2(border0) ;if thres lt amax*0.2 then thres = amax*0.3 ;h3=h2*(h2 ge thres) ;sky=Napp(0)+wgtmax(h3(Napp(0):border0))+omin ;quiet_sun=border0+wgtmax(h3(border0:Napp(1)))+omin sky = peaks0(0) + omin quiet_sun = peaks0(1) +omin sky=imagemin+sky/Range*(imagemax-imagemin) quiet_sun=imagemin+quiet_sun/Range*(imagemax-imagemin) CASE frequency OF 17: T0 = 1e4 34: T0 = 1e4 ELSE: T0 = 1.6e4 ENDCASE ;stop image = image - sky quiet_sun = quiet_sun - sky ;;stop image=image/quiet_sun*T0 ;image=(image-sky)/quiet_sun*T0 end ####################################################### function carrot, date, time Sz = size(date) type = Sz(Sz(0)+1) if type eq 7 then begin if n_elements(time) le 0 then time = '00:00:00' year = strmid(date, 6, 4) if strlen(date) lt 10 then begin if year lt 50 then year = '20'+year else year = '19'+year endif d = fix([year, $ strmid(date, 3, 2), $ strmid(date, 0, 2), $ strmid(time, 0, 2), $ strmid(time, 3, 2)]) JULDATE, d, jd jd = jd+2400000d0 return, 1690d0 + (jd - 2444235.34d0)/27.2753d0 endif else return, caldatg( (date-1690d0)*27.2753d0+2444235.34d0 ) end ####################################################### pro cf_xtext_event,ev WIDGET_CONTROL, ev.id, get_uval = uv CASE uv OF 'Exit' : widget_control, ev.top, /destroy 'Open' : begin file = dialog_pickfile(/read) if file eq '' then return widget_control, ev.top, /destroy cf_xtext, file = file, title = shortfilename(file) end 'Save' : begin file = dialog_pickfile(/write) if file eq '' then return widget_control, ev.top, get_uval = Out_text, /no_copy openw, lun, file, /get for j=0L, n_elements(Out_text)-1 do printf, lun, Out_text[j] free_lun, lun end ENDCASE end pro cf_xtext, single_argument, text = text, file = file, group_leader = group_leader, $ identifier = identifier, numbers = numbers, title = title ; Displays interactively a text similar to XDISPLAYFILE. if n_elements(title) le 0 then title = 'xtext' CASE strlowcase(!version.os_family) OF 'windows': _win = '&' 'unix': _win = '' ELSE: begin print, 'Not tested on this platform. Returning...' return end ENDCASE if n_elements(group_leader) le 0 then group_leader=0L CASE 1 OF n_params() eq 1: Out_text = single_argument n_params() eq 0 and n_elements(text) gt 0: Out_text = Text n_params() eq 0 and n_elements(file) gt 0: Out_text = readform(file) ELSE: Out_text = '' ENDCASE Nlines = n_elements(Out_text) if keyword_set(numbers) then begin n_signs = ceil(alog10(Nlines)) Out_text = strmid(sindgen(Nlines), 12-n_signs, n_signs)+' '+Out_text endif base= widget_base(title = title, group_leader=group_leader, /column, mbar = bar) button=widget_button(bar, val = _win + 'File', /menu) button1 = widget_button(button, val = _win + 'Open', uval='Open') button1 = widget_button(button, val = _win + 'Save', uval='Save') button1 = widget_button(button, val = 'E' + _win + 'xit', uval='Exit', /sep) Txt = widget_text(base, /frame, Ysize = Nlines < 50 > 4, $ value = Out_text, /scroll, uvalue='text', xsize=max(strlen(Out_text)) +2 > 10) widget_control, base, /realize, set_uval = Out_text, /no_copy widget_control, Txt, /input identifier = base xmanager,'cf_xtext', base, group_leader = group_leader, /no_block end ####################################################### function Chanfreq,Channel,Receiver ;+ ; The CHANFREQ function returns the frequency corresponding to ; the channel number given or vice versa, in dependency of the ; input value "Chan": ; if "Chan" is less than 2,000,000, then "Chan" is ; interpreted as a channel number; if not, then "Chan" ; is interpreted as a frequency. ; ; Rec_type is a type of the receiver: 0 is MFB (180 channels), ; 1 is AOR (192 channels). For the calculations concerning ; AOR the measured regression dependency "channel-frequen- ; cy" is used. The edges of the operation band are of no ; significance (e.g. you can put and get the channel numbers ; -257.789 as well as +1576.985). ; ; All the output variables are floating-point, double precision. ; ; If input variable "Chan" is array, then CHANFREQ returns also ; an array of the same sizes as the input variable. ; ; EXAMPLES: ; ; Fx = CHANFREQ(198,0) returns the frequency Fx ; corresponding to the effective channel of ; number 198 for the MFB receiver. ; ; Nx = CHANFREQ(5.4789d9,1) returns the effective channel ; number Nx of the AOR receiver corresponding to ; the frequency 5.4789E+9 ; ; Nmfb = CHANFREQ(CHANFREQ(Naor,1),0) returns channel ; number of MFB corresponding to the same ; frequency as the AOR channel Naor. ; ;- a=double(Channel) & M=double(Receiver) Dc0=0;10000 Dc1=0;0.01d6 Dc2=0;1500 Dfmin=0 Mc=[0,3] Fmin=[5.675241d9, 5.676136d9+Dfmin] Df1=[0.652d6, 0.584d6+Dc0+Dc1] Df2=[0.642d6, 0.584d6+Dc0] Df3=[0.642d6, 0.584d6+Dc0] Ddf=[0.6222273d6, 0.584d6+Dc2] f1=Fmin+(44+Mc)*Ddf+Df1/2. f2=Fmin+2*(44+Mc)*Ddf+Df1+Df2/2. f3=Fmin+3*(44+Mc)*Ddf+Df1+Df2+Df3/2. if a(0) lt 2d6 then begin B=Fmin(M)+(a-1)*Ddf(M) B=B+ $ (-Ddf(M)+Df1(M))*(a gt 45+Mc(M) and a le 90+2*Mc(M))+ $ (-2*Ddf(M)+Df1(M)+Df2(M))*(a gt 90+2*Mc(M)and a le 135+3*Mc(M))+ $ (-3*Ddf(M)+Df1(M)+Df2(M)+Df3(M))*(a gt 135+3*Mc(M)) endif else begin B=(a-Fmin(M))/Ddf(M)+1 B=B+ $ (-Df1(M)/Ddf(M)+1)*(a gt f1(M) and a le f2(M))+ $ ((-Df1(M)-Df2(M))/Ddf(M)+2)*(a gt f2(M) and a le f3(M))+ $ ((-Df1(M)-Df2(M)-Df3(M))/Ddf(M)+3)*(a gt f3(M)) endelse return,B end ####################################################### function chan_to_p,Channel,Dir,Receiver, SUN=SUN if n_elements(Receiver) le 0 then Receiver=1 if n_elements(Dir) le 0 then Dir=0 ;E-W D=4.9D0 & C=2.997925D8 F=chanfreq(Channel,Receiver) INT_ORD,Dir,Receiver,SUN,P,Nord,Ord,Chan Order=ORD_RECOGNIZE(Channel,Nord,Ord,Chan) return, acos(Order*C/(F*D) > (-1) < 1) end ####################################################### FUNCTION CHECKVIS,Receiver,N_ord,Chan,time_scan=time_scan ; Returns model of the quiet Sun when the number of interferention ; orders (N_ord) and channels corresponding to the center and edges ; of the SUN (Chan) are given. N_ord and Chan are calculated by the ; INT_ORD routine. Chan_store=Chan CASE keyword_set(time_scan) OF 0: begin Sum_chan=[180,192] X=findgen(Sum_chan(Receiver))+1 Z=fltarr(Sum_chan(Receiver)) end 1: begin N_ord=1 Chan=Chan(sort(Chan)) Chan=Chan-Chan(0) X=findgen(Chan(2)-Chan(0))+1 Z=fltarr(Chan(2)-Chan(0)) end ENDCASE for i=0,N_ord-1 do $ Z=Z+sqrt(1-((X-Chan(1,i))/((Chan(2,i)-Chan(0,i))/2))^2 > 0) Chan=Chan_store RETURN,Z end ####################################################### function check_dir, name if n_params() lt 1 then message, 'Incorrect call' Sz=size(name) if (Sz(Sz(0)+1) ne 7) or (Sz(Sz(0)+2) ne 1) then message, 'Incorrect argument' name1=strtrim(name,2) spawn,'dir > filesdir.tmp' wait,1 openr,lun,'filesdir.tmp', /get_lun, /del a=fstat(lun) b=bytarr(a.size) readu,lun,b free_lun,lun x=strsplit(strcompress(string(b)),delim=string('0a'xb)) if !version.OS eq 'windows' then name1=strupcase(name1) N=n_elements(x) xx=strmid(x,0,strlen(name1)+6) index=where(xx eq name1+' ') return, fix(index(0) ge 0) end ####################################################### pro circ,fill=fill,thick=thick ; Defines user symbol as filled or non-filled circle. if n_elements(fill) le 0 then fill=0 if n_elements(thick) le 0 then thick=!P.thick N=16 a=findgen(N)*(!Pi*2/(N-1)) usersym,cos(a),sin(a),fill=fill,thick=thick end ####################################################### function civ_date, bintme ;+ ; converts binary time in 10 microseconds starting ; on jan., 1, 1990 to civil time and number of days ; days since jan., 1, 1990. ; ; usage: d = civ_time(b) ; ; where b = time in 10 usec (double) since jan. 1, 1990, 00 ut ; and d = [year,day_of_year,month,day]. ;- jdcnv, 1990,1,1,0.,julian1 daycnv, julian1 + (bintme/8.64d9)+.1, year, month, day jdcnv, year,1,1,0.,julian2 jdcnv, year,month,day,0.,julian3 doy = fix(julian3-julian2 + 1.01) return, [year, doy, month, day] end ####################################################### function civ_time, bintime ;+ ; converts binary time in 10 microseconds starting ; on jan., 1, 1990 to civil time. ; ; usage: c = civ_time(b)' ; ; where b = time in 10 usec (double) since jan. 1, 1990 00 ut ; c = [hour,min,sec,msec,usec]. ;- hour = long( ( bintime mod 8.64d09) / 3.6d08 + 1.d-14) mins = long( ( bintime mod 3.60d08) / 6.0d06 + 1.d-14) sec = long( ( bintime mod 6.00d06) / 1.0d05 + 1.d-14) msec = long( ( bintime mod 1.00d05) / 1.0d02 + 1.d-14) usec = long( ( bintime mod 1.00d02) * 10 ) return, [hour, mins, sec, msec, usec] end ####################################################### function cleanbe1, hdr, isam, number=number if n_elements(number) le 0 then NN=1 else NN=number ;+ ;NAME: ; CLEANBEAM16D ;PURPOSE: ; Create a projected image of the clean beam ;CALLING SEQUENCE: ; beam=CLEANBEAM(HEADER) ;INPUT: ; HEADER, header of a FITS file of a cleaned and projected image ;OUTPUT: ; returns a fltarr(21,21) array. ; the center of the beam is (10,10). ;RESTRICTIONS: ; The FITS header must include SOLP and PMATn keywords. ;MODIFICATION HISTORY: ; K. FUJIKI, MAY, 1996. ;- if n_params() eq 1 then isam=16 i=0 while (strmid(hdr(i),0,5) ne 'SOLP ') do i=i+1 solp=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT1') do i=i+1 pmat1=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT2') do i=i+1 pmat2=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT3') do i=i+1 pmat3=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT4') do i=i+1 pmat4=strmid(hdr(i),11,19)*1.0 beam=fltarr(21*NN,21*NN) for l=-10*NN,10*NN do begin for i=-10*NN,10 do begin x=(cos(solp/!radeg)*i $ -sin(solp/!radeg)*l)*4.91104/4.64947 y=(sin(solp/!radeg)*i $ +cos(solp/!radeg)*l)*4.91104/4.64947 xx=pmat1*x+pmat3*y yy=1.000112494*(pmat2*x+pmat4*y) if (isam eq 16) then beam(i+10*NN, l+10*NN)=exp(-0.0554*(xx*xx+yy*yy)) if (isam eq 8) then beam(i+10*NN, l+10*NN)=exp(-0.1478*(xx*xx+yy*yy)) endfor endfor return,beam end ####################################################### function cleanbeam, hdr, isam ;+ ;NAME: ; CLEANBEAM16D ;PURPOSE: ; Create a projected image of the clean beam ;CALLING SEQUENCE: ; beam=CLEANBEAM(HEADER) ;INPUT: ; HEADER, header of a FITS file of a cleaned and projected image ;OUTPUT: ; returns a fltarr(21,21) array. ; the center of the beam is (10,10). ;RESTRICTIONS: ; The FITS header must include SOLP and PMATn keywords. ;MODIFICATION HISTORY: ; K. FUJIKI, MAY, 1996. ;- if n_params() eq 1 then isam=16 i=0 while (strmid(hdr(i),0,5) ne 'SOLP ') do i=i+1 solp=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT1') do i=i+1 pmat1=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT2') do i=i+1 pmat2=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT3') do i=i+1 pmat3=strmid(hdr(i),11,19)*1.0 i=0 while (strmid(hdr(i),0,5) ne 'PMAT4') do i=i+1 pmat4=strmid(hdr(i),11,19)*1.0 beam=fltarr(21,21) for l=-10,10 do begin for i=-10,10 do begin x=(cos(solp/!radeg)*i $ -sin(solp/!radeg)*l)*4.91104/4.64947 y=(sin(solp/!radeg)*i $ +cos(solp/!radeg)*l)*4.91104/4.64947 xx=pmat1*x+pmat3*y yy=1.000112494*(pmat2*x+pmat4*y) if (isam eq 16) then beam(i+10, l+10)=exp(-0.0554*(xx*xx+yy*yy)) if (isam eq 8) then beam(i+10, l+10)=exp(-0.1478*(xx*xx+yy*yy)) endfor endfor return,beam end ####################################################### function closest_terms, x, y Ny = n_elements(y) ind = lonarr(Ny) for j=0,Ny-1 do begin amin = min(abs((1-double(x)/y[j])), imin) ind[j] = imin endfor return, ind end ####################################################### function coeffr,n,Receiver=Receiver,Band=Band ; Returns broadening factor(s) of the SSRT beam due to dispersion ; in the frequency band corresponding to order(s) given. if n_elements(Receiver) le 0 then Receiver=1 if n_elements(Band) le 0 then begin if Receiver then Band=2 else Band=5 endif if not(Receiver) and Band eq 4 then Band=5 bexp2ccd0=[1.000000, 1.000048, 1.000095, 1.000143, $ 1.000191, 1.000239, 1.000374, 1.000510, $ 1.000645, 1.000781, 1.000916, 1.001154, $ 1.001391, 1.001628, 1.001865, 1.002102, $ 1.002428, 1.002755, 1.003081, 1.003407, $ 1.003734, 1.004177, 1.004619, 1.005062, $ 1.005505, 1.005948, 1.006455, 1.006962, $ 1.007469, 1.007976, 1.008483, 1.009110, $ 1.009737, 1.010363, 1.010990, 1.011617, $ 1.012321, 1.013025, 1.013730, 1.014434, $ 1.015138, 1.016040, 1.016942, 1.017843, $ 1.018745, 1.019647, 1.020588, 1.021529] bexp2ccd1=[1.022470, 1.023411, 1.024352, 1.025369, $ 1.026386, 1.027403, 1.028419, 1.029436, $ 1.030555, 1.031675, 1.032794, 1.033913, $ 1.035032, 1.036438, 1.037845, 1.039251, $ 1.040658, 1.042064, 1.043406, 1.044748, $ 1.046090, 1.047433, 1.048775, 1.050218, $ 1.051661, 1.053104, 1.054547, 1.055990, $ 1.057639, 1.059288, 1.060937, 1.062585, $ 1.064234, 1.066099, 1.067964, 1.069829, $ 1.071694, 1.073559, 1.075331, 1.077103, $ 1.078875, 1.080647, 1.082419, 1.084386, $ 1.087951, 1.088401] bexp4ccd0=[1.000000, 1.000188, 1.000377, 1.000565, $ 1.000754, 1.000942, 1.001502, 1.002062, $ 1.002622, 1.003181, 1.003741, 1.004692, $ 1.005642, 1.006593, 1.007543, 1.008494, $ 1.009836, 1.011179, 1.012521, 1.013864, $ 1.015206, 1.016982, 1.018758, 1.020533, $ 1.022309, 1.024084, 1.026255, 1.028425, $ 1.030595, 1.032765, 1.034935, 1.037591, $ 1.040248, 1.042904, 1.045560, 1.048217, $ 1.051366, 1.054515, 1.057664, 1.060813, $ 1.063962, 1.067798, 1.071634, 1.075470, $ 1.079306, 1.083142, 1.087393, 1.091644] bexp4ccd1=[1.095896, 1.100147, 1.104398, 1.109363, $ 1.114328, 1.119293, 1.124259, 1.129224, $ 1.135140, 1.141056, 1.146972, 1.152888, $ 1.158803, 1.165708, 1.172613, 1.179518, $ 1.186423, 1.193328, 1.200688, 1.208049, $ 1.215409, 1.222769, 1.230129, 1.238291, $ 1.246453, 1.254615, 1.262777, 1.270939, $ 1.279941, 1.288943, 1.297945, 1.306948, $ 1.315950, 1.325952, 1.335954, 1.345956, $ 1.355958, 1.365959, 1.377183, 1.388407, $ 1.399631, 1.410854, 1.422078, 1.434307, $ 1.447604, 1.459156] bexpmfb0=[1.000000, 1.000139, 1.000278, 1.000416, $ 1.000555, 1.000694, 1.001104, 1.001514, $ 1.001923, 1.002333, 1.002743, 1.003440, $ 1.004137, 1.004833, 1.005530, 1.006227, $ 1.007206, 1.008186, 1.009165, 1.010144, $ 1.011123, 1.012418, 1.013712, 1.015006, $ 1.016300, 1.017595, 1.019164, 1.020733, $ 1.022302, 1.023871, 1.025440, 1.027348, $ 1.029255, 1.031163, 1.033070, 1.034978, $ 1.037217, 1.039457, 1.041696, 1.043936, $ 1.046175, 1.048905, 1.051635, 1.054366, $ 1.057096, 1.059826, 1.062802, 1.065779] bexpmfb1=[1.068756, 1.071732, 1.074709, 1.078106, $ 1.081503, 1.084899, 1.088296, 1.091693, $ 1.095519, 1.099345, 1.103171, 1.106997, $ 1.110823, 1.115538, 1.120252, 1.124966, $ 1.129681, 1.134395, 1.139427, 1.144460, $ 1.149493, 1.154525, 1.159558, 1.165179, $ 1.170801, 1.176422, 1.182044, 1.187666, $ 1.193855, 1.200044, 1.206234, 1.212423, $ 1.218612, 1.225440, 1.232267, 1.239095, $ 1.245923, 1.252751, 1.260059, 1.267368, $ 1.274677, 1.281986, 1.289295, 1.297114, $ 1.306223, 1.313210] bexp2ccd=[bexp2ccd0, bexp2ccd1] bexp4ccd=[bexp4ccd0, bexp4ccd1] bexpmfb=[bexpmfb0, bexpmfb1] CASE Band OF 2: Coef=[bexp2ccd0, bexp2ccd1] 4: Coef=[bexp4ccd0, bexp4ccd1] 5: Coef=[bexpmfb0, bexpmfb1] ELSE: begin print,'Error: this value not allowed' return,0 end ENDCASE return,coef(abs(n)) end ####################################################### function comb_files, files0, files1, headers = ihead, times = itime all_files = [files0, files1] ihead = rd_fhead(all_files) itime = hmsd(msxpar(ihead, 'time-obs')) sort_ind = sort(itime) all_files = all_files(sort_ind) itime = itime(sort_ind) ihead = ihead(sort_ind) sort_ind = uNiq(itime) all_files = all_files(sort_ind) itime = itime(sort_ind) ihead = ihead(sort_ind) return, all_files end ####################################################### common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr ####################################################### function concat, X0, X1, X2, X3, X4, X5, X6, X7, transpose = transpose CASE n_params() OF 2: array = [[X0], [X1]] 3: array = [[X0], [X1], [X2]] 4: array = [[X0], [X1], [X2], [X3]] 5: array = [[X0], [X1], [X2], [X3], [X4]] 6: array = [[X0], [X1], [X2], [X3], [X4], [X5]] 7: array = [[X0], [X1], [X2], [X3], [X4], [X5], [X6]] 8: array = [[X0], [X1], [X2], [X3], [X4], [X5], [X6], [X7]] ELSE: message, 'Not implemented' ENDCASE if keyword_set(transpose) then return, transpose(array) else return, array end ####################################################### function congridg, image, xs, ys, INTERP=int, MINUS_ONE = m1 ;+ ; NAME: ; CONGRIDG ; ; PURPOSE: ; Shrink or expand the size of an image by an arbitrary amount. ; This IDL procedure simulates the action of the VAX/VMS ; CONGRID/CONGRIDI function. ; ; CATEGORY: ; Image processing. ; ; CALLING SEQUENCE: ; Result = CONGRIDG(Image, Xs, Ys [, INTERP = Interp]) ; ; INPUTS: ; Image: The 2D array to resample. ; Xs: The number of columns for the result. ; Ys: The number of rows for the result. ; ; KEYWORD PARAMETERS: ; INTERP: Keyword that, if set, causes bilinear interpolation to be ; used. Otherwise, the nearest-neighbor method is used. ; MINUS_ONE: Set this keyword to resample by the factor of ; (m-1)/(p-1) in the X direction, and (n-1)/(q-1) ; in the Y direction. Default is to resample by (m/p) and ; (n/q). See the PROCEDURE section below. ; This avoids extrapolating past the last row and ; column in the input image. ; OUTPUTS: ; Returns an image of the same type as input, of size (Xs, Ys). ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; This routine doesn't completely emulate the VAX/VMS CONGRID. The case ; of a rectangular grid of control points is not implemented. This ; method can be simulated using multiple calls to POLY_2D. ; ; PROCEDURE: ; Calls POLY_2D with the warping coefficients. ; Given an input image A of dimensions (m,n), the result of ; B = CONGRIDG(A, p, q) is: ; B(i,j) = G(A(i*m/p, j*n/q)) ; or if MINUS_ONE is set: ; B(i,j) = G(A(i*(m-1)/(p-1), j*(n-1)/(q-1))) ; where G is the interpolation function, either nearest neighbor ; or bilinear interpolation. ; ; EXAMPLE: ; To resize the 100 by 100-element image "im" to be 140 by 300 elements ; and store the result in the variable "newim", enter the command: ; newim = CONGRIDG(im, 140, 300, /INTERP) ; ; MODIFICATION HISTORY: ; DMS, Sept. 1988. ; DMS, Added the MINUS_ONE keyword, Sept. 1992. ; ISTP, Corrected the mistake of (N-1) seen at processing of small ; arrays. V.Grechnev, Oct. 1995. ;- on_error,2 ;Return to caller if an error occurs if n_params() gt 3 then begin ;Cant warp over small rectangles print,"CONGRIDG - Can't warp over control grid." return,undef endif s = size(image) if s(0) ne 2 then begin ;2d image? print,'CONGRIDG - Image parameter not 2 dimensional' return,undef endif if n_elements(int) le 0 then int = 0 ;Default = no interp if n_elements(m1) le 0 then m1 = 0 else m1 = keyword_set(m1) if keyword_set(int) then $ result=poly_2d(image, [[0,0],[(s(1)-m1-1)/float(xs-m1),0]], $ ;Use poly_2d [[0,(s(2)-m1-1)/float(ys-m1)],[0,0]],int,xs,ys) else $ result=poly_2d(image, [[0,0],[(s(1)-m1)/float(xs-m1),0]], $ ;Use poly_2d [[0,(s(2)-m1)/float(ys-m1)],[0,0]],int,xs,ys) return, result end ####################################################### pro cont_setting_event,ev common cont_setting,ID,data WIDGET_CONTROL,ev.id,GET_UVALUE = uv,/hour x=findgen(Data.Nlevels+2)/(Data.Nlevels+1) CASE uv OF "DONE": begin close,/al if ID.group_leader ne 0L then if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show WIDGET_CONTROL,ev.top,/DESTROY ID=0 end "OS": spawn "NC": spawn,'NC' "VC": spawn,'VC' "Save": begin name=pickfile(tit='Please select a file for saving levels',filt='*.lev') if name eq '' then return widget_control,/hour openw,lun,name,/get for j=0,n_elements(Data.Levels)-1 do printf,lun,(Data.levels)(j) free_lun,lun end "Load": begin name=pickfile(tit='Please select a file for reading levels',filt='*.lev') if name eq '' then return Data.Mode='custom' widget_control,/hour openr,lun,name,/get Read_array=fltarr(50) Read_string='' j=0 while not eof(lun) do begin readf,lun,Read_string Read_array(j)=Read_string j=j+1 endwhile free_lun,lun data={array:data.array, nlevels:j, levels:Read_array(0:j-1), $ upper:Data.upper, lower:Data.lower, show:Data.show, $ mode:Data.mode, max:Data.max, min:Data.min, Labels:Data.Labels} widget_control,ID.Nlevels,set_val=string(j,format='(i2)') end "Nlevels": begin widget_control,ev.id,get_val=text text=text(where(text)) Data.Nlevels=text(0) < 29 > 1 widget_control,ID.Nlevels,set_val=string(Data.nlevels,format='(i2)') end "lin": Data.Mode="lin" "sin": Data.Mode="sin" "asin": Data.Mode="asin" "exp": Data.Mode="exp" "log": Data.Mode="log" "Upper": begin widget_control,ev.id,get_val=text text=text(where(text)) Data.Upper=strmid(text(0),7,10) < Data.max widget_control,ID.Upper,set_val= $ strcompress(string(Data.Upper,format="('Upper = ',g11.3)")) end "Lower": begin widget_control,ev.id,get_val=text text=text(where(text)) Data.Lower=strmid(text(0),7,10) > Data.min widget_control,ID.Lower,set_val= $ strcompress(string(Data.Lower,format="('Lower = ',g11.3)")) end "Levels": begin Data.Mode='custom' widget_control,ev.id,get_val=text text=strcompress(text,/remove_all) text=text(where(text)) text=text(sort(float(text))) > Data.min < Data.max text=text(uniq(text)) text=string(text,format='(g11.3)') data={array:data.array, nlevels:n_elements(text), levels:text, $ upper:Data.upper, lower:Data.lower, show:Data.show, $ mode:Data.mode, max:Data.max, min:Data.min, Labels:Data.Labels} widget_control,ID.Nlevels,set_val=string(n_elements(text),format='(i2)') end "Show": Data.Show=ev.select "Labels": Data.Labels=ev.select ELSE: ENDCASE Dont_plot=(uv eq 'DONE') or (uv eq 'OS') or (uv eq 'VC') or (uv eq 'NC') or $ (uv eq 'Calculator') or (uv eq 'Xloadct') or (uv eq 'Help') or $ (uv eq 'Save') IF not Dont_plot THEN BEGIN x=findgen(Data.Nlevels+2)/(Data.Nlevels+1) CASE Data.Mode OF "lin": Argument=x "sin": Argument=0.5*(1+sin((x-0.5)*!pi)) "asin": Argument=0.5+asin(2*x-1)/!pi "exp": Argument=(exp(x)-1)/(exp(1)-1) "log": Argument=alog(x+1)/alog(2) ELSE: ENDCASE if Data.Mode ne "custom" then begin levels0=Argument*(Data.upper-Data.lower)+Data.lower levels=levels0(1:Data.Nlevels) endif else begin levels=Data.levels levels0=[Data.min,Data.levels,Data.max] endelse data={array:Data.array, nlevels:Data.nlevels, levels:levels, upper:Data.upper, $ lower:Data.lower, mode:Data.mode, max:Data.max, min:Data.min, $ Show:Data.show, Labels:Data.Labels} widget_control,ID.Levels,set_val=strtrim(string(Data.Levels,format='(g11.3)'),2) wset,ID.Win(0) plot,levels0,xtickl=-0.02,ytickl=-0.02,xran=[0,Data.Nlevels+1],/xst, $ yran=[Data.min,Data.max],/yst for j=0,Data.Nlevels-1 do plots,[0,Data.Nlevels+1],[1.,1.]*levels(j),col=!p.color,/noc if Data.show then begin wset,ID.Win(1) contour,data.array,levels=data.levels,/xst,/yst,fol=Data.Labels,xtickl=-0.02, $ ytickl=-0.02 endif empty ENDIF end pro cont_setting,array,levels=levels, follow=follow, $ group_leader=group_leader ; Performs interactive pre-definition of contour levels ; for CONTOUR representation of an array. common cont_setting,ID,data if (size(array))(0) ne 2 then begin print,'Incorrect input argument. Bye' return endif maxval=max(array,min=minval) if n_elements(group_leader) le 0 then group_leader=0L ID={Draw:[0L,0L], Win:[0L,0L], Nlevels:0L, Levels:0L, Upper:0L, Lower:0L, $ Show:0L, Labels:0L, group_leader:group_leader} !x.margin=[10,3] !y.margin=[4,3] MainBase=widget_base(/colu,tit='Contour levels setting') XPdMenu, ['"DONE" DONE', $ '"File" {', $ '"Load" Load', $ '"Save" Save', $ '}', $ '"Shell" {', $ '"OS" OS', $ '"NC" NC', $ '"VC" VC', $ '}'], MainBase Plain_Base=widget_base(MainBase,/row) LeftBase=widget_base(Plain_Base,/colu) RightBase=widget_base(Plain_Base,/colu) label=widget_label(LeftBase,val=strcompress(string(maxval,minval, $ format="('Max = ',g11.3,'; Min = ',g11.3)"))) bitmap_sin = [ $ [000B, 000B], $ [000B, 032B], $ [000B, 024B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [000B, 001B], $ [128B, 000B], $ [128B, 000B], $ [064B, 000B], $ [064B, 000B], $ [032B, 000B], $ [016B, 000B], $ [012B, 000B], $ [002B, 000B], $ [000B, 000B] $ ] bitmap_lin = [ $ [000B, 000B], $ [000B, 064B], $ [000B, 032B], $ [000B, 016B], $ [000B, 008B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [128B, 000B], $ [064B, 000B], $ [032B, 000B], $ [016B, 000B], $ [008B, 000B], $ [004B, 000B], $ [002B, 000B], $ [000B, 000B] $ ] bitmap_asin = [ $ [000B, 000B], $ [000B, 064B], $ [000B, 064B], $ [000B, 032B], $ [000B, 016B], $ [000B, 008B], $ [000B, 006B], $ [128B, 001B], $ [064B, 000B], $ [032B, 000B], $ [016B, 000B], $ [008B, 000B], $ [008B, 000B], $ [004B, 000B], $ [004B, 000B], $ [000B, 000B] $ ] bitmap_exp = [ $ [000B, 000B], $ [000B, 016B], $ [000B, 016B], $ [000B, 016B], $ [000B, 016B], $ [000B, 008B], $ [000B, 008B], $ [000B, 008B], $ [000B, 004B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [128B, 000B], $ [096B, 000B], $ [030B, 000B], $ [000B, 000B] $ ] bitmap_log = [ $ [000B, 000B], $ [000B, 000B], $ [000B, 112B], $ [000B, 014B], $ [128B, 001B], $ [064B, 000B], $ [032B, 000B], $ [016B, 000B], $ [008B, 000B], $ [008B, 000B], $ [004B, 000B], $ [004B, 000B], $ [002B, 000B], $ [002B, 000B], $ [002B, 000B], $ [000B, 000B] $ ] button_base=widget_base(LeftBase,/row,/frame) label=widget_label(button_base,val=' Shape: ') button_lin=widget_button(button_base,val=bitmap_lin,uval='lin') button_sin=widget_button(button_base,val=bitmap_sin,uval='sin') button_asin=widget_button(button_base,val=bitmap_asin,uval='asin') button_exp=widget_button(button_base,val=bitmap_exp,uval='exp') button_log=widget_button(button_base,val=bitmap_log,uval='log') label=widget_label(button_base,val=' Number: ') ; ************* Initial data if n_elements(follow) le 0 then follow=0 if n_elements(levels) le 0 then begin nlevels=15 x=findgen(Nlevels+2)/(Nlevels+1) Argument=x levels0=Argument*(maxval-minval)+minval levels=levels0(1:Nlevels) mode='lin' endif else begin mode='custom' nlevels=n_elements(levels) endelse data={array:array, nlevels:nlevels, levels:levels, upper:maxval, lower:minval, $ mode:mode, max:maxval, min:minval, Show:0, Labels:follow} ID.Nlevels=widget_text(button_base,/edit,ysiz=1,uval='Nlevels', $ val=string(Data.nlevels,format='(i2)'),xsiz=5) level_base=widget_base(LeftBase,/row,/frame) temp=widget_label(level_base,val='Levels: ') limit_base=widget_base(Level_Base,/colu) ID.Upper=widget_text(limit_base,/edit,ysiz=1,uval='Upper', $ val=strcompress(string(maxval,format="('Upper = ',g11.3)")),/frame) ID.Lower=widget_text(limit_base,/edit,ysiz=1,uval='Lower', $ val=strcompress(string(minval,format="('Lower = ',g11.3)")),/frame) ID.Levels=widget_text(level_base,/edit,/scroll,uval='Levels', $ ysiz=2,/fra,xsiz=12,val=strtrim(string(Data.Levels,format='(g11.3)'),2)) device,get_scr=scr ID.Draw(0)=widget_draw(Leftbase,xsi=scr(1)*0.6,ysi=scr(1)*0.6,/fra) Showbase=widget_base(Rightbase,/row,/nonexcl) ID.Labels=widget_button(Showbase,val='Annotation',uval='Labels') Showbase=widget_base(Rightbase,/row,/nonexcl) ID.Show=widget_button(Showbase,val='Show effect',uval='Show') ID.Draw(1)=widget_draw(Rightbase,xsi=scr(1)*0.6,ysi=scr(1)*0.6) widget_control,MainBase,/realize,/hour for j=0,1 do begin WIDGET_CONTROL,ID.Draw(j),GET_VALUE=temp ID.Win(j)=temp wset,ID.Win(j) erase endfor if Data.Mode ne "custom" then begin Argument=findgen(Data.Nlevels+2)/(Data.Nlevels+1) levels0=Argument*(Data.upper-Data.lower)+Data.lower levels=levels0(1:Data.Nlevels) endif else begin levels=Data.levels levels0=[Data.min,Data.levels,Data.max] endelse data={array:Data.array, nlevels:Data.nlevels, levels:levels, upper:Data.upper, $ lower:Data.lower, mode:Data.mode, max:Data.max, min:Data.min, $ Show:Data.show, Labels:Data.Labels} widget_control,ID.Levels,set_val=strtrim(string(Data.Levels,format='(g11.3)'),2) widget_control,ID.Labels,set_but=Data.Labels wset,ID.Win(0) plot,levels0,xtickl=-0.02,ytickl=-0.02,xran=[0,Data.Nlevels+1],/xst, $ yran=[Data.min,Data.max],/yst for j=0,Data.Nlevels-1 do plots,[0,Data.Nlevels+1],[1.,1.]*levels(j),col=!p.color,/noc empty WIDGET_CONTROL,ID.NLevels,/input xmanager,'cont_setting',MainBase,group=group_leader, /modal follow=Data.Labels Levels=float(Data.Levels) Data=0 end ####################################################### function conv, x, y return, swap_array(fft(fft(x, -1)*fft(y, -1), 1)) end ####################################################### FUNCTION SSMMHH, Time hour = long(Time)/3600 minute = long(Time-3600*hour)/60 sec = Time mod 60 sec_int=double(fix(sec)) msec=(sec-sec_int)*1d3 hour=hour mod 24 return, string(transpose([[hour], [minute], [sec_int], [msec]]), $ format = "(I2.2,':',I2.2,':',I2.2,'.', I3.3)") END function cursorpos, button=button, data=data, $ device=device, normal=normal, time=time, top=top, hours=hours, $ seconds=seconds, ytime=ytime ;+ ; CURSORPOS ; ; PURPOSE: ; Read the value of the pixel under the cursor. ; Display x,y under the cursor in the graphic window. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; Coord = CURSORPOS() ; ; INPUTS: ; None ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; ; BUTTON: return value of the pressed button (1 - left, 4 - right). ; ; DATA: If set and non-zero, DATA coordinate system is processed (by default). ; ; DEVICE: If set and non-zero, DEVICE coordinate system is processed. ; ; NORMAL: If set and non-zero, NORMAL coordinate system is processed. ; ; TIME: Display X coordinate in form "hh:mm:ss". Seconds along the X axis are intended. ; ; TOP: Display X,Y in the top left corner of the window ; ; HOURS: Display X coordinate in form "hh:mm:ss". Hours along the X axis are intended. ; ; SECONDS: Display X coordinate in the form "hh:mm:ss". Seconds along the X axis are ; intended. Same as TIME keyword. ; ; YTIME: Display Y coordinate in the form "hh:mm:ss". Seconds along the X axis are ; intended. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; The X, Y, and value of the pixel under the cursor are continuously displayed. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; X,Y values are printed as the cursor is moved over the plotting area. ; Press any mouse button to exit the procedure. ; ; MODIFICATION HISTORY: ; ISTP SD RAS, Feb, 1994. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ;- height=20 erase=replicate(!p.background, !d.x_size/2, height) Xout=3 if keyword_set(top) then Yout=!d.y_size-height else Yout=3 if keyword_set(top) then tv, erase, 0 else tv, erase, 0, 0 old_data=' ' REPEAT BEGIN cursor, xc, yc, /ch, data=data, device=device, normal=normal button=!err if keyword_set(ytime) then begin CASE 1 OF keyword_set(time) or keyword_set(seconds): aa= $ string(xc, format='(g12.5)')+', '+SSMMHH(yc) keyword_set(hours): aa=string(xc, format='(g12.5)')+', '+SSMMHH(yc*3600) ELSE: aa=string(xc, format='(g12.5)')+', '+SSMMHH(yc) ENDCASE endif else begin CASE 1 OF keyword_set(time) or keyword_set(seconds): aa=SSMMHH(xc)+ $ ', '+string(yc, format='(g12.5)') keyword_set(hours): aa=SSMMHH(xc*3600)+', '+string(yc, format='(g12.5)') ELSE: aa=string(xc, yc, format='(g12.5, ", ", g12.5)') ENDCASE endelse xyouts, Xout, Yout, old_data, /dev, font=0, col=!p.background xyouts, Xout, Yout, aa, /dev, font=0 old_data=aa ENDREP UNTIL ((button and 7B) ge 1B) or $ n_elements(in_data) gt 0 wait, 0.3 RETURN, [xc, yc] end ####################################################### function Cursor_out,in_data,button=button,data=data, $ device=device,normal=normal,start=start,Dt=Dt,model=model,time=time, $ top=top ; Issues coordinates of the cursor in graphics window. if n_elements(model) le 0 then model='hh:mm:ss.***' if n_elements(Dt) le 0 then Dt=1 if n_elements(start) le 0 then begin start=0 UT=0 endif else UT=1 if keyword_set(time) then ut=1 height=15 erase=replicate(!p.background,!d.x_size/2, height) Xout=0.01 Yout=0.01; 1-0.01 ; if keyword_set(top) then begin ;tv,erase, 0, !d.y_size-height ;Yout=1-0.01 ; endif else begin ;tv,erase, 0, 0 ;Yout=0.01 ; endelse tv,erase, 0, 0 ;!d.y_size-height old_data=' ' if n_elements(in_data) gt 0 then begin xc=in_data(0) if n_elements(in_data) eq 2 then yc=in_data(1) else yc=0 endif REPEAT BEGIN if n_elements(in_data) le 0 then cursor,xc,yc,/ch,data=data, $ device=device,normal=normal button=!err if UT then begin x=SMH(xc*3600,ms=3) CASE strlowcase(Model) OF 'hh:mm': x=strmid(x,0,5) 'mm:ss': x=strmid(x,3,5) 'ss': x=strmid(x,6,6) 'hh:mm:ss': x=strmid(x,0,8) ELSE: ENDCASE aa=x+' '+string(yc,format='(g12.5)') endif else aa=string(xc,yc,format='(g12.5, ", ", g12.5)') xyouts,Xout,Yout,old_data,/norm,font=0,col=!p.background xyouts,Xout,Yout,aa,/norm,font=0 old_data=aa ENDREP UNTIL ((button and 7B) ge 1B) or $ n_elements(in_data) gt 0 RETURN,[xc,yc] end ####################################################### function cyr,x,transliterate=transliterate prev='' N=strlen(x) b='!16' IF not keyword_set(transliterate) THEN BEGIN for j=0,N-1 do begin start0: if j ne 0 then prev=temp temp=strmid(x,j,1) if prev eq '!' then begin b=b+temp j=j+1 goto, start0 endif CASE temp OF 'ð':b=b+'a' ;a 'ñ':b=b+'b' ;b 'ò':b=b+'c' ;v 'ó':b=b+'d' ;g 'ô':b=b+'e' ;d 'õ':b=b+'f' ;e 'ö':b=b+'g' ;zh '÷':b=b+'h' ;z 'ø':b=b+'i' ;i 'ù':b=b+'j' ;j 'ú':b=b+'k' ;k 'û':b=b+'l' ;l 'ü':b=b+'m' ;m 'ý':b=b+'n' ;n 'þ':b=b+'o' ;o 'ÿ':b=b+'p' ;p '¨':b=b+'q' ;r '¸':b=b+'r' ;s 'ª':b=b+'s' ;t 'º':b=b+'t' ;u '¯':b=b+'u' ;f '¿':b=b+'v' ;h '¡':b=b+'w' ;c '¢':b=b+'x' ;ch '°':b=b+'y' ;sh '∙':b=b+'z' ;shch '•':b=b+'<' ;tw.znak '√':b=b+'>' ;y '¹':b=b+'@' ;myagk.znak '¤':b=b+'\' ;e '■':b=b+'^' ;yu ' ':b=b+';' ;ya '└':b=b+'A' ;a '┴':b=b+'B' ;b '┬':b=b+'C' ;v '├':b=b+'D' ;g '─':b=b+'E' ;d '┼':b=b+'F' ;e '╞':b=b+'G' ;zh '╟':b=b+'H' ;z '╚':b=b+'I' ;i '╔':b=b+'J' ;j '╩':b=b+'K' ;k '╦':b=b+'L' ;l '╠':b=b+'M' ;m '═':b=b+'N' ;n '╬':b=b+'O' ;o '╧':b=b+'P' ;p '╨':b=b+'Q' ;r '╤':b=b+'R' ;s '╥':b=b+'S' ;t '╙':b=b+'T' ;u '╘':b=b+'U' ;f '╒':b=b+'V' ;h '╓':b=b+'W' ;c '╫':b=b+'X' ;ch '╪':b=b+'Y' ;sh '┘':b=b+'Z' ;shch '┌':b=b+'#' ;tw.znak '█':b=b+'[' ;y '▄':b=b+']' ;myagk.znak '▌':b=b+'%' ;e '▐':b=b+'"' ;yu '▀':b=b+'_' ;ya ;'!':b=b+'!' ;! else:b=b+temp ENDCASE endfor ENDIF ELSE BEGIN for j=0,N-1 do begin start1: if j ne 0 then prev=temp temp=strmid(x,j,1) if prev eq '!' then begin b=b+temp j=j+1 goto, start1 endif if temp eq 'z' then begin j=j+1 goto, start1 endif if prev eq 'z' then begin if temp eq 'h' then begin b=b+'g' j=j+1 goto, start1 endif else b=b+'h' ;z endif CASE temp OF 'a':b=b+'a' ;a 'b':b=b+'b' ;b 'v':b=b+'c' ;v 'g':b=b+'d' ;g 'd':b=b+'e' ;d 'e':b=b+'f' ;e 'q':b=b+'g' ;zh ;'z':b=b+'h' ;z 'i':b=b+'i' ;i 'j':b=b+'j' ;j 'k':b=b+'k' ;k 'l':b=b+'l' ;l 'm':b=b+'m' ;m 'n':b=b+'n' ;n 'o':b=b+'o' ;o 'p':b=b+'p' ;p 'r':b=b+'q' ;r 's':b=b+'r' ;s 't':b=b+'s' ;t 'u':b=b+'t' ;u 'f':b=b+'u' ;f 'h':b=b+'v' ;h 'c':b=b+'w' ;c 'c':b=b+'x' ;ch 's':b=b+'y' ;sh 's':b=b+'z' ;shch 'tz':b=b+'<' ;tw.znak 'y':b=b+'>' ;y 'mz':b=b+'@' ;myagk.znak 'e':b=b+'\' ;e 'y':b=b+'^' ;yu 'y':b=b+';' ;ya 'A':b=b+'A' ;a 'B':b=b+'B' ;b 'V':b=b+'C' ;v 'G':b=b+'D' ;g 'D':b=b+'E' ;d 'E':b=b+'F' ;e 'Q':b=b+'G' ;zh 'Z':b=b+'H' ;z 'I':b=b+'I' ;i 'J':b=b+'J' ;j 'K':b=b+'K' ;k 'L':b=b+'L' ;l 'M':b=b+'M' ;m 'N':b=b+'N' ;n 'O':b=b+'O' ;o 'P':b=b+'P' ;p 'R':b=b+'Q' ;r 'S':b=b+'R' ;s 'T':b=b+'S' ;t 'U':b=b+'T' ;u 'F':b=b+'U' ;f 'H':b=b+'V' ;h 'C':b=b+'W' ;c 'C':b=b+'X' ;ch 'S':b=b+'Y' ;sh 'S':b=b+'Z' ;shch 'TZ':b=b+'#' ;tw.znak 'Y':b=b+'[' ;y 'MZ':b=b+']' ;myagk.znak 'E':b=b+'%' ;e 'Y':b=b+'"' ;yu 'Y':b=b+'_' ;ya ;'!':b=b+'!' ;! else:b=b+temp ENDCASE endfor ENDELSE return,b+'!3' end ####################################################### function cyrconv, x, to_dos=to_dos, to_win=to_win b=(a=byte(x)) dos=[bindgen(48)+128b,bindgen(16)+224b] win=192b+bindgen(64) index_in=[bindgen(48)+128b,bindgen(16)+224b] index_out=192b+bindgen(64) if keyword_set(to_dos) then begin index_in=win index_out=dos endif else begin index_in=dos index_out=win endelse for j=0,63 do begin index=where(a eq index_in(j)) if index(0) ne (-1) then b(index)=index_out(j) endfor return,string(b) end ####################################################### ;$Id: c_correlate.pro,v 1.2 1994/11/29 20:51:52 beth Exp $ ; ; Copyright (c) 1994, Research Systems, Inc. All rights reserved. ; Unauthorized reproduction prohibited. ;+ ; NAME: ; C_CORRELATE ; ; PURPOSE: ; This function computes the cross correlation Pxy(L) or cross ; covariance Rxy(L) of two sample populations X and Y as a function ; of the lag (L). ; ; CATEGORY: ; Statistics. ; ; CALLING SEQUENCE: ; Result = C_correlate(X, Y, Lag) ; ; INPUTS: ; X: An n-element vector of type integer, float or double. ; ; Y: An n-element vector of type integer, float or double. ; ; LAG: A scalar or n-element vector, in the interval [-(n-2), (n-2)], ; of type integer that specifies the absolute distance(s) between ; indexed elements of X. ; ; KEYWORD PARAMETERS: ; COVARIANCE: If set to a non-zero value, the sample cross ; covariance is computed. ; ; EXAMPLE ; Define two n-element sample populations. ; x = [3.73, 3.67, 3.77, 3.83, 4.67, 5.87, 6.70, 6.97, 6.40, 5.57] ; y = [2.31, 2.76, 3.02, 3.13, 3.72, 3.88, 3.97, 4.39, 4.34, 3.95] ; ; Compute the cross correlation of X and Y for LAG = -5, 0, 1, 5, 6, 7 ; lag = [-5, 0, 1, 5, 6, 7] ; result = c_correlate(x, y, lag) ; ; The result should be: ; [-0.448655, 0.915846, 0.628814, -0.393466, -0.350169, -0.282198] ; ; PROCEDURE: ; See computational formula published in IDL manual. ; ; REFERENCE: ; INTRODUCTION TO STATISTICAL TIME SERIES ; Wayne A. Fuller ; ISBN 0-471-28715-6 ; ; MODIFICATION HISTORY: ; Written by: GGS, RSI, October 1994 ; ;- function cross_cov, x, y, m, nx ;Sample cross covariance function. xmean = total(x) / nx ymean = total(y) / nx t = lindgen(nx - m - 1L) return, total((x(t) - xmean) * (y(t + m) - ymean)) end function c_correlate, x, y, lag, covariance = covariance ;Compute the sample cross correlation or cross covariance of ;(Xt, Xt+l) and (Yt, Yt+l) as a function of the lag (l). on_error, 2 nx = n_elements(x) ny = n_elements(y) if nx ne ny then $ message, 'x and y must be vectors of equal length.' nlag = n_elements(lag) if nlag eq 1 then lag = [lag] ;Create a 1-element vector. xtype = size(x) ytype = size(y) if xtype(2) eq 5 or ytype(2) eq 5 then cross = dblarr(nlag) $ else cross = fltarr(nlag) if keyword_set(covariance) eq 0 then begin ;Compute Cross Correlation. for k = 0L, nlag-1 do begin if lag(k) ge 0 then $ cross(k) = cross_cov(x, y, lag(k), nx) / $ sqrt(cross_cov(x, x, 0L, nx) * cross_cov(y, y, 0L, ny)) $ else cross(k) = cross_cov(y, x, abs(lag(k)), ny) / $ sqrt(cross_cov(x, x, 0L, nx) * cross_cov(y, y, 0L, ny)) endfor endif else begin ;Compute Cross Covariance. for k = 0L, nlag-1 do begin if lag(k) ge 0 then $ cross(k) = cross_cov(x, y, lag(k), nx) / nx $ else cross(k) = cross_cov(y, x, abs(lag(k)), nx) / nx endfor endelse return, cross end ####################################################### pro c_table,n_colors common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr N=(!d.n_colors-1)/float(n_colors-1) xx=replicate(1,N) yy=xx*0 for j=1,n_colors do yy=[yy,N*j*xx] r_curr=yy g_curr=yy b_curr=yy tvlct,r_curr, g_curr, b_curr end ####################################################### function Date_string,Date,to_character=to_character, $ to_digit=to_digit ; Converts month in a date given as a string from number to name ; and reverse. Dateout='' Names=['Jan','Feb','Mar','Apr','May','Jun','Jul','Aug', $ 'Sep','Oct','Nov','Dec'] IF not keyword_set(to_digit) THEN BEGIN DateOut= $ strmid(Date,0,2)+' '+Names(strmid(Date,3,2)-1)+' 19'+strmid(Date,6,2) ENDIF ELSE BEGIN Month=strlowcase(strmid(date,3,3)) Number=where(Month eq strlowcase(Names))+1 if Number(0) eq 0 then begin print,'Incorrect input argument' & goto,exit endif Number=string(Number,format="(I2.2)") DateOut=strmid(Date,0,2)+' '+Number+' '+strmid(Date,9,2) ENDELSE exit: return,DateOut end ####################################################### PRO DAYCNV, XJD, YR, MN, DAY, HR ;+ ; NAME: ; DAYCNV ; PURPOSE: ; Converts julian dates to gregorian calendar dates ; ; CALLING SEQUENCE: ; DAYCNV, XJD, YR, MN, DAY, HR ; ; INPUTS: ; XJD = Julian date, double precision scalar or vector ; ; OUTPUTS: ; YR = Year (Integer) ; MN = Month (Integer) ; DAY = Day (Integer) ; HR = Hours and fractional hours (Real). If XJD is a vector, ; then YR,MN,DAY and HR will be vectors of the same length. ; ; EXAMPLE: ; IDL> DAYCNV, 2440000.D, yr, mn, day, hr ; ; yields yr = 1968, mn =5, day = 23, hr =12. ; ; WARNING: ; Be sure that the julian date is specified as double precision to ; maintain accuracy at the fractional hour level. ; ; REVISION HISTORY: ; Converted to IDL from Yeoman's Comet Ephemeris Generator, ; B. Pfarr, STX, 6/16/88 ;- On_error,2 if N_params() lt 2 then begin print,"Syntax - daycnv, xjd, yr, mn, day, hr print,' Julian date, xjd, should be specified in double precision return endif sz = size(xjd) ; Adjustment needed because Julian day starts at noon, calender day at midnight jd = long(xjd) ;Truncate to integral day frac = double(xjd) - jd + 0.5 ;Fractional part of calender day after_noon = where(frac ge 1.0, Next) if Next GT 0 then begin ;Is it really the next calender day? frac(after_noon) = frac(after_noon) - 1.0 jd(after_noon) = jd(after_noon) + 1 endif hr = frac*24.0 l = jd + 68569 n = 4*l / 146097l l = l - (146097*n + 3l) / 4 yr = 4000*(l+1) / 1461001 l = l - 1461*yr / 4 + 31 ;1461 = 365.25 * 4 mn = 80*l / 2447 day = l - 2447*mn / 80 l = mn/11 mn = mn + 2 - 12*l yr = 100*(n-49) + yr + l return end ####################################################### ;+ ; NAME: ; DB_FILTER ; PURPOSE: ; Given a Nobeyama AR database, a search criterion, and a range of ; the parameter, returns indices of those entries where the parameter ; is within the given range, or outside the range, if ; /INVERSE keyword is set. ; ; CATEGORY: ; CALLING SEQUENCE: ; ; index = db_filter(db,criter,range,dbout) ; ; INPUTS: ; db the AR database to filter ; criter the parameter of search: 'Name', 'Area', 'Type', ; 'Latitude', 'CarrLng','Longitude', 'Polarization', 'Tbr' ; Only first 4 letters are significant. ; CRITER is case-insensitive. ; range the range of parameter values ; ; OPTIONAL (KEYWORD) INPUT PARAMETERS: ; ; inverse if set, entries (or regions) OUTSIDE of given range are ; returned. ; exhaustive a name of the variable to receive two-dimensional ; index of the regions found (1st - number of the entry, ; 2nd - number of the active region) ; exlusively if set, only the active regions whose type match ; exactly to the given criterion are retrived. ; absolute_value if set, absolute value of the criterion range is used. ; follower if set, use criterion in follower region data ; map if set, use criterion for map peak data ; leader if set, use criterion in leader region data (default) ; type if criter="Polarization" or "Tbr" specifies which type ; of location the polarization and Tbr should ; be compared with range. Possible choices are: ; for Criterion='Tbr': ; type keyword selection ; II, IV map I or V range at I peak of map ; VI, VV map I or V range at V peak of map ; II, IV follower I or V range at I peak of follower ; VI, VV follower I or V range at V peak of follower ; II, IV leader I or V range at I peak of leader ; VI, VV leader I or V range at V peak of leader ; for Criterion='Polarization': ; type keyword selection ; I map Polarization at I peak of map ; V map Polarization at V peak of map ; I follower Polarization at I peak of follower ; V follower Polarization at V peak of follower ; I leader Polarization at I peak of leader ; V leader Polarization at V peak of leader ; ; ROUTINES CALLED: ; OUTPUTS: ; dbout a new AR database containing the selected subset ; ; OPTIONAL (KEYWORD) OUTPUT PARAMETERS: ; error - 1 if no entries found ; ; COMMENTS: ; SIDE EFFECTS: ; RESTRICTIONS: ; MODIFICATION HISTORY: ; Written 24 Nov 1996 by Dale E. Gary ;- function db_filter, db, criter, range, dbout, inverse=inverse, $ error=error, exhaustive=exhaustive, absolute_value=absolute_value, $ type=type, follower=follower, map=map, exclusively=exclusively, $ leader=leader, array=array ; ********************************************* if n_params() lt 3 then message,'Insufficient arguments' Criterion=strmid(strcompress(strupcase(criter), /rem),0,4) if n_elements(Range) gt 1 then RangeS=Range(sort(Range)) else RangeS=Range if n_elements(type) le 0 then begin if Criterion eq 'POLA' then p_type = 'I' if Criterion eq 'BRIG' then p_type = 'II' endif else p_type=strcompress(strupcase(type), /rem) CASE Criterion OF 'NAME': temp=db.region.name 'AREA': temp=db.region.area 'LONG': temp=db.region.location.lng 'LATI': temp=db.region.location.lat 'CARR': temp=db.region.carrlng 'TYPE': begin Sz=size(Range) var_type=Sz(Sz(0)+1) AR_type=['ALPHA', 'BETA', 'GAMMA', 'DELTA'] if var_type ne 7 then RangeS=AR_type(RangeS) RangeS=strcompress(strupcase(RangeS), /rem) ind=0 temp=strcompress(db.region.type, /rem) IF keyword_set(exclusively) THEN $ for j=0,n_elements(RangeS)-1 do ind=[ind, where(temp eq RangeS(j))] ELSE $ for j=0,n_elements(RangeS)-1 do ind=[ind, where(strpos(temp, RangeS(j)) ge 0)] ind=ind(1:*) ind=ind(sort(ind)) end 'POLA': begin CASE 1 OF keyword_set(follower): begin if p_type eq 'V' then $ temp=db.region.follower.vpeak.vtb/(db.region.follower.vpeak.itb > 100) else $ temp=db.region.follower.ipeak.vtb/(db.region.follower.ipeak.itb > 100) end keyword_set(map): begin if p_type eq 'V' then $ temp=db.map.vpeak.vtb/(db.map.vpeak.itb > 100) else $ temp=db.map.ipeak.vtb/(db.map.ipeak.itb > 100) end ELSE: begin if p_type eq 'V' then $ temp=db.region.leader.vpeak.vtb/(db.region.leader.vpeak.itb > 100) else $ temp=db.region.leader.ipeak.vtb/(db.region.leader.ipeak.itb > 100) end ENDCASE end 'BRIG': begin CASE 1 OF keyword_set(follower): begin CASE p_type OF 'IV': temp=db.region.follower.ipeak.vtb 'VI': temp=db.region.follower.vpeak.itb 'VV': temp=db.region.follower.vpeak.vtb ELSE: temp=db.region.follower.ipeak.itb ENDCASE end keyword_set(map): begin CASE p_type OF 'IV': temp=db.map.ipeak.vtb 'VI': temp=db.map.vpeak.itb 'VV': temp=db.map.vpeak.vtb ELSE: temp=db.map.ipeak.itb ENDCASE end ELSE: begin CASE p_type OF 'IV': temp=db.region.leader.ipeak.vtb 'VI': temp=db.region.leader.vpeak.itb 'VV': temp=db.region.leader.vpeak.vtb ELSE: temp=db.region.leader.ipeak.itb ENDCASE end ENDCASE end 'MAGN': begin CASE 1 OF keyword_set(follower): temp=db.region.follower.kgauss keyword_set(map): temp=db.map.kgauss ELSE: temp=db.region.leader.kgauss ENDCASE end ELSE: temp=db.region.name ENDCASE IF Criterion ne 'TYPE' THEN BEGIN if keyword_set(absolute_value) then temp=abs(temp) ind=where(temp ge RangeS(0) and temp le RangeS(n_elements(RangeS)-1)) ENDIF Length=n_elements(temp) error=ind(0) lt 0 N_db=n_elements(db) if error then begin if keyword_set(inverse) then Record=lindgen(N_db) else Record=0 exhaustive=[0,0] goto, Err0 endif M=Length/N_db index=transpose([[ind mod M],[ind/M]]) Record=transpose(index(1,*)) exhaustive=index if keyword_set(inverse) then begin AA=lonarr(Length) AA(ind)=1 ind=where(AA eq 0) index=transpose([[ind mod M],[ind/M]]) exhaustive=index AA=lonarr(N_db) AA(Record)=1 Record=where(AA eq 0) endif Record=Record(uniq(Record)) Err0: exhaustive=transpose(exhaustive([1,0],*)) if n_params() eq 4 then dbout=db(Record > 0) return, Record end ####################################################### function def_circle,x0,x1,x2 ;+ Returns 3-elementary array [x0,y0,radius] containing ; determining coordinates of the circle passing through ; three points (x0,x1,x2). These variables must be ;- the 2-elementary arrays. A1=x0(0)+x1(0) B1=x0(0)-x1(0) C1=x0(1)+x1(1) D1=x0(1)-x1(1) A2=x0(0)+x2(0) B2=x0(0)-x2(0) C2=x0(1)+x2(1) D2=x0(1)-x2(1) Centre=solve_ls([[B1,D1],[B2,D2]],[A1*B1+C1*D1,A2*B2+C2*D2]/2.) Radius=sqrt(((x0-Centre)(0))^2+((x0-Centre)(1))^2) return, [Centre,Radius] end ####################################################### pro def_SSRT ; Defines the new system variable !SSRT containing parameters of the ; instrument. Read_Only=1 DEFSYSV, "!SSRT",{SSRT, N:128, D:4.9D, De:2.5, $ Fi:51.7575D*!DPi/180, H:832.0, $ Lon:(102D0+13D0/60+16.5D0/3600)*!DPi/180}, Read_Only end ####################################################### pro def_uc ; Defines new system variable !UC containing some universal constants. Read_Only=1 help_string=[$ 'The system variable !UC contains universal physical constants that', $ 'have been measured in SI as well as in the Gaussian systems', $ '(the latter marked by the auxiliary indices "g", "ge" - CGSE, "gm" - CGSM).', $ ' ', $ ' The constants are as follows:', $ "C - the light velocity in vacuum, H - Plank's constant,", $ "k - Boltzmann's constant, e and me - the charge and mass", $ ' of an electron.'] DEFSYSV, "!UC",{Univ_Const, C:2.997925D8, Cg:2.997925D10, $ h:6.6252D-34, hg:6.6252D-27, k:1.38042D-23, kg:1.38042D-16, $ e:1.60207D-19, ege:4.80288D-10, egm:1.60207D-20, me:9.1085D-31, $ meg:9.1085D-28, help:help_string}, Read_Only ;; n=1.00027 end ####################################################### function deg_pol, i, v, threshold=threshold, range=db, filter=filter, $ width=width, min=min if n_elements(threshold) le 0 then Thres=400 else Thres=threshold ; the sensitivity of 400 K if n_elements(db) le 0 then db=-23 ; the dynamic range of 23 dB (NRH colleagues give ; -25 dB, I use -23 to ensure reliability if n_elements(width) le 0 then width=3 if n_elements(min) le 0 then Pmin=0.005 else Pmin=min ; threshold of degree of polarization d_Range=(10.^(-abs(dB)*0.1)) ; the dynamic range p=v / (i > Thres) < 1 > (-1) index=where(abs(v) lt Thres or i lt Thres) if index(0) ge 0 then p(index)=0 ; zeroes p, where either i, or v ; is less than 400 K ;index=where(abs(p) gt 1 or abs(p) lt Pmin) index=where(abs(p) lt Pmin) if index(0) ge 0 then p(index)=0 ; zeroes p, where it is >1 or < 2% vmax=max(abs(v)) imax=max(i) index=where(abs(v) lt vmax*d_Range or abs(i) lt imax*d_Range) if index(0) ge 0 then p(index)=0 ; zeroes p, where the dynamic range is ; greater than 23 dB if keyword_set(filter) then $ p=median(p,width) ; median filtering to suppress point ; defects like 'salt and pepper' return, p end ####################################################### pro dev_close common dev_sel, dev, X_save,Y_save,Z_save,P_save, name CASE dev OF 's': 'g': begin if n_elements(name) eq 1 then $ Filename=pickfile(filt='*.gif',file=name+'.gif') else $ Filename=pickfile(filt='*.gif') if Filename eq '' then begin print,'You have selected no file' return endif if (!d.flags and 2L^16) ne 0 then widget_control,/hourglass xxx=tvrd() write_gif,Filename,xxx xxx=0 end 'b': begin if n_elements(name) eq 1 then $ Filename=pickfile(filt='*.bmp',file=name+'.bmp') else $ Filename=pickfile(filt='*.bmp') if Filename eq '' then begin print,'You have selected no file' return endif if (!d.flags and 2L^16) ne 0 then widget_control,/hourglass xxx=tvrd() write_bmp,Filename,xxx xxx=0 end 'p': device,/close 'e': device,/close 'l': device,/close 'c': device,/close ELSE: message, 'Incorrect device input' ENDCASE if strlowcase(strmid(!Version.OS,0,3)) eq 'win' then set_plot, 'WIN' $ else set_plot,'X' !P=P_save !P.background=0 !P.color=!d.n_colors-1 !x.thick=(!y.thick=(!z.thick=1)) !P.thick=(!P.charthick=1.) !p.multi=0 end ####################################################### pro dev_sel,Filename,landscape=landscape,half=half, $ Xoffset=Xoffset, Yoffset=Yoffset, Xsize=Xsize, Ysize=Ysize, color=color, $ thick=thick, bits_per_pixel=bits, keep_color_table = keep common dev_sel, dev,X_save,Y_save,Z_save,P_save, name common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr if strlowcase(strmid(!Version.OS,0,3)) eq 'win' then Screen='WIN' else Screen='X' if n_elements(color) le 0 then color=0 nc = !d.table_size inp: dev='' read,'Output - screen (S), PS (P), EPS (E), CGM (C), PCL (L), GIF (G), BMP (B)?', dev if n_elements(bits) le 0 then bits=8 dev=strlowcase(dev) IF dev ne 'b' and dev ne 'g' then begin if n_elements(Filename) le 0 then begin Filename=pickfile(/write) if Filename eq '' then begin print,'You have selected no file' return endif endif name=(name_extract(Filename))(1) ENDIF if n_elements(name) le 0 then name=(name_extract(Filename))(1) X_save=!X Y_save=!Y Z_save=!Z P_save=!P CASE dev OF 's': begin set_plot,Screen device, get_screen=screen window,/free,xsi=screen(0)*0.9,ysi=screen(1)*0.9,tit=name thick=1. end 'g': begin set_plot,Screen window, /free,xsi=640,ysi=480,tit=name thick=1. end 'b': begin set_plot,Screen window, /free, xsi=640,ysi=480,tit=name thick=1. end 'p': begin set_plot,'PS' CASE 1 OF (keyword_set(half) eq 0) and (keyword_set(landscape) eq 0): $ begin if n_elements(Xsize) le 0 then Xsize=17.78 if n_elements(Xoffset) le 0 then Xoffset = (21.-Xsize)/2. ; Xoffset=1.905 if n_elements(Ysize) le 0 then Ysize=22.0 if n_elements(Yoffset) le 0 then Yoffset=(29.-Ysize)/2. ; 3.3+1.5 end keyword_set(half): $ begin if n_elements(Xsize) le 0 then Xsize=17.78 if n_elements(Xoffset) le 0 then Xoffset = (21.-Xsize)/2. ; Xoffset=1.905 if n_elements(Ysize) le 0 then Ysize=12.7 if n_elements(Yoffset) le 0 then Yoffset=(29.-Ysize)/2.+4. ; 12.7 end keyword_set(landscape): $ begin if n_elements(Xsize) le 0 then Xsize=24.13 if n_elements(Yoffset) le 0 then Yoffset=29-(29.-Xsize)/2. ; 0.905 if n_elements(Ysize) le 0 then Ysize=15.71 if n_elements(Xoffset) le 0 then Xoffset=(21.-Ysize)/2. ; 0.905; 27.035 end ELSE: ENDCASE if not(keyword_set(landscape)) then begin device, file=name+'.ps', xsize=Xsize, ysize=Ysize, Xoff=Xoffset, yoff=Yoffset, $ /port, color=color, encaps=0, bits=bits endif else begin device, file=name+'.ps', xsize=Xsize, ysize=Ysize, Xoff=Xoffset, yoff=Yoffset, $ /land, color=color, encaps=0, bits=bits endelse if n_elements(r_curr) gt 1 then tvlct, r_curr, g_curr, b_curr if n_elements(thick) le 0 then thick=3. end 'e': begin set_plot,'PS' CASE 1 OF (keyword_set(half) eq 0) and (keyword_set(landscape) eq 0): $ begin if n_elements(Xoffset) le 0 then Xoffset=1.905 if n_elements(Yoffset) le 0 then Yoffset=3.3+1.5 if n_elements(Xsize) le 0 then Xsize=17.78 if n_elements(Ysize) le 0 then Ysize=22.0 end keyword_set(half): $ begin if n_elements(Xoffset) le 0 then Xoffset=1.905 if n_elements(Yoffset) le 0 then Yoffset=12.7 if n_elements(Xsize) le 0 then Xsize=17.78 if n_elements(Ysize) le 0 then Ysize=12.7 end keyword_set(landscape): $ begin if n_elements(Xoffset) le 0 then Xoffset=0.905 if n_elements(Yoffset) le 0 then Yoffset=27.035 if n_elements(Xsize) le 0 then Xsize=24.13 if n_elements(Ysize) le 0 then Ysize=15.71 end ELSE: ENDCASE if not(keyword_set(landscape)) then begin device, file=name+'.eps', xsize=Xsize, ysize=Ysize, Xoff=Xoffset, yoff=Yoffset, $ /port,color=color, encaps=1, bits=bits endif else begin Yoffset=29-(29.-Xsize) device, file=name+'.eps', xsize=Xsize, ysize=Ysize, Xoff=Xoffset, yoff=Yoffset, $ /land,color=color, encaps=1, bits=bits endelse if n_elements(r_curr) gt 1 then tvlct, r_curr, g_curr, b_curr if n_elements(thick) le 0 then thick=3. end 'l': begin set_plot,'PCL' device,file=name+'.pcl',xsize=17.78,ysize=22.0,yoff=3.3 if n_elements(thick) le 0 then thick=3. end 'c': begin set_plot,'CGM' device,file=name+'.cgm' if n_elements(thick) le 0 then thick=3. end ELSE: begin print,'Incorrect input' goto,inp end ENDCASE if !d.name ne 'CGM' then begin !P.background=!d.n_colors-1 !P.color=0 endif !x.thick=(!y.thick=(!z.thick=thick)) !P.thick=(!P.charthick=thick) if keyword_set(keep) then begin nc1 = !d.table_size tvlct, interpolate(r_curr, findgen(nc1/(nc1-1)*nc)), $ interpolate(g_curr, findgen(nc1/(nc1-1)*nc)), $ interpolate(b_curr, findgen(nc1/(nc1-1)*nc)) print, 'Color table loaded.' endif end ####################################################### function dg_make_struct ; Set up structure definitions a = {peak, itb: 0.0, vtb: 0.0, x: 0, y: 0} a = {info, ipeak: {peak}, vpeak: {peak}, kgauss: 0} a = { AR, $ name: '',$ location: $ {pos, lat:0.0, lng:0.0, x:0, y:0},$ area: 0,$ type: '',$ ;kgauss: 0,$ leader: {info},$ follower: {info},$ carrlng: 0} rgns = replicate({AR},10) a = { entry, $ date: '',$ time: '',$ rsun: 0.0,$ b0: 0.0,$ pa: 0.0,$ centerpix: [0,0],$ pixsz: 0.0,$ map: {info},$ nar: 0,$ region: rgns} return,a end ####################################################### function difrot, Dt, Phi, hours=hours, seconds=seconds, $ days=days, degree=degree, radians=radians, latitude=latitude ; Calculates new longitude(s) of point(s) on the Sun according to ; the differential rotation. If the LATITUDE keyword parameter ; is present, then the rotation is performed for the solid body. if keyword_set(radians) then Kdeg=1. else Kdeg=!Dtor CASE 1 OF keyword_set(seconds): Ktime=1/24./3600. keyword_set(days): Ktime=1. ELSE: Ktime=1/24. ENDCASE if n_elements(latitude) le 0 then Lat=Phi else Lat=(Phi*0.+1)*latitude return,-(13.39-2.7*(sin(Kdeg*Lat))^2)*float(Dt)*Ktime*!Dtor/Kdeg end ####################################################### function disc,N,Radius,show=show z=0 a=findgen(2*N)*(!Pi*2/(2*N)) x=cos(a) y=sin(a) Centre=[N/2.,N/2.] x=x*Radius+Centre(0) y=y*Radius+Centre(1) xx=polyfillv(x,y,N,N) z=fltarr(N,N) z(xx)=255 if keyword_set(show) then begin window,/free,xsi=(N > 150),ysi=(N > 150),xpos=0,ypos=0 tv,z endif return,z end ####################################################### ;------------------------------------------------------------- ;+ ; NAME: ; DISKCENTER ; PURPOSE: ; Find center and radius of a disk in an image. ; CATEGORY: ; CALLING SEQUENCE: ; diskcenter, img, xc, yc, rd ; INPUTS: ; img = input image containing the disk. in ; KEYWORD PARAMETERS: ; Keywords: ; /GRID plots fit to disk. ; OUTPUTS: ; xc, yc = array indices of disk center. out ; rd = estimated radius of disk in pixels. out ; COMMON BLOCKS: ; NOTES: ; Note: Image is assumed 0 outside disk, non-zero inside. ; Also center of array must be inside the disk. ; MODIFICATION HISTORY: ; R. Sterner, 21 Feb, 1991 ; ; Copyright (C) 1991, Johns Hopkins University/Applied Physics Laboratory ; This software may be used, copied, or redistributed as long as it is not ; sold and this copyright notice is reproduced on each copy made. This ; routine is provided as is without any express or implied warranties ; whatsoever. Other limitations apply as described in the file disclaimer.txt. ;- ;------------------------------------------------------------- pro diskcenter, img, x0, y0, rd, help=hlp, grid=grid if (n_params(0) lt 1) or keyword_set(hlp) then begin print,' Find center and radius of a disk in an image.' print,' diskcenter, img, xc, yc, rd' print,' img = input image containing the disk. in' print,' xc, yc = array indices of disk center. out' print,' rd = estimated radius of disk in pixels. out' print,' Keywords:' print,' /GRID plots fit to disk.' print,' Note: Image is assumed 0 outside disk, non-zero inside.' print,' Also center of array must be inside the disk.' return endif ;-------- Image size -------- sz = size(img) nx = sz(1) ny = sz(2) ;-------- Estimates of center and radius -------- w = where(img(*,ny/2) ne 0) x0 = midv(w) rx = .5*(max(w) - min(w)) w = where(img(nx/2,*) ne 0) y0 = midv(w) ry = .5*(max(w) - min(w)) rd = .5*(rx + ry) ;-------- Plot grid ----------------- if keyword_set(grid) then begin plots, x0 + [-rd, -rd], y0 + [-rd, rd], /dev plots, x0 + [0, 0], y0 + [-rd, rd], /dev plots, x0 + [rd, rd], y0 + [-rd, rd], /dev plots, x0 + [-rd, rd], y0 + [-rd, -rd], /dev plots, x0 + [-rd, rd], y0 + [0, 0], /dev plots, x0 + [-rd, rd], y0 + [rd, rd], /dev endif return end ####################################################### function diskmask, dim, radius, center if n_elements(center) le 0 then center = (dim-1)*0.5 Ncir = 1024 argcir = findgen(Ncir)/(Ncir-1)*!pi*2 xcir = center[0] + cos(argcir)*radius ycir = center[1] + sin(argcir)*radius mask1 = intarr(dim[0], dim[1]) mask1[polyfillv(xcir, ycir, dim[0], dim[1])] = 1 return, mask1 end ####################################################### pro disk_free,Length Length=50000000L return if !version.OS ne 'windows' then begin Length = 50000000L return endif widget_control,/hourglass Fname='diskfree.dat' spawn,'dir > '+Fname Loop: REPEAT BEGIN Flag=(findfile(Fname))(0) ne '' wait,0.6 ENDREP UNTIL Flag if Flag then add_eof,Fname else goto,Loop tmp='' x=strarr(1000) j=0 openr,lun,Fname,/get_lun,/del while not EOF(lun) do begin readf,lun,tmp x(j)=tmp j=j+1 endwhile free_lun,lun x=x((j-4) > 0 : j) N=n_elements(x) pattern='bytes free' ; length=10 Found=0 for j=0,N-1 do begin current=x(j) len=strlen(current) index=where(byte(current) eq (byte('b'))(0)) for k=0,n_elements(index)-1 do $ if strmid(current,index(0),10) eq pattern then goto, Label endfor Label: x=strmid(current,0,index((k-1)>0)) first=(byte(strsplit(x)))(0,*) i0=where(first lt 48 or first gt 57) x=(strsplit(x))(i0(0)+1 > 0:*) xx='' for j=0,n_elements(x)-1 do xx=xx+x(j) x=xx y=strsplit(x) N=n_elements(y) if strpos(x,'.') ge 0 then begin y=strsplit(y(0),delim='.') N=n_elements(y)+2 endif else if strpos(x,',') ge 0 then begin y=strsplit(y(0),delim=',') N=n_elements(y)+2 endif j=0 Length='' ; while j lt N-2 do begin ;Length=Length+strcompress(y(j),/rem) ;j=j+1 ; endwhile REPEAT begin Length=Length+strcompress(y(j),/rem) j=j+1 endrep UNTIL j ge N-2 Length=long(Length) end ####################################################### function distance, x, y Szx=size(x) Szy=size(y) CASE 1 OF (Szx[0] eq 1) and (Szy[0] eq 1): R = sqrt(total((float(x)-y)^2)) (Szx[0] eq 2) and (Szy[0] eq 2): R = sqrt(total((float(x)-y)^2, 2)) (Szx[0] eq 1) and (Szy[0] eq 2): R = min(sqrt((float(x[0])-y[*,0])^2+(float(x[1])-y[*,1])^2)) (Szx[0] eq 2) and (Szy[0] eq 1): R = min(sqrt((float(x[*,0])-y[0])^2+(float(x[*,1])-y[1])^2)) else: message, 'Arrays are incompatible' ENDCASE return, R end ####################################################### pro draw_circle,centre,radius,noerase=noerase, $ axes=axes,color=color,a_color=a_color,linestyle=linestyle, $ a_linestyle=a_linestyle,thick=thick ; Draws a circle of a given radius and centre. if n_elements(noerase) le 0 then noerase=0 if n_elements(color) le 0 then color=!p.color if n_elements(thick) le 0 then thick=1 if n_elements(a_color) le 0 then a_color=!p.color if n_elements(linestyle) le 0 then linestyle=!p.linestyle if n_elements(a_linestyle) le 0 then a_linestyle=!p.linestyle N=(!d.x_vsize < !d.x_vsize)/2 t=findgen(N)*(!pi*2/(N-1)) x=sin(t) y=cos(t) x0=float(centre(0)-radius)/!d.x_vsize x1=float(centre(0)+radius)/!d.x_vsize y0=float(centre(1)-radius)/!d.y_vsize y1=float(centre(1)+radius)/!d.y_vsize ;plot,x,y,xst=5,yst=5,pos=[x0,y0,x1,y1]*0.9999,noerase=noerase, $ ; color=color,linestyle=linestyle,thick=thick plots,x*radius+centre(0),y*radius+centre(1),color=color,linestyle=linestyle,thick=thick,/dev;,noerase=noerase if keyword_set(axes) then begin xc=float(centre(0))/!d.x_vsize yc=float(centre(1))/!d.y_vsize plots,[xc,xc],[0,1],/nor,color=a_color,linestyle=a_linestyle plots,[0,1],[yc,yc],/nor,color=a_color,linestyle=a_linestyle endif end ####################################################### pro draw_marker,x,factor,color=color,device=device, $ data=data,normal=normal,left=left,right=right,up=up,down=down, $ fill=fill ; Draws a triangle-shaped marker. if n_params() lt 2 then factor=1. if n_elements(color) le 0 then color=!p.color y=x if keyword_set(data) then y=convert_coord(x,/data,/to_device) if keyword_set(normal) then y=convert_coord(x,/data,/to_normal) CASE 1 OF keyword_set(left): a=[[0,10,10,0],[0,-5,5,0]] keyword_set(right): a=[[-10,0,-10,-10],[-5,0,5,-5]] keyword_set(up): a=[[0,-5,5,0],[0,-10,-10,0]] keyword_set(down): a=[[0,-5,5,0],[0,10,10,0]] ELSE: a=[[0,10,10,0],[0,-5,5,0]] ENDCASE a=a*factor plots,y(0)+a(*,0),y(1)+a(*,1),/dev,color=color if keyword_set(fill) then $ polyfill,y(0)+a(*,0),y(1)+a(*,1),color=color,/dev end ####################################################### pro d_pol_event, ev common d_pol, I, V, P, ID, data if ev.ID eq ID.Draw then begin wset, ID.Win widget_control, ID.Label, set_val= $ string(ev.x, ev.y, I(ev.x, ev.y), V(ev.x, ev.y), P(ev.x, ev.y), format= $ "(i3, ', ', i3, ', ', 'I: ', g9.3, ' V: ', g10.3, ' V/I: ', g10.3)") return endif widget_control, ev.id, get_uval=uv, /hour CASE uv OF 'Done': begin widget_control, ev.top, /destr end 'Colors': xloadct 'Stokes I': begin wset, ID.Win tvscl, I end 'Stokes V': begin wset, ID.Win tvscl, V end 'Degree of polarization': begin if (size(P))(0) ne 2 then return wset, ID.Win tvscl, P end 'db': begin widget_control, ID.db, get_val=tmp data.db=-float(tmp(0)) widget_control, ID.db, set_val=string(-data.db, format='(f4.1)') end 'threshold': begin widget_control, ID.threshold, get_val=tmp data.threshold=float(tmp(0)) widget_control, ID.threshold, set_val=string(data.threshold, format='(g9.3)') end 'Level': begin widget_control, ID.Level, get_val=tmp data.Level=float(tmp(0)) widget_control, ID.Level, set_val=string(data.Level, format='(g9.3)') end 'Filter': begin widget_control, ID.Filter, get_val=tmp data.Filter=fix(tmp(0)) widget_control, ID.Filter, set_val=string(data.Filter, format='(i1)') end 'Width': begin widget_control, ID.Width, get_val=tmp data.Width=fix(tmp(0)) widget_control, ID.Width, set_val=string(data.Width, format='(i1)') end 'EXECUTE': begin wset, ID.Win p=deg_pol(i, v, threshold=data.threshold, range=data.db, filter=data.filter, $ width=data.width, min=data.level) tvscl, p end ELSE: ENDCASE empty end function d_pol, Stokes_I, Stokes_V common d_pol, I, V, P, ID, data ID={draw:0L, Win:0L, Label:0L, db:0L, Level:0L, width:0L, Threshold:0L, Filter:0L} data={threshold:400, db:(-23.), level:0.005, filter:0, width:3} Sz=size(Stokes_I) if Sz(0) ne 2 then message, 'Arrays must have 2 dimensions' if not equiv(Sz, size(Stokes_V)) then message, 'Incompatible arrays' I=Stokes_I V=Stokes_V mainbase=widget_base(tit='Degree of polarization', /colu) menubase=widget_base(mainbase, /row) rl_base=widget_base(mainbase, /row) leftbase=widget_base(rl_base, /colu) inputbase=widget_base(rl_base, /colu) button=widget_button(menubase, val='Done', uval='Done') button=widget_button(menubase, val='Colors', uval='Colors') button=widget_button(menubase, val='Array', /menu) button1=widget_button(button, val='Stokes I', uval='Stokes I') button1=widget_button(button, val='Stokes V', uval='Stokes V') button1=widget_button(button, val='Degree of polarization', uval='Degree of polarization') ID.Draw=widget_draw(leftbase, xs=Sz(1), ys=Sz(2), /motion) ID.label=widget_label(leftbase, /fra, val=' ') button=widget_button(inputbase, val='EXECUTE', uval='EXECUTE') label=widget_label(inputbase, val='dB:') ID.db=widget_text(inputbase, val=string(-data.db, format='(f4.1)'), uval='db', /edit, /fra) label=widget_label(inputbase, val='Thres.:') ID.threshold=widget_text(inputbase, val=string(data.threshold, format='(g9.3)'), $ uval='threshold', /edit, /fra) label=widget_label(inputbase, val='Level:') ID.Level=widget_text(inputbase, val=string(data.Level, format='(g9.3)'), $ uval='Level', /edit, /fra) label=widget_label(inputbase, val='Filter:') ID.Filter=widget_text(inputbase, val=string(data.Filter, format='(i1)'), $ uval='Filter', /edit, /fra) label=widget_label(inputbase, val='Width:') ID.Width=widget_text(inputbase, val=string(data.Width, format='(i1)'), $ uval='Width', /edit, /fra) widget_control, mainbase, /real, /hour widget_control, ID.Draw, get_val=tmp ID.Win=tmp wset, ID.Win p=deg_pol(i, v, threshold=data.threshold, range=data.db, filter=data.filter, $ width=data.width, min=data.level) tvscl, p empty xmanager, 'd_pol', mainbase, /modal return, p end ####################################################### pro edit_event, ev widget_control, ev.id, get_uval = uv widget_control, ev.top, get_uval = ID widget_control, ID.Menubase, get_uval = text widget_control, ID.TimeLabel, set_val = strmid(systime(), 11, 5) IF TAG_NAMES(ev, /STRUCTURE_NAME) EQ 'WIDGET_TIMER' THEN return CASE uv OF 'Done': widget_control, ev.top, /dest 'Save As': begin file = pickfile(filt=ID.Filt, /write, file = ID.File, path = subdir(ID.File)) if file eq '' then return openw, lun, file, /get for j=0, n_elements(text)-1 do printf, lun, text(j) free_lun, lun name = (name_extract(file))(0) widget_control, ID.Label, set_val = 'File '+name+' saved at '+strmid(systime(), 11, 5) end 'Save': begin if ID.File eq '' then return openw, lun, ID.file, /get for j=0, n_elements(text)-1 do printf, lun, text(j) free_lun, lun name = (name_extract(ID.file))(0) widget_control, ID.Label, set_val = 'File '+name+' saved at '+strmid(systime(), 11, 5) end 'Open': begin file = pickfile(filt=ID.Filt, /read) if file eq '' then return ID.File = file text = readform(file) widget_control, ID.Text, set_val = text name = (name_extract(ID.file))(0) widget_control, ID.Label, set_val = 'File: '+name widget_control, ID.Edit, sens = 1 end 'Text': begin ;KBRD_FOCUS_EVENTS, TEXT_ALL_EVENTS, TEXT_EDITABLE, TEXT_NUMBER, ;TEXT_OFFSET_TO_XY, TEXT_SELECT, TEXT_TOP_LINE, TEXT_XY_TO_OFFSET. widget_control, ev.id, get_val = text number = widget_info(ev.id, /text_number) Ntext = n_elements(text) Len = long(total(strlen(text) + 1, /cum)) NLine = (where(Len gt ev.offset))(0) if NLine eq -1 then Nline = Ntext Ncolumn = ev.offset-Len(NLine-1>0) > 0 if Nline eq 0 then Ncolumn = ev.offset widget_control, ID.Line_number, set_val = $ string(Nline, Ncolumn, format = '("Line: ", i5, ", Column: ", i5)') widget_control, ID.Edit, sens = 1 end 'Find': begin xinput, frag, tit = 'Enter search substring' Ntext = n_elements(text) for j = 0, Ntext-1 do begin if j eq 0 then bytetext = [byte(text(j))] else bytetext = [bytetext, byte(text(j))] endfor bytetext = byte(text) ;help, bytetext bytetext = reform(bytetext, n_elements(bytetext)) bytetext = bytetext(where(bytetext ne 0)) bytefrag = byte(frag) Length = n_elements(bytefrag) ind = where(bytetext eq bytefrag(0)) Ntext = n_elements(text) Len = long(total(strlen(text) + 1, /cum)) ;NLine = (where(Len gt ev.offset))(0) ;if NLine eq -1 then Nline = Ntext if ind(0) lt 0 then a = widget_message(/info, 'Not found') else begin nind = n_elements(ind) for j=0, nind-1 do begin if equiv(bytefrag, bytetext(ind(j):ind(j)+Length-1)) then begin Nline = (where(Len gt ind(j)))(0) widget_control, ID. Text, set_text_select = [ind(j)+NLine, Length] ;widget_control, ID. Text, set_text_select = [ind(j), Length] print, string(bytetext(ind(j):ind(j)+Length-1)) return endif endfor endelse end 'Wrap': begin if ev.select eq 1 then text = short_string(text, ID.Length) widget_control, ID. Text, set_val = text end 'Length': begin widget_control, ID.Length_Input, get_val = tmp ID.Length = fix(tmp(0)) widget_control, ID.Length_Input, set_val = strtrim(ID.Length,2) end ELSE: ENDCASE if uv ne 'Done' then begin widget_control, ev.top, set_uval = ID widget_control, ID.Menubase, set_uval = text endif end pro edit ID = {Menubase:0L, Text:0L, file:'', filt: './*', Label:0L, TimeLabel:0L, $ Line_number:0L, Edit:0L, Find:0L, Wrap:0, Length_Input:0L, Length:80} text = '' ; widget_info: ;KBRD_FOCUS_EVENTS, TEXT_ALL_EVENTS, TEXT_EDITABLE, TEXT_NUMBER, ;TEXT_OFFSET_TO_XY, TEXT_SELECT, TEXT_TOP_LINE, TEXT_XY_TO_OFFSET. font = '-b&h-lucida bright-demibold-r-normal--14-140-72-72-p-84-iso8859-1' font = '-adobe-courier-bold-r-normal--14-140-75-75-m-90-iso8859-1' if strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then font = '' mainbase = widget_base(/colu, tit = 'Text editor') ID.Menubase = widget_base(mainbase, /row) button = widget_button(ID.Menubase, val = 'Done', uval = 'Done') button = widget_button(ID.Menubase, val = 'File', /menu) button1 = widget_button(button, val = 'Open', uval = 'Open') button1 = widget_button(button, val = 'Save', uval = 'Save') button1 = widget_button(button, val = 'Save As', uval = 'Save As') nonexcl_base = widget_base(ID.Menubase, /row, /nonexcl) button = widget_button(nonexcl_base, val = 'Wrap', uval = 'Wrap') ID.Length_Input = widget_text(ID.Menubase, /edit, xsiz = 5, ysiz = 1, /fra, $ val = strtrim(ID.Length,2), uval = 'Length') ID.Edit = widget_button(ID.Menubase, val = 'Edit', /menu) button1 = widget_button(ID.Edit, val = 'Find', uval = 'Find') ID.Find = widget_text(ID.Menubase, /edit, /fra, xs = 20, ys = 1, uval = 'Find_Input') ID.Label = widget_label(ID.Menubase, val = 'No file', /dynam, /frame) ID.TimeLabel = widget_label(ID.Menubase, val = strmid(systime(), 11, 5), /frame) device, get_scr = scr ID.Text = widget_text(mainbase, /edit, /fra, xs = 100, ys = 40, uval = 'Text', /scroll, $ /all_eve, font = font) ;, /KBRD_FOCUS_EVENTS) ID.Line_number = widget_Label(mainbase, /dynam, /frame) widget_control, mainbase, /real widget_control, mainbase, set_uval = ID, timer =60. widget_control, ID.Menubase, set_uval = text widget_control, ID.Text, /input widget_control, ID.Edit, sens = 0 xmanager, 'edit', mainbase, /no_block end ####################################################### function emptyticks, n_ticks, scalar = scalar if n_elements(n_ticks) le 0 then n_ticks = 20 if not keyword_set(scalar) then return, string(replicate('20'xb, 1, n_ticks)) $ else return, string(replicate('20'xb, n_ticks)) end ####################################################### function equiv,a,b ; Returns scalar 1 if input variables of any but the same type ; are equal and scalar 0 if not. c = where((a ne b),count) c=(count eq 0) return,c end ####################################################### function even,x ; Returns 0 if input value is even and 1 if odd. return,(x and 1) end ####################################################### pro ewsn_tv_draw Common Exch_ewsn_view,ID,V_ewsn,Surfs,Tvs,Setting,Scales,P_save,Bad_channels WIDGET_CONTROL,/hour !x.margin=[10,3] & !y.margin=[4,2] wset,V_ewsn.Win(0) if V_ewsn.EW then begin temp=V_ewsn.IEW if Bad_channels(0) ne 0 then temp([Bad_channels],*)=0 tv_axes,temp,scale=Tvs.scale, yfac=Tvs.yfactor, $ sam=Tvs.sample, neg=Tvs.negative,font=0 endif else plot,indgen(192)+1,/nodata,xstyle=4,ystyle=4 scale,temp,/mem & Scales.TvEW=temp wset,V_ewsn.Win(2) & xyouts,0.01,0.01,'E-W',/norm,font=0 wset,V_ewsn.Win(1) if V_ewsn.SN then begin tv_axes,V_ewsn.ISN,scale=Tvs.scale, yfac=Tvs.yfactor, $ sam=Tvs.sample, neg=Tvs.negative,font=0 endif else plot,indgen(192)+1,/nodata,xstyle=4,ystyle=4 scale,temp,/mem & Scales.TvSN=temp wset,V_ewsn.Win(3) & xyouts,0.01,0.01,'S-N',/norm,font=0 empty !x.margin=[10,3] & !y.margin=[4,2] end pro ewsn_view_cl_u,x Common Exch_ewsn_view,ID,V_ewsn,Surfs,Tvs,Setting,Scales,P_save,Bad_channels !P=P_save !x.margin=[10,3] & !y.margin=[4,2] loadct,0 if ID.group_leader ne 0 then if widget_info(ID.group_leader,/valid) $ then widget_control,ID.group_leader,/show if Setting.Restart then alt else begin ID=(V_ewsn=(Surfs=(Tvs=(Setting=(P_save=0))))) endelse end pro ewsn_view_event,ev Common Exch_ewsn_view,ID,V_ewsn,Surfs,Tvs,Setting,Scales,P_save,Bad_channels ;************** PROCESS DRAWABLE EVENTS *************** FOR j=0,4 DO IF ev.id eq ID.View(j) THEN BEGIN if ev.press then V_ewsn.press=1 ;Pressed button? if ev.release then V_ewsn.press=0 ;Released button? ENDIF IF ev.id eq ID.View(0) THEN BEGIN Window_set,V_ewsn.Win(0),scale=Scales.TvEW if V_ewsn.press then begin X_mark=(convert_coord(Setting.N_channels+10, 0, /DATA, /TO_DEVICE))(0) draw_marker,[X_mark,V_ewsn.Marker],col=!P.Background, 0.8, /left, /fill, /dev draw_marker,[X_mark,ev.y],col=!P.color, 0.8, /left, /fill, /dev if V_ewsn.SN then begin Window_set,V_ewsn.Win(1),scale=Scales.TvSN draw_marker,[X_mark,V_ewsn.Marker],col=!P.Background, 0.8, /left, /fill, /dev draw_marker,[X_mark,ev.y],col=!P.color, 0.8, /left, /fill, /dev Window_set,V_ewsn.Win(0),scale=Scales.TvEW endif V_ewsn.Marker=ev.y p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) N=string(p(1) > 0L < (V_ewsn.LengthEW-1),format='(I5)') V_ewsn.number=long(N) V_ewsn.Last='E-W' WIDGET_CONTROL,ID.Timelabel,set_val=time_outvalue(V_ewsn.number, $ time=V_ewsn.time_sec, Dt=Setting.Dt*V_ewsn.multi)+', '+strtrim(fix(p(0)),2) endif return ENDIF IF ev.id eq ID.View(1) THEN BEGIN Window_set,V_ewsn.Win(1),scale=Scales.TvSN if V_ewsn.press and V_ewsn.SN then begin X_mark=(convert_coord(Setting.N_channels+10, 0, /DATA, /TO_DEVICE))(0) draw_marker,[X_mark,V_ewsn.Marker],col=!P.Background, 0.8, /left, /fill, /dev draw_marker,[X_mark,ev.y],col=!P.color, 0.8, /left, /fill, /dev Window_set,V_ewsn.Win(0),scale=Scales.TvEW draw_marker,[X_mark,V_ewsn.Marker],col=!P.Background, 0.8, /left, /fill, /dev draw_marker,[X_mark,ev.y],col=!P.color, 0.8, /left, /fill, /dev Window_set,V_ewsn.Win(1),scale=Scales.TvSN V_ewsn.Marker=ev.y p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) N=string(p(1) > 0L < (V_ewsn.LengthSN-1),format='(I5)') V_ewsn.number=long(N) V_ewsn.Last='S-N' WIDGET_CONTROL,ID.Timelabel,set_val=time_outvalue(V_ewsn.number, $ time=V_ewsn.time_sec, Dt=Setting.Dt*V_ewsn.multi)+', '+strtrim(fix(p(0)),2) endif return ENDIF IF ev.id eq ID.View(2) THEN return IF ev.id eq ID.View(3) THEN return IF ev.id eq ID.View(4) THEN BEGIN Window_set,V_ewsn.Win(4),scale=Scales.Time p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) Length=n_elements(V_ewsn.TimeRecord) N=long(p(0)+0.5) > 0 < (Length-1) WIDGET_CONTROL,ID.UTimeLabel,set_val=' '+smh(V_ewsn.TimeRecord(N),ms=3) if V_ewsn.press then begin Time_array=['Utime:','',smh(V_ewsn.TimeRecord(N),ms=3),''] Interval=['Interval:','',''] CASE N OF 0: begin Time_array(1)=' BEGIN' Time_array(3)=smh(V_ewsn.TimeRecord(N+1),ms=3) Interval(2)=string(V_ewsn.TimeRecord(N+1)-V_ewsn.TimeRecord(N),format="(F7.3)") end Length-1: begin Time_array(1)=smh(V_ewsn.TimeRecord(N-1),ms=3) Time_array(3)=' END' Interval(1)=string(V_ewsn.TimeRecord(N)-V_ewsn.TimeRecord(N-1),format="(F7.3)") end ELSE: begin Time_array(1)=smh(V_ewsn.TimeRecord(N-1),ms=3) Interval(1)=string(V_ewsn.TimeRecord(N)-V_ewsn.TimeRecord(N-1),format="(F7.3)") Interval(2)=string(V_ewsn.TimeRecord(N+1)-V_ewsn.TimeRecord(N),format="(F7.3)") Time_array(3)=smh(V_ewsn.TimeRecord(N+1),ms=3) end ENDCASE WIDGET_CONTROL,ID.UTime,set_val=Time_array WIDGET_CONTROL,ID.Interval,set_val=Interval endif return ENDIF ; *************** OTHER EVENTS ************* CASE !version.os OF 'windows': delim='\' 'Win32': delim='\' ELSE: delim='/' ENDCASE WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "Done": WIDGET_CONTROL,ev.top,/DESTROY "Help": begin CASE !version.os OF 'windows': delim='\' 'Win32': delim='\' ELSE: delim='/' ENDCASE xtext,file=getenv('help_dir')+Delim+'ewsn.hlp',group=ev.top end "Load": begin WIDGET_CONTROL,/hourglass start=Setting.start & stop=Setting.stop bounds=Setting.bounds & Length=Setting.Length Dt=Setting.Dt & N_scans=Setting.N_scans IF Setting.Filename ne Setting.Deleted_File THEN BEGIN Filename=Setting.Filename & current_file=Setting.current_file ENDIF ELSE BEGIN Filename='' & current_file=0 ENDELSE fread,iew=iew,vew=vew,isn=isn,vsn=vsn, time_sec=time_sec,$ group_leader=ev.top,date=date,Length=Length, $ start=start,stop=stop,bounds=bounds,multi=multi,cancel=cancel, $ Filename=Filename,current_file=current_file,Dt=Dt,Fileformat=Fileformat if cancel then return N_scans=1L*(Fileformat(0) eq 'fdas')+32L*(Fileformat(0) eq 'aor') N_channels=176*(Fileformat(0) eq 'fdas')+192*(Fileformat(0) eq 'aor') Bad_channels=[0] Setting={start:start, stop:stop, bounds:bounds, Length:Length, $ Filename:Filename, current_file:1, N_scans:N_scans, $ Dt:Dt,Fileformat:Fileformat,N_channels:N_channels,Lang:Setting.Lang, $ Deleted_File:Setting.Deleted_File,Stokes:'Iew', Restart:Setting.Restart} if Fileformat(0) eq 'aor' then time_sec=time_sec+Setting.Dt*(Setting.start+(multi-1)/2) time_bounds=[time_sec(0),time_sec(n_elements(time_sec)-1)+(Setting.N_scans-1)*Setting.Dt] time=smh(time_sec(0),/str,ms=3) SUN=V_ewsn.SUN & suneph,date,time,SUN sn=(n_elements(isn) gt 1) LengthEW=(Size(iew))(2) & LengthSN=LengthEW *sn WIDGET_CONTROL,ID.ButtonIsn,sens=SN WIDGET_CONTROL,ID.ButtonVsn,sens=SN IF Fileformat(0) eq 'fdas' THEN BEGIN Chan_File=(findfile(getenv('spk_dat')+Delim+'00'+strcompress(Date,/remove_all)+'.cha'))(0) WIDGET_CONTROL,ID.Base1_toggle,MAP=1 IF Chan_File eq '' THEN BEGIN xwarning, [' File 00'+strcompress(date,/remove_all)+'.cha not found', $ 'All the channels are considered', ' as operatable'],/modal WIDGET_CONTROL,ID.Bad_channels,set_val=['Bad Channels:','???'] WIDGET_CONTROL,ev.top,/show ENDIF ELSE BEGIN Chan_File=subdir(Filename)+Delim+Chan_File openr,lun_c,Chan_File,/get_lun status=fstat(lun_c) N_bad_chan=(status.size-42)/18 data=intarr(2,N_bad_chan) emptystring='' readf,lun_c,emptystring readf,lun_c,emptystring readf,lun_c,data free_lun,lun_c i_Bad_channels=where(Data(1,*)) Bad_channels=Data(0,sort(Data(0,i_Bad_channels))) Bad_channels =reform(Bad_channels,n_elements(Bad_channels)) WIDGET_CONTROL,ID.Bad_channels,set_val=['Bad Channels:',strtrim(Bad_channels,2)] ENDELSE ENDIF ELSE WIDGET_CONTROL,ID.Base1_toggle,MAP=0 V_ewsn={Win:V_ewsn.Win, ew:1, sn:sn, $ iew:temporary(iew), vew:temporary(vew),$ isn:temporary(isn), vsn:temporary(vsn), TimeRecord:[0D0,0D0], $ time_sec:temporary(time_sec), surf:0, SUN:SUN, $ press:V_ewsn.press, number:0L, multi:multi, $ LengthEW:LengthEW, LengthSN:LengthSN,Last:'E-W', Marker:V_ewsn.Marker} WIDGET_CONTROL,ID.Surfmode,SENS=0 WIDGET_CONTROL,ID.ButSurf,set_but=0 WIDGET_CONTROL,ID.Datelabel,set_val=Date_string(Date) WIDGET_CONTROL,ID.Timelabel,set_val=time_outvalue(V_ewsn.number, $ time=V_ewsn.time_sec, Dt=Setting.Dt*V_ewsn.multi) for j=0,3 do begin & wset,V_ewsn.Win(j) & erase & end ewsn_tv_draw WIDGET_CONTROL,ID.ButSN,set_but=V_ewsn.SN,sens=V_ewsn.SN,/hour wset,V_ewsn.win(3) IF (V_ewsn.surf and V_ewsn.SN) THEN BEGIN surface,V_ewsn.isn,/ho scale,temp,/mem & Scales.SurfSN=temp ENDIF xyouts,0.01,0.01,'S-N',/norm,font=0 wset,V_ewsn.win(2) IF (V_ewsn.surf and V_ewsn.EW) eq 1 THEN BEGIN surface,V_ewsn.iew,/ho scale,temp,/mem & Scales.SurfEW=temp ENDIF xyouts,0.01,0.01,'E-W',/norm,font=0 empty end "Calculator": begin WIDGET_CONTROL,/hour & wcalc end "Parameters": begin WIDGET_CONTROL,/hour param_ssrt,V_ewsn.SUN.date,V_ewsn.SUN.time,1 end "OS": spawn "VC": spawn,'vc' "NC": spawn,'nc' "Archiver": begin WIDGET_CONTROL,/hour pushd,getenv('spk_dat') spawn,'rar' WIDGET_CONTROL,/hour popd end "Delete": begin a='' WIDGET_CONTROL,/hour xdelfile,a,path=getenv('spk_dat') Setting.Deleted_File=a WIDGET_CONTROL,ev.top,/show end "XMTool": begin WIDGET_CONTROL,/hour XMTool,group=ev.top end "Xloadct": begin WIDGET_CONTROL,/hour Xloadct,group=ev.top end "Size": begin WIDGET_CONTROL,/hour N=10+15*(Setting.Fileformat(0) eq 'fdas') if V_ewsn.Last eq 'E-W' then input= $ V_ewsn.iew(*,(V_ewsn.number-N > 0):(V_ewsn.number+N < ((size(V_ewsn.iew))(2)-1))) $ else input= $ V_ewsn.isn(*,(V_ewsn.number-N > 0):(V_ewsn.number+N < ((size(V_ewsn.isn))(2)-1))) source_size,Output, input=input,Date=V_ewsn.SUN.Date, $ Receiver=(Setting.Fileformat(0) eq 'aor'), Dt=Setting.Dt*V_ewsn.multi, $ interf=V_ewsn.Last,group=ev.top, $ time=time_outvalue(V_ewsn.number-N > 0, time=V_ewsn.time_sec, $ Dt=Setting.Dt*V_ewsn.multi) end "Coordinates": begin WIDGET_CONTROL,/hour if (size(V_ewsn.iew)) (0) gt 1 then iew=V_ewsn.iew(*,V_ewsn.number) else iew=0 if (size(V_ewsn.vew)) (0) gt 1 then vew=V_ewsn.vew(*,V_ewsn.number) else vew=0 if (size(V_ewsn.isn)) (0) gt 1 then isn=V_ewsn.isn(*,V_ewsn.number) else isn=0 if (size(V_ewsn.vsn)) (0) gt 1 then vsn=V_ewsn.vsn(*,V_ewsn.number) else vsn=0 source,output,Date=V_ewsn.SUN.Date, Rec=(Setting.Fileformat(0) eq 'aor'), $ iew=iew,vew=vew, isn=isn,vsn=vsn, group=ev.top, $ time=time_outvalue(V_ewsn.number, time=V_ewsn.time_sec, Dt=Setting.Dt*V_ewsn.multi) end "E-W": begin V_ewsn.EW=ev.select IF (V_ewsn.surf and V_ewsn.EW) THEN BEGIN WIDGET_CONTROL,/hour wset,V_ewsn.win(2) & surface,V_ewsn.iew,/ho scale,temp,/mem & Scales.SurfEW=temp xyouts,0.01,0.01,'E-W',/norm,font=0 & empty ENDIF end "S-N": begin V_ewsn.SN=ev.select IF (V_ewsn.surf and V_ewsn.SN) THEN BEGIN WIDGET_CONTROL,/hour wset,V_ewsn.win(3) & surface,V_ewsn.isn,/ho scale,temp,/mem & Scales.SurfSN=temp xyouts,0.01,0.01,'S-N',/norm,font=0 & empty ENDIF end "Surf": begin V_ewsn.surf=ev.select WIDGET_CONTROL,ID.Surfmode,SENS=V_ewsn.surf WIDGET_CONTROL,/hour IF (V_ewsn.surf and V_ewsn.EW) THEN BEGIN wset,V_ewsn.win(2) & surface,V_ewsn.iew,/ho scale,temp,/mem & Scales.SurfEW=temp xyouts,0.01,0.01,'E-W',/norm,font=0 ENDIF IF (V_ewsn.surf and V_ewsn.SN) THEN BEGIN wset,V_ewsn.win(3) & surface,V_ewsn.isn,/ho scale,temp,/mem & Scales.SurfSN=temp xyouts,0.01,0.01,'S-N',/norm,font=0 ENDIF empty end "Interpolate": begin Tvs.yfactor=-1 & Tvs.sample=0 & ewsn_tv_draw & end "Sample": begin Tvs.yfactor=-1 & Tvs.sample=1 & ewsn_tv_draw & end "Scale": begin & Tvs.scale=1 & ewsn_tv_draw & end "No scaling": begin & Tvs.scale=0 & ewsn_tv_draw & end "Natural": begin & Tvs.yfactor=1 & ewsn_tv_draw & end "Negative": begin & Tvs.negative=1 & ewsn_tv_draw & end "Positive": begin & Tvs.negative=0 & ewsn_tv_draw & end "Align": begin WIDGET_CONTROL,/hourglass for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([0,1])(j) for j=0,2 do WIDGET_CONTROL,ID.ProcessBase(j),MAP=([0,0,1,0])(j) Receiver=(Setting.Fileformat(0) eq 'aor') Length=(Size(V_ewsn.iew))(2) ;goto,obhod00 dir=0 ; E-W Time=smh(V_ewsn.time_sec(0)+Setting.Dt*Length/2,ms=3) SUN=V_ewsn.SUN suneph,SUN.Date,Time,SUN Df0=chanfreq(Setting.N_channels,Receiver)-chanfreq(1,Receiver) F0=(chanfreq(Setting.N_channels,Receiver)+chanfreq(1,Receiver))/2. df=Df0/(Setting.N_channels-1) C_shift0=F0*SUN.W0/df Time_array=(dindgen(Length)-0.5*Length)*Setting.Dt Hour_angle=Time_array*SUN.W0+SUN.H C_shift=long(C_shift0/(tan(Hour_angle))*Time_array) x=V_ewsn.iew ; & y=V_ewsn.vew for i=0,Length-1 do x(*,i)=shift(x(*,i), c_shift(i)) ;if n_elements(vew) gt 1 then $ ; for i=0,Length-1 do y(*,i)=shift(y(*,i), c_shift(i)) ;ewsn_tv_draw obhod00: wset,V_ewsn.Win(5) tv_axes,x,scale=Tvs.scale, yfac=Tvs.yfactor, $ sam=Tvs.sample, neg=Tvs.negative,font=0 end "View/Process": for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([0,1])(j) "View": begin for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([0,1])(j) for j=0,3 do WIDGET_CONTROL,ID.ProcessBase(j),MAP=([0,0,0,1])(j) end "View_Iew": Setting.Stokes='Iew' "View_Vew": Setting.Stokes='Vew' "View_Isn": Setting.Stokes='Isn' "View_Vsn": Setting.Stokes='Vsn' "OK_View": CASE Setting.Stokes OF 'Iew': array_view,V_ewsn.Iew,group=ev.top,/no_file,/image 'Vew': array_view,V_ewsn.Vew,group=ev.top,/no_file,/image 'Isn': array_view,V_ewsn.Isn,group=ev.top,/no_file,/image 'Vsn': array_view,V_ewsn.Vsn,group=ev.top,/no_file,/image ELSE: ENDCASE "Quit1": for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([1,0])(j) "Help1": begin for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([0,1])(j) for j=0,3 do WIDGET_CONTROL,ID.ProcessBase(j),MAP=([1,0,0,0])(j) end "Time record": begin for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([0,1])(j) for j=0,2 do WIDGET_CONTROL,ID.ProcessBase(j),MAP=([0,1,0,0])(j) WIDGET_CONTROL,/hourglass readfile,FileName=Setting.FileName,bounds=[0L,100000L],$ time=time, attr=attr, multi=1,date=date V_ewsn={Win:V_ewsn.Win, ew:V_ewsn.ew, sn:V_ewsn.sn, $ iew:V_ewsn.iew, vew:V_ewsn.vew, isn:V_ewsn.isn, vsn:V_ewsn.vsn, $ TimeRecord:temporary(time), $ time_sec:V_ewsn.time_sec, surf:V_ewsn.surf, SUN:V_ewsn.SUN, $ press:V_ewsn.press, number:V_ewsn.number, multi:V_ewsn.multi, $ LengthEW:V_ewsn.LengthEW, LengthSN:V_ewsn.LengthSN, $ Last:V_ewsn.Last, Marker:V_ewsn.Marker} wset,V_ewsn.Win(4) N=n_elements(V_ewsn.TimeRecord) Delta_t=Setting.Dt*Setting.N_scans !x.margin=[10,3] & !y.margin=[4,2] plot,V_ewsn.TimeRecord-V_ewsn.TimeRecord(0), $ Psym=-8,symsize=0.5,font=0, /noclip, ymargin=[5,2], $ title='Time record in the file '+(name_extract(Setting.Filename))(0), $ xtitle='Record number',subtitle='Ordinates - difference with initial time (sec)' scale,temp,/mem & Scales.Time=temp oplot,findgen(N)/(N-1)*(V_ewsn.TimeRecord(N-1)-V_ewsn.TimeRecord(0)),color=100 for j=1,N-1 do oplot,[j],[Delta_t*j],Psym=8,symsize=0.25,color=100,/noclip x=0.7 & y0=0.3 & y1=y0+0.05 Xoplot0=(convert_coord([x+0.05,y0],/norm,/to_data))([0,1]) Xoplot1=(convert_coord([x+0.05,y1],/norm,/to_data))([0,1]) plots,[x,x+0.1],[y0,y0],/norm,color=100 plots,[x,x+0.1],[y1,y1],/norm,color=!P.color oplot,[Xoplot0(0)],[Xoplot0(1)],Psym=8,symsize=0.5,color=100 oplot,[Xoplot1(0)],[Xoplot1(1)],Psym=8,symsize=0.5,color=!P.color xyouts,x+0.12,y0,/norm,'Right',font=0,color=100 xyouts,x+0.12,y1,/norm,'Actual',font=0,color=!P.color empty end "Language": begin Lang_def Setting.Restart=1 widget_control,ev.top,/destroy end ELSE: ENDCASE end ;************************************* pro ewsn_view,iew,isn,group_leader=group_leader Common Exch_ewsn_view,ID,V_ewsn,Surfs,Tvs,Setting,Scales,P_save,Bad_channels if xregistered('ewsn_view') then return if n_elements(group_leader) le 0 then group_leader=0 loadct,0,/silent circ,/fill Bad_channels=[0] Date='01 01 00' multi=1 Length=(start=(stop=0L)) bounds=[0L,0L] ew=0 isn=(sn=(n_params() gt 1)) Setting={start:start, stop:stop, bounds:bounds, Length:Length, $ Filename:'', current_file:0, N_scans:1L, Dt:0.056d0, Lang:0, $ Fileformat:['aor','0'],N_channels:192,Deleted_File:'',Stokes:'Iew', $ restart:0} goto,obhod if n_elements(iew) le 0 then begin fread,iew=iew,vew=vew,isn=isn,vsn=vsn, date=date,time_sec=time_sec,$ Length=Length, start=start,stop=stop,bounds=bounds,multi=multi, $ cancel=cancel,Dt=Dt,Fileformat=Fileformat if cancel then return N_scans=1L*(Fileformat(0) eq 'fdas')+32L*(Fileformat(0) eq 'aor') N_channels=176*(Fileformat(0) eq 'fdas')+192*(Fileformat(0) eq 'aor') Setting={start:start, stop:stop, bounds:bounds, Length:Length, $ Filename:Filename, current_file:1, N_scans:N_scans, Dt:Dt, Lang:0, $ Fileformat:Fileformat,N_channels:N_channels,Deleted_File:'',Stokes:'Iew', $ Restart:0} time_sec=time_sec+Setting.Dt*(Setting.start+(multi-1)/2) time=smh(time_sec(0),/str,ms=3) suneph,date,time,SUN ew=(n_elements(isn) gt 1) sn=(n_elements(isn) gt 1) endif obhod: CASE !version.os OF 'windows': delim='\' 'Win32': delim='\' ELSE: delim='/' ENDCASE Lang_def_file=getenv('gr_prg')+Delim+'sources'+Delim+'language.def' M=(strlowcase(findfile(Lang_def_file)))(0) if equiv(M,'') then M=0 else begin openr,lun,Lang_def_file,/get_lun readf,lun,M free_lun,lun endelse ;M=0 for English, M=1 - Russian Setting.Lang=M if n_elements(iew) le 0 then SUN=(time_sec=(iew=(vew=(isn=(vsn=0))))) !P.multi=0 !x.style=(!y.style=(!x.range=(!y.range=0))) P_save=!P !P.background=255B & !P.color=0B Win=(View=lindgen(8)) Surfs=[0,0] device,get_scr=scr LengthEW=(Size(iew))(2) & LengthSN=LengthEW *sn V_ewsn={Win:Win,ew:ew,sn:sn, iew:temporary(iew), vew:temporary(vew),$ vsn:temporary(vsn), isn:temporary(isn), TimeRecord:[0d0,0d0], $ time_sec:temporary(time_sec), surf:0, SUN:SUN, press:0, Number:0L, multi:multi, $ LengthEW:LengthEW, LengthSN:LengthSN,Last:'E-W',Marker:0} Tvs={yfactor:-1,xfactor:1,sample:1,scale:1,negative:0} Saxes={Axes, x:!x, y:!y, z:!z, map:!map} Scales={TvEW:{Axes}, TvSN:{Axes}, SurfEW:{Axes}, SurfSN:{Axes}, Time:{Axes}} Saxes=0 ID={Mainbase:0L, Base1:0L, ToggleBase:lonarr(2), ProcessBase:lonarr(4), $ Setsurfbase:0L, Butsurf:0L, Modebase:0L, ButEW:0L, ButSN:0L, $ Drawbase:0L, Tvbase:0L, Surfbase:0L, Surfmode:0L, $ Surflabel:0L, TimeLabel:0L, DateLabel:0L, UTime:0L, Interval:0L, UTimeLabel:0L, $ View:Lonarr(8), XPDM:0L, Source:0L, Base1_toggle:0L, $ Pos:0L, Neg:0L, Nat:0L, Reb:0L, Samp:0L, Interp:0L,Bad_channels:0L, $ ButtonIew:0L, ButtonVew:0L, ButtonIsn:0L, ButtonVsn:0L, $ group_leader:group_leader} sz=(size(iew))([1,2]) dxsize=40. & dysize=50. dxe=70. & ddx=0.5 Pixsize0=40 DrawYsize=scr(1)*0.45 ; ************** Drawing widget ************** ID.Mainbase=widget_base(/row, group=group_leader, $ tit=(['Viewer for the SSRT data','╧¨þó¨ðüüð ÿ¨þ¸üþª¨ð ôðýý√¿ ╤╤╨╥'])(Setting.Lang)) junk=widget_base(ID.Mainbase) for j=0,1 do ID.ToggleBase(j)=widget_base(junk,/row) ; *************** ToggleBase(0) *************** ID.Base1=widget_base(ID.ToggleBase(0),/colu) ID.DateLabel=WIDGET_LABEL(ID.Base1,/frame, $ val=Date_string(Date)) CASE Setting.Lang OF 0: begin XPdMenu,[ $ '"DONE" Done', $ '"Help" Help', $ '"File" {', $ '"Load" Load', $ '"Archiver" Archiver', $ '"! Delete !" Delete', $ '}', $ '"Tools" {', $ '"Calculator" Calculator', $ '"Parameters" Parameters', $ '"Size && Flux" Size', $ '"Coordinates" Coordinates', $ '"Time record" Time record', $ '"View" View', $ '"Align" Align', $ '"Color Table" Xloadct',$ '"View/Process" View/Process', $ '"XManager Tool" XMTool',$ '"Shell" {', $ '"OS" OS', $ '"NC" NC', $ '"VC" VC','}', $ '"Archiver" Archiver', $ '"Language" Language', $ '}', $ '"TV" {', $ '"Contrast" {', $ '"Scaled" Scale', $ '"No scaling" No scaling','}',$ '"Pos/Neg" {', $ '"Positive" Positive', $ '"Negative" Negative','}', $ '"Range" {', $ '"Natural" Natural', $ '"Scaled" {', $ '"Sample" Sample',$ '"Interpolate" Interpolate','}',$ '}', $ '}'],ID.Base1,/column end 1: begin XPdMenu,[ $ '"┬█╒╬─" Done', $ '"╤ÿ¨ðòúð" Help', $ '"╘ðùû" {', $ '"╟ðó¨º÷úð" Load', $ '"└¨¿øòðªþ¨" Archiver', $ '"! ╙ôðûõýøõ !" Delete', $ '}', $ '"╤õ¨òø¸" {', $ '"╩ðû¹úºû ªþ¨" Calculator', $ '"╧ð¨ðüõª¨√ ╤╤╨╥" Parameters', $ '"╨ð÷üõ¨ && ╧þªþú" Size', $ '"╩þþ¨ôøýðª√" Coordinates', $ '"╟ðÿø¸¹ ò¨õüõýø" Time record', $ '"╧¨þ¸üþª¨ üð¸¸øòð" View', $ '"┬√ÿ¨ üûõýøõ" Align', $ '"╓òõªð" Xloadct',$ '"─¨ºóþõ üõý■" View/Process', $ '"╤õ¨òø¸ XManager" XMTool',$ '"╤¨õôð" {', $ '"OS" OS', $ '"NC" NC', $ '"VC" VC','}', $ '"└¨¿øòðªþ¨" Archiver', $ '"▀÷√ú" Language', $ '}', $ '"╥┬" {', $ '"╩þýª¨ð¸ª" {', $ '"╠𸰪ðñø¨þòðýý√ù" Scale', $ '"╚¸¿þôý√ù" No scaling','}',$ '"╧þ÷øªøò/═õóðªøò" {', $ '"╧þ÷øªøò" Positive', $ '"═õóðªøò" Negative','}', $ '"╠𸰪ðñ" {', $ '"╚¸¿þôý√ù" Natural', $ '"┬ ¨ð÷üõ¨ þúýð" {', $ '"╧þòªþ¨õýý√ù" Sample',$ '"╚ýªõ¨ÿþû ¡ø " Interpolate','}',$ '}', $ '}'],ID.Base1,/column end ELSE: ENDCASE ID.Setsurfbase=widget_base(ID.Base1,/colu,/fra) ID.Surfmode=WIDGET_BUTTON(ID.Setsurfbase,Uval='Surfadj',val=(['Surface','╧þòõ¨¿ýþ¸ª¹'])(Setting.Lang)) Enbsurfbase=widget_base(ID.Setsurfbase,/colu,/nonexc) ID.Butsurf=WIDGET_BUTTON(Enbsurfbase,Uval='Surf',val=(['Show','╧þúð÷ðª¹'])(Setting.Lang)) WIDGET_CONTROL,ID.Surfmode,SENS=0 ID.Modebase=widget_base(ID.Base1,/colu,/nonexc,/fra) ID.ButEW=WIDGET_BUTTON(ID.Modebase,Uval='E-W',val='E-W') ID.ButSN=WIDGET_BUTTON(ID.Modebase,Uval='S-N',val='S-N') WIDGET_CONTROL,ID.ButEW,/set_but WIDGET_CONTROL,ID.ButSN,set_but=V_ewsn.SN if V_ewsn.SN eq 0 then WIDGET_CONTROL,ID.ButSN,sens=0 ID.Drawbase=widget_base(ID.ToggleBase(0),/row) ID.Tvbase=widget_base(ID.Drawbase,/colu) for j=0,1 do ID.View(j)=widget_draw(ID.Tvbase,xsiz=(sz(0) > 150)+dxsize+dxe, $ ysiz=DrawYsize,/motion_events,/button_events, retain=2) ID.Surfbase=widget_base(ID.Drawbase,/colu) for j=2,3 do ID.View(j)=widget_draw(ID.Surfbase,xsiz=scr(0)*0.4,ysiz=DrawYsize, $ retain=2) ID.TimeLabel=WIDGET_LABEL(ID.Base1,/frame, $ val=smh((V_ewsn.time_sec)(0),/str,ms=3)+' ') junk=WIDGET_BASE(ID.Base1) ID.Base1_toggle=WIDGET_BASE(junk,/colu) ID.Bad_channels=WIDGET_TEXT(ID.Base1_toggle, /frame, /scroll, $ xsize=15,ysize=4, val=['Bad Channels:']) ; *************** ToggleBase(1) *************** XPdMenu,[ $ '"DONE" Done', $ '"Other menu" Quit1', $ '"Tools" {', $ '"Time record" Time record', $ '"View" View', $ '"Calculator" Calculator', $ '"Parameters" Parameters', $ '"Align" Align', $ '"Color Table" Xloadct',$ '"XManager Tool" XMTool',$ '"DOS" DOS', $ '"Norton Commander" {','"NC" NC', $ '"VC" VC','}', $ '"Archiver" Archiver', $ '}', $ '"Help" Help1', $ '}'],ID.ToggleBase(1),/column PlaneBase=WIDGET_BASE(ID.ToggleBase(1),/frame) for j=0,3 do ID.ProcessBase(j)=WIDGET_BASE(PlaneBase,/row) ; *************** ProcessBase(0) ************** junk=WIDGET_TEXT(ID.ProcessBase(0), xsize=75,ysize=10, val= [ $ '', $ ' There are following tools:', $ ' -- View of record of UTime in a file;', $ ' -- Alignment of a data record to compensate motion of the Sun.', $ '', $ " First of all you should to load any file if you haven't yet done this.", $ ' When a file is loaded, then its name is used to re-load time record.', $ ' In any case whole time record is re-loaded', $ ' with no respect to file bounds choosen.']) ; *************** ProcessBase(1) ************** junk=WIDGET_BASE(ID.ProcessBase(1),/colu) Base=lonarr(2) & for j=0,1 do Base(j)=WIDGET_BASE(junk,/row) ID.View(4)=widget_draw(Base(0),xsiz=scr(0)*0.8,ysiz=scr(1)*0.7,/frame, $ /motion_events,/button_events, retain=2) junk1=WIDGET_BASE(Base(1),/row) ID.UTime=WIDGET_TEXT(junk1, /frame, xsize=15,ysize=4, val=['UTime:']) ID.Interval=WIDGET_TEXT(junk1, /frame, xsize=15,ysize=3, val=['Interval:']) ID.UTimeLabel=WIDGET_LABEL(junk1, val='Place cursor at the plot and click button') ; *************** ProcessBase(2) ************** junk=WIDGET_BASE(ID.ProcessBase(2),/colu) XPdMenu,[ $ '"Tools" {', $ '"Time record" Time record', $ '"Calculator" Calculator', $ '"Parameters" Parameters', $ '"Align" Align', $ '"Color Table" Xloadct',$ '"XManager Tool" XMTool',$ '"DOS" DOS', $ '"Norton Commander" {','"NC" NC', $ '"VC" VC','}', $ '"Archiver" Archiver', $ '}', $ '"Help" Help1', $ '}'],junk,/column ID.View(7)=widget_draw(junk,xsiz=scr(0)*0.4,ysiz=scr(1)*0.5, retain=2) junk=WIDGET_BASE(ID.ProcessBase(2),/colu) Base=lonarr(2) & for j=0,1 do Base(j)=WIDGET_BASE(junk,/colu) for j=5,6 do ID.View(j)=widget_draw(Base(0),xsiz=(sz(0) > 150)+dxsize+dxe, $ ysiz=DrawYsize, retain=2) ; *************** ProcessBase(3) ************** junk=WIDGET_BASE(ID.ProcessBase(3),/row) XPdMenu,['"OK" OK_View', $ '"Help" Help2', $ '}'],junk,/column junk1=WIDGET_BASE(junk,/excl,/frame) ID.ButtonIew=widget_button(junk1,val='Iew',uval='View_Iew') ID.ButtonVew=widget_button(junk1,val='Vew',uval='View_Vew') ID.ButtonIsn=widget_button(junk1,val='Isn',uval='View_Isn') ID.ButtonVsn=widget_button(junk1,val='Vsn',uval='View_Vsn') WIDGET_CONTROL,ID.ButtonIew,set_but=1 SN=(n_elements(V_EWSN.isn) gt 1) WIDGET_CONTROL,ID.ButtonIsn,sens=SN WIDGET_CONTROL,ID.ButtonVsn,sens=SN ; ************************************************* WIDGET_CONTROL,ID.Base1_toggle,MAP=0 for j=0,1 do WIDGET_CONTROL,ID.ToggleBase(j),MAP=([1,0])(j) for j=0,2 do WIDGET_CONTROL,ID.ProcessBase(j),MAP=([1,0,0])(j) WIDGET_CONTROL,ID.mainbase,/realize,/hourglass for j=0,7 do begin WIDGET_CONTROL,ID.View(j),get_v=temp V_ewsn.Win(j)=temp & wset,V_ewsn.Win(j) & erase,255B endfor if V_ewsn.EW then begin wset,V_ewsn.Win(0) tv_axes,V_ewsn.iew,scale=Tvs.scale, yfac=Tvs.yfactor, $ sam=Tvs.sample, neg=Tvs.negative,font=0 scale,temp,/mem & Scales.TvEW=temp wset,V_ewsn.Win(2) & xyouts,0.01,0.01,'E-W',/norm,font=0 endif if V_ewsn.SN then begin wset,V_ewsn.Win(1) tv_axes,V_ewsn.isn,scale=Tvs.scale, yfac=Tvs.yfactor, $ sam=Tvs.sample, neg=Tvs.negative,font=0 scale,temp,/mem & Scales.TvSN=temp wset,V_ewsn.Win(3) & xyouts,0.01,0.01,'S-N',/norm,font=0 endif if not (V_ewsn.EW or V_ewsn.SN) then begin wset,V_ewsn.Win(0) xyouts,0.5,0.5,/norm,align=0.5,font=0, $ (['Please load a file','╟ðó¨º÷øªõ ¯ðùû'])(Setting.Lang) endif wset,V_ewsn.Win(4) plot,indgen(192)+1,/nodata,xstyle=4,ystyle=4 scale,temp,/mem & Scales.Time=temp xmanager,'ewsn_view',ID.Mainbase,group_leader=group_leader,cleanup='ewsn_view_cl_u' end ####################################################### function fahren, degree, to_celsius = to_celsius, to_fahrenheit = to_fahrenheit ;+ ; Converts Fahrenheit degree to Celsius (default) and reverse if keyword ; TO_FAHRENHEIT is set and non-zero. ; ; Example: ; print, fahren([32, 63, 86]) ;- if not(keyword_set(to_fahrenheit)) then return, (degree-32.)/(212-32.)*100. else $ return, degree/100.*(212-32.)+32. end ####################################################### function fft_filter, x, N_points, high_pass = high_pass ft = fft(x, -1) N = n_elements(x) N_p = N_points < (N/2-1) if keyword_set (high_pass) then begin ft(0:N_p) = 0 ft(N-N_p-1:*) = 0Ê endif else ft(N_p:N-N_p-1) = 0 return, float(fft(ft, 1)) end ####################################################### function fh_mk_ssrt, Sz, struc case Sz(Sz(0)+1) of 1: bitpix = 8 2: bitpix = 16 3: bitpix = 32 4: bitpix = -32 5: bitpix = -64 6: bitpix = 64 7: bitpix = 8 else: message,'Illegal Image Datatype' endcase header = strarr(Sz(0) +7) + string(' ',format='(a80)') ;Create empty array header(0) = 'END' + string(replicate(32b,77)) sxaddpar, header, 'SIMPLE', 'T' sxaddpar, header, 'BITPIX', bitpix sxaddpar, header, 'NAXIS', Sz(0);# of dimensions if (Sz(0) GT 0 ) then begin for i = 1, Sz(0) do sxaddpar,header,'NAXIS' + strtrim(i,2),Sz(i) endif sxaddpar, header, 'object', struc.object sxaddpar, header, 'type-obs', struc.type_obs sxaddpar, header, 'time-obs', struc.time_obs sxaddpar, header, 'date-obs', struc.date_obs sxaddpar, header, 'origin', struc.origin sxaddpar, header, 'telescop', struc.telescop sxaddpar, header, 'wave', struc.wave sxaddpar, header, 'x-origin', struc.x_origin sxaddpar, header, 'y-origin', struc.y_origin sxaddpar, header, 'center-x', struc.center_x sxaddpar, header, 'center-y', struc.center_y sxaddpar, header, 'x-obs', struc.x_obs sxaddpar, header, 'y-obs', struc.y_obs sxaddpar, header, 'radius', struc.radius sxaddpar, header, 'p0', struc.p0 sxaddpar, header, 'lat0', struc.lat0 sxaddpar, header, 'lon0', struc.lon0 if (where(tag_names(struc) eq 'UT_START'))(0) ge 0 then $ sxaddpar, header, 'ut_start', struc.ut_start if (where(tag_names(struc) eq 'UT_STOP'))(0) ge 0 then $ sxaddpar, header, 'ut_stop', struc.ut_stop sxaddpar, header, 'bscale', struc.bscale sxaddpar, header, 'bzero', struc.bzero return, ([header,strarr(36-n_elements(header))]) end ####################################################### function fh_r_key,header,key, error=error, character=character ;+ ; Function FH_R_KEY searches for a given keyword KEY in the specified ; FITS header and returns value in the found line converted into ; a floating-point, double precision variable if this line does not contain ; apostrophe. Otherwise, string type variable is returned. ; The keyword parameter ERROR returns 0 if search was successful, and 1 ; if the specified keyword was not found. ; The case of the KEY value is not significant. ; The keyword parameter has no effect and left for compatibility ; with the previous version. ; ; EXAMPLE: ; ; VALUE=FH_R_KEY(header, 'NAXIS', error=error) ; HELP, VALUE ; ; WRITTEN by V.Grechnev, ISTP, May 1996 ;- N=n_elements(header) error=1 Result='' i=-1 Up_key=strupcase(key) repeat i=i+1 until strcompress(strmid(header(i),0,8),/rem) eq Up_key or i eq N-1 Length=strlen(key) if i lt N-1 then begin ;if strpos(header(i),"'") ge 0 then $ ; Result=(strsplit(header(i), delim="'"))(1) else $ ; Result=double((strsplit(header(i)))(1+(Length lt 8))) Left=strpos(header(i),"'") if Left ge 0 then begin Next=Left repeat begin Next=strpos(header(i),"'",Next+1) if next ge 0 then Right=Next endrep until next lt 0 Result=strmid(Header(i), Left+1, Right-Left-1) endif else Result=double((strsplit(header(i)))(1+(Length lt 8))) error=0 endif return, Result end ####################################################### function fh_r_time, header, error=error time=fh_r_key(header,'time-obs',/ch, error=error) if error then t=fh_r_key(header,'time',/ch, error=error) if error then begin t0=fh_r_key(header,'utstart',/ch, error=error0) t1=fh_r_key(header,'utstop',/ch, error=error1) error=error1 or error1 if error ne 1 then time=smh((hms(t1)+hms(t0))*3600d0/2) endif return,time end ####################################################### function fh_st_ssrt, ssrt=ssrt, soho=soho ;+ Returns FITS header structure except for obligatory keywords (simple, bitpix, ; naxis, end) ;- if keyword_set(ssrt) then return, $ { object:'', type_obs:'', time_obs:'', date_obs:'', $ telescop:'', wave:'', origin:'', $ x_origin:0., y_origin:0., center_x:0., center_y:0., $ x_obs:0., y_obs:0., $ radius:0., p0:0.d0, lat0:0.d0, lon0:0.d0, $ ut_start:'', ut_stop:'', bscale:1., bzero:0.} else $ return, { object:'', type_obs:'', time_obs:'', date_obs:'', $ telescop:'', wave:'', origin:'', $ x_origin:0., y_origin:0., center_x:0., center_y:0., $ x_obs:0., y_obs:0., $ radius:0., p0:0.d0, lat0:0.d0, lon0:0.d0, $ bscale:1., bzero:0.} end ####################################################### pro filesetting_event,ev common filesetting_Exch,Data WIDGET_CONTROL,ev.id,GET_UVALUE = wuv if wuv eq "INTEGRATED" then begin Data.summa=1 & wuv="MULTI" & end if wuv eq "MAXIMUM" then begin Data.summa=0 & wuv="MULTI" & end CASE wuv OF "DONE": begin WIDGET_CONTROL,ev.top,/DEST if Data.g_leader ne 0L then if WIDGET_INFO(Data.g_leader,/valid) $ then WIDGET_CONTROL,Data.g_leader,/show end "Iew": Data.Stokes_in(0)=ev.select "Vew": Data.Stokes_in(1)=ev.select "Isn": Data.Stokes_in(2)=ev.select "Vsn": Data.Stokes_in(3)=ev.select 'Limit_input': begin widget_control,Data.Limit_input,get_val=tmp Data.Number=fix(tmp(0)) > 1 widget_control,Data.Limit_input,set_val=strtrim(Data.Number,2) if Data.Nolimit ne 1 then Data.edges(1-Data.Last)= $ Data.edges(1-Data.Last) < $ (Data.Edges(Data.Last)+Data.Number-1) > $ (Data.Edges(Data.Last)-Data.Number+1) WIDGET_CONTROL,Data.slider0,set_val=Data.edges(0) WIDGET_CONTROL,Data.slider1,set_val=Data.edges(1) WIDGET_CONTROL,Data.Txt1,set_val=Time_Outvalue(Data.edges(0),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.First_Block, $ set_val=strtrim(Data.edges(0)/Data.N_scans,2) WIDGET_CONTROL,Data.First_Record, $ set_val=strtrim(Data.edges(0) mod Data.N_scans,2) WIDGET_CONTROL,Data.Txt2,set_val=Time_Outvalue(Data.edges(1),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.Last_Block, $ set_val=strtrim(Data.edges(1)/Data.N_scans,2) WIDGET_CONTROL,Data.Last_Record, $ set_val=strtrim(Data.edges(1) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) end "Limit": begin Data.Nolimit=1-ev.select if Data.Nolimit ne 1 then Data.edges(1-Data.Last)= $ Data.edges(1-Data.Last) < $ (Data.Edges(Data.Last)+Data.Number-1) > $ (Data.Edges(Data.Last)-Data.Number+1) WIDGET_CONTROL,Data.slider0,set_val=Data.edges(0) WIDGET_CONTROL,Data.slider1,set_val=Data.edges(1) WIDGET_CONTROL,Data.Txt1,set_val=Time_Outvalue(Data.edges(0),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.First_Block, $ set_val=strtrim(Data.edges(0)/Data.N_scans,2) WIDGET_CONTROL,Data.First_Record, $ set_val=strtrim(Data.edges(0) mod Data.N_scans,2) WIDGET_CONTROL,Data.Txt2,set_val=Time_Outvalue(Data.edges(1),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.Last_Block, $ set_val=strtrim(Data.edges(1)/Data.N_scans,2) WIDGET_CONTROL,Data.Last_Record, $ set_val=strtrim(Data.edges(1) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) end "NATURAL": begin Data.mul=1 & Data.summa=0 WIDGET_CONTROL,Data.base2,map=0 WIDGET_CONTROL,Data.slider2,SET_VAL=1 end "MULTI": begin WIDGET_CONTROL,Data.base2,map=1 WIDGET_CONTROL,Data.slider2,GET_VAL=mul Data.mul=mul end "HELP": begin WIDGET_CONTROL,/hourglass CASE !version.os OF 'windows': delim='\' 'Win32': delim='\' ELSE: delim='/' ENDCASE xtext,file=getenv('help_dir')+Delim+'filesett.hlp',group=ev.top end "START": begin Data.Last=0 Data.edges(0)=ev.value if Data.Nolimit ne 1 then Data.edges(1)= $ Data.edges(1) < (Data.Edges(0)+Data.Number-1) > (Data.Edges(0)-Data.Number+1) WIDGET_CONTROL,Data.slider1,set_val=Data.edges(1) WIDGET_CONTROL,Data.Txt1,set_val=Time_Outvalue(Data.edges(0),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.First_Block, $ set_val=strtrim(Data.edges(0)/Data.N_scans,2) WIDGET_CONTROL,Data.First_Record, $ set_val=strtrim(Data.edges(0) mod Data.N_scans,2) WIDGET_CONTROL,Data.Txt2,set_val=Time_Outvalue(Data.edges(1),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.Last_Block, $ set_val=strtrim(Data.edges(1)/Data.N_scans,2) WIDGET_CONTROL,Data.Last_Record, $ set_val=strtrim(Data.edges(1) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) end "STOP": begin Data.Last=1 Data.edges(1)=ev.value if Data.Nolimit ne 1 then Data.edges(0)= $ Data.edges(0) < (Data.Edges(1)+Data.Number-1) > (Data.Edges(1)-Data.Number+1) WIDGET_CONTROL,Data.slider0,set_val=Data.edges(0) WIDGET_CONTROL,Data.Txt2,set_val=Time_Outvalue(Data.edges(1),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.Last_Block, $ set_val=strtrim(Data.edges(1)/Data.N_scans,2) WIDGET_CONTROL,Data.Last_Record, $ set_val=strtrim(Data.edges(1) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) WIDGET_CONTROL,Data.Txt1,set_val=Time_Outvalue(Data.edges(0),$ time=Data.time, Dt=Data.Dt, space=46) WIDGET_CONTROL,Data.First_Block, $ set_val=strtrim(Data.edges(0)/Data.N_scans,2) WIDGET_CONTROL,Data.First_Record, $ set_val=strtrim(Data.edges(0) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) end "Open": Data.New_file=1 "Cancel": Data.Canc=1 ELSE: ENDCASE if (wuv eq "Cancel") or (wuv eq "Open") then $ WIDGET_CONTROL,ev.top,/DEST empty end pro filesetting, Filename=Filename, bounds=bounds,pathes=pathes,$ group_leader=group_leader, current_file=current_file,$ Fileformat=Fileformat,multi=multi,sum=sum,Cancel=Cancel, $ Stokes=Stokes,number=number,nolimit=nolimit,limit=limit ; Selects bounds of an array to be read from the SSRT data file. common filesetting_Exch,Data if n_elements(limit) le 0 then limit=200 Data={base2:0L, slider0:0L, slider1:0L, slider2:0L, Txt1:0L, Txt2:0L, Fname:'', $ edges:[0L,1000L-1], Length:0L, time:[0d,0d], mul:1, summa:1, $ New_file:0, Canc:0, Stokes_in:[1,1,1,1], Dt:0d, $ First_Block:0L, Last_Block:0L, First_Record:0L, Last_Record:0L, $ N_scans:0L, g_leader:0L, Label:0L, nolimit:keyword_set(nolimit), $ Number:Limit, Limit_input:0L, Last:0} if xregistered('filesetting') then return if n_elements(Length) le 0 then Length=0L device,get_scr=scr if n_elements(Filename) gt 0 then if Filename ne '' then pathes=subdir(Filename) if n_elements(pathes) le 0 then pathes='' if n_elements(group_leader) le 0 then group_leader = 0L Data.g_leader=group_leader if keyword_set(current_file) then begin Data.FName=Filename goto, old endif ret: i=0 REPEAT BEGIN Data.FName=pickfile(/read,path=pathes(i),file=Filename) i=i+1 ENDREP UNTIL Data.FName ne '' or i ge n_elements(pathes) if Data.FName eq '' then begin Data.mul=1 & Data.summa=1 Data.Canc=1 print,'You have selected no file' goto,exit1 endif old: Data.time=[0D,0D] Data.mul=1 & Data.summa=0 WIDGET_CONTROL,/hour openr,lun,Data.Fname,/get_lun Name=(name_lun(lun))(0) Descr_File=Fstat(lun) Block=ssrt_file_struc(lun, Fileformat=Fileformat, $ Offset=Offset, Blocklength=Blocklength, Length=Length, $ Num_blocks=Num_blocks, Dt=Dt) Data.Length=Length & Data.Dt=Dt Data.N_scans=1L*(Fileformat(0) eq 'fdas')+32L*(Fileformat(0) eq 'aor') IF Fileformat(1) ne 'clm' then begin Data.time(0)=read_time(Lun, Blocknumber=0) Data.time(1)=read_time(Lun, Blocknumber=Num_blocks-1)+(Data.N_scans-1)*Data.Dt ENDIF free_lun,lun Data.edges=[0L,Data.Length-1] IF Fileformat(1) ne 'clm' THEN BEGIN if keyword_set(current_file) then if n_elements(bounds) eq 2 $ then Data.edges=bounds ENDIF ELSE BEGIN edges=[0L,0L] & goto,exit ENDELSE main= widget_base(tit='File: '+Name,/colu, XOFF=0, ypad=10,space=10) Menu_base= widget_base(/row,main) XPdMenu, ['"DONE" DONE', $ '"FILE" {', $ '"Open" Open', $ '"Cancel" Cancel', $ '}', $ '"MODE" {', $ '"NATURAL" NATURAL', $ '"INTEGRATED" INTEGRATED', $ '"MAXIMUM" MAXIMUM', $ '}', $ '"HELP" HELP'], $ Menu_base Limit_base=widget_base(Menu_base,/row,/frame) Nonexcl_Base= widget_base(Limit_base,/row,/nonexcl) Button=widget_button(Nonexcl_Base,val='Limitation',uval='Limit') WIDGET_CONTROL,Button,set_but=1-Data.nolimit Data.Limit_input=widget_text(Limit_base,/edit,xsiz=10,uval='Limit_input') WIDGET_CONTROL,Data.Limit_input,set_val=strtrim(Data.Number,2) Label=widget_label(Limit_base,val='scans ') Upper_Base=widget_base(main,/row) base1= widget_base(Upper_Base,/row,/nonexcl,/fra) But_Stokes=lonarr(4) val=['Iew','Vew','Isn','Vsn'] for j=0,3 do begin But_Stokes(j)=WIDGET_BUTTON(base1,uval=val(j),val=val(j)+' ') WIDGET_CONTROL,But_Stokes(j),/set_but endfor Flag=equiv(Fileformat,['aor','1']) or equiv(Fileformat,['aor','cor0']) or $ equiv(Fileformat,['aor','cor1']) FOR j=2,3 DO BEGIN if not (Flag) then begin WIDGET_CONTROL,But_Stokes(j),set_but=0 WIDGET_CONTROL,But_Stokes(j),sens=0 Data.Stokes_in(j)=0 endif ENDFOR junk=WIDGET_LABEL(Upper_Base,val=' Total: ') Number_of_Blocks=WIDGET_LABEL(Upper_Base, $ val=strtrim(Data.Length/Data.N_scans,2)+$ ' Blocks, '+strtrim(Data.Length,2)+' Scans.') EmptyString=' ' gap=WIDGET_LABEL(Upper_Base,val=EmptyString) junk=WIDGET_LABEL(Upper_Base,val='Scans selected : ') Data.Label=WIDGET_LABEL(Upper_Base,val= $ ''+strtrim(abs(Data.edges(1)-Data.edges(0))+1,2)+' ') Data.slider0=WIDGET_SLIDER(main, MIN=0, MAX=Data.Length-1, $ TIT='First record', /FRA, $ UVAL= 'START', VAL=Data.edges(0),/drag) Slider_Base_0=WIDGET_BASE(main,/row) Data.Txt1 = WIDGET_LABEL(Slider_Base_0, val= $ Time_Outvalue(Data.edges(0), time=Data.time, Dt=Data.Dt, space=46)+EmptyString) Info1 = WIDGET_LABEL(Slider_Base_0, val='First block: ') Data.First_Block = WIDGET_LABEL(Slider_Base_0, $ val=' '+strtrim(Data.edges(0)/Data.N_scans,2)+' ') Info11 = WIDGET_LABEL(Slider_Base_0, val='Record: ') Data.First_Record = WIDGET_LABEL(Slider_Base_0, $ val=' '+strtrim(Data.edges(0) mod Data.N_scans,2)+' ') Data.slider1=WIDGET_SLIDER(main, MIN=0, MAX=Data.Length-1, $ TIT='Last record', /FRAME, $ UVAL= 'STOP', VAL=Data.edges(1),/drag) Slider_Base_1=WIDGET_BASE(main,/row) Data.Txt2 = WIDGET_LABEL(Slider_Base_1, val= $ Time_Outvalue(Data.edges(1), time=Data.time, Dt=Data.Dt, space=46)+EmptyString) Info2 = WIDGET_LABEL(Slider_Base_1, $ val='Last block: ') Data.Last_Block = WIDGET_LABEL(Slider_Base_1, $ val=' '+strtrim(Data.edges(1)/Data.N_scans,2)+' ') Info21 = WIDGET_LABEL(Slider_Base_1, val='Record: ') Data.Last_Record = WIDGET_LABEL(Slider_Base_1, $ val=' '+strtrim(Data.edges(1) mod Data.N_scans,2)+' ') Data.base2= widget_base(main,/colu,/fra,xsi=scr(0)*0.96) Data.slider2 = WIDGET_SLIDER(Data.base2, MIN=1, MAX=32, $ TIT='Number of scans', val=Data.mul, UVAL= 'MULTI',/drag) WIDGET_CONTROL,Data.base2,map=0 WIDGET_CONTROL,main,/real xmanager,'filesetting',main,/modal,group=group_leader if Data.New_file eq 1 then begin Data.Stokes_in=[1,1,1,1] current_file=(Data.New_file=0) goto, ret endif exit: bounds=Data.edges(sort(Data.edges)) if Data.Nolimit ne 1 then bounds(1) = bounds(1) < (bounds(0)+Data.Number-1) Stokes=Data.Stokes_in if Data.Canc eq 1 then current_file=(Data.New_file=0) exit1: multi=Data.mul & sum=Data.summa & Filename=Data.Fname Cancel=Data.Canc number=Data.Length Data=0 end ####################################################### function filetype,filename ;+ Function FILETYPE returns type of given file, if it is a standart ; image file (FITS, GIF87a, BMP or TIFF) ;- Attribute=bytarr(30) if not float(equiv(size(filename),[0,7,1])) then message,'Incorrect input' if filename eq '' then return,'NO FILE' openr,lun,filename,/get_lun readu,lun,Attribute free_lun,lun simple='SIMPLE =' FITS_ID=byte(string(simple,format="(a9,20x,'T')")) GIF87_ID=byte('GIF87a') GIF89_ID=byte('GIF89a') BMP_ID=byte('BM') TIFF0_ID=byte('MM') TIFF1_ID=byte('II') JPEG_ID=byte('JFIF') CASE 1 OF equiv(Attribute, FITS_ID): type='FITS' equiv(Attribute(0:5), GIF87_ID): type='GIF' equiv(Attribute(0:5), GIF89_ID): type='GIF' equiv(Attribute(0:1), BMP_ID): type='BMP' equiv(Attribute(0:1), TIFF0_ID): type='TIFF' equiv(Attribute(0:1), TIFF1_ID): type='TIFF' equiv(Attribute(6:9), JPEG_ID): type='JPEG' ELSE: type='UNRECOGNIZED' ENDCASE return, type end ####################################################### pro f_a_f_switch_block,Fileformat,Block,attr,I_EW,I_SN ; Reading data from a block of the initial file IF equiv(Fileformat, ['aor','0']) or equiv(Fileformat, ['aor','-1']) $ THEN BEGIN I_EW= [[total((Block.Set32.I)(0:47,*),1)], $ [total((Block.Set32.I)(48:95,*),1)], $ [total((Block.Set32.I)(96:143,*),1)], $ [total((Block.Set32.I)(144:*,*),1)]]/48. attr=Block.set32.attr ENDIF ELSE IF equiv(Fileformat, ['aor','1']) THEN BEGIN I_EW= [[total((Block.Set32.LEW)(0:47,*),1)], $ [total((Block.Set32.LEW)(48:95,*),1)], $ [total((Block.Set32.LEW)(96:143,*),1)], $ [total((Block.Set32.LEW)(144:*,*),1)]]/48. I_SN= [[total((Block.Set32.LSN)(0:47,*),1)], $ [total((Block.Set32.LSN)(48:95,*),1)], $ [total((Block.Set32.LSN)(96:143,*),1)], $ [total((Block.Set32.LSN)(144:*,*),1)]]/48. attr=[[Block.set32.AttrEW],[Block.set32.AttrSN]] ENDIF ELSE IF Fileformat(0) eq 'fdas' THEN BEGIN attr=Block.Descriptor_R CASE !version.OS OF 'windows': 'Win32': ELSE: byteorder, Block, /sswap ENDCASE I_EW= -[[total((Block.Right)(0:44))], $ [total((Block.Right)(45:89))], $ [total((Block.Right)(90:134))], $ [total((Block.Right)(135:*))]]/45. ENDIF end function get_switch_points,X,sigma=sigma ; Searches for switch points by calculating derivative if n_elements(sigma) le 0 then sigma=3. I_der=deriv(X) Std=stdev(I_der) Abs_I_der=abs(I_der) I_der1=I_der(where(Abs_I_der lt sigma*Std)) Std=stdev(I_der1) return,where(Abs_I_der gt sigma*Std) end pro f_a_find_switch,FileName=FileName, Iew=Iew, ISN=ISN, attr=attr, $ date=date,Points_EW=Points_EW,Points_SN=Points_SN, $ print_info=print_info, sigma=sigma ; Searches switching points in a whole file and calculates total ; among partial bands common file_align_Exch,Data,Array0,Array1,Array2, $ xx,yy,xxx,yyy,current_state,Sc,Sw_Points if n_elements(sigma) le 0 then sigma=3. if n_elements(Filename) le 0 then $ Filename=pickfile(path=getenv('spk_dat'),/read) WIDGET_CONTROL,/hourglass openr,LUN,FileName,/get_lun Block=SSRT_file_struc(LUN,Fileformat=Fileformat, $ Offset=Offset, Dt=Dt, Date=Date, Length=Length) IF Fileformat(0) eq 'fdas' THEN Block_length=1L else Block_length=32L N_block0=0L & N_blocks=Length/Block_length Blockset=assoc(LUN,Block,Offset) & attr_in=0B IEW=intarr(Length,4) IF equiv(Fileformat, ['aor','1']) THEN BEGIN ISN=IEW attr=bytarr(2,Length) ENDIF ELSE attr=bytarr(Length) widget_control,Data.Info_Label,/hour,set_val='Reading the file...' FOR j=0L,N_blocks-1 DO BEGIN f_a_f_switch_block,Fileformat,Blockset(j), attr_in,I_EW,I_SN j0=j*Block_length & j1=j0+Block_length-1 IEW(j0:j1,*)=I_EW IF equiv(Fileformat, ['aor','1']) THEN BEGIN ISN(j0:j1,*)=I_SN attr(*,j0:j1)=attr_in ENDIF ELSE attr(j0:j1)=attr_in Flag=((Block_length eq 32) or ((Block_length eq 1) and ((j mod 32) eq 0))) if Flag then WIDGET_CONTROL, Data.slider0,set_val=j*Block_length+Block_length-1 ENDFOR free_lun,LUN widget_control,Data.Info_Label,/hour,set_val='Analyzing the record...' Points_EW_0=get_switch_points(IEW(*,0),sigma=sigma) Points_EW_1=get_switch_points(IEW(*,1),sigma=sigma) Points_EW_2=get_switch_points(IEW(*,2),sigma=sigma) Points_EW_3=get_switch_points(IEW(*,3),sigma=sigma) Points_EW=find_equal(Points_EW_0,Points_EW_1,Points_EW_2,Points_EW_3) Index=Points_EW Abs_I_der=abs(deriv(total(IEW,2))) IF Index(0) ge 0 THEN BEGIN split_array,Index,Number=Number,first_subscript=F_s,last_subscript=L_s Points_EW=lonarr(Number) FOR j=0,Number-1 DO BEGIN amax=max(Abs_I_der(F_s(j):L_s(j)),imax) Points_EW(j)=F_s(j)+imax ENDFOR ENDIF ELSE Points_EW=-1 IF equiv(Fileformat, ['aor','1']) THEN BEGIN Points_SN_0=get_switch_points(ISN(*,0),sigma=sigma) Points_SN_1=get_switch_points(ISN(*,1),sigma=sigma) Points_SN_2=get_switch_points(ISN(*,2),sigma=sigma) Points_SN_3=get_switch_points(ISN(*,3),sigma=sigma) Points_SN=find_equal(Points_SN_0,Points_SN_1,Points_SN_2,Points_SN_3) Index=Points_SN Abs_I_der=abs(deriv(total(ISN,2))) IF Index(0) ge 0 THEN BEGIN split_array,Index,Number=Number,first_subscript=F_s,last_subscript=L_s Points_SN=lonarr(Number) FOR j=0,Number-1 DO BEGIN amax=max(Abs_I_der(F_s(j):L_s(j)),imax) Points_SN(j)=F_s(j)+imax ENDFOR ENDIF ELSE Points_SN=-1 ENDIF WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) end pro f_a_file_prepare,index,top, $ Offset_I,header_I,Offset_V,header_V,comments,type, cancel ; Opens output files and writes their headers common file_align_Exch,Data,Array0,Array1,Array2, $ xx,yy,xxx,yyy,current_state,Sc,Sw_Points WIDGET_CONTROL,/hour cancel=0 Name=name_extract(Data.Fname) path=subdir(Data.Fname) model=strmid(Name(1),Name(4)-6,6) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE if Data.Stokes(0) or Data.Stokes(1) then begin Data.Interf=(Interferometer='E-W') filter_I='*.awi' filter_V='.awv' endif else begin Data.Interf=(Interferometer='S-N') filter_I='*.ani' filter_V='.anv' endelse New_Name_I=newfilename(model=model,filt=filter_I,path=path) Channel=Data.Channel Start_time=Time_Outvalue(Data.edges(0),time=Data.time, Dt=Data.Dt) if Data.N_channels eq 192 then Receiver='AOR' else Receiver='FDAS' New_File_I=pickfile(/write,path=path,file=New_Name_I) New_File_V=subdir(New_File_I)+Delim+(name_extract(New_File_I))(1)+filter_V widget_control,top,/show if New_File_I eq '' then begin cancel=1 return endif ; *************** Writing of the output file headers ****************** widget_control,/hour Length=Data.edges(1)-Data.edges(0)+1 Sz=[2L,Data.N_channels,32L,2L,Data.N_channels*32L] if Data.lun_I(index) ne 0 then free_lun,Data.lun_I(index) if Data.lun_V(index) ne 0 then free_lun,Data.lun_V(index) openw,lun_I,New_File_I,/get_lun openw,lun_V,New_File_V,/get_lun Data.lun_I(index)=lun_I Data.lun_V(index)=lun_V Length=Data.edges(1)-Data.edges(0)+1 gr_header,lun_I,offset_I,header_I,/write, $ comments=comments, $ Parameter='Intensity', $ Interferometer=Interferometer, $ source_file=(name_extract(Data.Fname))(0),$ first_record=Data.edges(0), $ Date=Data.Date, $ Reference_time=Data.Reference_time, $ Reference_Channel=Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Data.Dt, $ Length=Length, $ N_channels=Data.N_channels, $ Creator='file_align.pro', $ Array_size=Array_size, $ Type=Type gr_header,lun_V,offset_V,header_V,/write, $ comments=comments, $ Parameter='Polarization', $ Interferometer=Interferometer, $ source_file=(name_extract(Data.Fname))(0),$ first_record=Data.edges(0), $ Date=Data.Date, $ Reference_time=Data.Reference_time, $ Reference_Channel=Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Data.Dt, $ Length=Length, $ N_channels=Data.N_channels, $ Creator='file_align.pro', $ Array_size=Array_size, $ Type=Type end pro f_a_file_read,index,top, $ Offset_I,header_I,Offset_V,header_V,comments,type ; Opens output files and writes their headers common file_align_Exch,Data,Array0,Array1,Array2, $ xx,yy,xxx,yyy,current_state,Sc,Sw_Points WIDGET_CONTROL,/hour Name=name_extract(Data.Fname) path=subdir(Data.Fname) File_I=(File_V=Data.Fname) strput,File_I,'i',strlen(File_I)-1 strput,File_V,'v',strlen(File_V)-1 for j=0,1 do if Data.lun_I(j) ne 0L then free_lun,Data.lun_I(j) for j=0,1 do if Data.lun_V(j) ne 0L then free_lun,Data.lun_V(j) openr,lun_I,File_I,/get_lun Data.lun_I(0)=lun_I openr,lun_V,File_V,/get_lun Data.lun_V(0)=lun_V gr_header,Data.lun_I(0),offset_I,header_I,/read,$ comments=comments_I, $ Parameter=Parameter_I, $ Interferometer=Interferometer, $ source_file=source_file, $ first_record=first_record, $ Date=Date, $ Reference_time=Reference_time, $ Reference_Channel=Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Dt, $ Length=Length, $ N_channels=N_channels, $ Creator=Creator, $ Array_size=Array_size, $ Type=Type gr_header,Data.lun_V(0),offset_V,header_V,/read,$ comments=comments_V, Parameter=Parameter_V Data.Dt=Dt Data.Date=Date Data.Length=Length Data.N_channels=N_channels ; Data.Start_time=Start_time Data.Reference_time=Reference_time Data.Interf=Interferometer Data.Channel=Channel Data.edges=[0,Length-1] ; Data.edges(0)=first_record ; Data.edges(1)=first_record+Length-1 ;param_ssrt, Data.date, Data.Reference_time, Data.N_channels eq 192, par=par, /si,sun=sun Data.threshold=(-1000.)*(Data.N_channels ne 192) xx=assoc(Data.lun_I(0), $ make_array(N_channels, $ type=array_size(n_elements(array_size)-2)), $ offset_I) yy=assoc(Data.lun_V(0), $ make_array(N_channels, $ type=array_size(n_elements(array_size)-2)), $ offset_V) Array1=intarr(Data.N_channels,512) for j=0,511 < (Data.Length/Data.factor(1)-1) do Array1(*,j)=xx(*,j*Data.factor(1)) end pro file_align_show ; Displays arrays in the graphics window common file_align_Exch,Data,Array0,Array1,Array2, $ xx,yy,xxx,yyy,current_state,Sc,Sw_Points WIDGET_CONTROL,/hour Iew=Data.Stokes(0) Vew=Data.Stokes(1) Isn=Data.Stokes(2) Vsn=Data.Stokes(3) WIDGET_CONTROL,/hour if Data.factor(0) eq 1 then bounds=Data.tv_bounds else bounds=Data.edges if bounds(1)-bounds(0) lt 255 then $ bounds=(bounds(0)+bounds(1))/2+ $ [-256,255] > 0 < (Data.Length-1) readfile,FileName=Data.Fname,bounds=bounds, date=date, $ Iew=Iew, Vew=Vew, ISN=ISN, VSN=VSN, multi=Data.factor(0),sum=1 Data.date=date if Data.factor(0) eq 1 then Data.tv_bounds=bounds if Data.Tv_bounds(0) eq Data.Tv_bounds(1) then $ Data.Tv_bounds(1)=Data.Tv_bounds(0)+2 Data.tv_bounds(1)=Data.tv_bounds(1) < (Data.tv_bounds(0)+511) CASE 1 OF Data.Stokes(0): Array0=Iew Data.Stokes(1): Array0=Vew Data.Stokes(2): Array0=Isn Data.Stokes(3): Array0=Vsn ENDCASE Wset,Data.Win(0) erase,0 tvscl,transpose(Array0) empty WIDGET_CONTROL,Data.Time_Label(0),set_val=' '+strtrim(bounds(0),2)+':'+$ Time_Outvalue(bounds(0), time=Data.time, Dt=Data.Dt, space=3)+ $ ' --- '+strtrim(bounds(1),2)+':'+ $ Time_Outvalue(bounds(1), time=Data.time, Dt=Data.Dt, space=3) end pro file_align_event,ev common file_align_Exch,Data,Array0,Array1,Array2, $ xx,yy,xxx,yyy,current_state,Sc,Sw_Points IF ev.id eq Data.View(0) THEN BEGIN device,/cursor_cross if ev.press then Data.press=1 if ev.release then Data.press=0 if Data.press then begin wset,Data.Win(0) Data.Reference=Data.tv_bounds(0)+ev.x*Data.factor(0) Data.Channel=ev.y WIDGET_CONTROL,Data.Slider2(1),set_val=Data.Reference WIDGET_CONTROL,Data.Slider2(2),set_val=ev.y+1 Data.Reference_time=Time_Outvalue(Data.Reference,time=Data.time, Dt=Data.Dt) WIDGET_CONTROL,Data.Ref_label(1),set_val=' '+Data.Reference_time endif if ev.release then begin wset,Data.Win(3) plot,findgen(Data.N_channels)+1, $ Array0(*,ev.X*Data.factor(0)),xmar=[6,2],ymar=[2,1] empty scale,temp,/mem Sc.W3=temp endif RETURN ENDIF IF ev.id eq Data.View(1) THEN begin wset,Data.Win(1) WIDGET_CONTROL,Data.Time_Label(1),set_val= $ string(data.tv_bounds(0)+ev.X*Data.factor(1),ev.Y,format="(I6,', ',I6)") w_box_cursor,ev,xy,init=Data.init,cur=current_state Data.init=0 Data.xy=xy if ev.release then begin widget_control,Data.QS_button,sens=1 widget_control,Data.Zero_button,sens=1 wset,Data.Win(3) plot,findgen(Data.N_channels)+1, $ Array1(*,ev.X) > Data.threshold,xmar=[6,2],ymar=[2,1] plots, [1,1]*Data.xy(0,1),!y.crange plots, [1,1]*Data.xy(1,1),!y.crange plots, [1,1]*Data.Zero(0),!y.crange,col=130 plots, [1,1]*Data.Zero(1),!y.crange,col=130 plots, [1,1]*Data.QS(0),!y.crange,col=200 plots, [1,1]*Data.QS(1),!y.crange,col=200 empty scale,temp,/mem Sc.W3=temp endif return ENDIF IF ev.id eq Data.View(2) THEN BEGIN device,/cursor_cross WIDGET_CONTROL,Data.Time_Label(2),set_val= $ string(data.tv_bounds(0)+ev.X*Data.factor(1),ev.Y,format="(I6,', ',I6)") if ev.release then begin wset,Data.Win(3) plot,findgen(Data.N_channels)+1, $ Array2(*,ev.X),xmar=[6,2],ymar=[2,1] empty scale,temp,/mem Sc.W3=temp endif return ENDIF IF ev.id eq Data.View(3) THEN BEGIN window_set,Data.Win(3),scale=Sc.W3 device,/cursor_cross X=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) WIDGET_CONTROL,Data.R_Win_Label(0),set_val= $ string(X(0),X(1),format="(I6,', ',I6)") return ENDIF IF ev.id eq Data.View(4) THEN BEGIN window_set,Data.Win(4),scale=Sc.W4 device,/cursor_cross X=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) WIDGET_CONTROL,Data.R_Win_Label(1),set_val= $ string(X(0),X(1),format="(I6,', ',I6)") if Data.Switch then begin if ev.press then begin Data.Point=X(0) WIDGET_CONTROL,Data.Goto_button,sens=1 Data.tv_bounds=Data.Point+[-256,255] > 0 < (Data.Length-1) if Data.Tv_bounds(0) eq Data.Tv_bounds(1) then $ Data.Tv_bounds(1)=Data.Tv_bounds(0)+2 Data.tv_bounds(1)=Data.tv_bounds(1) < (Data.tv_bounds(0)+511) WIDGET_CONTROL,Data.Ref_Label(0),set_val= $ Time_Outvalue(Data.Point, time=Data.time, Dt=Data.Dt, space=2) WIDGET_CONTROL, Data.slider2(0),set_val=Data.Point if Data.tv_bounds(1)-Data.tv_bounds(0) lt 255 then $ Data.tv_bounds=(Data.tv_bounds(0)+Data.tv_bounds(1))/2+ $ [-256,255] > 0 < (Data.Length-1) WIDGET_CONTROL,Data.Time_Label(0),set_val=' '+strtrim(Data.tv_bounds(0),2)+':'+$ Time_Outvalue(Data.tv_bounds(0), time=Data.time, Dt=Data.Dt, space=3)+ $ ' --- '+strtrim(Data.tv_bounds(1),2)+':'+ $ Time_Outvalue(Data.tv_bounds(1), time=Data.time, Dt=Data.Dt, space=3) wset,Data.Win(0) & erase,0 & empty file_align_show endif endif RETURN ENDIF WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "Xloadct": begin WIDGET_CONTROL,/hour Xloadct end "Calculator": begin WIDGET_CONTROL,/hour Wcalc end "Scan": for j=0,1 do WIDGET_CONTROL,Data.View_Base1(j),map=1-j "Trend": for j=0,1 do WIDGET_CONTROL,Data.View_Base1(j),map=j "Last": for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([1,0,0])(j) "Aligned": for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,1,0])(j) "Calibrated": for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,0,1])(j) "List": begin WIDGET_CONTROL,/hour a=xselect(string(Sw_Points),group=ev.top) if a ge 0 then if Sw_Points(0) ge 0 then $ Data.Point=Sw_Points(a) else Data.Point=0 WIDGET_CONTROL,Data.Goto_button,sens=1 end "Go to": begin Data.tv_bounds=Data.Point+[-256,255] > 0 < (Data.Length-1) if Data.Tv_bounds(0) eq Data.Tv_bounds(1) then $ Data.Tv_bounds(1)=Data.Tv_bounds(0)+2 Data.tv_bounds(1)=Data.tv_bounds(1) < (Data.tv_bounds(0)+511) WIDGET_CONTROL,Data.Ref_Label(0),set_val= $ Time_Outvalue(Data.Point, time=Data.time, Dt=Data.Dt, space=2) WIDGET_CONTROL, Data.slider2(0),set_val=Data.Point if Data.tv_bounds(1)-Data.tv_bounds(0) lt 255 then $ Data.tv_bounds=(Data.tv_bounds(0)+Data.tv_bounds(1))/2+ $ [-256,255] > 0 < (Data.Length-1) WIDGET_CONTROL,Data.Time_Label(0),set_val=' '+strtrim(Data.tv_bounds(0),2)+':'+$ Time_Outvalue(Data.tv_bounds(0), time=Data.time, Dt=Data.Dt, space=3)+ $ ' --- '+strtrim(Data.tv_bounds(1),2)+':'+ $ Time_Outvalue(Data.tv_bounds(1), time=Data.time, Dt=Data.Dt, space=3) wset,Data.Win(0) & erase,0 & empty end "Threshold": begin WIDGET_CONTROL,Data.thres,get_val=a,/hour Data.threshold=fix(a(0)) wset,Data.Win(1) erase tvscl,transpose(Array1) > Data.threshold empty end "Both": begin WIDGET_CONTROL,/hour if Data.lun_I(0) eq 0 then begin xwarning,'You should first make aligned file' return endif if equiv(Data.Zero, fltarr(2)) or equiv(Data.QS, fltarr(2)) then begin xwarning,'You should first indicate both reference areas - Zero and Quiet Sun' return endif Length=Data.edges(1)-Data.edges(0)+1 disk_free,tmp Data.free=tmp Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' if Data.Free lt Space_required then begin xwarning, 'There is not enough disk space!' return endif r_trend=(Zero=fltarr(Length)) widget_control,Data.Info_Label,/hour,set_val='Calculating gain factor...' for j=0,Length-1 do begin r_trend(j)=total((xx(j))(Data.QS(0):Data.QS(1))) Zero(j)=total((xx(j))(Data.Zero(0):Data.Zero(1))) if j mod 32 eq 0 then WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0)+j endfor ; ***************************************************************** wait,0.2 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) r_trend=r_trend/(Data.QS(1)-Data.QS(0)+1) Zero=Zero/(Data.Zero(1)-Data.Zero(0)+1) gain=(r_trend-Zero)/(r_trend(0)-Zero(0)) background=(Zero*r_trend(0)-Zero(0)*r_trend)/(r_trend(0)-Zero(0)) device,get_screen_size=scr k=0.45 window,/free,tit='Gain', xsize=scr(0)*k, ysize=scr(1)*k, $ xpos=scr(0)*0.5, ypos=0 plot,gain window,/free,tit='Zero level', xsize=scr(0)*k, ysize=scr(1)*k, $ xpos=scr(0)*0.5, ypos=scr(1)*0.5 plot,background empty ;r_trend=r_trend/(Data.QS(1)-Data.Zero(1)-Data.QS(0)+1) ;comp_factor=r_trend(0)/r_trend comp_factor=gain(0)/gain kb_in_text,comments comments=strtrim(comments) type='Aligned and calibrated record' f_a_file_prepare,1,ev.top,Offset_I,header_I,Offset_V,header_V,comments,type,cancel if cancel then return xxx=assoc(Data.lun_I(1),intarr(Data.N_channels),Offset_I) yyy=assoc(Data.lun_V(1),intarr(Data.N_channels),Offset_V) widget_control,Data.Info_Label,/hour,set_val='Calibrating gain ...' for j=0,Length-1 do begin xxx(j)=replicate(comp_factor(j),Data.N_Channels)*(xx(j)-Zero(j)) > (-10) yyy(j)=replicate(comp_factor(j),Data.N_Channels)*(yy(j)) if j mod 32 eq 0 then WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0)+j endfor ; ***************************************************************** wait,0.2 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' Data.factor(1)=Length/512+1 Array2=intarr(Data.N_channels,512) for j=0,511 < (Length/Data.factor(1)-1) do Array2(*,j)=xxx(*,j*Data.factor(1)) for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,0,1])(j) wset,Data.Win(2) erase tvscl,transpose(Array2) > Data.threshold empty end "Gain_only": begin WIDGET_CONTROL,/hour if Data.lun_I(0) eq 0 then begin xwarning,'You should first make aligned file' return endif if equiv(Data.Zero, fltarr(2)) or equiv(Data.QS, fltarr(2)) then begin xwarning,'You should first indicate both reference areas - Zero and Quiet Sun' return endif Length=Data.edges(1)-Data.edges(0)+1 disk_free,tmp Data.free=tmp Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' if Data.Free lt Space_required then begin xwarning, 'There is not enough disk space!' return endif r_trend=(Zero=fltarr(Length)) widget_control,Data.Info_Label,/hour,set_val='Calculating gain factor...' for j=0,Length-1 do begin r_trend(j)=total((xx(j))(Data.QS(0):Data.QS(1))) Zero(j)=total((xx(j))(Data.Zero(0):Data.Zero(1))) if j mod 32 eq 0 then WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0)+j endfor ; ***************************************************************** wait,0.2 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) r_trend=r_trend/(Data.QS(1)-Data.QS(0)+1) Zero=Zero/(Data.Zero(1)-Data.Zero(0)+1) Zero=min(Zero) gain=(r_trend-Zero)/(r_trend(0)-Zero(0)) background=(Zero*r_trend(0)-Zero(0)*r_trend)/(r_trend(0)-Zero(0)) device,get_screen_size=scr k=0.45 window,/free,tit='Gain', xsize=scr(0)*k, ysize=scr(1)*k, $ xpos=scr(0)*0.5, ypos=0 plot,gain window,/free,tit='Zero level', xsize=scr(0)*k, ysize=scr(1)*k, $ xpos=scr(0)*0.5, ypos=scr(1)*0.5 plot,background empty ;r_trend=r_trend/(Data.QS(1)-Data.Zero(1)-Data.QS(0)+1) ;comp_factor=r_trend(0)/r_trend comp_factor=gain(0)/gain kb_in_text,comments comments=strtrim(comments) type='Aligned and calibrated record' f_a_file_prepare,1,ev.top,Offset_I,header_I,Offset_V,header_V,comments,type,cancel if cancel then return xxx=assoc(Data.lun_I(1),intarr(Data.N_channels),Offset_I) yyy=assoc(Data.lun_V(1),intarr(Data.N_channels),Offset_V) widget_control,Data.Info_Label,/hour,set_val='Calibrating gain ...' for j=0,Length-1 do begin xxx(j)=replicate(comp_factor(j),Data.N_Channels)*(xx(j)-Zero) > (-10) yyy(j)=replicate(comp_factor(j),Data.N_Channels)*(yy(j)) if j mod 32 eq 0 then WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0)+j endfor ; ***************************************************************** wait,0.2 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' Data.factor(1)=Length/512+1 Array2=intarr(Data.N_channels,512) for j=0,511 < (Length/Data.factor(1)-1) do Array2(*,j)=xxx(*,j*Data.factor(1)) for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,0,1])(j) wset,Data.Win(2) erase tvscl,transpose(Array2) > Data.threshold empty end "Zero_0": begin WIDGET_CONTROL,/hour if Data.lun_I(0) eq 0 then begin xwarning,'You should first make aligned file' return endif if equiv(Data.QS, fltarr(2)) then begin xwarning,'You should first indicate reference area - Quiet Sun' return endif Length=Data.edges(1)-Data.edges(0)+1 disk_free,tmp Data.free=tmp Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' if Data.Free lt Space_required then begin xwarning, 'There is not enough disk space!' return endif r_trend=(Zero=fltarr(Length)) widget_control,Data.Info_Label,/hour,set_val='Calculating gain factor...' for j=0,Length-1 do begin r_trend(j)=total((xx(j))(Data.QS(0):Data.QS(1))) ;Zero(j)=total((xx(j))(Data.Zero(0):Data.Zero(1))) if j mod 32 eq 0 then WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0)+j endfor ; ***************************************************************** wait,0.2 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) r_trend=r_trend/(Data.QS(1)-Data.QS(0)+1) Zero=Zero/(Data.Zero(1)-Data.Zero(0)+1) Zero=min(Zero) gain=(r_trend-Zero)/(r_trend(0)-Zero(0)) background=(Zero*r_trend(0)-Zero(0)*r_trend)/(r_trend(0)-Zero(0)) device,get_screen_size=scr k=0.45 window,/free,tit='Gain', xsize=scr(0)*k, ysize=scr(1)*k, $ xpos=scr(0)*0.5, ypos=0 plot,gain window,/free,tit='Zero level', xsize=scr(0)*k, ysize=scr(1)*k, $ xpos=scr(0)*0.5, ypos=scr(1)*0.5 plot,background empty ;r_trend=r_trend/(Data.QS(1)-Data.Zero(1)-Data.QS(0)+1) ;comp_factor=r_trend(0)/r_trend comp_factor=gain(0)/gain kb_in_text,comments comments=strtrim(comments) type='Aligned and calibrated record' f_a_file_prepare,1,ev.top,Offset_I,header_I,Offset_V,header_V,comments,type, cancel if cancel then return xxx=assoc(Data.lun_I(1),intarr(Data.N_channels),Offset_I) yyy=assoc(Data.lun_V(1),intarr(Data.N_channels),Offset_V) widget_control,Data.Info_Label,/hour,set_val='Calibrating gain ...' for j=0,Length-1 do begin xxx(j)=replicate(comp_factor(j),Data.N_Channels)*(xx(j)-Zero) > (-10) yyy(j)=replicate(comp_factor(j),Data.N_Channels)*(yy(j)) if j mod 32 eq 0 then WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0)+j endfor ; ***************************************************************** wait,0.2 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' Data.factor(1)=Length/512+1 Array2=intarr(Data.N_channels,512) for j=0,511 < (Length/Data.factor(1)-1) do Array2(*,j)=xxx(*,j*Data.factor(1)) for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,0,1])(j) wset,Data.Win(2) erase tvscl,transpose(Array2) > Data.threshold empty end "Switch": begin widget_control,Data.Info_Label,/hour,set_val='Searching for switch points...' f_a_find_switch,FileName=Data.Fname,Iew=Iew,Points_EW=Points_EW Sw_Points=Points_EW Data.Switch=1 for j=0,1 do WIDGET_CONTROL,Data.View_Base1(j),map=j wset,Data.Win(4) plot,total(Iew,2),xmar=[6,3],ymar=[2,1],xticks=2,/xst scale,temp,/mem Sc.W4=temp WIDGET_CONTROL,Data.Trend_button,sens=1 empty Space_required=Data.Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,/hour,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' WIDGET_CONTROL,Data.List_button,sens=1 return end "Iew": begin Data.Stokes(0)=ev.select Data.Stokes(1)=1-Data.Stokes(0) Data.Stokes(2)=(Data.Stokes(3)=0) for j=0,3 do WIDGET_CONTROL,Data.But_Stokes(j),set_but=Data.Stokes(j) end "Vew": begin Data.Stokes(1)=ev.select Data.Stokes(0)=1-Data.Stokes(1) Data.Stokes(2)=(Data.Stokes(3)=0) for j=0,3 do WIDGET_CONTROL,Data.But_Stokes(j),set_but=Data.Stokes(j) end "Isn": begin Data.Stokes(2)=ev.select Data.Stokes(3)=1-Data.Stokes(2) Data.Stokes(0)=(Data.Stokes(1)=0) for j=0,3 do WIDGET_CONTROL,Data.But_Stokes(j),set_but=Data.Stokes(j) end "Vsn": begin Data.Stokes(3)=ev.select Data.Stokes(2)=1-Data.Stokes(3) Data.Stokes(0)=(Data.Stokes(1)=0) for j=0,3 do WIDGET_CONTROL,Data.But_Stokes(j),set_but=Data.Stokes(j) end "Natural": begin for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([1,0,0])(j) Data.factor(0)=1 file_align_show end "Compressed": begin for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([1,0,0])(j) Data.factor(0)=Data.factor(1) file_align_show end "HELP": begin WIDGET_CONTROL,/hour CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE xtext,file=getenv('help_dir')+Delim+'filesett.hlp',group=ev.top end "START": begin Data.edges(0)=ev.value WIDGET_CONTROL,Data.Txt1,set_val=Time_Outvalue(Data.edges(0),$ time=Data.time, Dt=Data.Dt, space=5) WIDGET_CONTROL,Data.First_Block, $ set_val=strtrim(Data.edges(0)/Data.N_scans,2) WIDGET_CONTROL,Data.First_Record, $ set_val=strtrim(Data.edges(0) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) end "STOP": begin Data.edges(1)=ev.value WIDGET_CONTROL,Data.Txt2,set_val=Time_Outvalue(Data.edges(1),$ time=Data.time, Dt=Data.Dt, space=5) WIDGET_CONTROL,Data.Last_Block, $ set_val=strtrim(Data.edges(1)/Data.N_scans,2) WIDGET_CONTROL,Data.Last_Record, $ set_val=strtrim(Data.edges(1) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) end "Open": Data.New_file=1 "TV": begin Data.tv_bounds=ev.value+[-256,255] > 0 < (Data.Length-1) if Data.Tv_bounds(0) eq Data.Tv_bounds(1) then $ Data.Tv_bounds(1)=Data.Tv_bounds(0)+2 Data.tv_bounds(1)=Data.tv_bounds(1) < (Data.tv_bounds(0)+511) WIDGET_CONTROL,Data.Ref_Label(0),set_val= $ Time_Outvalue(ev.value, time=Data.time, Dt=Data.Dt, space=2) if Data.tv_bounds(1)-Data.tv_bounds(0) lt 255 then $ Data.tv_bounds=(Data.tv_bounds(0)+Data.tv_bounds(1))/2+ $ [-256,255] > 0 < (Data.Length-1) WIDGET_CONTROL,Data.Time_Label(0),set_val=' '+strtrim(Data.tv_bounds(0),2)+':'+$ Time_Outvalue(Data.tv_bounds(0), time=Data.time, Dt=Data.Dt, space=3)+ $ ' --- '+strtrim(Data.tv_bounds(1),2)+':'+ $ Time_Outvalue(Data.tv_bounds(1), time=Data.time, Dt=Data.Dt, space=3) wset,Data.Win(0) & erase,0 & empty end "Channel": Data.Channel=ev.value-1 "Time": begin WIDGET_CONTROL,/hourglass Data.Reference=ev.value Data.Reference_time= $ Time_Outvalue(ev.value,time=Data.time, Dt=Data.Dt) WIDGET_CONTROL,Data.Ref_label(1),set_val=' '+Data.Reference_time Wset,Data.Win(3) Iew=Data.Stokes(0) Vew=Data.Stokes(1) Isn=Data.Stokes(2) Vsn=Data.Stokes(3) bounds=[1L,1L]*ev.value readfile,FileName=Data.Fname,bounds=bounds, Iew=Iew, Vew=Vew, ISN=ISN, VSN=VSN CASE 1 OF Data.Stokes(0): x=Iew Data.Stokes(1): x=Vew Data.Stokes(2): x=Isn Data.Stokes(3): x=Vsn ENDCASE Wset,Data.Win(3) plot,findgen(Data.N_channels)+1,x,xmar=[6,2],ymar=[2,1] scale,temp,/mem Sc.W3=temp empty end "Align": begin widget_control,/hour ; ************************** Show settings ******************** Data.edges=Data.edges(sort(Data.edges)) Data.edges=[Data.edges(0)/32*32, (Data.edges(1)+1)/32*32-1] Length=Data.edges(1)-Data.edges(0)+1 disk_free,tmp Data.free=tmp Space_required=Length*Data.N_channels*4+1000 widget_control,Data.Info_Label,set_val= $ ' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ' if Data.Free lt Space_required then begin xwarning, 'There is not enough disk space!' return endif WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) WIDGET_CONTROL, Data.slider1,set_val=Data.edges(1) WIDGET_CONTROL,Data.Txt1,set_val=Time_Outvalue(Data.edges(0),$ time=Data.time, Dt=Data.Dt, space=5) WIDGET_CONTROL,Data.First_Block, $ set_val=strtrim(Data.edges(0)/Data.N_scans,2) WIDGET_CONTROL,Data.First_Record, $ set_val=strtrim(Data.edges(0) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) WIDGET_CONTROL,Data.Txt2,set_val=Time_Outvalue(Data.edges(1),$ time=Data.time, Dt=Data.Dt, space=5) WIDGET_CONTROL,Data.Last_Block, $ set_val=strtrim(Data.edges(1)/Data.N_scans,2) WIDGET_CONTROL,Data.Last_Record, $ set_val=strtrim(Data.edges(1) mod Data.N_scans,2) WIDGET_CONTROL,Data.Label, $ set_val=strtrim(abs(Data.edges(1)-Data.edges(0))+1,2) ; *************** Show the array around reference time *************** Data.tv_bounds=Data.Reference+[-256,255] > 0 < (Data.Length-1) if Data.Tv_bounds(0) eq Data.Tv_bounds(1) then $ Data.Tv_bounds(1)=Data.Tv_bounds(0)+2 Data.tv_bounds(1)=Data.tv_bounds(1) < (Data.tv_bounds(0)+511) WIDGET_CONTROL,Data.Ref_Label(0),set_val= $ Time_Outvalue(Data.Reference, time=Data.time, Dt=Data.Dt, space=2) if Data.Length gt 512 then WIDGET_CONTROL, Data.slider2(0),set_val=Data.Reference if Data.tv_bounds(1)-Data.tv_bounds(0) lt 255 then $ Data.tv_bounds=(Data.tv_bounds(0)+Data.tv_bounds(1))/2+ $ [-256,255] > 0 < (Data.Length-1) file_align_show Wset,Data.Win(0) device,set_gr=6 plots,[1,1]*(Data.Reference-Data.tv_bounds(0)) > 0 < 511,[0,192],/dev plots,[0,511],[1,1]*Data.Channel,/dev device,set_gr=3 empty Iew=Data.Stokes(0) Vew=Data.Stokes(1) Isn=Data.Stokes(2) Vsn=Data.Stokes(3) bounds=[1L,1L]*Data.Reference readfile,FileName=Data.Fname,bounds=bounds, Iew=Iew, Vew=Vew, ISN=ISN, VSN=VSN CASE 1 OF Data.Stokes(0): x=Iew Data.Stokes(1): x=Vew Data.Stokes(2): x=Isn Data.Stokes(3): x=Vsn ENDCASE Wset,Data.Win(3) plot,findgen(Data.N_channels)+1,x,xmar=[6,2],ymar=[2,1] scale,temp,/mem Sc.W3=temp empty ; **************** Building of the output file names ************* ; *************************** Is all OK ? ************************ xquestion,aaa,text='Are all the settings OK?', $ group=ev.top,sel=['OK','Cancel'],ypos=0 if aaa eq 'Cancel' then return kb_in_text,comments comments=strtrim(comments) type='Aligned record' f_a_file_prepare,0,ev.top,Offset_I,header_I,Offset_V,header_V,comments,type,cancel if cancel then return xx=assoc(Data.lun_I(0),intarr(Data.N_channels,32),Offset_I) yy=assoc(Data.lun_V(0),intarr(Data.N_channels,32),Offset_V) Channel=Data.Channel if Data.N_channels eq 192 then Receiver='AOR' else Receiver='FDAS' N_block=Data.edges/32 start_time=Data.reference_time suneph,Data.date,start_time,SUN Receiver=Receiver eq 'AOR' ; ****************** Aligning cycle ***************************** for j=N_block(0),N_block(1) do begin bounds0=[0L,31L] bounds=bounds0+32*j Iew=Data.Stokes(0) or Data.Stokes(1) Vew=Data.Stokes(1) or Data.Stokes(0) Isn=Data.Stokes(2) or Data.Stokes(3) Vsn=Data.Stokes(3) or Data.Stokes(2) dir=isn readfile,FileName=Data.Fname,bounds=bounds,$ IEW=IEW, VEW=VEW, ISN=ISN, VSN=VSN, time=time_sec, date=date,/fast fast=(single=(interp=0)) interp=1 if dir then iew=isn if not Receiver then time_sec=time_sec(0) scan=s_align(iew,Date,time_sec,Receiver,Data.Dt,Dir,sin=single, $ fast=fast,interp=interp, $ start=start_time,SUN=SUN,Channel=Channel) xx(j-N_block(0))=scan if dir then vew=vsn scan=s_align(vew,Date,time_sec,Receiver,Data.Dt,Dir,sin=single, $ fast=fast,interp=interp, /polar, $ start=start_time,SUN=SUN,Channel=Channel) yy(j-N_block(0))=scan WIDGET_CONTROL, Data.slider0,set_val=bounds(1) endfor ; ***************************************************************** wait,0.4 WIDGET_CONTROL, Data.slider0,set_val=Data.edges(0) Length=Data.edges(1)-Data.edges(0)+1 Data.factor(1)=Length/512+1 xx=assoc(Data.lun_I(0),intarr(Data.N_channels),Offset_I) yy=assoc(Data.lun_V(0),intarr(Data.N_channels),Offset_V) Array1=intarr(Data.N_channels,512) for j=0,511 < (Length/Data.factor(1)-1) do Array1(*,j)=xx(*,j*Data.factor(1)) for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,1,0])(j) wset,Data.Win(1) erase tvscl,transpose(Array1) > Data.threshold empty widget_control,Data.Compressed,sens=1 widget_control,Data.Natural,sens=1 end "Zero": begin Data.Zero=Data.xy(*,1) window_set,Data.Win(3),scale=Sc.W3 plots, [1,1]*Data.Zero(0),!y.crange,col=130 plots, [1,1]*Data.Zero(1),!y.crange,col=130 empty end "Q.Sun": begin Data.QS=Data.xy(*,1) window_set,Data.Win(3),scale=Sc.W3 plots, [1,1]*Data.QS(0),!y.crange,col=200 plots, [1,1]*Data.QS(1),!y.crange,col=200 empty end ELSE: ENDCASE if (uv eq "Cancel") or (uv eq "Open") or (uv eq "DONE") then begin device,/cursor_cross WIDGET_CONTROL,ev.top,/DEST,/hour if Data.g_leader ne 0L then begin if WIDGET_INFO(Data.g_leader,/valid) then g_leader=Data.g_leader else g_leader=0L endif else g_leader=0L New_file=Data.New_file eq 1 for j=0,1 do begin if Data.lun_I(j) ne 0 then flush,Data.lun_I(j) if Data.lun_V(j) ne 0 then flush,Data.lun_V(j) if Data.lun_I(j) ne 0 then free_lun,Data.lun_I(j) if Data.lun_V(j) ne 0 then free_lun,Data.lun_V(j) endfor Data=Data.Fname Array0=(Array1=(Array2=0)) xx=(yy=(xxx=(yyy=(current_state=(Sc=(Sw_Points=0)))))) if New_file then file_align,group_leader=g_leader else begin if g_leader ne 0L then begin if WIDGET_INFO(g_leader,/valid) then WIDGET_CONTROL,g_leader,/show $ else g_leader=0L endif else g_leader=0L endelse endif IF uv eq 'Iew' $ or uv eq 'Vew' $ or uv eq 'Isn' $ or uv eq 'Vsn' $ or uv eq 'Redraw' $ or uv eq 'Go to' $ THEN file_align_show end pro file_align, Filename=Filename, path=path, group_leader=group_leader ; Selects bounds of an array to be read from the SSRT data file. common file_align_Exch,Data,Array0,Array1,Array2, $ xx,yy,xxx,yyy,current_state,Sc,Sw_Points if n_elements(group_leader) le 0 then group_leader = 0L Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} Sc={W3:Ax, W4:Ax} Ax=0 if n_elements(Filename) gt 0 then begin if Filename ne '' then path=subdir(Filename) endif else begin if n_tags(data) eq 0 and n_elements(data) eq 1 $ and equiv(size(data), [0L,7L,1L]) then Filename=data $ else Filename='' endelse if n_elements(path) le 0 then path=getenv('spk_dat') Data={ slider0:0L, slider1:0L, slider2:[0L,0L,0L], $ Txt1:0L, Txt2:0L, Fname:'', Slider_Base:lonarr(3), $ But_stokes:lonarr(4), Time_label:lonarr(3), $ Ref_label:lonarr(3), N_channels:192, lun_I:lonarr(2), $ lun_V:lonarr(2), edges:[0L,1000L-1], Length:0L, $ time:[0d,0d], mul:1, sum:1, New_file:0, Canc:0, $ Stokes:[1,0,0,0], Dt:0d, Date:'', First_Block:0L, Last_Block:0L,$ First_Record:0L, Last_Record:0L, N_scans:0L, $ g_leader:group_leader, Label:0L, View:lonarr(5), Win:lonarr(5), $ tv_bounds:[0L,0L], press:0, free:0L, Channel:0, $ Reference_time:'', Reference:0L, View_Base0:lonarr(3), $ View_Base1:lonarr(2), Info_Label:0L, Point:0L, Scan_button:0L, $ Trend_button:0L, init:1, xy:intarr(2,2), R_Win_Label:[0L,0L], $ List_button:0L, Switch:0, Goto_button:0L, factor:[1,1], $ threshold:(-100), thres:0L, Compressed:0L, Natural:0L, $ Interf:'E-W', File_Type:'Original', Zero_button:0L, $ QS_button:0L, Zero:[0,0], QS:[0,0]} if xregistered('file_align') then return if n_elements(Length) le 0 then Length=0L device,get_scr=scr Data.FName=Filename ret: Filename=Data.FName Data.FName=pickfile(/read,path=path,file=Filename) if Data.FName eq '' then begin Data.Canc=1 print,'You have selected no file' goto,exit1 endif old: Data.time=[0D,0D] Data.mul=1 & Data.sum=0 WIDGET_CONTROL,/hour Name=name_extract(Data.Fname) if Name(2) eq 'awi' or $ Name(2) eq 'awv' or $ Name(2) eq 'ani' or $ Name(2) eq 'anv' then begin f_a_file_read,index,top, $ Offset_I,header_I,Offset_V,header_V,comments,type Data.File_Type='Processed' Data.n_scans=32L endif else begin openr,lun,Data.Fname,/get_lun Block=ssrt_file_struc(lun, Fileformat=Fileformat, $ Offset=Offset, Blocklength=Blocklength, Length=Length, $ Num_blocks=Num_blocks, Dt=Dt) Data.Length=Length & Data.Dt=Dt Receiver=fix(Fileformat(0) eq 'aor') ;if equiv(Fileformat, ['aor','1']) ne 1 then Data.Interf='E-W' Data.N_scans=1L+31L*Receiver Data.N_channels=([176,192])(Receiver) Data.time(0)=read_time(Lun, Blocknumber=0) Data.time(1)=read_time(Lun, Blocknumber=Num_blocks-1)+(Data.N_scans-1)*Data.Dt free_lun,lun Data.edges=[0L,Data.Length-1] if keyword_set(current_file) then if current_file $ then if n_elements(bounds) eq 2 then Data.edges=bounds endelse main=widget_base(tit='Alignment of the file '+Name(0),/colu) Menu_Base=widget_base(main,/row) XPdMenu, ['"DONE" DONE', $ '"FILE" {', $ '"Open" Open', $ '"1 Switch Points" Switch',$ '"2 Align" Align', $ '"3 Calibrate" {', $ '"Calculate both gain and zero level" Both', $ '"Calculate gain and subtract zero level" Gain_only',$ '"Calculate gain assuming zero of 0" Zero_0',$ '}', $ '}', $ '"Tools" {', $ '"Colors" Xloadct', $ '"Calculator" Calculator', $ '}', $ '"HELP" HELP'], $ Menu_Base disk_free,tmp Data.free=tmp Space_required=Data.Length*Data.N_channels*4+1000 Data.Info_Label=widget_label(Menu_Base, /frame, $ val=' Disk space available: '+ $ strtrim(string(0.001*Data.free,format="(F9.1)"),2)+' Kb, required: '+ $ strtrim(string(0.001*Space_required,format="(F7.1)"),2)+' Kb ') Upper_Base=widget_base(main,/row) base1= widget_base(Upper_Base,/row,/excl,/fra) val=['Iew','Vew','Isn','Vsn'] for j=0,3 do begin Data.But_Stokes(j)=WIDGET_BUTTON(base1,uval=val(j),val=val(j)+' ') WIDGET_CONTROL,Data.But_Stokes(j),set_but=([1,0,0,0])(j) endfor FOR j=2,3 DO BEGIN ;if not equiv(Fileformat,['aor','1']) then begin if Data.File_Type ne 'Processed' then $ if not equiv(Fileformat,['aor','1']) then begin WIDGET_CONTROL,Data.But_Stokes(j),set_but=0 WIDGET_CONTROL,Data.But_Stokes(j),sens=0 Data.Stokes(j)=0 endif ENDFOR junk=WIDGET_LABEL(Upper_Base,val=' Total: ') Number_of_Blocks=WIDGET_LABEL(Upper_Base, $ val=strtrim(Data.Length/Data.N_scans,2)+$ ' Blocks, '+strtrim(Data.Length,2)+' Scans.') EmptyString=' ' gap=WIDGET_LABEL(Upper_Base,val=EmptyString) junk=WIDGET_LABEL(Upper_Base,val='Scans selected : ') Data.Label=WIDGET_LABEL(Upper_Base,val= $ ''+strtrim(abs(Data.edges(1)-Data.edges(0))+1,2)+' ') Double_Base=widget_base(main,/row) Left_Base=widget_base(Double_Base,/colu,/fra) Right_Base=widget_base(Double_Base,/colu,/fra) Data.slider0=WIDGET_SLIDER(Left_Base, MIN=0, MAX=Data.Length-1, $ TIT='First record', /FRA, $ UVAL= 'START', VAL=Data.edges(0),/drag) Slider_Base_0=WIDGET_BASE(Left_Base,/row) Data.Txt1 = WIDGET_LABEL(Slider_Base_0, val= $ Time_Outvalue(Data.edges(0), time=Data.time, Dt=Data.Dt, space=5)+EmptyString) Info1 = WIDGET_LABEL(Slider_Base_0, val='First block: ') Data.First_Block = WIDGET_LABEL(Slider_Base_0, $ val=' '+strtrim(Data.edges(0)/Data.N_scans,2)+' ') Info11 = WIDGET_LABEL(Slider_Base_0, val='Record: ') Data.First_Record = WIDGET_LABEL(Slider_Base_0, $ val=' '+strtrim(Data.edges(0) mod Data.N_scans,2)+' ') line=widget_base(Left_Base,/frame,/row,ysiz=1) Data.slider1=WIDGET_SLIDER(Left_Base, MIN=0, MAX=Data.Length-1, $ TIT='Last record', /FRAME, $ UVAL= 'STOP', VAL=Data.edges(1),/drag) Slider_Base_1=WIDGET_BASE(Left_Base,/row) Data.Txt2 = WIDGET_LABEL(Slider_Base_1, val= $ Time_Outvalue(Data.edges(1), time=Data.time, Dt=Data.Dt, space=5)+EmptyString) Info2 = WIDGET_LABEL(Slider_Base_1, val='Last block: ') Data.Last_Block = WIDGET_LABEL(Slider_Base_1, $ val=' '+strtrim(Data.edges(1)/Data.N_scans,2)+' ') Info21 = WIDGET_LABEL(Slider_Base_1, val='Record: ') Data.Last_Record = WIDGET_LABEL(Slider_Base_1, $ val=' '+strtrim(Data.edges(1) mod Data.N_scans,2)+' ') Draw_base=widget_base(main,/row) Left_Draw_base=widget_base(Draw_Base,/colu) Right_Draw_base=widget_base(Draw_Base,/colu) Plain_Base=widget_base(Left_Draw_Base) for j=0,2 do begin Data.View_Base0(j) =widget_base(Plain_base,/colu) Data.View(j)=WIDGET_DRAW(Data.View_Base0(j),/fra, $ xsi=256*2,ysi=192,/motion, /button) Data.Time_Label(j)=widget_label(Data.View_Base0(j),val=Emptystring) endfor Left_Button_Base=widget_base(Left_Draw_base,/row) Parent_button=widget_button(Left_Button_Base,val='Initial',/menu) Initial=widget_button(Parent_button,val='Last',uval='Last') Data.Compressed=widget_button(Parent_button,val='Natural',uval='Natural') Data.Natural=widget_button(Parent_button,val='Compressed',uval='Compressed') widget_control,Data.Compressed,sens=0 widget_control,Data.Natural,sens=0 Aux_Base=widget_Base(Left_Button_Base,/row,/fra) button=widget_button(Aux_Base,val='Aligned',uval='Aligned') Label=widget_label(Aux_Base,val='Threshold: ') Data.thres=widget_text(Aux_Base,/edit,xsize=6,/fra,uval='Threshold', $ val=string(Data.threshold,format="(I6)")) button=widget_button(Left_Button_Base,val='Calibrated',uval='Calibrated') Data.Zero_button=widget_button(Left_Button_Base,val='Zero',uval='Zero') Data.QS_button=widget_button(Left_Button_Base,val='Q.Sun',uval='Q.Sun') widget_control,Data.QS_button,sens=0 widget_control,Data.Zero_button,sens=0 Plain_Base=widget_base(Right_Draw_Base) for j=0,1 do begin Data.View_Base1(j) =widget_base(Plain_base,/colu) Data.View(3+j)=WIDGET_DRAW(Data.View_base1(j),/fra, $ xsi=scr(0)*0.95-256*2,ysi=192,/motion, /button) Data.R_Win_Label(j)=widget_label(Data.View_Base1(j),val=Emptystring) endfor Right_Button_Base=widget_base(Right_Draw_base,/row) Data.List_button=widget_button(Right_Button_Base,val='List',uval='List') Data.Goto_button=widget_button(Right_Button_Base,val='Go to',uval='Go to') Data.Scan_button=widget_button(Right_Button_Base,val='Scan',uval='Scan') Data.Trend_button=widget_button(Right_Button_Base,val='Trend',uval='Trend') WIDGET_CONTROL,Data.List_button,sens=0 WIDGET_CONTROL,Data.Goto_button,sens=0 WIDGET_CONTROL,Data.Trend_button,sens=0 Setting_Base=widget_base(Right_Base,/row) Reference_Base=widget_base(Setting_Base,/colu) Label=widget_label(Reference_Base,val=Emptystring+' Reference:') Data.Tv_bounds=[256 < (Data.Length/2-1), $ (Data.Length-256) > (Data.Length/2-1)] if Data.Tv_bounds(0) eq Data.Tv_bounds(1) then $ Data.Tv_bounds(1)=Data.Tv_bounds(0)+2 Label_values=[ $ Time_Outvalue(Data.tv_bounds(0), time=Data.time, Dt=Data.Dt,space=2)+' ', $ Time_Outvalue(Data.tv_bounds(0), time=Data.time, Dt=Data.Dt,space=2)+' ', $ Emptystring+Emptystring] Column_Base=widget_base(Reference_Base,/colu) Slider_Labels=lonarr(3) for j=0,2 do begin Data.Slider_Base(j)= widget_base(Column_Base,/row) Slider_Labels(j)=widget_label(Data.Slider_Base(j),val=Emptystring+Emptystring) Data.slider2(j) = WIDGET_SLIDER(Data.Slider_Base(j), $ MIN=([Data.tv_bounds(0),0,1])(j), $ MAX=([Data.tv_bounds(1),Data.Length-1,Data.N_channels])(j), $ val=([0 > Data.tv_bounds(0),0,1])(j), $ UVAL= (['TV','Time', 'Channel'])(j), $ /drag) Data.Ref_label(j)=widget_label(Data.Slider_Base(j),val=Label_values(j)) endfor Data.tv_bounds=Data.tv_bounds-256 > 0 Data.tv_bounds(1)=Data.tv_bounds(1) < (Data.tv_bounds(0)+511) Redraw_button=widget_button(Data.Slider_Base(2),val='Redisplay',uval='Redraw' ) WIDGET_CONTROL,Data.Slider_Base(0),map=Data.Length gt 512 for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([1,0,0])(j) for j=0,1 do WIDGET_CONTROL,Data.View_Base1(j),map=1-j WIDGET_CONTROL,main,/real for j=0,4 do begin WIDGET_CONTROL,Data.View(j),get_val=tmp Data.Win(j)=tmp endfor for j=0,2 do widget_control,Slider_Labels(j),set_val=$ ([' TV ',' Time ', 'Channel'])(j) if Data.File_type eq 'Original' then begin file_align_show Plotting_array=Array0(*,0) Array1=(Array2=intarr(192,512)) endif else begin for j=0,2 do WIDGET_CONTROL,Data.View_Base0(j),map=([0,1,0])(j) wset,Data.Win(1) tvscl,transpose(Array1) > Data.threshold Plotting_array=Array1(*,0) widget_control,Data.Compressed,sens=1 widget_control,Data.Natural,sens=1 endelse Plotting_array=Plotting_array > Data.threshold wset,Data.Win(3) plot,findgen(Data.N_channels)+1,Plotting_array,xmar=[6,2],ymar=[2,1] scale,tmp,/mem Sc.W3=tmp wset,Data.Win(4) plot,findgen(Data.N_channels)+1,Plotting_array,/nodata,xst=4,yst=4 scale,tmp,/mem Sc.W4=tmp loadct,0,/si device,/cursor_cross empty Data.Reference_time= $ Time_Outvalue(0,time=Data.time, Dt=Data.Dt) xmanager,'file_align',main,group=group_leader exit1: if n_tags(Data) gt 1 then Filename=Data.Fname else Filename=Data end ####################################################### pro file_dir,filter,path=path,filename=filename ; Creates a file containing file list in a given subdirectory. ; For MS Windows Only. if n_elements(filter) le 0 then filter='*.*' if n_elements(filename) le 0 then filename='files.lst' if n_elements(path) gt 0 then pushd,path a=findfile(filter) if n_elements(path) gt 0 then popd a=a(sort(a)) & Sz=size(a) if (Sz)(0) gt 0 then Sz=Sz(1) else Sz=0 for j=0,Sz-1 do if strmid(a(j),strlen(a(j))-1,1) eq '\' then $ if n_elements(b) le 0 then b=j else b=[b,j] N_b=n_elements(b) if N_b gt 0 then begin a_save=a(b) for j=0,N_b-1 do a=a(where(a ne a_save(j))) a=[a_save,a] endif openw,lun,filename,/get_lun for j=0,Sz-2 do printf,lun,a(j) writeu,lun,a(Sz-1),'1A'xb free_lun,lun end ####################################################### pro find_circle_event, ev common find_circle, ID, data if ev.id eq ID.Draw then begin if ev.press then begin CASE Data.N_Points OF 0: begin Data.Points(*,Data.N_Points)=[ev.x, ev.y] Data.N_Points=Data.N_Points+1 end 1: begin Data.Points(*,Data.N_Points)=[ev.x, ev.y] Data.N_Points=Data.N_Points+1 end 2: begin Data.Points(*,Data.N_Points)=[ev.x, ev.y] Data.N_Points=0;Data.N_Points+1 Data.Circle=def_circle(Data.Points(*,0), Data.Points(*,1), Data.Points(*,2)) NN=500 t=findgen(NN)/(NN+1)*2*!Pi x=cos(t)*Data.Circle(2)+Data.Circle(0) y=sin(t)*Data.Circle(2)+Data.Circle(1) device, set_gr=6 plots, x, y, /dev, col=!d.n_colors-1, lines=1 plots, Data.Circle(0), Data.Circle(1), psym=1, syms=2, col=!d.n_colors-1, /dev device, set_gr=3 empty end ELSE: begin Data.N_Points=0 end ENDCASE for j=0,2 do widget_control, ID.buttons(j), sens=([0,0,0])(j) if Data.N_Points gt 0 then widget_control, ID.buttons(Data.N_Points-1), sens=1 endif return endif widget_control, ev.id, get_uval=uv CASE uv OF 'Done': begin widget_control, ev.top, /dest end ELSE: ENDCASE end function find_circle, array, title=title common find_circle, ID, data ID={Draw:0L, buttons:lonarr(3)} Data={N_Points:0, Points:fltarr(2,3), Circle:fltarr(3)} Sz=size(array) if Sz(0) eq 0 then begin print,'No argument. Returning...' return, 0 endif if n_elements(title) le 0 then title='Define circle' base=widget_base(tit=title, /colu) buttonbase=widget_base(base, /row) button=widget_button(buttonbase, val='Done', uval='Done') for j=0,2 do $ ID.buttons(j)=widget_button(buttonbase, val='Point '+strtrim(j+1,2), uval='Point '+strtrim(j+1,2)) ;button=widget_button(buttonbase, val='Point 2', uval='Point 2') ;button=widget_button(buttonbase, val='Point 3', uval='Point 3') ID.Draw=widget_draw(base, xs=Sz(1) > Sz(2), ys=Sz(1) > Sz(2), /button, /motion) widget_control, base, /real, /hour for j=0,2 do widget_control, ID.buttons(j), sens=([0,0,0])(j) widget_control, ID.Draw, get_val=tmp wset, tmp erase, 100 tvscl, array empty xmanager,'find_circle', base, /modal return, Data.circle end ####################################################### function find_closest, array1, array2 N1 = n_elements(array1) N2 = n_elements(array2) N = N1 < N2 index = lonarr(N) if N1 gt N2 then begin for j=0, N-1 do begin tmp = array1/float(array2[j])-1 amin = min(abs(tmp), imin) index[j] = imin endfor endif else begin for j=0, N-1 do begin tmp = array1[j]/float(array2)-1 amin = min(abs(tmp), imin) index[j] = imin endfor endelse return, index end ####################################################### function find_equal_in_pair,x,y,error=error error=0 ind=-1 Nx=n_elements(x) Ny=n_elements(y) N=Nx > Ny x1=x(sort([x])) y1=y(sort([y])) index=intarr(Nx,Ny)-1 for j=0,Ny-1 do index(0,j)=where(x1 eq y1(j)) temp=where(index ge 0) if temp(0) eq -1 then goto, L1 ind=index(temp) ind=ind(sort(ind)) ind=ind(uniq(ind)) L1: if ind(0) lt 0 then begin error=1 return,-1 endif return,x1(ind) end function find_equal,x0,x1,x2,x3,error=error ;+ Finds coinciding elements in two arrays ;- N=n_params() Output=0 error=0 ind=-1 CASE N OF 2: Output=find_equal_in_pair(x0,x1,error=error) 3: begin Output=find_equal_in_pair(x0,x1,error=error) if error then goto, L2 Output=find_equal_in_pair(x2,Output,error=error) if error then goto, L2 end 4: begin Output=find_equal_in_pair(x0,x1,error=error) if error then goto, L2 Output=find_equal_in_pair(x2,Output,error=error) if error then goto, L2 Output=find_equal_in_pair(x3,Output,error=error) if error then goto, L2 end ELSE: begin print,'Number of arguments must be from 2 to 4.' error=1 end ENDCASE L2: if error ne 1 then goto, L3 Output=-1 print,'Nothing coincides' error=1 L3: return,Output end ####################################################### function find_peaks,y,x,width=width,sigma=sigma,all=all ;+ ; Function FIND_PEAKS returns array of indices where ; input argument has local maximumes. ; ;- y_save=y if n_elements(width) gt 0 then y=y-median(y,width) if n_elements(sigma) gt 0 then begin a=stdev(y)*sigma index=where(abs(y) lt a) if index(0) ne -1 then y(index)=0 endif if not keyword_set(all) then begin Yint=y inter=1 endif else begin xx=findgen(n_elements(y)*2-1)/2 Yint=interpolate(y,xx) inter=2 endelse z=deriv(sign(deriv(Yint))) lt (-0.5) index=where(z) in=index(0) for j=1,n_elements(index)-1 do $ if index(j)-index(j-1) gt 1 then in=[in,index(j)] N=n_elements(Yint) index=in for j=0,n_elements(in)-1 do begin a=max(Yint((in(j)-2 > 0):(in(j)+2 < N-1)),imax) index(j)=in(j)+imax-2 > 0 endfor if n_elements(index) eq 1 then begin if index(0) lt 0 then a=max(Yint,index) endif else if index(0) eq 0 then index=index(1:*) if n_params() eq 2 then x=Yint(index) y=y_save return,index/inter end ####################################################### function first_ind, array, number return, (where(array ge number) )(0) end ####################################################### function fragment, array, center, width, cursor=cursor, $ subscript=subscript, mark = mark Case 1 OF n_params() lt 3 and not keyword_set(cursor): message, 'Insufficient number of arguments' n_params() gt 2 and keyword_set(cursor): message, 'Too many arguments' n_params() lt 3 and keyword_set(cursor): begin wid=center cent=cursorpos(/dev) end ELSE: begin wid=width cent=center end ENDCASE Sz=size(array) Mesg='Warning! The size of array does not fit to the given one.' w=wid/2 X0=cent(0)-w X1=cent(0)+w-1 if (X0 lt 0) or (X1 gt (Sz(1)-1)) then print, Mesg X0=X0 > 0 X1=X1 < (Sz(1)-1) Y0=cent(1)-w Y1=cent(1)+w-1 if (Y0 lt 0) or (Y1 gt (Sz(2)-1)) then print, Mesg Y0=Y0 > 0 Y1=Y1 < (Sz(2)-1) subscript=transpose([[X0,X1],[Y0,Y1]]) if keyword_set(mark) then begin plotframe, cent, wid, /dev if !d.name eq 'X' or !d.name eq 'Win' then empty endif return, array(X0:X1, Y0:Y1, *) end ####################################################### function frag_copy, array, subscript i=subscript return,array(i(0,0):i(0,1), i(1,0):i(1,1), *) end ####################################################### function frd_time, path, files=files, dtime=dtime, no_sort=no_sort, $ sunset = sunset, polariz = polariz if n_elements(sunset) le 0 then sunset = 17. CASE n_params() OF 0: begin file=pickfile(/read) path=subdir(file) end 1: ELSE: message, 'Too many arguments' ENDCASE CASE strlowcase(strmid(!version.OS, 0, 3)) OF 'win': begin wildcard='\*.fit' end ELSE: wildcard='/*.fit*' ;message, 'Not supported on this platform' ENDCASE files=findfile(path+wildcard) files = files(uniq(files)) N=n_elements(files) h=bytarr(80,36) polariz = (time=strarr(N)) help,time for j=0, N-1 do begin openr, lun, files(j), /get readu, lun, h time(j)=sxpar(string(h), 'time-obs') polariz(j)=sxpar(string(h), 'polariz') free_lun, lun endfor dtime=hmsd(time) if keyword_set(no_sort) ne 1 then begin sort_index=sort(dtime) dtime=dtime(sort_index) time=time(sort_index) files=files(sort_index) polariz=polariz(sort_index) sort_index = [where(dtime gt sunset), where(dtime lt sunset)] sort_index = sort_index(where(sort_index ge 0)) dtime=dtime(sort_index) time=time(sort_index) files=files(sort_index) polariz=polariz(sort_index) endif return, time end ####################################################### pro fread,iew=iew,vew=vew,isn=isn,vsn=vsn, $ group_leader=group_leader,time_sec=time_sec,date=date,Length=Length, $ start=start,stop=stop,bounds=bounds,multi=multi,cancel=cancel, $ Filename=Filename,Fileformat=Fileformat,current_file=current_file, $ Dt=Dt,attr=attr,nolimit=nolimit ; Performs reading of data arrays from the SSRT data files. if n_elements(group_leader) le 0 then group_leader=0L if n_elements(current_file) le 0 then current_file=0 if n_elements(nolimit) le 0 then nolimit=0 widget_control,/hour filesetting, Filen=Filename,boun=bounds,path=getenv('spk_dat'),$ current_file=current_file, Filefor=Fileformat,mul=multi, $ sum=sum,Cancel=Cancel,Stokes=Stokes,group_leader=group_leader,number=Length, $ nolimit=nolimit current_file=1 widget_control,hour=0 if (Filename eq '') or (cancel eq 1) then return iew=Stokes(0) & vew=Stokes(1) isn=Stokes(2) & vsn=Stokes(3) widget_control,/hour readfile,FileName=FileName,bounds=bounds,$ Iew=Iew, Vew=Vew, ISN=ISN, VSN=VSN, time=time_sec, attr=attr, $ start=start, stop=stop, multi=multi, sum=sum, extr=extr, $ date=date if Fileformat(0) eq 'fdas' then Dt=0.014d0 else Dt=0.056d0 end ####################################################### pro free_all for j=100L,128L do free_lun,j print,'All logical units are deallocated.' end ####################################################### function width_interpolate,index,x,y,ymax index0=index(0) & index1=index(n_elements(index)-1) index01=index0-1 > 0 index11=index1+1 < (n_elements(y)-1) ymin0=y(index0) & ymin1=y(index01) ymax0=y(index1) & ymax1=y(index11) IF ymin1 eq ymin0 then x0=(x(index0)+x(index01))/2. else $ x0=x(index01)+(0.5*ymax-ymin1)*(x(index01)-x(index0))/(ymin1-ymin0) IF ymax1 eq ymax0 then x1=(x(index1)+x(index11))/2. else $ x1=x(index1)+(ymax0-0.5*ymax)*(x(index11)-x(index1))/(ymax0-ymax1) return,[x0,x1] end function fwhm,x,y,x_peak=x_peak,i_peak=i_peak, $ full=full,error=error,follow=follow ;+ Function FWHM returns value of full width at half maximum ; (FWHM) for input curve with respect to zero level. If there ; is only one input argument, then FWHM is calculated in ; subscript values. If two arguments are given, then the first ; (X) is interpreted as abscissae and second (Y) as the curve ; to measure. In this latter case FWHM is calculated in X values. ; When no keyword parameter is specified, FWHM is ; calculated for the area around the highest value of the input ; curve. ; Keyword parameters: ; I_PEAK - subscript of the input array corresponding ; to the area of the peak of interest (I_PEAK is not ; necessary subscript of a maximum peak value). ; X_PEAK - any abscissa corresponding to the area of ; the peak of interest (X_PEAK is not necessary abscissa of ; a maximum peak value). ; FULL - if this keyword is set and non-zero, then full ; width FWHM is returned with no respect to existence and values ; of any local minimums. ; ERROR - specifies name of the variable to place error ; message "No maximum" if it is the case. ;- WIDGET_CONTROL,/HOUR error='' x_save=x if n_params() lt 2 then begin y=x & x=findgen(n_elements(y)) endif CASE 1 OF n_elements(x_peak) gt 0: N_peak=(where(x ge x_peak))(0) n_elements(i_peak) gt 0: N_peak=i_peak ELSE: ymax=max(y,N_peak) ENDCASE if N_peak(0) lt 0 then begin print,'N_peak(0)=',N_peak(0) error='No maximum' goto,exit endif peak=select_peak(y,N_peak) ymax=max(y(peak(0):peak(1)),N_peak) N_peak=N_peak+peak(0) ;PRINT,'N_peak=',N_peak IF keyword_set(follow) THEN BEGIN j=N_peak while (y(j) ge ymax/2.) and (j ge 1) do j=j-1 if j eq 0 then jl=0 else jl=j+1 j=N_peak while (y(j) ge ymax/2.) and (j le n_elements(y)-2) do j=j+1 if j ne (n_elements(y)-1) then j=j-1 index=[jl,j] ;print,'index=',index goto, A1 ENDIF index=where(y gt ymax/2.) if n_elements(index) eq 1 then if index(0) eq -1 then begin width=x(n_elements(x)-1)-x(0) ;print,'Nindex=',n_elements(index),'index(0)=',index(0) error='No maximum' goto,exit endif IF not keyword_set(full) THEN BEGIN split_array,index,first_subscript=Sf,last_subs=Sl,number=n for j=0,n-1 do if N_peak ge Sf(j) and N_peak le Sl(j) then $ index=indgen(Sl(j)-Sf(j)+1)+Sf(j) ;print,'indexfull=',index ENDIF A1: xw=width_interpolate(index,x,y,ymax) ;print,'xw=',xw width=(xw(1)-xw(0)) exit: if error ne '' then print,error x=x_save return,width end ####################################################### function gaussian,x,width,position ; Returns Gaussian curve having given width and position. if n_elements(position) le 0 then position=0. if n_params() lt 2 then begin print,'You must define WIDTH' return,0 endif z=((x-position)/width) > (-5) < 5 return,exp(-z^2*4.*alog(2)) end ####################################################### ;+ ; PROJECT: ; SDAC ; NAME: ; GOES ; ; PURPOSE: ; Provide a widget interface to plot GOES data and derived quantities. ; ; CATEGORY: ; GOES ; ; CALLING SEQUENCE: ; GOES ; ; CALLS: ; HXRBS_FORMAT, SET_GRAPHICS, CHECKVAR, UTIME, YOHKOH_FORMAT, WIDG_TYPE, ; XSET_VALUE, TWIDGET, RESPOND_WIDG, WCHECK_SET, GOESPLOT, Y_AVERAGE, ANYTIM, ; TEM_CALC, TEM_PLOT, POINT, ZOOM_COOR, GETUTBASE, TEKPRINT, ATIME, ; CLEANPLOT ; ; INPUTS: ; none explicit, only through commons; ; ; OUTPUTS: ; Goes_str- A structure containing the data obtained by the procedure ; See the readme tag in the structure. ; ; KEYWORDS: ; INPUT-OPTIONAL, A structure with tag names that must correspond to named variables ; within GOES.PRO. May be used to input starting values for ; STIME- Start time in seconds from 1-jan-1979, anytim( date_string, /sec). ; ETIME- End time in seconds from 1-jan-1979, anytim( date_string, /sec). ; MARKBAD- Logical, mark bad points with X. ; LOGPLOT- Set for logarithmic y scaling. ; SAT- GOES Satellite default request. ; N_PTS- Sample average to use. ; INITIAL_BACKG_STATE- Set(unset def) background subtraction option on ; raw data. ; VERSIONRELEASE- Developer's tool, to check performance prior to !version.release of 4 ; ; COMMON BLOCKS: ; goes_widgets, goes_plot, savegoes, goes_back ; ; RESTRICTIONS: ; Procedure looks to see if the GOES data files containing are ; found under GOES_FITS or withing the Yohkoh GBO archive. ; If not, displays error message. ; ; PROCEDURE: ; Data is read from the GOES archive in GOES_FITS from FITS files. ; Options are available for cleaning the data of gain change spikes, ; computing temperature and emission measure, log/linear scaling, ; overlaying channels, etc. If the GOES_FITS archive doesn't exist ; for a particular time, the Yohkoh GBO archive is searched and utilized. ; ; MODIFICATION HISTORY: ; Written by Kim Tolbert 11/92 ; Mod 7/2/93 by KT to add ERR_MSG keyword to call to GOESPLOT and ; TEM_PLOT. ERR_MSG contains the text of the error message to ; be displayed in the message window. Previously, messages ; were stored in PLOTERR array. ; Mod 7/6/95 by AES to avoid specifying any widget sizes - was causing ; problems at upgrades. also include yderiv keyword, so that ; the time derivative is saved in save files. ; Mod 7/31/95 by AES to compare seconds of time instead of string format ; dates, to avoid possible differences in format (uses anytim) ; Mod 09/95 by RCJ to include SATELLITE field and SAMPLE AVG. droplist. ; Mod 3/20/96 by AES to enable satellite goes-9 ; Mod 22-jul-1996, ras, pass savesat onto TEM_CALC ; Mod 08/07/96 by RCJ to include SATELLITE in README when WRITEFILE ; option is chosen. ; Mod 09/12/96 by RCJ to use droplist to choose flux, tempr. or emis. ; plot, offer sample average to tempr. and emis. plots, make any ; x-axis change be reflected on other 2 graphs, add more (bkg's ; and averaged) arrays to output file. ; Mod 09/13/96 by RCJ. Added documentation. ; Mod 11/01/96 by RCJ to show sample avg. in message window and also ; save it in README (see WRITEFILE). Make ave_* = fltarr(1) ; at beginning of program. ; Mod 27-jan-1997, by RAS, implemented list widgets for droplists for less than ; IDL release 4 when droplist didn't exist. ; Mod 28-jan-1997 by RAS, added readme to common savegoes, goes_str output ; Version 14 ; readme to common savegoes, goes_str outputMod 31-jan-1997 by RAS, ; added VERSIONRELEASE and INPUT keywords. Added INITIAL_BACKG_STATE. ; Version 15 ; RAS, 13-feb-1997, add start_time and end_time as optional input keywords ; Use anytim compatible format.t ; Version 16 ; richard.schwartz@gsfc.nasa.gov, changed wask to respond_widg, 8-sep-1997. ; Version 17 ; richard.schwartz@gsfc.nasa.gov, cleaned twidget code, 24-sep-1997. ; Version 18 ; amy@aloha.nascom.nasa.gov, 22-Jul-1998, added code for GOES 10 ; Version 19 ; richard.schwartz@gsfc.nasa.gov, 5-Oct-1999, modified test of time interval ; to determine validity of save request. ; Version 20 ; richard.schwartz@gsfc.nasa.gov,10-nov-1999, expand range of twidget to 1980-2020. ; Version 21 ; kim.tolbert@gsfc.nasa.gov, 20-nov-1999, don't use parse_atime to get year after ; call to twidget - returns 0 for 2000, which means user selected 'all' - ; instead use elements of rtime1. Also call twidget with nowild. ; ; ;- ; -------------------------------------------------------------------------- ; pro goes_event, event common goes_widgets, base, $ wcstart, wcend, wcdur, wtstart, wtend, wtdur, wthxrbs,$ wstart, wend, whxrbs, wselect, wmulti, wchannels, $ wavg, r3a1_emis, r3a1_flux, r3a1_temp,$ satbut, llbut, prbut, chbut, rawbut, tmpbut, embut, $ wmessage, wcurrent, $ wxmin_f, wxmax_f, wxauto_f, wymin_f, wymax_f, wyauto_f, $ wxmin_t, wxmax_t, wxauto_t, wymin_t, wymax_t, wyauto_t, $ wxmin_e, wxmax_e, wxauto_e, wymin_e, wymax_e, wyauto_e common goes_plot, goes_window, want_plotfile, done_plot, tekfile, psfile, $ logplot, ch_select, raw, clean, markbad, deriv, flxsback, $ tmpsback, tmpnosback, tmpmarkbad, $ emsback, emnosback, emmarkbad, $ stime, etime, tarray, yarray, yclean, yderiv,tempr, emis,$ nosubemis, nosubtempr, ch0_bad, ch1_bad, $ utbase, overlay, combch, overch, flarenum, $ prevplot, xzoom, yzoom_f, yzoom_t, yzoom_e, sat, n_pts, $ ave_tarray, ave_yclean, ave_emis, ave_tempr, $ ave_nosubemis, ave_nosubtempr common savegoes, savesat, savestime, saveetime, savetarray, saveyarray, $ saveyclean, savech0_bad, savech1_bad, loedges, hiedges, readme common goes_back, sback_str, eback_str, avback ;widget_control, event.id, get_value = value, get_uvalue = uvalue ;the above line is now under the BUTTON wtype only. RCJ 10/24/95 wtype = widg_type(event.id) ; possibilities: 'DROPLIST','TEXT','BUTTON' ;wtype = strmid (tag_names(event,/structure_name), 7, 1000) oldstime = stime oldetime = etime case wtype of 'DROPLIST': begin widget_control,event.id,get_uvalue=uvalue input_drop=uvalue(event.index) case input_drop of 'Flux': begin widget_control,r3a1_temp,map=0 widget_control,r3a1_emis,map=0 widget_control,r3a1_flux,map=1 end 'Temp.': begin widget_control,r3a1_flux,map=0 widget_control,r3a1_emis,map=0 widget_control,r3a1_temp,map=1 end 'Em. Meas.': begin widget_control,r3a1_flux,map=0 widget_control,r3a1_temp,map=0 widget_control,r3a1_emis,map=1 end '1_pt': n_pts=1 '10_pts': n_pts=10 '20_pts': n_pts=20 '30_pts': n_pts=30 '40_pts': n_pts=40 'choose_pts': begin value=1 xset_value,value,min=1,max=200, $ title='Select Sample Avg.',group=base n_pts=value end ; end to 'users choice' endcase ; end input_drop case widget_control, wmessage, /append, $ set_value='Sample average = '+strtrim(n_pts,2) end ; end of DROPLIST block 'LIST': begin widget_control,event.id,get_uvalue=uvalue input_drop=uvalue(event.index) case input_drop of 'Flux': begin widget_control,r3a1_temp,map=0 widget_control,r3a1_emis,map=0 widget_control,r3a1_flux,map=1 end 'Temp.': begin widget_control,r3a1_flux,map=0 widget_control,r3a1_emis,map=0 widget_control,r3a1_temp,map=1 end 'Em. Meas.': begin widget_control,r3a1_flux,map=0 widget_control,r3a1_temp,map=0 widget_control,r3a1_emis,map=1 end '1_pt': n_pts=1 '10_pts': n_pts=10 '20_pts': n_pts=20 '30_pts': n_pts=30 '40_pts': n_pts=40 'choose_pts': begin value=1 xset_value,value,min=1,max=200, $ title='Select Sample Avg.',group=base n_pts=value end ; end to 'users choice' endcase ; end input_drop case widget_control, wmessage, /append, $ set_value='Sample average = '+strtrim(n_pts,2) end ; end of LIST block 'TEXT': begin widget_control, event.id, get_value = fstring case 1 of ; (event.id eq wxmin_f) or (event.id eq wxmin_t) or $ (event.id eq wxmin_e): begin widget_control, wxmin_f, set_value = fstring(0) widget_control, wxmin_t, set_value = fstring(0) widget_control, wxmin_e, set_value = fstring(0) temp = utime(fstring(0), error=error) if not(error) then xzoom(0) = temp end ; (event.id eq wxmax_f) or (event.id eq wxmax_t) or $ (event.id eq wxmax_e): begin widget_control, wxmax_f, set_value = fstring(0) widget_control, wxmax_t, set_value = fstring(0) widget_control, wxmax_e, set_value = fstring(0) temp = utime(fstring(0), error=error) if not(error) then xzoom(1) = temp end ; (event.id eq wymin_f): yzoom_f(0) = float(fstring(0)) (event.id eq wymin_t): yzoom_t(0) = float(fstring(0)) (event.id eq wymin_e): yzoom_e(0) = float(fstring(0)) (event.id eq wymax_f): yzoom_f(1) = float(fstring(0)) (event.id eq wymax_t): yzoom_t(1) = float(fstring(0)) (event.id eq wymax_e): yzoom_e(1) = float(fstring(0)) ; (event.id eq wtstart) or (event.id eq wtend): begin temp = utime(fstring(0), error=error) if not(error) then begin if event.id eq wtstart then stime = temp else etime = temp endif goto, display_times end (event.id eq wtdur): begin val = float(fstring(0)) if val gt 0 then etime = stime + val goto, display_times end endcase ; end event.id case ; if event.id eq wthxrbs then begin ; val = fix(fstring(0)) ; if val gt 0 and val le 12776 then begin ; read_minicat, fldata, num, flare=val, error=error ; if not(error) then begin ; stime = fldata(0).start_sec ; etime = fldata(0).start_sec + fldata(0).dur ; goto, display_times ; endif ; endif ; widget_control, wmessage, /append, set_value = $ ; 'Error in flare selection.' ; goto, goback ; ; endif end ; end of text block 'BUTTON': begin ; start button case block widget_control, event.id, get_value = value, get_uvalue = uvalue if (event.id eq wstart) or (event.id eq wend) then begin widget_control, base, sensitive=0 str = 'start' if event.id eq wend then str = 'end' widget_control, wcurrent, set_value = 'Starting '+str+' time ' + $ 'selection widget ...' gettime: widget_control,wmessage,/append,set_value = 'Select '+str+' time.' twidget, year=[1980,2020], outtime=rtime1, group_leader=base, /all, error=error, /nowild if error ne 0 then goto, goback ;parse_atime, rtime1, year=y, month=m, day=d y = rtime1(6) m = rtime1(5) d = rtime1(4) if (y le 0) or (m le 0) or (d le 0) then begin widget_control, wmessage, /append, set_value = $ 'Wild card dates not allowed. Please reselect start time.' goto, gettime endif asctime= (anytim(/sec, rtime1))(0) if event.id eq wstart then stime = asctime else etime = asctime goto, display_times endif ; if event.id eq whxrbs then begin ; hflare, hxr_flare, group_leader=base ; read_minicat, fldata, num, flare=hxr_flare, error=error ; if error then begin ; widget_control, wmessage, /append, set_value = $ ; 'Error in flare selection.' ; goto, goback ; endif ; stime = fldata(0).start_sec ; etime = fldata(0).start_sec + fldata(0).dur ; widget_control, wthxrbs, set_value=strtrim(hxr_flare,2) ; goto, display_times ; endif if (event.id eq wxauto_f) or (event.id eq wxauto_t) or $ (event.id eq wxauto_e) then begin xzoom = [0.,0.] widget_control, wxmin_f, set_value = '0.' widget_control, wxmax_f, set_value = '0.' widget_control, wxmin_t, set_value = '0.' widget_control, wxmax_t, set_value = '0.' widget_control, wxmin_e, set_value = '0.' widget_control, wxmax_e, set_value = '0.' goto, goback endif if (event.id eq wyauto_f) then begin yzoom_f = [0.,0.] widget_control, wymin_f, set_value = '0.' widget_control, wymax_f, set_value = '0.' goto, goback endif if (event.id eq wyauto_t) then begin yzoom_t = [0.,0.] widget_control, wymin_t, set_value = '0.' widget_control, wymax_t, set_value = '0.' goto, goback endif if (event.id eq wyauto_e) then begin yzoom_e = [0.,0.] widget_control, wymin_e, set_value = '0.' widget_control, wymax_e, set_value = '0.' goto, goback endif q = where (event.id eq wmulti) if q(0) ne -1 then begin row = fix(q(0)/2) & col = q(0)-row*2 widget_control, wmulti(col,0), set_value=value goto, goback endif q=where (event.id eq chbut) if q(0) ne -1 then begin ch_select(q(0)) = event.select goto,goback endif q=where (event.id eq rawbut) if q(0) ne -1 then begin if q(0) eq 0 then raw = event.select if q(0) eq 1 then clean = event.select if q(0) eq 2 then flxsback = event.select if q(0) eq 3 then deriv = event.select if q(0) eq 4 then markbad = event.select goto,goback endif q=where (event.id eq tmpbut) if q(0) ne -1 then begin if q(0) eq 0 then tmpsback = event.select if q(0) eq 1 then tmpnosback = event.select if q(0) eq 2 then tmpmarkbad = event.select goto,goback endif q=where (event.id eq embut) if q(0) ne -1 then begin if q(0) eq 0 then emsback = event.select if q(0) eq 1 then emnosback = event.select if q(0) eq 2 then emmarkbad = event.select goto,goback endif input_type = strmid (uvalue, 0, 2) input_value = strmid (uvalue, 2, 100) case input_type of ; start input_type case block 'c_': begin ; start command (c_) case block case input_value of ; start input_value within c_ case block 'Newplot': begin !p.multi = [0,1,1,0,0] erase end 'FPlot': begin ; check that start>end and range < 6 days. if (stime gt etime) or (etime-stime gt 518400.d0) then begin widget_control, wmessage, /append, set_value = $ 'Error in time selection. Try again.' goto, goback endif if total(ch_select) eq 0 then begin widget_control, wmessage, /append, set_value = $ 'No channels selected for plotting.' goto,goback endif widget_control, base, sensitive=0 widget_control, wcurrent, set_value = $ 'Accumulating data and/or setting up plot, please wait...' temp_multi = intarr(5) for i=0,1 do begin widget_control, wmulti(i,0), get_value=val temp_multi(i+1) = val endfor if (temp_multi(1) ne !p.multi(1)) or $ (temp_multi(2) ne !p.multi(2)) then !p.multi=temp_multi dofplot: if flxsback then getnewback=1 else getnewback=0 if getnewback and $ (abs(stime-utime(sback_str)) lt 86400.) then $ getnewback = 1 - respond_widg( title=' Define new background intervals? ',$ message = string( bytarr(35)+32b), group_leader=base ) ;wask, quest=' Define new background intervals? ', $ ; answer=getnewback, group_leader=base if getnewback then begin wcheck_set, goes_window2, title='GOES Plot 2',retain=2 wshow, goes_window2 save_multi = !p.multi !p.multi = 0 goesplot, stime=atime(stime),etime=atime(etime), $ tarray=tarray, yarray=yarray, yclean=yclean, $ /clean, ch0_bad=ch0_bad, ch1_bad=ch1_bad, $ logplot=logplot, ch_select=[1,0], error=error,$ err_msg=err_msg,sat=sat,n_pts=n_pts, $ ave_tarray=ave_tarray,ave_yclean=ave_yclean if error ne 0 then begin widget_control,wmessage,/app,set_v=err_msg wdelete, goes_window2 goto,goback endif y_average, tarray, yclean, avback, wmessage=wmessage, $ stime_str=sback_str, etime_str=eback_str !p.multi = save_multi wdelete, goes_window2 endif wcheck_set, goes_window, title='GOES Plot', retain=2 wshow, goes_window if !p.multi(0) eq 0 then erase goesplot,stime=atime(stime),etime=atime(etime), $ tarray=tarray, yarray=yarray, yclean=yclean, $ clean=clean, markbad=markbad, back=avback*flxsback, $ logplot=logplot, plotfile=want_plotfile,$ ch_select=ch_select, error=error, err_msg=err_msg, $ ch0_bad=ch0_bad, ch1_bad=ch1_bad, yderiv=yderiv, $ xrange=xzoom, yrange=yzoom_f, deriv=deriv, $ e_bars=e_bars, sat=sat,n_pts=n_pts, $ ave_tarray=ave_tarray,ave_yclean=ave_yclean widget_control, wmessage, /append, set_value = $ 'GOES '+ string(sat,format='(i2)') + ' data being retrieved' if (sat eq 6) and anytim(stime,/sec) gt anytim('94/1/1') and $ anytim(etime,/sec) lt anytim('94/08/18') then $ widget_control,wmessage,/append, $ set_value='GOES 7 also has data for the selected date range' if (sat eq 7) and anytim(stime,/sec) gt anytim('94/1/1') and $ anytim(etime,/sec) lt anytim('94/08/18') then $ widget_control,wmessage,/append, $ set_value='GOES 6 also has data for the selected date range' if error ne 0 then begin widget_control,wmessage,/app,set_v=err_msg goto,goback endif ; if want both clean and raw data overlaid, already plotted ; clean, so now plot raw. if clean+raw eq 2 then $ goesplot,stime=atime(stime),etime=atime(etime), $ tarray=tarray, yarray=yarray, yclean=yclean, $ clean=0, markbad=markbad, back=avback*flxsback, $ logplot=logplot, plotfile=want_plotfile, $ ch_select=ch_select, error=error, err_msg=err_msg, $ xrange=xzoom, yrange=yzoom_f, /noerase, deriv=deriv, $ e_bars=e_bars, yderiv=yderiv,sat=sat,n_pts=n_pts, $ ave_tarray=ave_tarray,ave_yclean=ave_yclean if error ne 0 then begin widget_control,wmessage,/app,set_v=err_msg goto,goback endif prevplot = 'FPlot' done_plot = 1 set_graphics, printer = p psfile = (p eq 'PS') ; 0 or 1 tekfile = (p eq 'TEK') ; 0 or 1 if psfile or tekfile then begin plotfile = 'goesplot.ps' if tekfile then plotfile = 'goesplot.tek' f = findfile (plotfile, count=count) if count gt 0 then widget_control, wmessage, $ /append, set_value = 'Saved in plot file ' + f(0) endif end 'TPlot': begin if tmpsback+tmpnosback eq 0 then begin widget_control, wmessage, /append, set_value = $ 'You must select do or don''t do bkgd subtraction' goto, goback endif getnewback = 1 if not(tmpsback) then getnewback = 0 goto, teplot end 'EPlot': begin if emsback+emnosback eq 0 then begin widget_control, wmessage, /append, set_value = $ 'You must select do or don''t do bkgd subtraction' goto, goback endif getnewback = 1 if not(emsback) then getnewback = 0 teplot: if stime eq 0 or etime eq 0 then begin widget_control, wmessage, /append, set_value = $ 'You must first select times or flare number.' goto, goback endif widget_control,wcurrent,set_value='Accumulating, please wait...' if getnewback and $ (abs(stime-utime(sback_str)) lt 86400.) then $ getnewback = 1 - respond_widg( title=' Define new background intervals? ',$ message = string( bytarr(35)+32b), group_leader=base ) ;wask, quest=' Define new background intervals? ', $ ; answer=getnewback, group_leader=base if getnewback then begin wcheck_set, goes_window2, title='GOES Plot 2',retain=2 wshow, goes_window2 save_multi = !p.multi !p.multi = 0 goesplot,stime=atime(stime),etime=atime(etime), $ tarray=tarray, yarray=yarray, yclean=yclean, $ /clean, ch0_bad=ch0_bad, ch1_bad=ch1_bad, $ logplot=logplot, ch_select=[1,0], error=error, $ err_msg=err_msg,sat=sat,n_pts=n_pts, $ ave_yclean=ave_yclean, yderiv=yderiv if error ne 0 then begin widget_control,wmessage,/app,set_v=err_msg wdelete, goes_window2 goto,goback endif y_average, tarray, yclean, avback, wmessage=wmessage, $ stime_str=sback_str, etime_str=eback_str !p.multi = save_multi wdelete, goes_window2 endif ; end of getnewback ; ; The following lines are only for setting up a demo file. ;tarray = long(tarray) ;save, /xdr, file='goestem_demo.sav', tarray, tempr, emis, $ ; nosubtempr, nosubemis, eback_str, sback_str, avback ; tem_calc, tarray=tarray, yclean=yclean, tempr=tempr, $ emis=emis, nosubtemp=nosubtempr, $ nosubemis=nosubemis, savesat=savesat, date=getutbase() temp_multi = intarr(5) for i=0,1 do begin widget_control, wmulti(i,0), get_value=val temp_multi(i+1) = val endfor if (temp_multi(1) ne !p.multi(1)) or $ (temp_multi(2) ne !p.multi(2)) then !p.multi=temp_multi doteplot: wcheck_set, goes_window, title='GOES Plot', retain=2 wshow, goes_window if !p.multi(0) eq 0 then erase if input_value eq 'TPlot' then begin tem_plot, do_tempr=tmpsback, do_tnosub=tmpnosback, $ tarray=tarray, yarray=tempr, ynosub = nosubtempr, $ logplot=logplot, plotfile=want_plotfile, $ markbad=tmpmarkbad, badpts=[ch0_bad,ch1_bad], $ xrange=xzoom, yrange=yzoom_t, error=error, $ err_msg=err_msg, sat=sat, n_pts=n_pts, t_vals=ave_tarray,$ y_vals=ave_tempr,y_nosubvals=ave_nosubtempr endif else begin tem_plot, do_emis=emsback, do_enosub=emnosback, $ tarray=tarray, yarray=emis, ynosub=nosubemis, $ logplot=logplot, plotfile=want_plotfile, $ markbad=emmarkbad, badpts=[ch0_bad,ch1_bad], $ xrange=xzoom, yrange=yzoom_e,error=error, $ err_msg=err_msg,sat=sat, n_pts=n_pts, t_vals=ave_tarray,$ y_vals=ave_emis,y_nosubvals=ave_nosubemis endelse if error ne 0 then begin widget_control,wmessage,/app,set_v=err_msg goto,goback endif prevplot = input_value done_plot = 1 set_graphics, printer = p psfile = (p eq 'PS') ; 0 or 1 tekfile = (p eq 'TEK') ; 0 or 1 if psfile or tekfile then begin plotfile = 'goesplot.ps' if tekfile then plotfile = 'goesplot.tek' f = findfile (plotfile, count=count) if count gt 0 then widget_control, wmessage, $ /append, set_value = 'Saved in plot file ' + f(0) endif end 'Point': begin if not(done_plot) then begin widget_control, wmessage, /append, set_value= $ 'Nothing plotted yet.' goto,goback endif widget_control, wmessage, /append, set_value= $ 'Press left mouse button to get x and y values, ' + $ ' middle mouse button to get time and y value.' widget_control, wmessage, /append, set_value= $ ' PRESS RIGHT MOUSE BUTTON WHILE POINTING IN ' + $ 'PLOT WINDOW TO EXIT.' widget_control, base, sensitive=0 wshow, goes_window point,x,y end 'Zoom': begin if not(done_plot) then begin widget_control, wmessage, /append, set_value= $ 'Nothing plotted yet.' goto,goback endif widget_control, base, sensitive=0 wshow, goes_window widget_control, wmessage, /append, set_value = $ 'Position cross at bottom left corner of zoom window ' + $ 'and press left mouse button.' widget_control, wmessage, /append, set_value = $ ' Then position cross at opposite corner and press ' + $ 'left mouse button again.' zoom_coor, xzoom, yzoom temp0 = strmid(atime(xzoom(0)+getutbase(0)), 10, 12) temp1 = strmid(atime(xzoom(1)+getutbase(0)), 10, 12) xzoom(0)=strtrim(xzoom(0),2) & xzoom(1)=strtrim(xzoom(1),2) widget_control, wxmin_f, set_value = temp0 widget_control, wxmax_f, set_value = temp1 widget_control, wxmin_t, set_value = temp0 widget_control, wxmax_t, set_value = temp1 widget_control, wxmin_e, set_value = temp0 widget_control, wxmax_e, set_value = temp1 case prevplot of 'FPlot': begin widget_control, wymin_f, set_value = strtrim(yzoom(0),2) widget_control, wymax_f, set_value = strtrim(yzoom(1),2) yzoom_f(0)=strtrim(yzoom(0),2) & yzoom_f(1)=strtrim(yzoom(1),2) input_value = prevplot goto, dofplot end 'TPlot': begin widget_control, wymin_t, set_value = strtrim(yzoom(0),2) widget_control, wymax_t, set_value = strtrim(yzoom(1),2) yzoom_t(0)=strtrim(yzoom(0),2) & yzoom_t(1)=strtrim(yzoom(1),2) input_value = prevplot goto, doteplot end 'EPlot': begin widget_control, wymin_e, set_value = strtrim(yzoom(0),2) widget_control, wymax_e, set_value = strtrim(yzoom(1),2) yzoom_e(0)=strtrim(yzoom(0),2) & yzoom_e(1)=strtrim(yzoom(1),2) input_value = prevplot goto, doteplot end else: begin widget_control, wmessage, /append, set_value= $ 'Nothing plotted yet.' end endcase ; end prevplot case end 'Hardcopy': begin if not(done_plot) then begin widget_control, wmessage, /append, set_value= $ 'Nothing plotted yet.' goto,goback endif if want_plotfile eq 0 then begin widget_control, wmessage, /append, set_value= $ 'No hardcopy format selected. ' + $ 'Select a hardcopy format, then redraw plot.' goto,goback endif set_graphics, printer=pr wrong_pr = ' ' if pr eq 'TEK' then if not(tekfile) then wrong_pr = 'Tek' if pr eq 'PS' then if not(psfile) then wrong_pr = 'PS' if wrong_pr ne ' ' then begin widget_control, wmessage, /append, set_value = wrong_pr + $ ' format was not selected when you made the plot.' widget_control, wmessage, /append, set_value = $ 'Please plot again before requesting ' + wrong_pr + $ ' hardcopy.' goto,goback endif tek_print,file='goesplot' widget_control, wmessage, /append, set_value = $ 'Sending plot file to printer.' end ; --- Write XDR Save file with base time, time array, cleaned y ; array, and temperature and emission measure if they've been ; calculated 'Writefile': begin ; check that current time interval has been accumulated if ( abs( anytim(savestime) - anytim(stime)) gt 1.0 ) or $ ( abs(anytim(saveetime) - anytim(etime)) gt 1.0 ) then begin widget_control, wmessage, /append, set_value= $ 'Data for selected time interval not accumulated.' widget_control, wmessage, /append, set_value= $ ' Accumulate data by plotting it first.' ; goto, goback endif ; construct output file name at = atime(stime) savefile = 'idlsave_goes' + $ strmid(at,0,2)+strmid(at,3,2)+strmid(at,6,2)+'.dat' ; save base time as seconds since 79/1/1 and ASCII time utbase = getutbase(0) asciibase = atime(utbase) ; if temperature and emission measure haven't been calculated ; yet, set them to 0 so we can use the same SAVE command if (size(tempr))(1) eq 0 then tempr = fltarr(1) if (size(emis))(1) eq 0 then emis = fltarr(1) if (size(nosubtempr))(1) eq 0 then nosubtempr = fltarr(1) if (size(nosubemis))(1) eq 0 then nosubemis = fltarr(1) satellite='GOES '+ string(sat,format='(i1)') save, asciibase, ave_emis, ave_nosubemis, ave_nosubtempr, $ ave_tarray, ave_tempr, ave_yclean, ch0_bad, ch1_bad, $ emis, nosubemis, nosubtempr, n_pts, readme, satellite, $ tarray, tempr, utbase, yclean, yderiv, /xdr, $ file=savefile widget_control, wmessage, /append, set_value= $ 'Saved in IDL XDR save file ' + savefile end ; --- Exit GOES widget 'Quit': goto,exit else: print,'Error in command.' endcase ; end of input_value case block end 's_': begin if (input_value eq 'disable') and (event.select eq 1) then clean=0 if (input_value eq 'enable') and (event.select eq 1) then clean=1 end 'l_': begin if (input_value eq '0') and (event.select eq 1) then logplot=0 if (input_value eq '1') and (event.select eq 1) then logplot=1 end 'p_': begin if event.select ne 1 then goto,goback if input_value eq 'none' then want_plotfile = 0 else want_plotfile = 1 if input_value eq 'ps' then set_graphics,printer='PS' if input_value eq 'tek' then set_graphics,printer='TEK' end 'g_': begin g_prepend = 'Within GOES_FITS directory, ' if (input_value eq '6') and (event.select eq 1) then begin sat=6 widget_control, wmessage, /append, set_value= $ g_prepend + 'GOES 6 data range: 80/01/04 - 94/08/18' endif if (input_value eq '7') and (event.select eq 1) then begin sat=7 widget_control, wmessage, /append, set_value= $ g_prepend + 'GOES 7 data range: 94/01/01 - 96/08/03' endif if (input_value eq '8') and (event.select eq 1) then begin sat=8 widget_control, wmessage, /append, set_value= $ g_prepend + 'GOES 8 data starts: 96/03/21' endif if (input_value eq '9') and (event.select eq 1) then begin sat=9 widget_control, wmessage, /append, set_value= $ g_prepend + 'GOES 9 data range: 96/03/20 - 98/07/24' endif if (input_value eq '10') and (event.select eq 1) then begin sat=10 widget_control,wmessage, /append, set_value=$ g_prepend + 'GOES 10 data starts: 98/07/10' endif end else: print,'error in widget' endcase ;end of command (c_) case block end ; end button block else: print,'error in input - doesn''t match any of wtypes.' endcase ; end wtype case block goto, goback display_times: widget_control, wtstart, set_value = (atime(stime))(0) widget_control, wcstart, set_value = 'Start: ' + atime(stime) widget_control, wtend, set_value = (atime(etime))(0) widget_control, wcend, set_value = 'End: ' + (atime(etime))(0) widget_control, wtdur, set_value= $ (strtrim(string(etime-stime,form='(f10.3)'),2) )(0) widget_control, wcdur, set_value='Duration: ' + $ (strtrim(string(anytim(etime,/sec)-anytim(stime,/sec),form='(f10.3)'),2))(0) if stime ne oldstime or etime ne oldetime then begin tempr = fltarr(1) emis = fltarr(1) endif goto, goback exit: ;xbackregister,'flash_bck',base,/unregister ;-- kill flashing widget widget_control, event.top, /destroy cleanplot ; set !p,!x,!y,!z back to starting values goto,getout goback: for i=0,n_elements(satbut)-1 do widget_control,satbut(i), set_button=(sat-6) eq i widget_control, base, /sensitive widget_control, wcurrent, set_value = $ 'Select time interval, plot options, or command button.' getout: end pro goes, goes_str, group_leader=group, versionrelease=versionrelease, input=input,$ start_time=start_time, end_time=end_time common goes_widgets, base, $ wcstart, wcend, wcdur, wtstart, wtend, wtdur, wthxrbs,$ wstart, wend, whxrbs, wselect, wmulti, wchannels, $ wavg, r3a1_emis, r3a1_flux, r3a1_temp,$ satbut, llbut, prbut, chbut, rawbut, tmpbut, embut, $ wmessage, wcurrent, $ wxmin_f, wxmax_f, wxauto_f, wymin_f, wymax_f, wyauto_f, $ wxmin_t, wxmax_t, wxauto_t, wymin_t, wymax_t, wyauto_t, $ wxmin_e, wxmax_e, wxauto_e, wymin_e, wymax_e, wyauto_e common goes_plot, goes_window, want_plotfile, done_plot, tekfile, psfile, $ logplot, ch_select, raw, clean, markbad, deriv, flxsback, $ tmpsback, tmpnosback, tmpmarkbad, $ emsback, emnosback, emmarkbad, $ stime, etime, tarray, yarray, yclean, yderiv,tempr, emis,$ nosubemis, nosubtempr, ch0_bad, ch1_bad, $ utbase, overlay, combch, overch, flarenum, $ prevplot, xzoom, yzoom_f, yzoom_t, yzoom_e, sat, n_pts, $ ave_tarray, ave_yclean, ave_emis, ave_tempr, $ ave_nosubemis, ave_nosubtempr common savegoes, savesat, savestime, saveetime, savetarray, saveyarray, $ saveyclean, savech0_bad, savech1_bad, loedges, hiedges, readme common goes_back, sback_str, eback_str, avback if n_elements(input) gt 0 then begin tags=tag_names(input) for i=0,n_elements(tags)-1 do extest = execute(tags(i)+'=input.(i)') endif stime = (anytim(/sec, fcheck(fcheck( start_time, stime), savestime)))(0) etime = (anytim(/sec, fcheck(fcheck( end_time, etime), saveetime)))(0) checkvar, readme, [ ' ASCIIBASE - base time in ASCII format ',$ 'AVE_EMIS - (if more than one array element) - '+$ 'averaged emis ',$ 'AVE_NOSUBEMIS - (if more than one array element) - '+$ 'ave. emis, no bkg subtracted', $ 'AVE_NOSUBTEMPR - (if more than one array elem.) - '+$ 'ave. tempr, no bkg subtracted', $ 'AVE_TARRAY - (if more than one array element) - '+$ 'averaged tarray ',$ 'AVE_TEMPR - (if more than one array element) - '+$ 'averaged tempr ',$ 'AVE_YCLEAN - (if more than one array element) - '+$ 'averaged yclean ',$ 'CH0_BAD - element #s in YCLEAN, TEMPR, EMIS'+$ ' that were interpolated for Chan 1',$ 'CH1_BAD - element #s in YCLEAN, TEMPR, EMIS'+$ ' that were interpolated for Chan 2', $ 'EMIS (if more than one array element) - '+$ 'emission measure in 10^49 cm^-3',$ 'NOSUBEMIS - emis, no bkg subtracted ', $ 'NOSUBTEMPR - tempr, no bkg subtracted ', $ 'N_PTS - sample average ',$ 'SATELLITE - satellite: GOES 6, 7, 8 or 9 ', $ 'TARRAY - time in sec since base time ',$ 'TEMPR (if more than one array element) - '+$ 'temperature in MegaKelvin',$ 'UTBASE - base time in sec since 79/1/1,0',$ 'YCLEAN - channels 1 and 2 with gain change '+$ 'spikes smoothed out',$ 'YDERIV - time derivative for channels 1 and 2'] checkvar, versionrelease, !version.release hxrbs_format, old_format = old_time_format if (!d.flags and 65536) eq 0 then message,'Widgets are unavailable' set_plot,xdevice() if n_elements(group) eq 0 then widget_control, /reset set_graphics,printer='PS' checkvar, stime, utime('80/5/21,2050') checkvar, etime, utime('80/5/21,2140') checkvar,savestime, -1 & checkvar, saveetime, -1 checkvar,savesback, -1 & checkvar, saveeback, -1 want_plotfile = 1 done_plot = 0 prevplot = 'none' tekfile = 0 & psfile = 0 raw = 0 & clean = 1 deriv = 0 markbad = 1 flxsback = 0 tmpsback = 1 & tmpnosback = 0 & tmpmarkbad = 1 emsback = 1 & emnosback = 0 & emmarkbad = 1 logplot = 1 !p.multi = [0,0,0,0,0] ch_select = intarr(2) + 1 xzoom = [0., 0.] yzoom_f = [0., 0.] yzoom_t = [0., 0.] yzoom_e = [0., 0.] sback_str = '80/1/1,0' checkvar,avback, [0,0] device, get_screen_size = sc fspace = .0146 * sc(0) * .5 fxpad = .0117 * sc(0) * .5 fypad = .0146 * sc(1) * .5 checkvar,savesat,6 checkvar,sat,6 n_pts=1 ave_emis=fltarr(1) ave_nosubemis=fltarr(1) ave_tempr=fltarr(1) ave_nosubtempr=fltarr(1) checkvar, initial_backg_state, 0 welcome = 'Welcome to the GOES Plot Workbench' btitle = 'GOES Plot Workbench' ;base = widget_base (title=btitle, xpad=fxpad, ypad=fypad*2, $ ; space=fspace, /column, /frame) base = widget_base (title=btitle, /column, /frame) ;------------------------------------------------------------------------- ; 0th row ;------------------------------------------------------------------------- r0 = widget_base (base, /column, /frame) whattodo = 'Select time interval, plot options, or command button.' wcurrent = widget_label (r0, value=whattodo, uvalue='BACKGROUND') ;widget_flash, whattodo, wcurrent ;------------------------------------------------------------------------- ; 1st row ;------------------------------------------------------------------------- ;r1a = widget_base (base, /row, /frame, space=4.*fspace) r1a = widget_base (base, /row, /frame) ;------------------------------------------------------------------------- ; 1st row - Satellite ;------------------------------------------------------------------------- ; satbut = lonarr(5) xmenu, ['GOES 6','GOES 7','GOES 8','GOES 9','GOES10'], r1a, $ uvalue=['g_6','g_7','g_8','g_9','g_10'], buttons = satbut, $ base = wsatellite, /column, /exclusive, title = 'Satellite:' widget_control,satbut(sat-6), /set_button ;------------------------------------------------------------------------- ; 1st row - Times selected ;------------------------------------------------------------------------- r1curr = widget_base (r1a, /column, /frame) w = widget_label (r1curr, value=' ') w = widget_label (r1curr, value='Current start/end times selected: ') wcstart = widget_label (r1curr, value='Start: ' + atime(stime)) wcend = widget_label (r1curr, value='End: ' + atime(etime)) wcdur = widget_label (r1curr, value='Duration: ' + $ strtrim(string(etime-stime,form='(f10.3)'),2) ) ;------------------------------------------------------------------------- ; 1st row - Choose date and time ;------------------------------------------------------------------------- r1type = widget_base (r1a, /column) w = widget_label (r1type, value = 'Type selection and !! PRESS RETURN !! :') w = widget_base (r1type, /row) w1 = widget_label (w, value='Start time: ') wtstart = widget_text (w, /edit, value=atime(stime)) w = widget_base (r1type, /row) w1 = widget_label (w, value='End time: ') wtend = widget_text (w, /edit, value=atime(etime)) w = widget_base (r1type, /row) w1 = widget_label (w, value='Duration (s): ') wtdur = widget_text (w, /edit, $ value=strtrim(string(etime-stime,form='(f10.3)'),2)) w = widget_base (r1type, /row) ;w1 = widget_label (w, value='HXRBS flare #: ') ;wthxrbs = widget_text (w, /edit, value='538') ;r1wid = widget_base (r1a, /column, space=2*fspace) r1wid = widget_base (r1a, /column) w = widget_label (r1wid, value = 'or Use widgets:') wstart = widget_button (r1wid, value='Start time') wend = widget_button (r1wid, value='End time ') ;whxrbs = widget_button (r1wid, value='HXRBS flare #') ;-------------------------------------------------------------------------- ; 2nd row - Multiple plots ;-------------------------------------------------------------------------- ;r2 = widget_base (base, /row, space=fspace*2., xpad = fxpad*2.) r2 = widget_base (base, /row) ;r2c1 = widget_base (r2, /column, /frame, space=2*fspace) r2c1 = widget_base (r2, /column, /frame) w = widget_label (r2c1, value='Multiple Plots: ') r1bb = widget_base (r2c1, /row) wmulti = lonarr (2,10) wmulti(0,0) = widget_button(r1bb, value='1', menu=2) for j=1,9 do begin val = string(j,format='(i1)') wmulti(0,j) = widget_button (wmulti(0,0), $ value=val, uvalue='m_'+val) endfor w = widget_label (r1bb, value=' x ') wmulti(1,0) = widget_button(r1bb, value='1', menu=2) for j=1,9 do begin val = string(j,format='(i1)') wmulti(1,j) = widget_button (wmulti(1,0), $ value=val, uvalue='n_'+val) endfor wnewplot = widget_button (r2c1, value='Clear Multiple Plot', $ uvalue='c_Newplot') ;-------------------------------------------------------------------------- ; 2nd row - y-axis type ;-------------------------------------------------------------------------- llbut = lonarr(2) xmenu, ['Linear', 'Logarithmic'], r2, $ uvalue=['l_0', 'l_1'], buttons = llbut, $ base = wloglin, /column, /exclusive, title='Y axis:' widget_control, llbut(1), /set_button ;------------------------------------------------------------------------- ; 2nd row - Hardcopy ;------------------------------------------------------------------------- prbut = lonarr(3) xmenu, ['None', 'PostScript', 'Tektronix'], r2, $ uvalue=['p_none', 'p_ps', 'p_tek'], buttons=prbut, $ title='Hardcopy Format:', $ base = wprinter, /column, /exclusive widget_control, prbut(1), /set_button ; ;------------------------------------------------------------------------- ; 2nd row - Sample average ;------------------------------------------------------------------------- r2c4=widget_base(r2,/column,/frame) w = widget_label (r2c4, value='Sample Avg.: ') val=['1 pt','10 pts','20 pts','30 pts','40 pts',"User's choice"] uval=['1_pt','10_pts','20_pts','30_pts','40_pts','choose_pts'] widget_type=(['widget_list','widget_droplist'])(versionrelease ge 4) wavg=call_function(widget_type, r2c4, value=val,uvalue=uval) ;--------------------------------------------------------------- ; 3rd row ;--------------------------------------------------------------- ;r3 = widget_base (base, /row, space=fspace*2.) r3 = widget_base (base, /row) r3col1 = widget_base (r3, /column, /frame) if versionrelease lt 4 then r31 = widget_base(r3col1, /row) ; pl_val=['Flux','Temp.','Em. Meas.'] if versionrelease ge 4 then $ pl_type = call_function( 'widget_droplist', r3col1, value=pl_val(0), $ title=' Plot Type : ', uvalue=pl_val) else begin pl_label= widget_label(r31, value=' Plot Type : ') pl_type = call_function( 'widget_list', r31, xsize=20, value=pl_val(0), $ uvalue=pl_val) endelse ; ; These next two text widgets are just space holders ; if versionrelease lt 4 then begin r3_a = widget_label(r31,value='') r3_b = widget_label(r31,value='') endif widget_control,pl_type,set_value=pl_val ;--------------------------------------------------------------- ; 3rd row - Flux ;--------------------------------------------------------------- r3a1 = widget_base (r3col1) r3a1_flux = widget_base(r3a1,/column, map=1) r3b1=widget_base(r3a1_flux,/row) chbut = lonarr(2) xmenu, ['1', '2'], r3b1, $ uvalue = indgen(2), buttons = chbut, $ base = wchannels, /nonexclusive, /column, title='Channels:' widget_control, chbut(0), /set_button widget_control, chbut(1), /set_button ; rawbut = lonarr(5) xmenu, ['Raw','Clean','Bkgd subtracted','Derivative','Mark bad'],r3b1, $ uvalue = indgen(5), buttons = rawbut, $ /nonexclusive, /column, title='Options:' widget_control, rawbut(1), /set_button widget_control, rawbut(4), /set_button if initial_backg_state then widget_control, rawbut(2), /set_button ; r3b1c2 = widget_base (r3b1, /column, /frame) w = widget_label (r3b1c2, value='Set axis ranges and !! PRESS RETURN !! : ' + $ ' (0. means autoscale)') r3b1c2r1 = widget_base (r3b1c2, /row) r3b1c2c1 = widget_base (r3b1c2r1, /column) w = widget_label (r3b1c2c1, value='Enter x limits as hhmm:ss') wxauto_f = widget_button (r3b1c2c1, value='Autoscale x axis', uvalue='autox') w = widget_base (r3b1c2c1, /row) w1 = widget_label (w, value='X min:') wxmin_f = widget_text (w, /edit, value='0.') w = widget_base (r3b1c2c1, /row) w1 = widget_label (w, value='X max:') wxmax_f = widget_text (w, /edit, value='0.') ; r3b1c2c2 = widget_base (r3b1c2r1, /column) w = widget_label (r3b1c2c2, value=' ') wyauto_f = widget_button (r3b1c2c2, value='Autoscale y axis', uvalue='autoy') w = widget_base (r3b1c2c2, /row) w1 = widget_label (w, value='Y min:') wymin_f = widget_text (w, /edit, value='0.') w = widget_base (r3b1c2c2, /row) w1 = widget_label (w, value='Y max:') wymax_f = widget_text (w, /edit, value='0.') ; wfplot = widget_button (r3a1_flux, $ value='$$$$$$$$$$$$$$$$$$$$$$$$$$ Do Plot $$$$$$$$$$$$$$$$$$$$$$$$$$', uvalue='c_FPlot') ;------------------------------------------------------------------------- ; 3rd row - Temperature ;------------------------------------------------------------------------- r3a1_temp = widget_base(r3a1,/column, map=0) r3b1=widget_base(r3a1_temp, /row) tmpbut = lonarr(3) xmenu, ['Bkgd subtracted', 'Bkgd not subtracted', 'Mark bad'], r3b1, $ uvalue = indgen(3), buttons = tmpbut, $ /nonexclusive, /column, title='Options:' widget_control, tmpbut(0), /set_button widget_control, tmpbut(2), /set_button ; r3b1c2 = widget_base (r3b1, /column,/frame) w = widget_label (r3b1c2, value='Set axis ranges and !! PRESS RETURN !! : ' + $ ' (0. means autoscale)') r3b1c2r1 = widget_base (r3b1c2, /row) r3b1c2c1 = widget_base (r3b1c2r1, /column) w = widget_label (r3b1c2c1, value='Enter x limits as hhmm:ss') wxauto_t = widget_button (r3b1c2c1, value='Autoscale x axis', uvalue='autox') w = widget_base (r3b1c2c1, /row) w1 = widget_label (w, value='X min:') wxmin_t = widget_text (w, /edit, value='0.') w = widget_base (r3b1c2c1, /row) w1 = widget_label (w, value='X max:') wxmax_t = widget_text (w, /edit, value='0.') ; r3b1c2c2 = widget_base (r3b1c2r1, /column) w = widget_label (r3b1c2c2, value=' ') wyauto_t = widget_button (r3b1c2c2, value='Autoscale y axis', uvalue='autoy') w = widget_base (r3b1c2c2, /row) w1 = widget_label (w, value='Y min:') wymin_t = widget_text (w, /edit, value='0.') w = widget_base (r3b1c2c2, /row) w1 = widget_label (w, value='Y max:') wymax_t = widget_text (w, /edit, value='0.') ; wtplot = widget_button (r3a1_temp, $ value='$$$$$$$$$$$$$$$$$$$$$$$$$$ Do Plot $$$$$$$$$$$$$$$$$$$$$$$$$$', uvalue='c_TPlot') ;------------------------------------------------------------------------ ; 3rd row - Emission Measure ;------------------------------------------------------------------------ r3a1_emis = widget_base (r3a1, /column, map=0) r3b1=widget_base(r3a1_emis, /row) embut = lonarr(3) xmenu, ['Bkgd subtracted', 'Bkgd not subtracted', 'Mark bad'], r3b1, $ uvalue = indgen(3), buttons = embut, $ /nonexclusive, /column, title='Options:' widget_control, embut(0), /set_button widget_control, embut(2), /set_button ; r3b1c2 = widget_base (r3b1, /column, /frame) w = widget_label (r3b1c2, value='Set axis ranges and !! PRESS RETURN !! : ' + $ ' (0. means autoscale)') r3b1c2r1 = widget_base (r3b1c2, /row) r3b1c2c1 = widget_base (r3b1c2r1, /column) w = widget_label (r3b1c2c1, value='Enter x limits as hhmm:ss') wxauto_e = widget_button (r3b1c2c1, value='Autoscale x axis', uvalue='autox') w = widget_base (r3b1c2c1, /row) w1 = widget_label (w, value='X min:') wxmin_e = widget_text (w, /edit, value='0.') w = widget_base (r3b1c2c1, /row) w1 = widget_label (w, value='X max:') wxmax_e = widget_text (w, /edit, value='0.') ; r3b1c2c2 = widget_base (r3b1c2r1, /column) w = widget_label (r3b1c2c2, value=' ') wyauto_e = widget_button (r3b1c2c2, value='Autoscale y axis', uvalue='autoy') w = widget_base (r3b1c2c2, /row) w1 = widget_label (w, value='Y min:') wymin_e = widget_text (w, /edit, value='0.') w = widget_base (r3b1c2c2, /row) w1 = widget_label (w, value='Y max:') wymax_e = widget_text (w, /edit, value='0.') ; weplot = widget_button (r3a1_emis,$ value='$$$$$$$$$$$$$$$$$$$$$$$$$$ Do Plot $$$$$$$$$$$$$$$$$$$$$$$$$$', uvalue='c_EPlot') ;------------------------------------------------------------------------- ; 3rd row - Other buttons ;------------------------------------------------------------------------- ;r5 = widget_base (base, /row, space=fspace*2., xpad=fxpad*2, ypad=fypad*2.) ;r5 = widget_base (r3, /column, space=fspace, xpad=fxpad*2, ypad=fypad) ; r5 = widget_base (r3, /column) wpoint = widget_button (r5, value='Point', uvalue='c_Point') wzoom = widget_button (r5, value='Zoom', uvalue='c_Zoom') wprint = widget_button (r5, value='Hardcopy', uvalue='c_Hardcopy') wfile = widget_button (r5, value='Write File', uvalue='c_Writefile') wquit = widget_button (r5, value=' QUIT ', uvalue='c_Quit', /frame) ;------------------------------------------------------------------------ ; 4th row - Message window ;------------------------------------------------------------------------ r6 = widget_base (base, /column, /frame) wm = widget_label (r6, value='Message Window') wmessage = widget_text (r6, /scroll, ysize=3) widget_control,wmessage,/app,set_v='Remember to press RETURN key after ' + $ 'entering selection via text widget.' widget_control, base, /realize widget_control,wmessage,/app,set_v='GOES 6 data range: 80/01/04 - 94/08/18 ' ;------------------------------------------------------------------------ ;xbackregister, 'flash_bck', base ;print,'xregistered? ', xregistered('flash_bck') ;xmanager, 'goes', base, group_leader=group, background='flash_bck' xmanager, 'goes', base, group_leader=group if old_time_format eq 'YOHKOH' then yohkoh_format if n_params() ge 1 then begin if n_elements(tarray) gt 0 then begin time = anytim(/ints,getutbase()+tarray) goes_gen ={goes_data, satellite:sat, time:time(0).time,day:time(0).day, lo: 0.0, hi: 0.0,$ emis:0.0, tempr:0.0} goes=replicate( goes_gen, n_elements(tarray)) goes.time = time.time goes.day = time.day goes.lo = (yclean(*,0) - avback(0))(*) goes.hi = (yclean(*,1) - avback(1))(*) if n_elements(emis) eq n_elements(goes.emis) then begin goes.emis = emis goes.tempr= tempr endif checkvar, readme1, [ 'These are the tags and their definition in this structure.',$ 'UTBASE - base time in seconds from 1-jan-1979 for AVE_TARRAY',$ 'BACKGROUND - background used for Long and Short Wavelength Channels.', $ 'N_PTS - number of samples used to average.',$ 'CH0_BAD - element #s in YCLEAN, TEMPR, EMIS that were interpolated for Chan 1', $ 'CH1_BAD - element #s in YCLEAN, TEMPR, EMIS that were interpolated for Chan 2', $ 'In Goes_str.gen, ', $ 'SATELLITE - satellite: GOES 6, 7, 8, 9, or 10 ', $ 'TIME - time in millisec since start of day ', $ 'DAY - day since 1-jan-1979 ', $ 'LO - GOES long wavelength channel with spikes interpolated over, see CH0_BAD for indeces, background subtracted.',$ 'HI - GOES short wavelength channel with spikes interpolated over, see CH1_BAD for indeces, background subtracted.',$ 'The next two quantities are derived using GOES_TEM.PRO', $ 'TEMPR (if more than one array element) - temperature in MegaKelvin', $ 'EMIS (if more than one array element) - emission measure in 10^49 cm^-3', $ 'If N_PTS, the sample average, used is greater than 1,then Goes_avg is included;',$ 'SATELLITE - satellite: GOES 6, 7, 8, 9, or 10 ', $ 'TIME - time in millisec since start of day ', $ 'DAY - day since 1-jan-1979 ', $ 'LO - GOES long wavelength channel with spikes interpolated over, see CH0_BAD for indeces, background subtracted.',$ 'HI - GOES short wavelength channel with spikes interpolated over, see CH1_BAD for indeces, background subtracted.',$ 'The next two quantities are derived using GOES_TEM.PRO', $ 'TEMPR (if more than one array element) - temperature in MegaKelvin', $ 'EMIS (if more than one array element) - emission measure in 10^49 cm^-3'] if n_pts eq 1 then goes_str = { gen: goes, readme: byte(readme1), utbase: getutbase(), $ background: avback, ch0_bad:ch0_bad, ch1_bad:ch1_bad} else begin goes_avg = replicate(goes_gen, n_elements(ave_tarray)) goes_avg.satellite = goes(0).satellite time = anytim(/ints,getutbase()+ave_tarray) goes_avg.time = time.time goes_avg.day = time.day goes_avg.lo = (ave_yclean(*,0) - avback(0))(*) goes_avg.hi = (ave_yclean(*,1) - avback(1))(*) if n_elements(ave_emis) eq n_elements(goes_avg.emis) then begin goes_avg.emis = ave_emis goes_avg.tempr= ave_tempr endif goes_str = { gen: goes, readme: byte(readme1), utbase: getutbase(), $ background: avback, ch0_bad:ch0_bad, ch1_bad:ch1_bad, avg:goes_avg} endelse endif else goes_str=0 endif end ####################################################### ;+ ; PROJECT: ; SDAC ; ; NAME: ; GOESPLOT ; ; PURPOSE: ; Display the time profile of any interval of GOES data. ; ; CATEGORY: ; GOES ; ; CALLING SEQUENCE: ; GOESPLOT, [FLARE=FLARE, STIME=STIME, ETIME=ETIME, $ ; TARRAY=TARRAY, YARRAY=YARRAY, YCLEAN=YCLEAN, CLEANED=CLEANED,$ ; YDERIV=YDERIV,CH_SELECT, PLOTFILE=PLOTFILE, LOGPLOT=LOGPLOT,$ ; POINTPLOT=POINTPLOT, ERROR=ERROR, XRANGE=XRANGE, YRANGE=YRANGE,$ ; MARKBAD=MARKBAD, BACK=BACK, CH0_BAD=CH0_BAD, CH1_BAD=CH1_BAD,$ ; NOERASE=NOERASE, DERIV=DERIV, E_BARS=E_BARS, ERR_MSG=ERR_MSG, $ ; NODATA=NODATA, AVE_TARRAY=AVE_TARRAY, AVE_YCLEAN=AVE_YCLEAN, $ ; SAT=SAT, N_PTS=N_PTS, PROC=PROC] ; ; CALLS: ; HXRBS_FORMAT, CHECKVAR, READ_MINICAT, ATIME, ANYTIM, GFITS_R, ; CLEAN_GOES, SET_UTLABEL, ERROR_BARS, GETUTBASE, SYS2UT, SET_GRAPHICS, ; CHKLOG, LINECOLORS, UTPLOT, EPLOT ; ; INPUTS: ; Through keywords ; ; OUTPUTS: ; Through keywords ; ; KEYWORDS: ; FLARE: HXRBS Flare number ; STIME: Start time of data to plot in any of allowed formats: ; 'YY/MM/DD,HHMM:SS.XXX', 'DD-MMM-YY HH:MM:SS.XXX', ; seconds since 79/1/1, structure, or 7xn array ; ETIME: End time of data to plot in any of allowed formats ; TARRAY: Variable in which to return the time array. ; Times are in seconds relative to the start of the day. ; x=getutbase() contains the number of seconds to the ; start of the day from 79/1/1,0000. ; i.e. print,atime(tarray(0)+getutbase(0)) will print ; the ascii time for the first point. ; YARRAY: Variable in which to return the two channels of GOES ; data for each time in TARRAY. ; YCLEAN: Variable in which to return the two channels of cleaned ; (spikes are eliminated) GOES data for each time in ; TARRAY ; CLEANED: If set, cleaned data is used for plot. ; YDERIV: Variable in which to return time derivative of two ; channels. ; CH_SELECT: Channels to plot. [1,0] means Chan 1 only, [0,1] means ; Chan 2 only, [1,1] means Chan 1 overlaid on Chan 2. ; Default is [1,1]. ; PLOTFILE: If nonzero, a plot file will be created when you plot ; on screen. Can be set either to a nonzero number in ; which case the file name will be goesplot.xx or can be ; set to the desired file name. Format of plotfile can ; be selected by entering the SELECT_DEV procedure. ; LOGPLOT: If non-zero, y axis is logarithmic. ; POINTPLOT: If non-zero, a point plot is drawn. Otherwise,histogram. ; ERROR: 0/1 No errors found / Errors found. Error msg text ; in ERR_MSG. ; XRANGE: 2-element vector specifying limits for x axis ; YRANGE: 2-element vector specifying limits for y axis ; MARKBAD: Plot 'X's at the times where there were spikes and ; the data was interpolated from surrounding points ; BACK: Values of background to subtract for two channels ; CH0_BAD: Element numbers of data arrays where Channel 1 data ; had spike which was eliminated and interpolated over. ; CH1_BAD: Same as CH0_BAD for Channel 2. ; NOERASE: If set, don't clear screen before plotting. ; DERIV: If set, plot derivative of GOES channel requested in ; COMB and OVERLAY keywords. ; E_BARS: If set, draws error bars. ; ERR_MSG: ASCII string containing error message if ERROR = 1 ; NODATA: If set, only plot box is drawn, useful for further ; overplotting ; AVE_TARRAY: Averaged tarray. See n_pts. ; AVE_YCLEAN: Averaged yclean. See n_pts. ; SAT: 6, 7, 8, 9 for GOES 6, GOES 7 or GOES 8 GOES 9 data ; (default depends on time selected or defaults to last used). ; N_PTS: Sample average to be used by the rebin function. ; Default is 1. ; PROC: A procedure to call with arguments encoded in a ; structure. Used for drawing lines on GOES plots ; ; COMMON BLOCKS: ; goesplot, savegoes ; ; PROCEDURE: ; GOESPLOT reads the file for requested flare and ; plots the time profile with the following options: ; plot any combination of the available channels ; overlay any combination of the available channels ; logarithmic or linear y axis ; point or histogram plot ; only plot data within x and/or y limits ; If the device is capable of X windows graphics (logical name ; DEVICE_TYPE equals X) then X windows is the default screen graphics ; device. Otherwise Tektronix is the default. PostScript is the ; default printer format. The user can select the devices by typing ; SELECT_DEV. ; The time array and the raw and cleaned data are returned in ; keyword arguments. ; Sample calls: ; GOESPLOT,FLARE=5,TARRAY=T,YARRAY=Y,CH_SEL=[1,0] ; GOESPLOT,STIME='92/4/19,2300',ETIME='92/4/19,2350',/CLEAN,/MARK ; ; MODIFICATION HISTORY: ; Written by Kim Tolbert 10/92 (based on hxarchive.pro) ; Mod. by KT 7/16/93 to handle real time data (in FITS format, data later ; than 93/1/1). ; Mod. by KT 12/94 to accept a filename in PLOTFILE keyword, to accept ; any times in any format in STIME and ETIME keywords, and to set default ; ASCII time format to HXRBS, then restore it to whatever it was on exit. ; Mod. by Amy Skowronek 7/94 to only look for FITS files. All DC files ; have been converted to FITS and placed in one directory. ; ras, 7-dec-94, did some error handling in clean_goes to check for degenerate ; cases, too little good data in particular ; AES, 3/13/95, added yderiv, variable in which to return time derivative ; ras, 5-aug-95 added nodata to facilitate overplots of time-averaged data ; RCJ, 09/95 added SAT and N_PTS keywords, SAVESAT in common block, and ; REBIN function to be applied to tarray and yplotted ; aes, 3/96 added time/sat consistency checks for goes 8 & 9 ; ras, 3-aug-96, changed satellite constraints to allow goes 7,8,and 9 when the ; files exist ; RCJ, 09/12/96 Added ave_tarray and ave_yclean keywords. ; RCJ, 09/13/96 Added documentation. ; ras, 16-oct-1996, include test to account for end of GOES7 ; RCJ, 11/01/96, rescale charsize if pmulti(2)=2 or >2 and sc_device='X', ; Add sample avg. (if > 1 pt) subtitle to graph plot. ; Changed distance input to pl_scale from .07 to .12 ; RCJ, 12/10/96, rescale charsize if pmulti(2)=2 or >2, sc_device='X', ; *and* !d.y_size le 512. Rescaled charsize was too big ; in fsplot, option data,all4 , where window is resized to ; !d.y_size=959. Also rescale y coordinate of xyouts under ; same conditions. ; RCJ, 01/07/96, modify command xyouts,...,codes to xyouts,...,codes(q) ; so that extra codes won't show on short period ps plots. ; Print msg when sample avg. > n_elements y-axis. ; RAS, 01/28/1997, added readme to common savegoes ; RAS, 02/04/1997, ensured stime and etime are scalars for tests ; default satellite is the last satellite used. ; Version 18, ; RAS, 02/07/1997, passed satellite number into cleaning algorithm. ; Version 19, ; richard.schwartz@gsfc.nasa.gov, fixed bug with yover ; Version 20, ; richard.schwartz@gsfc.nasa.gov, 18-may-1998, changed 'X' to xdevice('X') ; richard.schwartz@gsfc.nasa.gov, 13-jul-1998, use axis to label right y axis. ; amy@aloha.nascom.nasa.gov, 22-jul-1998, added a character to the plot ; label so it can display the numbers of satellites over 9. ; richard.schwartz@gsfc.nasa.gov, 19-aug-1998, fix GOES class labeling. ; ;- ; PRO GOESPLOT, FLARE=FLARE, STIME=SIN, ETIME=EIN, $ TARRAY=TARRAY, YARRAY=YARRAY, YCLEAN=YCLEAN, CLEANED=CLEANED,$ CH_SELECT=CH_SELECT, PLOTFILE=PLOTFILE, LOGPLOT=LOGPLOT,$ POINTPLOT=POINTPLOT, ERROR=ERROR, XRANGE=XRANGE, YRANGE=YRANGE,$ MARKBAD=MARKBAD, BACK=BACK, CH0_BAD=CH0_BAD, CH1_BAD=CH1_BAD,$ NOERASE=NOERASE, DERIV=DERIV, E_BARS=E_BARS, ERR_MSG=ERR_MSG,$ YDERIV=YDERIV, NODATA=NODATA, SAT=SAT, N_PTS=N_PTS, PROC=PROC, $ AVE_TARRAY=AVE_TARRAY,AVE_YCLEAN=AVE_YCLEAN ; common goesplot, save_bangp, save_bangx, save_bangy ; common savegoes ,savesat, savestime, saveetime, savetarray, saveyarray, $ saveyclean, savech0_bad, savech1_bad, loedges, hiedges, readme hxrbs_format, old_format = old_time_format error = 0 if not(keyword_set(sin) and keyword_set(ein)) then begin if not(keyword_set(flare)) then begin print,'Please specify a flare number or time interval via keywords ',$ 'FLARE or STIME and ETIME' print,'e.g. goesplot,FLARE=xxx or ',$ 'goesplot,stime=''91/1/1,1200'',etime=''91/1/1,1400'')' err_msg = 'Error. You didn''t select start/end time, flare # ' + $ 'or channels.' goto,error_exit endif endif checkvar, ch_select, [1,1] checkvar, plotfile, 0 checkvar, logplot, 0 checkvar, pointplot, 0 checkvar, markbad, 0 checkvar, back, [0,0] checkvar, deriv, 0 checkvar, noerase, 0 checkvar, xrange, [0.,0.] checkvar, yrange, [0.,0.] checkvar, e_bars, 0 checkvar, sat, 0 checkvar, n_pts, 1 save_bangp=replicate(!p,2) save_bangx=replicate(!x,2) save_bangy=replicate(!y,2) ; ; If we have passed PROC, then we are trying to overplot on the figue ; if keyword_set( proc) then begin proc_tags = tag_names(proc) ex_proc = proc.(0) for ip= 1,n_elements( proc_tags)-1 do begin ex_proc = ex_proc+','+proc_tags(ip)+'= proc.('+strtrim(ip,2)+')' endfor ;help,ex_proc endif savelogplot = logplot if keyword_set(deriv) and logplot then begin print,'Changing to linear y axis for derivative plot.' logplot = 0 endif ; if plotfile keyword passed, it is either nonzero (use goesplot.xx as ; filename) or the name of the plot file. if keyword_set(plotfile) then begin if (size(plotfile))(1) eq 7 then plotname = plotfile else $ plotname = 'goesplot' noplotfile = 0 endif else noplotfile = 1 ; If flare number specified, read mini catalog to get corresponding times. if keyword_set(flare) then begin read_minicat, fldata, num_flares, flare=flare, error=error if error ne 0 then begin err_msg = 'Error reading flare catalog to get times for ' + $ 'selected flare.' goto, error_exit endif stime = (atime(fldata.start_sec, /hxrbs) )(0) etime = (atime(fldata.start_sec + fldata.dur, /hxrbs))(0) endif else begin stime = (atime(sin, /hxrbs))(0) etime = (atime(ein, /hxrbs))(0) endelse if n_elements(sat) eq 0 and n_elements(savesat) ne 0 then sat = savesat if n_elements(sat) eq 0 then $ case 1 of (anytim(stime,/sec) gt anytim('80/1/4',/sec)) and $ (anytim(etime,/sec) lt anytim('94/01/01',/sec)) : sat = 6 (anytim(stime,/sec) gt anytim('94/8/18',/sec)) and $ (anytim(etime,/sec) lt anytim('96/3/21',/sec)) : sat=7 (anytim(stime,/sec) gt anytim('96/3/21',/sec)) and $ (sat eq 6 ) : sat = 8 (anytim(stime,/sec) gt anytim('96/8/10',/sec)) and $ (sat eq 7 ) : sat = 8 else: endcase ;stop ; If times are the same as last time we read data, we already have the data. ; Or if times are contained within saved times, extract the subset we want. ; ; Now that we have more satellite choices, the program checks for that condition, too. ; RCJ 09/95. ; if n_elements(savestime) ne 0 then begin ; Changed by V. Grechnev if n_elements(savestime) eq 1 then savestime = savestime[0] if n_elements(saveetime) eq 1 then saveetime = saveetime[0] if (sat eq savesat) and (stime eq savestime) and (etime eq saveetime) then begin tarray = savetarray & yarray = saveyarray & yclean = saveyclean ch0_bad = savech0_bad & ch1_bad = savech1_bad goto, gotfile endif if (stime ge savestime) and (etime le saveetime) $ and (sat eq savesat) then begin utb = getutbase(0) q = where ( (savetarray+utb gt utime(stime)) and $ (savetarray+utb lt utime(etime)), kq) if kq gt 0 then begin tarray = savetarray(q) & yarray = saveyarray(q,*) yclean=saveyclean(q,*) ch0_bad = savech0_bad - q(0) & ch1_bad = savech1_bad - q(0) qc = where (ch0_bad ge 0 and ch0_bad lt kq, kqc) if kqc gt 0 then ch0_bad = ch0_bad(qc) else ch0_bad = -1 qc = where (ch1_bad ge 0 and ch1_bad lt kq, kqc) if kqc gt 0 then ch1_bad = ch1_bad(qc) else ch1_bad = -1 goto, gotfile endif endif endif ; hardcode the channel edges loedges = [1., .5] & hiedges = [8., 4.] gfits_r, tarray=tarray, yarray=yarray, stime=stime, etime=etime, $ error=error, sat=sat, numstat=numstat, tstat=tstat, stat=stat, $ err_msg=err_msg if error ne 0 then begin if strpos( err_msg, 'File for requested time not found.') ne -1 then begin ;Requested satellite tried, loop through all others exiting after 20! print,'Try another satellite' goto, error_exit endif else goto, error_exit endif ;endelse help,tarray,yarray if n_elements(tarray) gt 5 then clean_goes, tarray = tarray, yarray = yarray, $ yclean = yclean, bad0 = ch0_bad, bad1 = ch1_bad, numstat=numstat, satellite=sat, $ tstat=tstat, stat=stat, error=clean_error $ else begin ch0_bad = -1 ch1_bad = -1 yclean = yarray endelse if clean_error then begin err_msg = 'Problem in Clean_GOES, error.' error=1 goto, error_exit endif savesat=sat savestime = stime & saveetime = etime savetarray=tarray & saveyarray=yarray & saveyclean=yclean savech0_bad = ch0_bad & savech1_bad = ch1_bad ;This commented out section was used to create the XDR save file for the ; SDAC widget demo. ;saveutb = long(getutbase()) ;savetarray = long(savetarray*10) ;save,/xdr,file='goes_data.sav', saveutb, savetarray, saveyarray, $ ; saveyclean, savech0_bad, savech1_bad, savestime, saveetime, loedges, $ ; hiedges ;savetarray = savetarray / 10.d0 gotfile: if keyword_set(cleaned) then yuse = yclean else yuse = yarray sizey = size(yuse) q=where (ch_select eq 1, kq) if kq eq 0 then begin print,'No channels selected.' err_msg = 'Error. You didn''t select any channels.' goto, error_exit endif chana = q(0) if kq eq 2 then chanb = q(1) else chanb = -1 set_utlabel,0 ; don't write start time label inside plot box update=0 ; means start a new plot if noerase then update=1 ; means add to current plot if !p.multi(0) gt 0 then update=1 ; means add to current plot pmulti = !p.multi ; Store the first channel requested (or derivative) in yplotted array if keyword_set(deriv) then begin yplotted =(yuse(1:*,chana) - yuse(*,chana)) / $ (fix(((tarray(1:*)-tarray(*))/3)+.5)*3.064) yplotted = [yplotted, yplotted(sizey(1)-2)] endif else yplotted = yuse(*,chana) - back(chana) if chana eq 0 then bada = ch0_bad if chana eq 1 then bada = ch1_bad q=where (bada ne -1, kbada) ; If both channels were requested, store second channel in yover array. if chanb ne -1 then begin if keyword_set(deriv) then begin yover = (yuse(1:*,chanb) - yuse(*,chanb)) / $ (fix(((tarray(1:*)-tarray(*))/3)+.5)*3.064) yover = [yover, yover(sizey(1)-2)] endif else yover = yuse(*,chanb) - back(chanb) badb = ch1_bad q = where (badb ne -1, kbadb) endif if keyword_set(e_bars) then error_bars, tarray, yuse, ch0_bad, ch1_bad, ebars psym = 10 if pointplot eq 1 then psym = 0 ; Set x axis limits if xrange(0) eq 0. then xmin = min(tarray) else xmin = xrange(0) if xrange(1) eq 0. then xmax = max(tarray) else xmax = xrange(1) ; Set y axis limits if yrange(0) eq 0. or yrange(1) eq 0. then begin ymax=max(yplotted) if chanb ne -1 then ymax = max([ymax,yover]) if logplot then begin ymin = 1.e30 q = where (yplotted gt 0., count) if count gt 0 then ymin = min(yplotted(q)) if chanb ne -1 then begin q = where (yover gt 0., count) if count gt 0 then ymin = min([ymin,yover(q)]) endif if ymin eq 1.e30 then begin err_msg = 'Error. Log plot selected but no positive data to plot.' print, err_msg goto, error_exit endif endif else begin ymin = min(yplotted) if chanb ne -1 then ymin = min([ymin,yover]) endelse endif if yrange(0) ne 0. then ymin = yrange(0) if yrange(1) ne 0. then ymax = yrange(1) ; ; use rebin here, on tarray and yplotted. ; If n_pts=1, ave_tarray=tarray and yarray1=yplotted RCJ 09/95 ; new_n=n_pts*(long(n_elements(yplotted)/n_pts)) if new_n lt 1 then begin err_msg='Sample avg. > n_elements y-axis. Try again.' goto,error_exit endif yarray1=yplotted(0:new_n-1) ave_tarray=tarray(0:new_n-1) yarray1=rebin(yarray1,new_n/n_pts) ave_tarray=rebin(ave_tarray,new_n/n_pts) title = 'GOES '+ string(sat,format='(i2)') if keyword_set(deriv) then title = title + ' Derivative' ytitle = 'Watts m!u-2!n' if keyword_set(deriv) then ytitle = ytitle + ' s!u-1!n' ; Construct labels for bottom of plot sub1 = 'Data Start: ' + strmid(atime(xmin+getutbase(0),/hxr),0,17) + $ '!cChannel ' sub2 = 'Plot created: ' + strmid(atime(sys2ut(0),/hxr),0,14) edgelo = loedges(chana) & edgehi = hiedges(chana) sub3 = '!c' + strtrim(chana+1,2) + ' (' + $ strtrim(string(edgelo,format='(f6.1)'),2)+$ ' - ' + strtrim(string(edgehi,format='(f6.1)'),2) + ' Angstroms)' if not(keyword_set(deriv)) then begin if back(chana) gt 0. then sub3 = sub3 + ' Background subtracted = ' + $ strtrim(string(back(chana),format='(e8.1)'),2) else $ sub3 = sub3 + ' Background not subtracted' endif if chanb ne -1 then begin edgelo = loedges(chanb) & edgehi = hiedges(chanb) sub4 = '!c!c' + strtrim(chanb+1,2) + ' (' + $ strtrim(string(edgelo,format='(f6.1)'),2)+$ ' - ' + strtrim(string(edgehi,format='(f6.1)'),2) + $ ' Angstroms)' if not(keyword_set(deriv)) then begin if back(chanb) gt 0. then sub4 = sub4 + ' Background subtracted = ' + $ strtrim(string(back(1),format='(e8.1)'),2) else $ sub4 = sub4 + ' Background not subtracted' endif endif else sub4 = ' ' ; Plot stuff is set up, now do plot on screen and to plot file if requested. ; If don't want plot file, we'll just do loop once with iloop=2. ; If both screen and printer device are Tek, we'll just do loop once w/ iloop=1 ; For other cases, loop twice, first creating plot file then plotting to screen ifirst = 1 & ilast = 2 set_graphics, screen = sc_device, printer = hard_device set_plot,sc_device if noplotfile then begin ifirst = 2 endif else begin if(sc_device eq 'TEK') and (hard_device eq 'TEK') then ilast = 1 endelse colors = [9,3] ; ;---------- Loop over output devices -------- for iloop = ifirst, ilast do begin if iloop eq 1 then tek_init, file=plotname, update=update if !d.name eq 'TEK' then device,gin_chars=6 ; if !d.name eq 'PS' then device,/landscape ; ; if we haven't created the window yet, create it with backing store ; Use execute command so we can test whether it was successful w/o crashing. test = execute ("if (iloop eq 2) and (sc_device eq xdevice('X')) and " + $ "(!d.window eq -1) then window,retain=2") if not test then begin print, ' ' if !version.os eq 'vms' then begin print, 'Error creating window. Possible reasons:' trans = chklog("sys$login") ustart = strpos (trans(0), '[') user = strmid (trans(0), ustart+1, strlen(trans(0))-ustart-2) node = chklog("sys$node") print, 'Your display node cannot do X windows graphics.' print, 'You have not authorized '+node+user+' to create a ' + $ 'window on the display node.' print, 'You did not issue the $ SET DISPLAY/CREATE/NODE=x ' + $ 'before entering IDL.' print, 'Your display node name is not known to '+node+'. Specify '+$ 'your display node''s' print, ' address instead of the name in the set display command. ' endif else print,'Error creating window.' print, ' ' err_msg = 'Error opening plot window.' goto, error_exit endif if !d.name ne 'NULL' then linecolors !p.multi = pmulti ; reset to start value if noerase eq 0 then begin yran = [ymin,ymax] ystyle = 0 endif else begin !p.multi(0) = !p.multi(0)+1 yran = crange('Y') if not(logplot) then ystyle = 1 ytitle = ' ' endelse ; This is an attempt to correct the charsize when !p.multi=[0,1,2] or ; !p.multi=[0,1,>2] without affecting a 'tek' sc_device: chscale=ch_scale(0.8) if sc_device eq 'X' and !d.y_size le 512 then begin if pmulti(2) eq 2 then chscale=ch_scale(0.8)*1.8 if pmulti(2) gt 2 then chscale=ch_scale(0.8)*2.25 endif utplot, ave_tarray, yarray1, $ ymargin=[10,2],xmargin=[13,5], title=title, ytitle=ytitle, $ xtitle=' ', xrange=[xmin,xmax], xstyle=1, yrange=yran, ystyle=ystyle, $ ytype=logplot, psym=psym, chars = chscale, noerase=noerase, $ color=colors(chana), nodata=nodata if noerase then !p.multi(0) = !p.multi(0) - 1 if markbad and kbada gt 0 and not keyword_set(nodata) then $ oplot, tarray(bada), yplotted(bada),psym=7, color=colors(chana) if chanb ne -1 and not keyword_set(nodata) then begin yover1=yover(0:new_n-1) yover1=rebin(yover1,new_n/n_pts) oplot, ave_tarray, yover1, psym=psym, color = colors(chanb) if markbad and kbadb gt 0 then $ oplot, tarray(badb), yover(badb), $ psym=7, color=colors(chanb) endif ; if keyword_set(e_bars) and not keyword_set(nodata) then begin if keyword_set(deriv) then factor = .44 else factor = 1. eplot,tarray,yplotted,ey=(ebars(*,chana)*factor),color=colos(chana) if chanb ne -1 then eplot,tarray,yover,ey=(ebars(*,chanb)*factor),$ color=colors(chanb) endif ; ; The following is for average saving purposes: sizey=size(yarray1) ave_yclean=fltarr(sizey(1),2) ave_yclean(*,0)=yarray1 & if chanb ne -1 then ave_yclean(*,1)=yover1 ; ;--Use normalized x and y window limits to place labels ; l = !x.window(0) & r = !x.window(1) b = !y.window(0) & t = !y.window(1) xi = !x.s ; if exist( ex_proc) then result_execute= execute( ex_proc) ; This is an attempt to correct the charsize when !p.multi=[0,1,2] or ; !p.multi=[0,1,>2] without affecting a 'tek' sc_device: chscale=ch_scale(0.9,/xy) dist_y=b-pl_scale(.07,/yc) if sc_device eq xdevice('X') and !d.y_size le 512 then begin if pmulti(2) eq 2 then chscale=ch_scale(0.9,/xy)*1.9 if pmulti(2) gt 2 then chscale=ch_scale(0.9)*1.3 dist_y=b-pl_scale(.12,/yc) endif xyouts, l, dist_y, sub1, /normal, chars = chscale xyouts, l+(r-l)*.53, dist_y, sub2, /normal, $ chars=chscale xyouts, l+(r-l)*.18, dist_y, sub3, /normal, $ chars = chscale, color=colors(chana) xyouts, l+(r-l)*.18, dist_y, sub4, /normal, $ chars=chscale, color=colors(chanb>0) if markbad then xyouts, l, dist_y, $ '!c!c!cX marks bad data points' , /normal, chars = chscale if (n_pts ne 1) then xyouts, l+(r-l)*.53, dist_y, $ '!c!c!cSample average = '+strtrim(n_pts,2) , /normal, chars=chscale ; Print GOES importance levels on right side of log plots if (logplot and not keyword_set(deriv) ) then begin ylims = crange('y') ytickv = 10.^[-11+indgen(9)] ytickname = [strarr(3)+' ','A','B','C','M','X',' '] q = where(( ytickv ge ylims(0)) and ( ytickv le ylims(1)), kq) if kq gt 0 then axis, yaxis=1, ytickv = ytickv(q),/ylog, ytickname=ytickname(q) ;Following code is the bizarre difficult way.!! ;levels = [1.e-8, 1.e-7, 1.e-6, 1.e-5, 1.e-4] ;codes = [' A', ' B', ' C', ' M', ' X'] ;ylims = crange('y') ;q = where ((levels ge ylims(0)) and (levels le ylims(1)), kq) ;if kq gt 0 then $ ; xyouts,!x.crange(1), levels, codes(q), charsize=chscale endif ; yderiv=yclean ;--Save yplotted into yderiv, so it gets returned to the main program if keyword_set(deriv) then begin yderiv(*,0)=yplotted if n_elements(yover) eq n_elements(yderiv(*,1)) then yderiv(*,1)=yover endif ; ;help,yarray,tarray,yclean,yderiv ;--Save system plotting variables for device in case we're going back ; to plot for another device. ; save_bangp(iloop-1) = !p save_bangx(iloop-1) = !x save_bangy(iloop-1) = !y ; ;--Close the TEK file. ; if iloop eq 1 then TEK_END endfor ; end of loop over output devices goto, getout error_exit: error = 1 getout: logplot = savelogplot ; restore logplot value in case changed it to linear if old_time_format eq 'YOHKOH' then yohkoh_format end ####################################################### pro gr, all_colors=all_colors, colors common psprnt, fname, num device, decomp = 0 ; This routine defines the environment variables required by the ; express-preprocessing programs 'ewsn_view', 'source', 'source_size' if n_elements(colors) le 0 and not keyword_set(all_colors) $ then colors=200 fname='' num=0 IF !version.OS eq 'windows' or !version.OS eq 'Win32' THEN BEGIN Delim='\' setenv,'gr_root=e:\grech\idl' ; common path ENDIF ELSE BEGIN Delim='/' setenv,'gr_root=/disk2/worg' ; common path setenv,'gr_prg='+getenv('gr_root')+'/istp' ; grlib if not keyword_set(all_colors) then begin window,0,xsi=100,ysi=100,colors=colors loadct,0 wait,0.5 wdelete,0 endif ENDELSE PATH=getenv('gr_root')+Delim cd,getenv('gr_prg') setenv,'help_dir='+'c:\idl\lib\istp\demo' setenv,'ssrt_demo='+'c:\idl\lib\istp\demo' setenv,'results='+'e:\grech\results' setenv,'ps_files='+'e:\grech\ps_files' print,'Environment variables for the SSRT data processing' print,' are established.' print,'Now current directory is ' + getenv('gr_root') print ; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! setenv,'spk_dat=f:\data' ; data directory setenv,'optics_dir=f:\data\optics' ; optical data setenv,'astr_data=c:\astr_dat' ; directory for files sol**.dat setenv,'gr_prg=e:\grech\idl' setenv,'SSW_EIT_RESPONSE=C:\ssw\soho\eit\response' def_ssrt def_uc ; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! end ####################################################### pro gr_fits,x,header,hstruc device,get_scr=scr index=-1 filnam=pickfile(/read) if filnam eq '' then goto,exit x=rfitsg(filnam,index=fnum,key_struct=hstruc,header=header,error=err, $ user_struct=ustruc,date_obs=date,time_obs=time,/sc) ;x=x*hstruc.bscale+hstruc.bzero Sz=size(x) window,/free,xsi=Sz(1),ysi=Sz(2),tit=(name_extract(filnam))(0)+', '+ $ string(Sz(1),Sz(2),format='(i4,"x",i4," pix")'),xpo=scr(0)-Sz(1), $ ypo=scr(1)-Sz(2) tvscl,x xloadct xquestion,aaa,text='Do you want to see the header?' if strlowcase(aaa) eq 'yes' then xtext,text=header exit: end ####################################################### function gr_gaussian,x,width,position ; Returns Gaussian curve having given width and position. if n_elements(position) le 0 then position=0. if n_params() lt 2 then begin print,'You must define WIDTH' return,0 endif z=((x-position)/width) > (-5) < 5 return,exp(-z^2*4.*alog(2)) end ####################################################### pro gr_goes, i1, i2, bcolor=bcolor, quiet=quiet, $ fem=fem, fillnight=fillnight, saa=saa, fillsaa=fillsaa, $ gdata=gxr_rec, low=low, high=high, gcolor=gcolor, $ nodeftitle=nodeftitle, no6=no6, no7=no7, $ three=three,title=title,thick=thick,_extra=plot_keywords, fast=fast, $ grid_thick=grid_thick, timerange=timerange, noylab=noylab, intlab=intlab, $ one_minute=one_minute, five_minute=five_minute, auto_range=auto_range, $ hc=hc, hardcopy=hardcopy, landscape=landscape, portrait=portrait, $ xsize=xsize, ysize=ysize, status=status, $ time4=time4, time8 = time8, chan4 = chan4, chan8 = chan8 ;+ ; Name: goes_plot ; ; Purpose: plot goes x-ray data (Yohkoh structure) ; ; Input Parameters: ; input1 - user start time or goes xray data record structure array ; input2 - user stop time ; ; Optional Keyword Paramters: ; fem - if set, overplot Yohko ephemeris grid (call fem_grid) ; fillnight - (pass to fem_grid) - polyfill Yohkoh nights ; fillsaa - (pass to fem_grid) - polyfill Yohkoh saas ; saa - (pass to fem_grid) - show saa events overlay grid ; low - if set, only plot low energy ; high - if set, only plot high energy ; title - user title (appended to default title predicate) ; nodeftitle- if set, dont append default title predicate ; color - color of lines ; ; Calling Sequence: ; plot_goes,'5-sep-92' ; start time + 24 hours ; plot_goes,'5-sep-92',/three ; same, but use 3 second data ; plot_goes,'5-sep-92',6 ; start time + 6 hours ; plot_goes,'5-sep-92','7-sep-92' ; start time / stop time ; plot_goes,gxtstr ; input goes records from rd_gxt ; plot_goes,'5-sep',/fem ; overplot Yohkoh ephemeris grid ; plot_goes,'5-sep',/fillnight ; ditto, but fill in Yohkoh nights ; plot_goes,'1-jun','30-jul',/low ; only plot low energy ; ; plot_goes,t1,t2,/one_minute ; one minute averages (default) ; plot_goes,t1,t2,/five_minute ; five minute averages ; plot_goes,t1,t2,/auto ; use environmental goes_auto_range ; plot_goes,t1,t2,auto=[.25,1.,5] ; auto range (3 second/1 min/5 min) ; plot_goes,t1,t2,/hc or /hardcopy ; PS hardcopy (default orient=landscape) ; plot_goes,t1,t2,/portrait ; PS hardcopy (orient=portrait) ; ; History: slf 22-sep-1992 ; slf 11-oct-1992 - added low and high keywords, add documentation ; slf 26-oct-1992 - added nodeftitle keyword ; slf 15-mar-1993 - return on no data ; mdm 24-Mar-1993 - corrected error due to integer overflow ; slf 19-Jul-1993 - implemented LO and HI keyword function ; slf 29-jul-1993 - added max_value keyword (pass to utplot) ; slf 4-sep-1993 - add charsize, no6, no7 keywords ; slf 22-Nov-1993 - added lots of plot keyowords ; jrl 1-dec-1993 - added thick, charthick, xtitle keywords ; slf 5-dec-1993 - set default xstyle = 1 ; slf, 7-dec-1993 - a) added three (second) keyword and functions ; c) gave up on any and all hopes for clean logic ; slf 15-dec-1993 - a) yrange w/gxt input b) check deriv(valid) ; cleanup the input logic a little. ; ras 17-aug-1994 - no longer use call procedure by setting proc to ; 'utplot' or 'utplot_io' by just calling utplot and ; setting ytype as needed ; slf, 19-aug-94 - make no6 default if start time after 17-aug ; dmz 21-Aug-1994 - lumped all plot keywords into _EXTRA ; so that keyword inheritance will work with ; UTPLOT. Also replaced OUTPLOT by OPLOT and ; fixed potential bug in DVALID ; slf, 25-aug-94 - merged divergent changes (19-aug / 21-aug) ; add /fast switch (use saved version if avail) ; gal, 13-aug-94 - added grid_thick switch to control goes grids. ; mdm, 20-Sep-94 - Added TIMERANGE option ; slf, 9-oct-94 - Added NOYLAB keyword ; slf, 30-aug-95 - add ONE_MINUTE and FIVE_MINUTE keywords ; add auto_ranging (via environ= goes_auto_range) ; preferentially use G71 instead of GXT if availble ; slf, 26-sep-95 - protect against missing G6 ; slf, 28-sep-95 - add HC, HARDCOPY, LANDSCAPE, and PORTRAIT switches ; slf, 5-oct-95 - add STATUS keyword (1=some data, 0=none) ; jmm, 8-aug-96 - Fixed bugs to allow for the plotting of input ; data structures, changed a reference to GXR_DATA_REC ; to GXD_DATA_REC. ; slf, 13-aug-96 - make GOES 9 default after 1-july-1996 ; (replace GOES 7 , no goes7 after 14-aug-96) ; slf, 18-aug-96 - add goes91/95 to the ydb_exist check ; slf, 30-Jul-98 - GOES 9 off , make GOES8 the default ; ; Side Effects: ; /fast switch causes color table 15 load ;- hardcopy=keyword_set(hc) or keyword_set(hardcopy) or keyword_set(landscape) $ or keyword_set(portrait) portrait=keyword_set(portrait) landscape=keyword_set(landscape) or (1-portrait) loud=1-keyword_set(quiet) if keyword_set(fast) then begin if file_exist(concat_dir('$DIR_GEN_SHOWPIX',concat_dir('new_data','GOES_PLOT_24h.genx'))) then begin fl_goesplot, image, R, G, B wdef,yyy, image=image,/uleft tv,image loadct,15 tbeep prstr,['','--------- Current UT Time is: ' + ut_time() + ' ---------',''] endif else message,/info,"Your site does not support /fast switch..." return endif if hardcopy then begin if not keyword_set(xsize) then xsize=([6.5,9])(landscape) if not keyword_set(ysize) then ysize=([3,6])(landscape) ; print,"Postscript " + (['portrait','landscape'])(landscape) + " size= " + $ ; strtrim(xsize,2) + " X " + strtrim(ysize,2) + " inches" ; dtemp=!d.name ; save ; set_plot,'ps' ; exe=execute( (["device,/portrait","device,/landscape"])(landscape)) ; if landscape then device,/landscape else device,/portrait ; device, color=0, /inches, xsize=xsize, ysize=ysize, xoffset=.5, yoffset=.5 endif ;qtemp=!quiet if n_elements(i1) eq 0 then i1=gt_day(addtime(syst2ex(),delta=-24*60),/str) if n_elements(i2) eq 0 then i2=36 ; inhibit goes 6 after 00:00 17-aug secs=int2secarr(anytim2ints(i1),'17-aug-94') no6=keyword_set(no6) or secs gt 0 def9=int2secarr(anytim2ints(i1),'1-jul-96') gt 0 no7=keyword_set(no7) def8=int2secarr(anytim2ints(i1),'25-jul-98') gt 0 case 1 of def8: box_message,'GOES 9 off, trying GOES 8' def9 and 1-no7: message,/info, "GOES 7 off, trying GOES 9" else: endcase ; set defaults for tektronics files ; ancient "default" ytype= 0 yrange=[101,679] ; default is gxt files ; 15-dec - backwardly compatible - allow gxt structure input directly gxrin=0 ;if data_chk(i1,/struct) then gxrin=tag_names(i1,/struct) eq 'GXR_DATA_REC' ;GXR_DATA_REC to GXD_DATA_REC, jmm 8-aug-1996 if data_chk(i1,/struct) then gxrin=tag_names(i1,/struct) eq 'GXD_DATA_REC'; ; ------------------------------------------------------------------------ if not gxrin then begin input1=fmt_tim(i1) ; any yohkoh fmt case data_chk(i2,/type) of 8: input2=fmt_tim(i2) ; yohkho struct 7: input2=i2 else: input2=fmt_tim(anytim2ints(i1,offset=float(i2)*60.*60.)) endcase ; ------------------------------------------------------------------------ ; select count cadence - one_minute is default chk_auto=get_logenv('goes_auto_range') five_minute=keyword_set(five_minute) ; slf, 30-aug-95 three=keyword_set(three) ; 3 second one_minute=keyword_set(one_minute) case 1 of one_minute: one_minute =ydb_exist([input1,input2],/range,'G71') five_minute: five_minute =ydb_exist([input1,input2],/range,'G75') three: n_elements(auto_range) eq 3: arange=auto_range data_chk(auto_range,/scaler) and get_logenv('goes_auto_range') ne '': $ arange=float(str2arr(get_logenv('goes_auto_range'))) else: one_minute=1 endcase if n_elements(arange) eq 3 then begin ; cutoffs [three-second, onemin, five] offday=(int2secarr(anytim2ints([input1,input2])))(1)/86400. which=where(offday gt arange,cnt) type=(['three','one_minute','five_minute'])(cnt>0<2) ; set appropriate keyword exestat=execute(type + '=1') if loud then message,/info,"Auto-ranging is enabled..." endif ; verify selected gxd file exists if one_minute then one_minute=ydb_exist([input1,input2],/range,'G71') or $ ydb_exist([input1,input2],/range,'G91') or $ ydb_exist([input1,input2],/range,'G81') if five_minute then five_minute=ydb_exist([input1,input2],/range,'G75') or $ ydb_exist([input1,input2],/range,'G95') or $ ydb_exist([input1,input2],/range,'G85') gxd=three or one_minute or five_minute if not gxd then begin message,/info,"Forcing GXD one minute..." one_minute=1 gxd=1 endif repeats= ([gxd * (1-keyword_set(no6) and 1-no7) + 1,1])(def9) ;FUTURE - allow 8&9 ; ------------------------------------------------------------------------ if gxd then begin mess='Using 3 second data ' if not three then mess=mess + $ (['(One','(Five'])(keyword_set(five_minute)) + ' Minute Averages) ' + '...' if loud then message,/info,mess case 1 of ; messy due to maintaining existing logic def8: rd_gxd,input1,input2,gxr_rec,/goes8, $ one_minute=one_minute, five_minute=five_minute def9: rd_gxd,input1,input2,gxr_rec,/goes9, $ one_minute=one_minute, five_minute=five_minute keyword_set(no6): rd_gxd,input1,input2, gxr_rec, /goes7, $ one_minute=one_minute, five_minute=five_minute keyword_set(no7): rd_gxd,input1,input2, gxr_rec,/goes6, $ one_minute=one_minute, five_minute=five_minute else: rd_gxd,input1,input2, gxr_rec, /goes7, $ one_minute=one_minute, five_minute=five_minute endcase yrange=[1.e-9, 1.e-3] ytype = 1 endif else begin rd_gxt,input1, input2, gxr_rec endelse endif else begin ;jmm, 8-aug-1996, to allow plotting of input data structures gxr_rec = i1 gxd = 1 repeats= gxd * (1-keyword_set(no6) and 1-keyword_set(no7)) + 1 yrange=[1.e-9, 1.e-3] ytype = 1 endelse status=1 if n_elements(gxr_rec) lt 2 then begin ; return on no data status=0 types=['',' three second '] message,/info,'No ' + types(three) + 'GOES data available for specified time' return endif gapsize=10 ;dont plot gaps labels=['G7 Low','G6 Low','G7 High','G6 High'] delim=['',': '] mtitle='GOES X-Rays' if keyword_set(no6) then mtitle='GOES 7 X-Rays' if keyword_set(no7) then mtitle='GOES 6 X-Rays' if keyword_set(def9) then mtitle='GOES 9 X-Rays' if keyword_set(def8) then mtitle='GOES 8 X-Rays' if keyword_set(nodeftitle) then mtitle='' if not keyword_set(title) then title='' mtitle=mtitle + delim(keyword_set(mtitle)) + title linestyle=[0,1,0,1] psym=[-3,3,-3,3] symsize=[.7,1,.7,1] usersym,[-1,1],[0,0] offset=2 ; first data field yticks=6 intlab=keyword_set(intlab) noylab=keyword_set(noylab) or intlab ytickname=['1E-9','A ','B ','C ','M ','X ','1E-3'] if keyword_set(noylab) then ytickname(*)=' ' yticklen=.001 yminor=1 ymax=679 if (n_elements(timerange) eq 1) then timerange=[input1, input2] ; set up the axis labels and plot scaling ; slf 7-dec-1993 - add three second option - use log plot if 3 sec ;yrtemp=!y.crange ;!y.crange=yrange ytype = 1 ;utplot, gxr_rec,indgen(n_elements(gxr_rec)) < ymax ,/nodata, $ ; yminor=yminor, yticks=yticks, $ytickname=ytickname, $ ; JRL set yticklen = .001 ; title=mtitle,$ ; yrange=yrange,$ ; xstyle=1,ystyle=1,ytype=ytype,$ ; thick=thick,_extra=plot_keywords, timerange=timerange ;!quiet=0 ;utplot stuff clobbers this! ; determine which channels to plot tags=tag_names(gxr_rec) lochan=where(strpos(tags,'LO') ne -1) hichan=where(strpos(tags,'HI') ne -1) g6chan=where(strpos(tags,'G6') ne -1) g7chan=where(strpos(tags,'G7') ne -1) case 1 of keyword_set(low) and 1-keyword_set(high): wchan=lochan keyword_set(high) and 1-keyword_set(low): wchan=hichan keyword_set(no6) and (1-gxd): wchan=g7chan keyword_set(no7) and (1-gxd): wchan=g6chan else: wchan=[lochan, hichan] endcase if n_elements(wchan) eq 2 or repeats eq 2 then psym=[-3,-3] case 1 of n_elements(color) eq 0: color=intarr(4)+255 n_elements(color) lt n_elements(wchan): $ color=replicate(color(0),n_elements(wchan)) else:color=color(0:n_elements(wchan)-1) endcase if !d.name eq 'PS' then color = 255 - color if n_elements(thick) eq 0 then thick=1 time4 = -1 chan4 = -1 time8 = -1 chan8 =-1 for rep=0, repeats-1 do begin ; loop added for 3 second ; now plot the valid points for i=0, n_elements(wchan)-1 do begin ; for each desired channel valid=where(gxr_rec.(wchan(i))+1) ; initial val=-1 ; ; ------------------- uplot_gap.pro subroutine?? ------------------------- dvalid=-1 ; initialize DVALID (DMZ) if valid(0) ne -1 then dvalid=deriv_arr(valid) ; identify gaps rgst=0 & rgsp=n_elements(valid)-1 ; at least one interval! gapsp = where(dvalid gt gapsize, count) ; discontinuity > gapsize if count gt 0 then begin ; at least one gap gapst=gapsp+1 rgst=[rgst,gapst] & rgsp = [gapsp,rgsp] ; define subranges endif ;circ,/fil psym = [-8,-8] symsize = [1,1]*0.4 for j = 0, n_elements(rgst)-1 do begin ; plot each interval ; Tested if rgst(j) ne rgsp(j) then begin ; kludge for now time_gr0 = anytim(gxr_rec( valid (rgst(j):rgsp(j))))-getutbase() count_gr0 = gxr_rec(valid(rgst(j):rgsp(j))).(wchan(i)) ; oplot,time_gr0, $ ; count_gr0,color=color(i), $ ; psym=psym(i), symsize=symsize(i), max=670,thick=thick CASE i OF 1: if n_elements(time4) le 1 then begin time4 = time_gr0 chan4 = count_gr0 endif else begin time4 = [time4, time_gr0] chan4 = [chan4, count_gr0] endelse 0: if n_elements(time8) le 1 then begin time8 = time_gr0 chan8 = count_gr0 endif else begin time8 = [time8, time_gr0] chan8 = [chan8, count_gr0] endelse ELSE: ENDCASE endif endfor ;------------------------------------------------------------------------ endfor time4 = (time4 + getutbase()); mod 86400 time8 = (time8 + getutbase()); mod 86400 ;!quiet=0 ;utplot stuff clobbers this! ; more 3 second logic stuff if repeats eq 2 and rep eq 0 then begin psym=[3,3] message,/info,'reading goes 6 rd_gxd,input1,input2, gxr_rec, /goes6, $ one_minute=one_minute, five_minute=five_minute if not data_chk(gxr_rec,/struct) then begin message,/info,"Sorry, No GOES 6 data for this interval..." rep=repeats ;**** UNSTRUCTURED FOR LOOP EXIT **** endif endif endfor ; ; overplot Yohkoh ephemeris grid on request ;!y.crange=yrange ;!!! fem = keyword_set(fem) or keyword_set(fillnight) or $ keyword_set(fillsaa) or keyword_set(saa) ;if fem then $ ; fem_grid,fillnight=fillnight, fillsaa=fillsaa, saa=saa ;------------------------------------------------------ ; ; draw grid indicating goes level if not keyword_set(gcolor) then gcolor=bytarr(6)+255 if !d.name eq 'PS' then gcolor=255-gcolor ;goes_grid, color=gcolor, grid_thick=grid_thick ; , color=bindgen(6)*50+50 ; ;------------------------------------------------------ if intlab then begin ; device,get_graphics=oldg arr=['','A','B','C','M','X'] gpos=(indgen(6) * (!y.window(1)-!y.window(0))/6.) + (!y.window(0) + .005) ; device,set_graphics=6 ; for i=0,5 do xyouts,!x.window(0)+.01,gpos(i),arr(i),/norm,charsize=1.3 ; device,set_graphics=oldg endif ; if hardcopy then begin ; pprint ; set_plot,dtemp endif ;!quiet=qtemp return end ####################################################### function gr_goes_tem, f4, f8, flux17 = flux17 ; Temperature in 10^6 K, Emission Measure in 10^45 cm-3 R = double(f4/f8) T = 3.15 + 77.2*R + 164*R^2 + 205*R^3 b8 = -3.86 + 1.17*T - 1.31d-2*T^2 + 1.78d-4*T^3 EM = F8/(b8)*1d55 flux17 = 3.1e7*em/1d55/sqrt(t) return, [[float(T)], [float(EM/1d45)]] end ####################################################### pro gr_header,lun,offset,header, $ version=version, $ write=write, read=read, $ comments=comments, $ Parameter=Parameter, $ Interferometer=Interferometer, $ source_file=source_file, $ first_record=first_record, $ Date=Date, $ Reference_time=Reference_time, $ Reference_channel=Reference_channel,$ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Dt, $ Length=Length, $ N_channels=N_channels, $ Created=Created, $ Creator=Creator, $ Array_size=Array_size, $ Type=Type, $ Channel_bounds=Channel_bounds, $ i_scan_bounds=i_scan_bounds, $ d_scan_bounds=d_scan_bounds, $ zero=zero, $ factor=factor, $ weight=weight CR='0a'xb if n_elements(version) le 0 then version='221295' Markers='gr_header '+['221295','220196'] Format_length=[19,25] CASE keyword_set(write) OF 0: BEGIN point_lun,lun,0 F_marker_rd=bytarr(16) readu,lun,F_marker_rd F_marker=string(F_marker_rd) index=where(F_marker(0) eq Markers) if index(0) ge 0 then begin Format_marker=Markers(index(0)) Format_length=Format_length(index(0)) endif else begin print,'Unrecognized format.' return endelse header=strarr(Format_length) point_lun,lun,0 tmp='' for j=0,Format_length-1 do begin readf,lun,tmp header(j)=tmp endfor Offset=long(((strsplit(header(1)))(1))) Type=header(2) Comments=header(3) Parameter=(strsplit(header(4)))(1) Interferometer=(strsplit(header(5)))(1) Source_file=(strsplit(header(6)))(1) First_record=long(((strsplit(header(7)))(1))) Date=strmid(header(8),6,8) Reference_time=(strsplit(header(9)))(1) Reference_Channel=fix(((strsplit(header(10)))(1))) Start_time=(strsplit(header(11)))(1) Receiver=(strsplit(header(12)))(1) Dt=double(((strsplit(header(13)))(1))) Length=long(((strsplit(header(14)))(1))) N_Channels=fix(((strsplit(header(15)))(1))) Array_size=long((strsplit(header(16)))(1:*)) Created=strmid(header(17),9,100) Creator=strmid(header(18),9,100) IF Format_marker eq Markers(1) THEN BEGIN Channel_bounds=fix((strsplit(header(19)))(1:*)) i_scan_bounds=long((strsplit(header(20)))(1:*)) d_scan_bounds=long((strsplit(header(21)))(1:*)) zero=float(((strsplit(header(22)))(1))) factor=float(((strsplit(header(23)))(1))) weight=float(((strsplit(header(24)))(1))) ENDIF END ELSE: BEGIN Format_marker='gr_header '+version ;Format_marker Case version OF strmid(Markers(0),10,6): begin AUX='' Array_size=[2,N_channels,32,2,N_channels*32L] end strmid(Markers(1),10,6): begin AUX=[ $ byte('Channel_bounds: '), $ byte(string(Channel_bounds(0))+string(Channel_bounds(1))), CR, $ byte('I_scan_bounds: '), $ byte(string(i_scan_bounds(0))+string(i_scan_bounds(1))), CR, $ byte('D_scan_bounds: '), $ byte(string(d_scan_bounds(0))+string(d_scan_bounds(1))), CR, $ byte('Zero: '), byte(string(zero)), CR, $ byte('Factor: '), byte(string(factor)), CR, $ byte('Weight: '), byte(string(weight)), CR ] C_Number=Channel_bounds(1)-Channel_bounds(0)+1 Array_size=[2,C_Number,32,2,C_Number*32L] end ELSE: begin AUX='' C_Number=Channel_bounds(1)-Channel_bounds(0)+1 Array_size=[2,C_Number,32,2,C_Number*32L] end EndCase Header=[ $ byte(Type), CR, $ byte('Comments: '), byte(comments), CR, $ byte('Parameter: '), byte(Parameter), CR, $ byte('Interferometer: '), byte(Interferometer), CR, $ byte('Source_file: '), byte(source_file), CR, $ byte('First_record: '), byte(string(first_record)),CR, $ byte('Date: '), byte(Date), CR, $ byte('Reference_time: '), byte(Reference_time), CR, $ byte('Reference_channel: '), byte(string(Reference_channel)),CR, $ byte('Start_time: '), byte(Start_time), CR, $ byte('Receiver: '), byte(Receiver), CR, $ byte('Dt: '), byte(string(Dt)), CR, $ byte('Length: '), byte(string(Length)), CR, $ byte('N_channels: '), byte(string(N_channels)),CR, $ byte('Size: '), $ byte(string(reform(byte(string(Array_size)), $ n_elements(byte(string(Array_size)))))), $ CR, $ byte('Created: '), byte(systime(0)), CR, $ byte('Creator: '), byte(Creator), CR, $ AUX] Offset=n_elements(Header)+36 s_header_length=strcompress(string(Offset),/rem) Record=[ $ byte(Format_marker), CR, $ byte('Header_length: '), byte(s_header_length), CR, $ Header] point_lun,lun,0 writeu,lun,Record END ENDCASE end ####################################################### pro gr_read, scan,I_record, V_record, header, file=file, $ version=version, $ comments=comments, $ Parameter=Parameter, $ Interferometer=Interferometer, $ source_file=source_file, $ first_record=first_record, $ Date=Date, $ Reference_time=Reference_time, $ Reference_Channel=Reference_Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Dt, $ Length=Length, $ N_channels=N_channels, $ Creator=Creator, $ Created=Created, $ Array_size=Array_size, $ Type=Type, $ Channel_bounds=channel_bounds, $ i_scan_bounds=i_scan_bounds, $ d_scan_bounds=d_scan_bounds, $ zero=zero, $ factor=factor, $ weight=weight if n_elements(File) le 0 then $ File=pickfile(path=getenv('spk_dat'),filt='*.wrs *nrs') if File eq '' then return widget_control,/hour openr,lun,File,/get_lun gr_header,lun,offset,header,/read, $ version=version, $ comments=comments, $ Parameter=Parameter, $ Interferometer=Interferometer, $ source_file=source_file, $ first_record=first_record, $ Date=Date, $ Reference_time=Reference_time, $ Reference_Channel=Reference_Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Dt, $ Length=Length, $ N_channels=N_channels, $ Creator=Creator, $ Created=Created, $ Array_size=Array_size, $ Type=Type, $ Channel_bounds=channel_bounds, $ i_scan_bounds=i_scan_bounds, $ d_scan_bounds=d_scan_bounds, $ zero=zero, $ factor=factor, $ weight=weight point_lun,lun,Offset scan_I=(scan_V=fltarr(N_channels)) d_scan_I=(d_scan_V=fltarr(N_channels)) model=fltarr(N_channels) Number=Channel_bounds(1)-Channel_bounds(0)+1 I_record=(V_record=intarr(Number,Length)) readu,lun, scan_I, scan_V, d_scan_I, d_scan_V, model, I_record, V_record free_lun,lun scan_I=(scan_I-zero)*weight scan_V=scan_V*weight I_record=(I_record-zero)*weight V_record=V_record*weight scan=[[scan_I], [scan_V], [d_scan_I], [d_scan_V]] print,file help,file ;save,scan_I, scan_V, d_scan_I, d_scan_V, model, I_record, V_record,$ ;filename='E:\NATASHA\moskal\data\vse.wrs' end ####################################################### pro gr_stonyhurst, Center, Radius, B0, color = color if n_elements(color) le 0 then color = !p.color if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-Center(0),!d.x_size-Center(0)]/Radius !y.range=[-Center(1),!d.y_size-Center(1)]/Radius map_set, B0, 0, 0, /grid, /ortho, /noerase, pos=[0,0,1,1], /nobor, latdel=10, londel=10, col=color !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set, B0, 0, 0, /ortho, /noerase, pos=[0,0,1,1], /nobor !x.s=[Center(0), Radius] / float(!d.x_size) !y.s=[Center(1), Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, col = color !P.clip=P_clip_save endelse empty end ####################################################### function gr_strsplit,x,delimiter=delimiter ; Splits a string into substrings. if n_elements(delimiter) le 0 then delimiter=' ' xbyte=byte(x) Sz=size(xbyte) length=max(strlen(x)) z=strlen(strcompress(x)) lmax=max(temporary(z), imax) i=where(xbyte(*, imax) eq (byte(delimiter))(0)) r=replicate(1, n_elements(i)) for j=1, n_elements(i)-1 do if i(j) eq i(j-1)+1 then r(j)=0 tmp=where (r eq 0) if tmp(0) ge 0 then ind=inv_index(i(tmp), length) else ind=lindgen(length) if i(0) eq 0 then ind=ind(1:*) N_ind=n_elements(ind)-1 if total((xbyte(ind(N_ind)) eq byte(delimiter))) eq Sz(2) then ind=ind(0:N_ind-1) compressed=string((byte(x))(ind,*)) index=where(byte(compressed(imax)) eq (byte(delimiter))(0)) IF index(0) eq (-1) THEN return, compressed ELSE BEGIN N=n_elements(index) result=strarr(N+1, Sz(2)) index=[-1,index,lmax] for j=0,N do result(j,*)=strmid(compressed, index(j)+1, index(j+1)-index(j)-1) return,result ENDELSE end ####################################################### function HEADFITS, filename, EXTEN = exten ;+ ; NAME: ; HEADFITS ; CALLING SEQUENCE: ; Result = headfits( filename ,[ EXTEN = ]) ; ; PURPOSE: ; Read a FITS file header record ; ; INPUTS: ; FILENAME = String containing the name of the FITS file to be read. ; ; OPTIONAL INPUT KEYWORD: ; EXTEN = integer scalar, specifying which FITS extension to read. ; For example, to read the header of the first extension set ; EXTEN = 1. Default is to read the primary FITS header ; (EXTEN = 0). ; ; OUTPUTS: ; Result of function = FITS header, string array ; ; EXAMPLE: ; Read the FITS header of a file 'test.fits' into a string variable, h ; ; IDL> h = headfits( 'test.fits') ; ; MODIFICATION HISTORY: ; adapted by Frank Varosi from READFITS by Jim Wofford, January, 24 1989 ; Keyword EXTEN added, K.Venkatakrishna, May 1992 ;- On_error,2 If N_params() LT 1 then begin print,'Sytax - header = headfits( filename, [ EXTEN = ]) return, -1 end ; Open file and read header information openr,unit,filename, /GET_LUN, /BLOCK y = indgen(36*8) y2 = y - 8*(y/8) + 80*(y/8) offset = 0 extn = 0 START: r = 0 hdr = assoc(unit, bytarr(80,36), offset) ; Read header one record at a time if EOF(unit) then message,' No such extension, End of file reached' LOOP: x = hdr(r) name = string( x(y2) ) ;Get first 8 char of each line pos = strpos( name, 'END ' ) if r EQ 0 then header = string(x) else header = [header,string(x)] if (pos lt 0) then begin r = r + 1 goto, LOOP endif lastline = 36*r + pos / 8 header = header(0:lastline) ; IF extension, get the size of the ; data. Find no of records to skip If keyword_set(EXTEN) then begin bitpix = sxpar( header, 'BITPIX') naxis = sxpar( header, 'NAXIS') Nax = sxpar( header, 'NAXIS*' ) ; Read NAXES nbytes = nax(0) * abs( bitpix )/ 8 if naxis GT 1 then for i = 2, naxis do nbytes = nbytes*nax(i-1) $ else nbytes = 0 nrec = nbytes /2880 if nbytes GT nrec*2880L then nrec = long( nrec + 1 ) else $ nrec = long(nrec) point_lun, -unit, pointlun pointlun = pointlun + nrec*2880L point_lun,unit,pointlun offset = pointlun extn = extn + 1 if (extn LE EXTEN) then goto, START endif free_lun, unit return, header end ####################################################### PRO HELIOTRANS,X0,Y0,CROTA2,POS,BLAT,BLONG,IX,IY,IR,HLONG,HLAT ;transforms spherical coordinates [IX-X0,IY-Y0,IR] into cartesian coordinates ;[HLONG,HLAT] of heliografic longitude/latitude. ; ;X0, Y0 are pixel coords of disk center ;POS is position angle to rotate, CROTA2 is rotation angle of image: both zero ;BLAT,BLONG is heliografic longitude and latitude of disk center. ;IX, IY are coords to be rotated: one may be an array (pixels) ;IR is solar radius in units of pixels: height of rotating surface ;HLONG, HLAT are helio lat and long - the output PI =ACOS(-1.) &DPOS =POS+CROTA2 X =FLOAT(IX-X0) &Y =FLOAT(IY-Y0) POSRAD =-DPOS*PI/180. &BLATRAD=BLAT*PI/180. SINPOS =SIN(POSRAD) &COSPOS =COS(POSRAD) SINBLAT =SIN(BLATRAD) &COSBLAT=COS(BLATRAD) RXY =SQRT(X^2+Y^2) RR =FLOAT(IR) > RXY Z2 =RR^2-Y^2-X^2 ;z-coordinate squared Z =SQRT(Z2 > 0) ;z-coordinate XX =X*COSPOS-Y*SINPOS ;rotation position angle Y1 =X*SINPOS+Y*COSPOS YY =Z*SINBLAT+Y1*COSBLAT ;rotation by BLAT V2 =(RR^2-YY^2) V =SQRT(V2 > 0) ;radius proj in equator-plane SINPHI =IX*0.+1. ind =where(v gt 0) SINPHI(ind)=(XX(ind)/V(ind)) ;longitude difference from center SINPHI =SINPHI > (IX*0.-1.) SINPHI =SINPHI < (IX*0.+1.) DLON =XX*0. ind =where(sinphi ne 0) DLON(ind)=(180./PI)*ASIN(SINPHI(ind)) ;longitude difference in degree HLONG =BLONG+DLON ;heliographic longitude SINLAT =(YY/RR) HLAT =(180./PI)*ASIN(SINLAT) ;heliographic latitude END ####################################################### PRO HELIOTRANS2,X0,Y0,CROTA2,POS,BLAT,BLONG,HLONG,HLAT,IR,IX,IY ;transforms cartesian coordinates [HLONG,HLAT] of heliografic ;longitude/latitude into spherical coordinates [X,Y,R]=[IX-X0,IY-Y0,IR] ;POS is position angle, CROTA2 = rotation angle of image ;BLAT,BLONG is heliografic longitude and latitude of disk center. PI =ACOS(-1.) &EPS =1.E-8 DPOS =POS+CROTA2 &DLON =HLONG-BLONG POSRAD =+DPOS*PI/180. &BLATRAD=+BLAT*PI/180. SINPOS =SIN(POSRAD) &COSPOS =COS(POSRAD) SINBLAT =SIN(BLATRAD) &COSBLAT=COS(BLATRAD) SINPHI =SIN(DLON*PI/180.) &SINLAT =SIN(HLAT*PI/180.) Y1 =IR*SINLAT ;HLONG-SIN equatorial coord X1 =SQRT(IR^2-Y1^2)*SINPHI ;HLAT-SIN equatorial coord. Z1 =SQRT(IR^2-Y1^2-X1^2 > EPS);z-coordinate X2 =X1 ;x-coordinate Y2 =-Z1*SINBLAT+Y1*COSBLAT ;disk center at BLAT,BLONG X3 =X2*COSPOS-Y2*SINPOS ;position angle rotation Y3 =X2*SINPOS+Y2*COSPOS ;position angle rotation IX =X3+X0 ;RA-SIN with image center at X0 IY =Y3+Y0 ;DEC-SIN with image center at Y0 END ####################################################### function help_info, name, error=error, show=show, path=path error=0 if !version.OS eq 'windows' then Delim='\' else Delim='/' name_only=(name_extract(name))(1) wildcard=strmid(name_only,0,8) if n_elements(path) gt 0 then wildcard=path+Delim+wildcard file=findfile(wildcard+'*.pro') if n_elements(file) gt 1 then begin if n_elements(path) gt 0 then name_only=path+Delim+name_only file=findfile(name_only+'.pro') endif file=file(0) if file eq '' then begin error=1 return, '';text='' endif j=0 tmp='' text=strarr(1000) openr, lun, file, /get while not eof(lun) do begin readf,lun,tmp text(j)=tmp j=j+1 endwhile free_lun,lun text=text(0:j-1) first=(where(strmid(text,0,2) eq ';+'))(0) last=(where(strmid(text,0,2) eq ';-'))(0) if (first lt 0) or (last lt 0) then begin error=1 text='' endif else text=text(first:last) if keyword_set(show) then xtext, tex=text return,text end ####################################################### FUNCTION HMS,Ngrad,Nmin,Sec ; Converts hours, minutes, seconds into hours; ; converts time of string type into hours. temp=Ngrad T_sign=0 IF n_params() eq 1 THEN BEGIN Sz=Size(temp) CASE 1 OF (Sz(n_elements(Sz)-2) eq 7): begin T_Sign=strmid(temp,0,1) eq '-' ;Ngrad=(Nmin=(Sec=make_array(size=Sz,/string))) Ngrad=strmid(temp,0+T_sign,2) Nmin=strmid(temp,3+T_sign,2) Sec=strmid(temp,6+T_sign,12) end Sz(0): begin Ngrad=temp(0) Nmin=temp(1) Sec=temp(2) end ELSE: begin Ngrad=temp(*,0) Nmin=temp(*,1) Sec=temp(*,2) end ENDCASE ENDIF Grad=(double(Ngrad)+double(Nmin)/60+double(Sec)/3600)* $ (1-2*T_sign) Ngrad=temp return,Grad end ####################################################### FUNCTION hmsd, In_time, seconds = seconds, hours = hours ;+ Converts time of string type "hh:mm:ss.ms" into seconds or hours (double). ;- T_Sign=strmid(In_time, 0, 1) eq '-' temp = In_time ind = where(T_sign eq 0, count) if count ne 0 then Temp(ind) = '+' + temp(ind) ind = 0 Out_time = (double(strmid(Temp, 1, 2))*3600 + $ double(strmid(Temp, 4, 2))*60 + $ double(strmid(Temp, 7, 12))) * $ (1-2*T_sign) if keyword_set(hours) then return, Out_time/3600d0 else return, Out_time end ####################################################### function hxt_image_filter, index, data, db = db, noise_level = sigma, $ width = width if n_elements(dB) le 0 then dB=10 if n_elements(sigma) le 0 then sigma = 3. if n_elements(width) le 0 then width = 5 Sz = size(data) noise_level = sqrt(index.hxi.cnts_p_cm2)/64. newdata = data max_amount = index.hxi.max_bright dyn_range = 10^(-abs(dB)/10.) for j=0, Sz(Sz(0))-1 do begin tmp=data(*,*,j) if width gt 1 then smoothtmp = smooth(tmp, width) ind=where(smoothtmp lt index(j).hxi.max_bright*dyn_range $ and smoothtmp lt noise_level(j)*sigma) if ind(0) ge 0 then tmp(ind)=0 newdata(*,*,j) = tmp endfor return, newdata end ####################################################### pro hxt_tabl, obs, mode, gammas, factors observed = transpose(obs) Sz = size(observed) if Sz(0) eq 1 then Nobs = 1 else Nobs = Sz(2) obs_ratios = [observed(1, *)/observed(0, *), $ observed(2, *)/observed(1, *), $ observed(3, *)/observed(2, *)] if strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then Delim = '\' else Delim = '/' file_non_therm = getenv('grlib')+Delim +'nontherm_tabl_gr.txt' xx = readform(file_non_therm) n_index = where(strmid(xx, 0, 5) eq 'index') N = n_elements(n_index) gamma=float(strmid(xx(n_index),9,15)) ratiosn = fltarr(N, 3) for j=0,2 do ratiosn(*,j) = float(strmid(xx(n_index+1+j),0,15)) calc_ratesn= transpose(float(strsplit(xx(n_index+4)))) file_therm = getenv('grlib')+Delim +'therm_tabl_gr.txt' xx = readform(file_therm) i0 = (where(strmid(strtrim(xx, 2), 0, 5) eq '10.00'))(0) in = indgen(n_elements(xx)/2-1)*2+i0 xx=xx(in)+xx(in+1) xx =float(strsplit(xx)) ratiost = transpose(xx(5:*,*)) calc_ratest = transpose(xx(1:4,*)) TT = transpose(xx(0,*)*1e6) Nt = n_elements(TT) gammas = fltarr(Nobs, 3) factors = dblarr(Nobs, 3) CASE mode OF 0: begin calc_rates = calc_ratesn gamt = gamma Number = N ratios = ratiosn end 1: begin calc_rates = calc_ratest gamt = TT Number = Nt ratios = ratiost end ENDCASE for j = 0,2 do begin interp = interpol(findgen(Number), ratios(*,j), obs_ratios(j, *)) gammas(*, j) = interpolate(gamt, interp) > 0 factors(*, j) = ([1d-11, 1d45])(mode)/interpolate(calc_rates(*,j), interp)*observed(j,*) > 0 endfor bad = where(finite(factors) ne 1) if bad(0) ge 0 then factors(bad) = 0 bad = where(finite(gammas) ne 1) if bad(0) ge 0 then gammas(bad) = 0 end ####################################################### pro im_contour, a, absc, ordin, WINDOW_SCALE = window_scale, ASPECT = aspect, $ INTERP = interp, nlevels = nlevels, levels=levels, $ xticklen = xticklen, yticklen = yticklen, title = title, $ xtitle = xtitle, ytitle = ytitle, font = font, follow=follow, $ color=color,background=background ;+ ; NAME: ; IMAGE_CONT ; ; PURPOSE: ; Overlay an image and a contour plot. ; ; CATEGORY: ; General graphics. ; ; CALLING SEQUENCE: ; IMAGE_CONT, A ; ; INPUTS: ; A: The two-dimensional array to display. ; ; KEYWORD PARAMETERS: ; WINDOW_SCALE: Set this keyword to scale the window size to the image size. ; Otherwise, the image size is scaled to the window size. ; This keyword is ignored when outputting to devices with ; scalable pixels (e.g., PostScript). ; ; ASPECT: Set this keyword to retain the image's aspect ratio. ; Square pixels are assumed. If WINDOW_SCALE is set, the ; aspect ratio is automatically retained. ; ; INTERP: If this keyword is set, bilinear interpolation is used if ; the image is resized. ; ; OUTPUTS: ; No explicit outputs. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; The currently selected display is affected. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; If the device has scalable pixels, then the image is written over ; the plot window. ; ; MODIFICATION HISTORY: ; DMS, May, 1988. ; ISTP, Oct, 1995. A number of keywords is added. Corrected the mistake ; of (N-1) seen on small arrays. ;- on_error,2 ;Return to caller if an error occurs sz = size(a) ;Size of image if sz(0) lt 2 then message, 'Parameter not 2D' if n_elements(nlevels) le 0 then nlevels=6 if n_elements(xticklen) le 0 then xticklen=0.02 if n_elements(yticklen) le 0 then yticklen=0.02 if n_elements(absc) le 0 then absc=findgen(sz(1)) if n_elements(ordin) le 0 then ordin=findgen(sz(2)) if n_elements(title) le 0 then title=' ' if n_elements(xtitle) le 0 then xtitle=' ' if n_elements(ytitle) le 0 then ytitle=' ' if n_elements(font) le 0 then font=-1 if n_elements(color) le 0 then color=!p.color if n_elements(background) le 0 then background=!P.background ;set window used by contour contour,[[0,0],[1,1]],/nodata, xstyle=4, ystyle = 4 erase,background px = !x.window * !d.x_vsize ;Get size of window in device units py = !y.window * !d.y_vsize swx = px(1)-px(0) ;Size in x in device units swy = py(1)-py(0) ;Size in Y six = float(sz(1)) ;Image sizes siy = float(sz(2)) aspi = six / siy ;Image aspect ratio aspw = swx / swy ;Window aspect ratio f = aspi / aspw ;Ratio of aspect ratios if (!d.flags and 1) ne 0 then begin ;Scalable pixels? if keyword_set(aspect) then begin ;Retain aspect ratio? ;Adjust window size if f ge 1.0 then swy = swy / f else swx = swx * f endif tvscl,a,px(0),py(0),xsize = swx, ysize = swy, /device endif else begin ;Not scalable pixels if keyword_set(window_scale) then begin ;Scale window to image? tvscl,a,px(0),py(0) ;Output image swx = six ;Set window size from image swy = siy endif else begin ;Scale window if keyword_set(aspect) then begin if f ge 1.0 then swy = swy / f else swx = swx * f endif ;aspect if keyword_set(interp) then $ tvscl,poly_2d(bytscl(a),$ ;Have to resample image [[0,0],[(six-1)/swx,0]], [[0,(siy-1)/swy],[0,0]],$ keyword_set(interp),swx,swy), $ px(0),py(0) else $ tvscl,poly_2d(bytscl(a),$ ;Have to resample image [[0,0],[six/swx,0]], [[0,siy/swy],[0,0]],$ keyword_set(interp),swx,swy), $ px(0),py(0) endelse ;window_scale endelse ;scalable pixels mx = !d.n_colors-1 ;Brightest color colors = [mx,mx,mx,0,0,0] ;color vectors if !d.name eq 'PS' then colors = mx - colors ;invert line colors for pstscrp if n_elements(levels) le 0 then $ contour,a, absc, ordin, /noerase,/xst,/yst,$ ;Do the contour pos = [px(0),py(0), px(0)+swx,py(0)+swy],/dev,$ c_color = colors, nlevels = nlevels, $ xticklen = xticklen, yticklen = yticklen, follow=follow, $ title = title, xtitle = xtitle, ytitle = ytitle, font = font, $ color=color,background=background else $ contour,a, absc, ordin, /noerase,/xst,/yst,$ ;Do the contour pos = [px(0),py(0), px(0)+swx,py(0)+swy],/dev, $ c_color = colors, nlevels = nlevels, levels=levels, $ xticklen = xticklen, yticklen = yticklen, follow=follow, $ title = title, xtitle = xtitle, ytitle = ytitle, font = font, $ color=color,background=background return end ####################################################### pro im_con_tog, array1a, array2a, x_arg, y_arg, follow=follow, $ xstyle=xstyle, ystyle=ystyle, subtitle=subtitle, $ nlevels=nlevels, c_color=c_color,color=color,xticklen=xticklen, $ yticklen=yticklen,xmargin=xmargin,ymargin=ymargin,title=title, $ xtitle=xtitle,ytitle=ytitle,c_linestyle=c_linestyle,thick=thick,c_thick=c_thick, $ levels=levels,noerase=noerase,background=background,scale=scale, $ charsize=charsize, position=position, xticks=xticks, yticks=yticks, $ xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, c_charsize=c_charsize, $ c_annotation = c_annotation,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xminor = xminor, yminor = yminor, sample = sample, $ fit_window = fit_window, resize = resize ;+ ; NAME: ; IM_CON_TOG ; ; PURPOSE: ; Displays simultaneously two 2-dimensional arrays, one in brightness ; representation, and another is shown by contours (IMage and CONtour TOGether) ; ; If the dimensions of one array larger than those of another array, then ; the arrays are intended to have the same center, and subarrays with the ; same dimensions are displayed. ; ; CATEGORY: ; General graphics. ; ; CALLING SEQUENCE: ; ; IM_CON_TOG, Image1, Image2 [, X_arg, Y_arg] ; ; INPUTS: ; Image1: Array to be displayed in brightness representation. ; Image2: Array to be displayed by contours. ; These arrays may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; X_arg: Argument along X axis. If supplied, then Y_arg must be supplied also. ; The dimensions of X_arg, Y_arg must correspond to the dimensions of ; the smallest array of Image1 and Image2. Usage of the IM_CON_TOG ; routine is similar to that of the CONTOUR routine. ; ; Y_arg: Argument along Y axis. If supplied, then X_arg must be supplied also. ; The dimensions of X_arg, Y_arg must correspond to the dimensions of ; the smallest array of Image1 and Image2. ; ; KEYWORD PARAMETERS: ; ; Scale: If set and is zero, then the array Image1 is displayed as is, without scaling ; of brigthness (TV). Otherwise (by default), scaling is performed (TVSCL). ; ; Sample: If set and nonzero, then the array Image1 is resized without interpolation. ; Usage of this keyword parameter is the same as for the REBIN routine. ; ; Resize: Scalar integer or floating-point number specifying the number of pixels ; to resize the Image1 when output to PostScript is performed. By default, ; the Image1 is not resized if its least dimension exceed 500, otherwise ; its dimensions are resized in such a way that the least dimension becomes 500. ; This enhances the quality of the image in the printout. ; ; If many images are sent to the PostScript file, then its size can become huge ; when all of them are resized in such a way. To prevent this, set Resize to a ; less value. ; ; Fit_window: If set and nonzero, then the plotting region fits displayable area similar to ; setting xmargin = [0,0] and ymargin = [0,0] ; ; ; Usage of the remainder keyword parameters is the same as for the CONTOUR routine. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; Both arrays are displayed on the current graphics device. ; ; RESTRICTIONS: ; If either of supplied, then both X_arg and Y_arg must present. ; The dimensions of X_arg, Y_arg must correspond to the dimensions of the smallest ; array of Image1 and Image2. ; ; The images always fit the displayable region of the graphics device, and the aspect ratio ; is not maintained. ; ; PROCEDURE: ; TV(SCL) + CONGRID are used for one array, and CONTOUR for the ; other array. In case of PostScript device, pixels of the Image1 are ; scaled, instead of use the CONGRID routine. ; ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, Dec, 1996. ; Victor Grechnev (Grechnev@iszf.irk.ru): ; Initially written. ; ; ISTP SD RAS, Jan, 2000. ; Victor Grechnev (Grechnev@iszf.irk.ru): ; Keywords C_ANNOTATION and SAMPLE are added. ; ; UMD, 2001. ; Vladimir Garaimov (gvi@astro.umd.edu): ; Resizing of the Image1 is added when output to PostScript file is performed. ; Processing of arrays with different dimensions is added. ; ;- Sz=size(array1a) Sz2=size(array2a) nx_arg=n_elements(x_arg) ny_arg=n_elements(y_arg) Np=n_params() if (Np lt 2) or (Np eq 3) or (Np gt 4) $ then message, 'Incorrect number of arguments' if Sz(0) ne 2 then message, 'Input arguments must be 2d arrays' if (Sz(0) ne Sz2(0)) then message, 'Arrays are incompatible' if (Sz(1) mod 2 - Sz2(1) mod 2) ne 0 then message, 'Use ROT for correction on 0.5 point' if (Sz(1) ne Sz2(1)) or (Sz(2) ne Sz2(2)) then begin if Sz(1) gt Sz2(1) then begin array2=array2a xo=(Sz(1)-1)/2. - (Sz2(1)-1)/2. yo=(Sz(2)-1)/2. - (Sz2(2)-1)/2. array1=array1a(xo:(xo+(Sz2(1)-1)),yo:(yo+Sz2(2)-1)) if nx_arg ne 0 and nx_arg eq Sz(1) then begin x_arg_s=x_arg x_arg=x_arg(xo:(xo+(Sz2(1)-1))) end if ny_arg ne 0 and ny_arg eq Sz(2) then begin y_arg_s=y_arg y_arg=y_arg(yo:(yo+(Sz2(2)-1))) end endif else begin array1=array1a xo=(Sz2(1)-1)/2. - (Sz(1)-1)/2. yo=(Sz2(2)-1)/2. - (Sz(2)-1)/2. array2=array2a(xo:(xo+(Sz(1)-1)),yo:(yo+Sz(2)-1)) if nx_arg ne 0 and nx_arg eq Sz2(1) then begin x_arg_s=x_arg x_arg=x_arg(xo:(xo+(Sz(1)-1))) end if ny_arg ne 0 and ny_arg eq Sz2(2) then begin y_arg_s=y_arg y_arg=y_arg(yo:(yo+(Sz(2)-1))) end end Sz=size(array1) Sz2=size(array2) endif else begin array1=array1a array2=array2a end if Np eq 4 then begin if ((Size(x_arg))(1) ne Sz(1)) or ((Size(y_arg))(1) ne Sz(2)) then $ message, 'Arguments are incompatible' endif if nx_arg le 0 then x_arg=findgen(Sz(1)) if ny_arg le 0 then y_arg=findgen(Sz(2)) if n_elements(follow) le 0 then follow=0 if n_elements(xstyle) le 0 then xstyle=!x.style if n_elements(ystyle) le 0 then ystyle=!y.style if n_elements(nlevels) le 0 then nlevels=6 if n_elements(c_color) le 0 then c_color=!P.color if n_elements(color) le 0 then color=!P.color if n_elements(xticklen) le 0 then xticklen=!x.ticklen if n_elements(yticklen) le 0 then yticklen=!y.ticklen if n_elements(xmargin) le 0 then xmargin=!x.margin if n_elements(ymargin) le 0 then ymargin=!y.margin if n_elements(ytitle) le 0 then ytitle=!y.title if n_elements(xtitle) le 0 then xtitle=!x.title if n_elements(subtitle) le 0 then subtitle=!p.subtitle if n_elements(title) le 0 then title=!p.title if n_elements(c_linestyle) le 0 then c_linestyle=!P.linestyle if n_elements(thick) le 0 then thick=!p.thick if n_elements(c_thick) le 0 then c_thick=!p.thick if n_elements(noerase) le 0 then noerase=!p.noerase if n_elements(background) le 0 then background=!p.background if n_elements(scale) le 0 then scale=1 if n_elements(charsize) le 0 then charsize=!P.charsize if n_elements(xticks) le 0 then xticks=!x.ticks if n_elements(yticks) le 0 then yticks=!y.ticks if n_elements(xtickformat) le 0 then xtickformat=!x.tickformat if n_elements(ytickformat) le 0 then ytickformat=!y.tickformat if n_elements(xtickname) le 0 then xtickname=!x.tickname if n_elements(ytickname) le 0 then ytickname=!y.tickname if n_elements(c_charsize) le 0 then c_charsize=!p.charsize if n_elements(c_annotation) le 0 then begin c_annotation=string(replicate('20'xb,1,30)) c_charsize=1e-6 end if n_elements(xgridstyle) le 0 then xgridstyle=0 if n_elements(ygridstyle) le 0 then ygridstyle=0 if n_elements(xminor) le 0 then xminor=!x.minor if n_elements(yminor) le 0 then yminor=!y.minor int = 1-(keyword_set(sample)) SzN = Sz(1:2) if max(SzN/500.) lt 1 or n_elements(resize) gt 0 then begin if n_elements(resize) le 0 then resize = 500. if SzN(0) gt SzN(1) then SzN = SzN*float(resize(0))/SzN(0) else SzN = SzN*float(resize(0))/SzN(1) endif if keyword_set(fit_window) then begin xmargin = [0,0] ymargin = [0,0] endif Pmsave=!P.multi if n_elements(position) le 0 then $ plot, x_arg, y_arg, xst=5,yst=5,/nodata,xmargin=xmargin,ymargin=ymargin, $ noerase=noerase,charsize=charsize, xticks=xticks, yticks=yticks, $ xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, $ xgridstyle=xgridstyle,ygridstyle=ygridstyle else $ plot, x_arg, y_arg, xst=5,yst=5,/nodata,xmargin=xmargin,ymargin=ymargin, $ noerase=noerase,charsize=charsize, position=position, xticks=xticks, $ yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname,xgridstyle=xgridstyle, $ ygridstyle=ygridstyle Pmsave1=!P.multi !P.multi=Pmsave if scale then begin if !d.name ne 'PS' then $ ;!! tvscl, congrid(array1, !d.x_size*(!x.window(1)-!x.window(0)), $ !d.y_size*(!y.window(1)-!y.window(0)),int=int,/minus),$ !d.x_size*!x.window(0),!d.y_size*!y.window(0) else $ tvscl, congrid(array1, SzN(0), SzN(1), int = int), $ xsize=!d.x_size*(!x.window(1)-!x.window(0)), $ ysize=!d.y_size*(!y.window(1)-!y.window(0)), $, !d.x_size*!x.window(0),!d.y_size*!y.window(0),/dev endif else begin if !d.name ne 'PS' then $ ;!! tv, congrid(array1, !d.x_size*(!x.window(1)-!x.window(0)), $ !d.y_size*(!y.window(1)-!y.window(0)), int=int, /minus),$ !d.x_size*!x.window(0),!d.y_size*!y.window(0) else $ tv, congrid(array1, SzN(0), SzN(1), int = int), $ xsize=!d.x_size*(!x.window(1)-!x.window(0)), $ ysize=!d.y_size*(!y.window(1)-!y.window(0)), $, !d.x_size*!x.window(0),!d.y_size*!y.window(0),/dev endelse IF n_elements(position) le 0 then begin if n_elements(levels) le 0 then $ contour, array2, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase, follow=follow, subtitle=subtitle, $ nlevels=nlevels,c_color=c_color,color=color,xticklen=xticklen, $ yticklen=yticklen,xmargin=xmargin,ymargin=ymargin,title=title, $ xtitle=xtitle,ytitle=ytitle,c_linestyle=c_linestyle,thick=thick,c_thick=c_thick, $ background=background,charsize=charsize, xticks=xticks, yticks=yticks, $ xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, c_charsize=c_charsize, $ c_annotation = c_annotation,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xminor = xminor, yminor = yminor $ else contour, array2, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase,follow=follow, subtitle=subtitle, $ nlevels=nlevels,c_color=c_color,color=color,xticklen=xticklen, $ yticklen=yticklen,xmargin=xmargin,ymargin=ymargin,title=title, $ xtitle=xtitle,ytitle=ytitle,c_linestyle=c_linestyle,thick=thick,c_thick=c_thick, $ levels=levels,background=background,charsize=charsize, xticks=xticks, $ yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, c_charsize=c_charsize, $ c_annotation = c_annotation,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xminor = xminor, yminor = yminor endif else begin if n_elements(levels) le 0 then $ contour, array2, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase,follow=follow, subtitle=subtitle, $ nlevels=nlevels,c_color=c_color,color=color,xticklen=xticklen, $ yticklen=yticklen,xmargin=xmargin,ymargin=ymargin,title=title, $ xtitle=xtitle,ytitle=ytitle,c_linestyle=c_linestyle,thick=thick,c_thick=c_thick, $ background=background,charsize=charsize, position=position, $ xticks=xticks, yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, c_charsize=c_charsize, $ c_annotation = c_annotation,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xminor = xminor, yminor = yminor $ else contour, array2, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase,follow=follow, subtitle=subtitle, $ nlevels=nlevels,c_color=c_color,color=color,xticklen=xticklen, $ yticklen=yticklen,xmargin=xmargin,ymargin=ymargin,title=title, $ xtitle=xtitle,ytitle=ytitle,c_linestyle=c_linestyle,thick=thick,c_thick=c_thick, $ levels=levels,background=background,charsize=charsize, position=position, $ xticks=xticks, yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, c_charsize=c_charsize, $ c_annotation = c_annotation,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xminor = xminor, yminor = yminor endelse !P.multi=Pmsave1 if n_elements(x_arg_s) ne 0 then x_arg=x_arg_s if n_elements(y_arg_s) ne 0 then y_arg=y_arg_s end ####################################################### function integrate, x ;+ Straightforward function of indefinite integration ;- sz=size(x) type_x=sz(sz(0)+1) if type_x eq 0 then message, 'No argument' CASE 1 OF (type_x eq 1) or (type_x eq 2) or (type_x eq 3): type_y=3 (type_x eq 5): type_y=5 (type_x eq 6): type_y=6 ELSE: type_y=4 ENDCASE y=make_array(sz(sz(0)+2), type=type_y) y(0)=x(0) for j=1,sz(sz(0)+2)-1 do y(j)=y(j-1)+x(j) return, y end ####################################################### pro INT_ORD,dir,Receiver,SUN,P,Nord,Ord,Chan,Radio=Radio ;+ ; INPUT ARGUMENTS: ; ; dir - direction (0 - E-W, 1 - S-N); ; Receiver - Type of the SSRT receiver used: 0 - MFB, 1 - AOR; ; SUN - structure SOL_EPHEMERIDE issued by the procedure ; SUNEPH. ; ; OUTPUT VALUES: ; P - 3-elementary floating-point, double precision array composed ; from the angles between interferometer's base and one edge of ; the Sun; centre of the Sun; other edge of the Sun, respectively. ; This angle is measured from the Western direction for the ; E-W interferometer, and from the Southern direction for the ; S-N interferometer. ;- if n_elements(Radio) le 0 then Radio=1.08;1.175 D=4.9D0 & C=2.997925D8 & Fi=51.7575D0*!DPi/180 Sum_chan=[180,192] Bound_Frequencies=chanfreq([1,Sum_chan(Receiver)],Receiver) Fmin=Bound_Frequencies(0) Fmax=Bound_Frequencies(1) Ord=intarr(4) IF dir eq 0 then P=acos(sin(SUN.H)*cos(SUN.Decl)) else $ P=acos(cos(SUN.H)*cos(SUN.Decl)*sin(Fi)-sin(SUN.Decl)*cos(Fi)) dP=Radio*SUN.R*((1-dir)*sign(SUN.H)+dir) P=[P-dP,P,P+dP] Ordmin=Fmin*D*Cos(P(2))/C Ordmax=Fmax*D*Cos(P(0))/C Ord(0)=fix(Ordmin+((1-dir)*sign(SUN.H)+dir)) Nord=0 for i=0,2 do begin if(abs(Ord(0))+i LE abs(Ordmax)) then begin Nord=i+1 Ord(i+1)=Ord(i)+((1-dir)*sign(SUN.H)+dir) endif endfor Nord=Nord > 1 Ord=Ord(0:Nord-1) Chan=chanfreq((C/(D*cos(P))#Ord),Receiver) end ####################################################### function inv_index, index, length ;+ returns complementary 1-d index ;- if n_params() lt 2 then message,'Useage: RESULT=inv_index(index, length)' if index[0] lt 0 then return, lindgen(length) Flag = bytarr(length) Flag(index) = 1 return, where(Flag eq 0) end ####################################################### pro istp_env, all_colors=all_colors, colors common psprnt, fname, num ; This routine defines the environment variables required by the ; express-preprocessing programs 'ewsn_view', 'source', 'source_size' if n_elements(colors) le 0 and not keyword_set(all_colors) $ then colors=200 fname='' num=0 Delim='/' home_dir=getenv('HOME') idl_dir=getenv('IDL_DIR') if not keyword_set(all_colors) then begin window,0,xsi=100,ysi=100,colors=colors loadct,0 wait,0.5 wdelete,0 endif cd, home_dir setenv,'gr_root='+idl_dir+'/lib/istp' setenv,'gr_prg='+idl_dir+'/lib/istp' setenv,'ssrt_demo='+idl_dir+'/lib/istp/demo' setenv,'help_dir='+idl_dir+'/lib/istp/demo' setenv,'ar_database='+idl_dir+'/lib/istp/data' setenv,'astr_data='+idl_dir+'/lib/istp/data/astr_dat' ; directory for files sol**.dat setenv,'spk_dat=/usr/home/data' setenv,'optics_dir=/usr/home/data/optics' setenv,'ps_files=/usr/home/data/ps_files' setenv,'results=/usr/home/data/results' print,'Environment variables for the SSRT data processing' print,'are established.' print,'Now current directory is ' + home_dir print def_ssrt def_uc end ####################################################### PRO JDCNV,YR,MN,DAY,HR,JULIAN ;+ ; NAME: ; JDCNV ; PURPOSE: ; Converts Gregorian dates to Julian days ; ; CALLING SEQUENCE: ; JDCNV, YR, MN, DAY, HR, JULIAN ; ; INPUTS: ; YR = Year (integer) ; MN = Month (integer 1-12) ; DAY = Day (integer 1-31) ; HR = Hours and fractions of hours of universal time (U.T.) ; ; OUTPUTS: ; JULIAN = Julian date (double precision) ; ; EXAMPLE: ; To find the Julian Date at 1978 January 1, 0h (U.T.) ; ; IDL> JDCNV, 1978, 1, 1, 0., JULIAN ; ; will give JULIAN = 2443509.5 ; NOTES: ; (1) JDCNV will accept vector arguments ; (2) JULDATE is an alternate procedure to perform the same function ; ; REVISON HISTORY: ; Converted to IDL from Don Yeomans Comet Ephemeris Generator, ; B. Pfarr, STX, 6/15/88 ;- On_error,2 if N_params() LT 4 then begin print,'Syntax - JDCNV, yr, mn, day, hr, julian return endif yr = long(yr) & mn = long(mn) & day = long(day) ;Make sure integral L = (mn-14)/12 ;In leap years, -1 for Jan, Feb, else 0 julian = day - 32075l + 1461l*(yr+4800l+L)/4 + $ 367l*(mn - 2-L*12)/12 - 3*((yr+4900l+L)/100)/4 julian = double(julian) + (HR/24.0D) - 0.5D return end ####################################################### PRO JULDATE, DATE, JD, PROMPT = prompt ;+ ; NAME: ; JULDATE ; PURPOSE: ; Convert from calender to Reduced Julian Date ; ; CALLING SEQUENCE: ; JULDATE, /PROMPT ;Prompt for Calender Date, print Julian Date ; or ; JULDATE, date, jd ; ; INPUT: ; DATE - 5-element array containing year,month (1-12),day,hour & minute ; all specified as numbers (Universal Time). Year after 1900 ; can be specified 2 ways, either for example, as 83 or 1983. ; Years B.C should be entered as negative numbers. If Hour or ; Minute are not supplied, they will default to 0. ; ; OUTPUT: ; JD - reduced julian date, double precision scalar. To convert to ; Julian Date, add 2400000. JULDATE will print the value of ; JD at the terminal if less than 2 parameters are supplied, or ; if the /PROMPT keyword is set ; ; OPTIONAL INPUT KEYWORD: ; PROMPT - If this keyword is set and non-zero, then JULDATE will prompt ; for the calender date at the terminal. ; ; RESTRICTIONS: ; Will not work for years between 0 and 99 A.D. (since these are ; interpreted as years 1900 - 1999). Will not work for year 1582. ; ; The procedure HELIO_JD can be used after JULDATE, if a heliocentric ; Julian date is required. ; ; EXAMPLE: ; A date of 25-DEC-1981 06:25 UT may be expressed as either ; ; IDL> juldate, [81,12,25,6,25], jd ; IDL> juldate, [1981,12,25.2673611], jd ; ; In either case, one should obtain a reduced julian date of ; JD = 44963.7673611 ; ; REVISION HISTORY ; Adapted from IUE RDAF (S. Parsons) 8-31-87 ; Algorithm from Sky and Telescope April 1981 ; Added /PROMPT keyword, W. Landsman September 1992 ;- On_error,2 if ( N_params() EQ 0 ) and (not keyword_set( PROMPT ) ) then begin print,'Syntax - JULDATE, date, jd or JULDATE, /PROMPT print,' date - 3-5 element vector containing [year,month,day,hour,minute] print,' jd - reduced julian date (double precision) return endif if ( N_elements(date) EQ 0 ) then begin opt = '' rd: read,' Enter Year,Month,Day,Hour & Minute (All Numeric): ',opt date = getopt( opt, 'F' ) endif case N_elements(date) of 5: 4: date = [ date, 0.] 3: date = [ date, 0., 0.] else: message,'Illegal DATE Vector - must have a least 3 elements' endcase iy = fix( date(0) ) im = fix( date(1) ) day = double(date(2)) + ( date(3) + date(4)/60.0) / 24.0 if iy LT 100 then iy = iy + 1900 ; if ( im LT 3 ) then begin ;If month is Jan or Feb, don't include leap day iy= iy-1 & im = im+12 end a = fix(iy/100) ry = float(iy) if ( iy LT 1582 ) then b = 0 else b = 2 - a + fix(a/4) if ( iy EQ 1582 ) then $ message,'ERROR: Year 1582 not covered' jd = fix(ry*0.25) + 365.*(ry -1860.) + fix(30.6001*(im+1.)) + b + day - 105.5 if N_params() LT 2 or keyword_set( PROMPT) then begin yr = fix( date(0) ) if yr LT 100 then yr = yr+1900 print, FORM='(A,I4,A,I3,A,F9.5)',$ ' Year ',yr,' Month', fix(date (1) ),' Day', day print, FORM='(A,F15.5)',' Reduced Julian Date:',JD endif return end ; juldate ####################################################### pro kb_in_helio_event,ev,a Common Exch_kb_in_helio,ID,Value,Label WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "DONE": WIDGET_CONTROL,ev.top,/DESTROY "Helio": begin WIDGET_CONTROL,ID.Label,set_v=Label(0) ID.Mode=0 end "Plane": begin WIDGET_CONTROL,ID.Label,set_v=Label(1) ID.Mode=1 end "Help": "TEXT": begin WIDGET_CONTROL,ev.id,GET_V=a if (a(0) eq '') and n_elements(a) gt 1 then a=a(1:*) if (a(0) eq '') and n_elements(a) gt 1 then a=a(1:*) a=strlowcase(strcompress(a(0),/rem)) i1=strpos(a,',') i2=strlen(a) lon=float(strmid(a, 1-ID.Mode, i1+ID.Mode-1)) lat=float(strmid(a, i1-ID.Mode+2, i2-i1)) if strmid(a,0,1) eq 'e' then lon=-lon if strmid(a,i1+1,1) eq 's' then lat=-lat Value=[[Value],[lon,lat,ID.Mode]] if Value(2,0) eq -1. then Value=Value(*,1:*) end ELSE: ENDCASE empty end ;************************************* pro kb_in_helio,a,prompt=prompt,xsize=xsize,group_leader=group_leader Common Exch_kb_in_helio,ID,Value,Label ; Interactive input of the heliographical coordinates. IF(XRegistered("kb_in_helio") NE 0) THEN GOTO, exit device,get_scr=scr if n_elements(prompt) le 0 then prompt='Input spots coordinates' if n_elements(group_leader) le 0 then group_leader=0 if n_elements(xsize) le 0 then xsize=scr(0)/3 ID={base:0L,Text:0L,Label:0L,Mode:0.} if n_elements(a) le 0 then Value=[0.,0.,-1.] else Value=a ID.base=widget_base(/colu,xoff=scr(0)*0.01,yoff=scr(1)*0.01, $ space=5,xsiz=xsize,ypad=6,tit=prompt,group=group_leader) XPdMenu, ['"DONE" DONE', $ '"Mode" {', $ '"Latitude, Longitude" Helio', $ '"Radius fractions" Plane', '}', $ '"Help" Help'],ID.base Label=[' Example: w47.3, s28',' Example: -0.93, 0.675'] ID.label=widget_label(ID.base,YSI=20,Val=Label(0)) IF Value(2,0) eq -1. THEN Textval='' ELSE BEGIN Lat=(Lon=string(Value(0,*))) for j=0,n_elements(Lon)-1 do begin IF Value(0,j) ge 0. then Lon(j)='w' else Lon(j)='e' IF Value(1,j) ge 0. then Lat(j)='n' else Lat(j)='s' endfor Lon=strcompress(Lon+string(abs(Value(0,*))),/rem) Lat=strcompress(Lat+string(abs(Value(1,*))),/rem) Textval=transpose(Lon+', '+Lat) ENDELSE ID.text=WIDGET_TEXT(ID.base,/fra,/EDIT,/scroll, $ XSI=40,YSI=4,UV='TEXT',val=Textval) WIDGET_CONTROL,ID.base,/realize,/hourglass WIDGET_CONTROL,ID.text,/input_focus xmanager,'kb_in_helio',ID.base,/modal exit: a=Value end ####################################################### pro kb_in_text_event,ev,a Common Exch_kb_in_text,Value WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "DONE": WIDGET_CONTROL,ev.top,/DESTROY "Help": xtext,text= $ ['You must press ENTER before exiting if you have made any changes.', $ 'Empty lines are allowed.'] "TEXT": begin WIDGET_CONTROL,ev.id,GET_V=a Value=a end ELSE: ENDCASE empty end ;************************************* pro kb_in_text,x,prompt=prompt,xsize=xsize, $ scroll=scroll,group_leader=group_leader,n_lines=n_lines,text=text ; Interactive input of a text. Common Exch_kb_in_text,Value IF(XRegistered("kb_in_text") NE 0) THEN return device,get_scr=scr if n_elements(prompt) le 0 then prompt='Input text' if n_elements(group_leader) le 0 then group_leader=0 if n_elements(xsize) le 0 then xsize=scr(0)/3 if n_elements(scroll) le 0 then scroll=0 if n_elements(n_lines) le 0 then n_lines=1 if n_elements(text) le 0 then text='' Value=[' '] base=widget_base(/colu,xoff=scr(0)*0.01,yoff=scr(1)*0.01, $ space=5,xsiz=xsize,ypad=6,tit=prompt,group=group_leader) XPdMenu, ['"DONE" DONE', $ '"Help" Help'],base if text ne '' then Lab_val=text else Lab_val='Print text and press ENTER' label=WIDGET_LABEL(base,val=Lab_val) text=WIDGET_TEXT(base,/fra,scroll=scroll,/EDIT, $ XSI=40,YSI=n_lines,UV='TEXT',val=Value) WIDGET_CONTROL,base,/realize,/hourglass WIDGET_CONTROL,text,/input_focus xmanager,'kb_in_text',base,/modal exit: ;Value=strlowcase(strcompress(Value)) x=rotate(Value(where(Value)),2) if n_elements(x) eq 1 then x=x(0) end ####################################################### pro kb_in_time_event,ev,a Common Exch_kb_in_time,Value WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "DONE": WIDGET_CONTROL,ev.top,/DESTROY "Help": xtext,text= $ ['You must press ENTER before exiting if you have made any changes.', $ 'Empty lines are allowed.'] "TEXT": begin WIDGET_CONTROL,ev.id,GET_V=a Value=strlowcase(strcompress(a)) end ELSE: ENDCASE empty end ;************************************* pro kb_in_time,Date,Time,prompt=prompt,xsize=xsize,group_leader=group_leader Common Exch_kb_in_time,Value ; Interactive input of time. IF(XRegistered("kb_in_time") NE 0) THEN GOTO, exit device,get_scr=scr if n_elements(prompt) le 0 then prompt='Input date and time' if n_elements(group_leader) le 0 then group_leader=0 if n_elements(xsize) le 0 then xsize=scr(0)/3 Value=['Date: ','Time: '] if n_elements(Time) gt 0 then Value(1)='Time: '+Time if n_elements(Date) gt 0 then Value(0)='Date: '+Date base=widget_base(/colu,xoff=scr(0)*0.01,yoff=scr(1)*0.01, $ space=5,xsiz=xsize,ypad=6,tit=prompt,group=group_leader) XPdMenu, ['"DONE" DONE', $ '"Help" Help'],base Label=[' Example: Date: 06 12 93',' Time: 07 04 08.458'] label0=widget_label(base,YSI=20,Val=Label(0)) label1=widget_label(base,YSI=20,Val=Label(1)) text=WIDGET_TEXT(base,/fra,/scroll,/EDIT, $ XSI=40,YSI=2,UV='TEXT',val=Value) WIDGET_CONTROL,base,/realize,/hourglass WIDGET_CONTROL,text,/input_focus xmanager,'kb_in_time',base,/modal exit: Value=strlowcase(strcompress(Value)) for j=0,n_elements(Value)-1 do begin if strmid(Value(j),0,4) eq 'date' then $ Date=strmid(Value(j),6,8) if strmid(Value(j),0,4) eq 'time' then $ Time=strmid(Value(j),6,12) endfor end ####################################################### function koi8, x z=(y=byte(x)) model=transpose(byte(['┼', '÷', '╥', '▐', '╬', '╫', '¿', '┴', '╓', '═', '┘', '╩'])) Out=transpose(byte(['õ', '├', '¨', '¢', 'ý', 'ò', '╙', 'ð', 'ö', 'ü', '√', 'ù'])) model=[model, transpose(byte(['ÿ', '┬', '▌', '¢', '█', '╔', '┌', '─', '╙', '╘', '├', '╧']))] Out=[Out, transpose(byte(['╬', 'ñ', '∙', '┬', '°', 'ø', '÷', 'ô', '¸', 'ª', '¡', 'þ']))] model=[model, transpose(byte(['╨', '╠', '•', '╞', '╪', '╟', '¨', '╤', 'º', '╒', '╦', '╚', '└']))] Out=[Out, transpose(byte(['ÿ', 'û', '╟', '¯', '¹', 'ó', '╧', ' ', '╤', 'º', 'ú', '¿', '■']))] model=[model, transpose(byte(['¯', 'ª', 'ü', 'ó', '▄', 'ø', 'ù']))] Out=[Out, transpose(byte(['╥', '╨', '╦', '╓', '¤', '╒', '╚']))] model=[model, transpose(byte(['ñ', '√', '▀', '■', 'þ', 'ò', 'ý', 'û', 'õ']))] Out=[Out, transpose(byte(['└', '╪', '•', '╫', '═', '┴', '╠', '╩', '┼']))] model=[model, transpose(byte(['ö', '¸', 'ô', '¹', '∙', 'ú', '°']))] Out=[Out, transpose(byte(['╘', '▀', '─', '▌', '█', '╔', '▄']))] for j=0, n_elements(model)-1 do begin ind=where(y eq model(j)) if ind(0) ge 0 then z(ind) = Out(j) endfor return, string(z) end ####################################################### pro lang_def xquestion,a,text='What language do you want?', $ sel=['English','Russian'],prompt='Language choice' a=a eq 'Russian' a=strtrim(fix(a),2) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE file=getenv('gr_prg')+Delim+'sources'+Delim+'language.def' openw,lun,file,/get_lun writeu,lun,a free_lun,lun flush,lun end ####################################################### function last_ind, array, number ind = where(array le number) return, ind(n_elements(ind)-1) end ####################################################### ;+ ; NAME: ; LEGEND ; PURPOSE: ; Create an annotation legend for a plot. ; EXPLANATION: ; This procedure makes a legend for a plot. The legend can contain ; a mixture of symbols, linestyles, Hershey characters (vectorfont), ; and filled polygons (usersym). A test procedure, legendtest.pro, ; shows legend's capabilities. Placement of the legend is controlled ; with keywords like /right, /top, and /center or by using a position ; keyword for exact placement (position=[x,y]) or via mouse (/position). ; CALLING SEQUENCE: ; LEGEND [,items][,keyword options] ; EXAMPLES: ; The call: ; legend,['Plus sign','Asterisk','Period'],psym=[1,2,3] ; produces: ; ----------------- ; | | ; | + Plus sign | ; | * Asterisk | ; | . Period | ; | | ; ----------------- ; Each symbol is drawn with a plots command, so they look OK. ; Other examples are given in optional output keywords. ; ; lines = indgen(6) ; for line styles ; items = 'linestyle '+strtrim(lines,2) ; annotations ; legend,items,linestyle=lines ; vertical legend---upper left ; items = ['Plus sign','Asterisk','Period'] ; sym = [1,2,3] ; legend,items,psym=sym ; ditto except using symbols ; legend,items,psym=sym,/horizontal ; horizontal format ; legend,items,psym=sym,box=0 ; sans border ; legend,items,psym=sym,delimiter='=' ; embed '=' betw psym & text ; legend,items,psym=sym,margin=2 ; 2-character margin ; legend,items,psym=sym,position=[x,y] ; upper left in data coords ; legend,items,psym=sym,pos=[x,y],/norm ; upper left in normal coords ; legend,items,psym=sym,pos=[x,y],/device ; upper left in device coords ; legend,items,psym=sym,/position ; interactive position ; legend,items,psym=sym,/right ; at upper right ; legend,items,psym=sym,/bottom ; at lower left ; legend,items,psym=sym,/center ; approximately near center ; legend,items,psym=sym,number=2 ; plot two symbols, not one ; legend,items,/fill,psym=[8,8,8],colors=[10,20,30]; 3 filled squares ; INPUTS: ; items = text for the items in the legend, a string array. ; For example, items = ['diamond','asterisk','square']. ; You can omit items if you don't want any text labels. ; OPTIONAL INPUT KEYWORDS: ; ; linestyle = array of linestyle numbers If linestyle(i) < 0, then omit ; ith symbol or line to allow a multi-line entry. ; psym = array of plot symbol numbers. If psym(i) is negative, then a ; line connects pts for ith item. If psym(i) = 8, then the ; procedure usersym is called with vertices define in the ; keyword usersym. If psym(i) = 88, then use the previously ; defined user symbol ; vectorfont = vector-drawn characters for the sym/line column, e.g., ; ['!9B!3','!9C!3','!9D!3'] produces an open square, a checkmark, ; and a partial derivative, which might have accompanying items ; ['BOX','CHECK','PARTIAL DERIVATIVE']. ; There is no check that !p.font is set properly, e.g., -1 for ; X and 0 for PostScript. This can produce an error, e.g., use ; !20 with PostScript and !p.font=0, but allows use of Hershey ; *AND* PostScript fonts together. ; N. B.: Choose any of linestyle, psym, and/or vectorfont. If none is ; present, only the text is output. If more than one ; is present, all need the same number of elements, and normal ; plot behaviour occurs. ; By default, if psym is positive, you get one point so there is ; no connecting line. If vectorfont(i) = '', ; then plots is called to make a symbol or a line, but if ; vectorfont(i) is a non-null string, then xyouts is called. ; /help = flag to print header ; /horizontal = flag to make the legend horizontal ; /vertical = flag to make the legend vertical (D=vertical) ; box = flag to include/omit box around the legend (D=include) ; clear = flag to clear the box area before drawing the legend ; clrclear = color of clearing ; delimiter = embedded character(s) between symbol and text (D=none) ; colors = array of colors for plot symbols/lines (D=!color) ; textcolors = array of colors for text (D=!color) ; margin = margin around text measured in characters and lines ; spacing = line spacing (D=bit more than character height) ; pspacing = psym spacing (D=3 characters) ; charsize = just like !p.charsize for plot labels ; charthick = array of char thickness numbers ; thick = array of line thickness numbers, if used, then linestyle ; must also be specified ; position = data coordinates of the /top (D) /left (D) of the legend ; normal = use normal coordinates for position, not data ; device = use device coordinates for position, not data ; number = number of plot symbols to plot or length of line (D=1) ; usersym = 2-D array of vertices, cf. usersym in IDL manual. (D=square) ; /fill = flag to fill the usersym ; /left = flag to place legend snug against left side of plot window (D) ; /right = flag to place legend snug against right side of plot window ; If /right,pos=[x,y], then x is position of RHS and text ; runs right-to-left. ; /top = flag to place legend snug against top of plot window (D) ; /bottom = flag to place legend snug against bottom of plot window ; /top,pos=[x,y] and /bottom,pos=[x,y] produce same positions. ; ; If LINESTYLE, PSYM, VECTORFONT, THICK, COLORS, or TEXTCOLORS are ; supplied as scalars, then the scalar value is set for every line or ; symbol in the legend. ; Outputs: ; legend to current plot device ; OPTIONAL OUTPUT KEYWORDS: ; corners = 4-element array, like !p.position, of the normalized ; coords for the box (even if box=0): [llx,lly,urx,ury]. ; Useful for multi-column or multi-line legends, for example, ; to make a 2-column legend, you might do the following: ; c1_items = ['diamond','asterisk','square'] ; c1_psym = [4,2,6] ; c2_items = ['solid','dashed','dotted'] ; c2_line = [0,2,1] ; legend,c1_items,psym=c1_psym,corners=c1,box=0 ; legend,c2_items,line=c2_line,corners=c2,box=0,pos=[c1(2),c1(3)] ; c = [c1(0)c2(2),c1(3)>c2(3)] ; plots,[c(0),c(0),c(2),c(2),c(0)],[c(1),c(3),c(3),c(1),c(1)],/norm ; Useful also to place the legend. Here's an automatic way to place ; the legend in the lower right corner. The difficulty is that the ; legend's width is unknown until it is plotted. In this example, ; the legend is plotted twice: the first time in the upper left, the ; second time in the lower right. ; legend,['1','22','333','4444'],linestyle=indgen(4),corners=corners ; ; BOGUS LEGEND---FIRST TIME TO REPORT CORNERS ; xydims = [corners(2)-corners(0),corners(3)-corners(1)] ; ; SAVE WIDTH AND HEIGHT ; chdim=[!d.x_ch_size/float(!d.x_size),!d.y_ch_size/float(!d.y_size)] ; ; DIMENSIONS OF ONE CHARACTER IN NORMALIZED COORDS ; pos = [!x.window(1)-chdim(0)-xydims(0) $ ; ,!y.window(0)+chdim(1)+xydims(1)] ; ; CALCULATE POSITION FOR LOWER RIGHT ; plot,findgen(10) ; SIMPLE PLOT; YOU DO WHATEVER YOU WANT HERE. ; legend,['1','22','333','4444'],linestyle=indgen(4),pos=pos ; ; REDO THE LEGEND IN LOWER RIGHT CORNER ; You can modify the pos calculation to place the legend where you ; want. For example to place it in the upper right: ; pos = [!x.window(1)-chdim(0)-xydims(0),!y.window(1)-xydims(1)] ; Common blocks: ; none ; Procedure: ; If keyword help is set, call doc_library to print header. ; See notes in the code. Much of the code deals with placement of the ; legend. The main problem with placement is not being ; able to sense the length of a string before it is output. Some crude ; approximations are used for centering. ; Restrictions: ; Here are some things that aren't implemented. ; - An orientation keyword would allow lines at angles in the legend. ; - An array of usersyms would be nice---simple change. ; - An order option to interchange symbols and text might be nice. ; - Somebody might like double boxes, e.g., with box = 2. ; - Another feature might be a continuous bar with ticks and text. ; - There are no guards to avoid writing outside the plot area. ; - There is no provision for multi-line text, e.g., '1st line!c2nd line' ; Sensing !c would be easy, but !c isn't implemented for PostScript. ; A better way might be to simply output the 2nd line as another item ; but without any accompanying symbol or linestyle. A flag to omit ; the symbol and linestyle is linestyle(i) = -1. ; - There is no ability to make a title line containing any of titles ; for the legend, for the symbols, or for the text. ; Side Effects: ; Modification history: ; write, 24-25 Aug 92, F K Knight (knight@ll.mit.edu) ; allow omission of items or omission of both psym and linestyle, add ; corners keyword to facilitate multi-column legends, improve place- ; ment of symbols and text, add guards for unequal size, 26 Aug 92, FKK ; add linestyle(i)=-1 to suppress a single symbol/line, 27 Aug 92, FKK ; add keyword vectorfont to allow characters in the sym/line column, ; 28 Aug 92, FKK ; add /top, /bottom, /left, /right keywords for automatic placement at ; the four corners of the plot window. The /right keyword forces ; right-to-left printing of menu. 18 Jun 93, FKK ; change default position to data coords and add normal, data, and ; device keywords, 17 Jan 94, FKK ; add /center keyword for positioning, but it is not precise because ; text string lengths cannot be known in advance, 17 Jan 94, FKK ; add interactive positioning with /position keyword, 17 Jan 94, FKK ; allow a legend with just text, no plotting symbols. This helps in ; simply describing a plot or writing assumptions done, 4 Feb 94, FKK ; added thick, symsize, and clear keyword Feb 96, W. Landsman HSTX ; David Seed, HR Wallingford, d.seed@hrwallingford.co.uk ; allow scalar specification of keywords, Mar 96, W. Landsman HSTX ; Converted to IDL V5.0 W. Landsman September 1997 ;- pro legend,help=help,items,linestyle=linestyle,psym=psym,vectorfont=vectorfont $ ,horizontal=horizontal,vertical=vertical,box=box,margin=margin $ ,delimiter=delimiter,spacing=spacing,charsize=charsize,pspacing=pspacing $ ,position=position,number=number,colors=colors,textcolors=textcolors $ ,fill=fill,usersym=usersym,corners=corners $ ,left=left,right=right,top=top,bottom=bottom,center=center $ ,data=data,normal=normal,device=device,charthick=charthick $ ,symsize=symsize,thick=thick,clear=clear,clrclear=clrclear ; ; =====>> HELP ; on_error,2 if keyword_set(help) then begin & doc_library,'legend' & return & endif ; ; =====>> SET DEFAULTS FOR SYMBOLS, LINESTYLES, AND ITEMS. ; ni = n_elements(items) np = n_elements(psym) nl = n_elements(linestyle) nth = n_elements(thick) nv = n_elements(vectorfont) nlpv = max([np,nl,nv]) n = max([ni,np,nl,nv]) ; NUMBER OF ENTRIES strn = strtrim(n,2) ; FOR ERROR MESSAGES if n eq 0 then message,'No inputs! For help, type legend,/help.' if ni eq 0 then begin items = replicate('',n) ; DEFAULT BLANK ARRAY endif else begin szt = size(items) if (szt[szt[0]+1] ne 7) then message,'First parameter must be a string array. For help, type legend,/help.' if ni ne n then message,'Must have number of items equal to '+strn endelse symline = (np ne 0) or (nl ne 0) ; FLAG TO PLOT SYM/LINE if (np ne 0) and (np ne n) and (np NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in PSYM array.' if (nl ne 0) and (nl ne n) and (nl NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in LINESTYLE array.' if (nth ne 0) and (nth ne n) and (nth NE 1) then message, $ 'Must have 0, 1 or '+strn+' elements in THICK array.' if nl EQ 0 then linestyle = intarr(n) else $ D=SOLID if nl EQ 1 then linestyle = intarr(n) + linestyle if nth EQ 0 then thick = intarr(n) + 1 else $ if nth EQ 1 then thick = intarr(n) + thick if np EQ 0 then psym = intarr(n) else $ ; D=SOLID if np EQ 1 then psym = intarr(n) + psym if nv EQ 0 then vectorfont = replicate('',n) else $ if nv EQ 1 then vectorfont = replicate(vectorfont,n) ; ; =====>> CHOOSE VERTICAL OR HORIZONTAL ORIENTATION. ; if n_elements(horizontal) eq 0 then begin ; D=VERTICAL if n_elements(vertical) eq 0 then vertical = 1 endif else begin if n_elements(vertical) eq 0 then vertical = not horizontal endelse ; ; =====>> SET DEFAULTS FOR OTHER OPTIONS. ; if n_elements(box) eq 0 then box = 1 if n_elements(clear) eq 0 then clear = 0 if n_elements(clrclear) eq 0 then cclr = -1 else cclr=clrclear(0) if n_elements(charthick) eq 0 then chthk= 1 else chthk=charthick(0) if n_elements(margin) eq 0 then margin = 0.5 if n_elements(delimiter) eq 0 then delimiter = '' if n_elements(charsize) eq 0 then charsize = !p.charsize if charsize eq 0 then charsize = 1 if (n_elements (symsize) eq 0) then symsize= charsize + intarr(n) if n_elements(number) eq 0 then number = 1 if n_elements(colors) eq 0 then colors = !P.color + intarr(n) else $ if N_elements(colors) EQ 1 then colors = colors + intarr(n) if n_elements(textcolors) eq 0 then textcolors = !P.color + intarr(n) else $ if N_elements(textcolors) EQ 1 then textcolors = textcolors + intarr(n) fill = keyword_set(fill) if n_elements(usersym) eq 0 then usersym = 2*[[0,0],[0,1],[1,1],[1,0]]-1 ; ; =====>> INITIALIZE SPACING ; if n_elements(spacing) eq 0 then spacing = 1.2 if n_elements(pspacing) eq 0 then pspacing = 3 xspacing = !d.x_ch_size/float(!d.x_size) * (spacing > charsize) yspacing = !d.y_ch_size/float(!d.y_size) * (spacing > charsize) ltor = 1 ; flag for left-to-right if n_elements(left) eq 1 then ltor = left eq 1 if n_elements(right) eq 1 then ltor = right ne 1 ttob = 1 ; flag for top-to-bottom if n_elements(top) eq 1 then ttob = top eq 1 if n_elements(bottom) eq 1 then ttob = bottom ne 1 xalign = ltor ne 1 ; x alignment: 1 or 0 yalign = -0.5*ttob + 1 ; y alignment: 0.5 or 1 xsign = 2*ltor - 1 ; xspacing direction: 1 or -1 ysign = 2*ttob - 1 ; yspacing direction: 1 or -1 if not ttob then yspacing = -yspacing if not ltor then xspacing = -xspacing ; ; =====>> INITIALIZE POSITIONS: FIRST CALCULATE X OFFSET FOR TEXT ; xt = 0 if nlpv gt 0 then begin ; SKIP IF TEXT ITEMS ONLY. if vertical then begin ; CALC OFFSET FOR TEXT START for i = 0,n-1 do begin if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE if psym[i] eq 0 then expand = 1 else expand = 2 thisxt = (expand*pspacing*(num-1)*xspacing) if ltor then xt = thisxt > xt else xt = thisxt < xt endfor endif ; NOW xt IS AN X OFFSET TO ALIGN ALL TEXT ENTRIES. endif ; ; =====>> INITIALIZE POSITIONS: SECOND LOCATE BORDER ; if !x.window[0] eq !x.window[1] then begin plot,/nodata,xstyle=4,ystyle=4,[0],/noerase endif ; next line takes care of weirdness with small windows pos = [min(!x.window),min(!y.window),max(!x.window),max(!y.window)] case n_elements(position) of 0: begin if ltor then px = pos[0] else px = pos[2] if ttob then py = pos[3] else py = pos[1] if keyword_set(center) then begin if not keyword_set(right) and not keyword_set(left) then $ px = (pos[0] + pos[2])/2. - xt if not keyword_set(top) and not keyword_set(bottom) then $ py = (pos[1] + pos[3])/2. + n*yspacing endif position = [px,py] + [xspacing,-yspacing] end 1: begin ; interactive message,/inform,'Place mouse at upper left corner and click any mouse button.' cursor,x,y,/normal position = [x,y] end 2: begin ; convert upper left corner to normal coordinates if keyword_set(data) then $ position = convert_coord(position,/to_norm) $ else if keyword_set(device) then $ position = convert_coord(position,/to_norm,/device) $ else if not keyword_set(normal) then $ position = convert_coord(position,/to_norm) end else: message,'Position keyword can have 0, 1, or 2 elements only. Try legend,/help.' endcase yoff = 0.25*yspacing*ysign ; VERT. OFFSET FOR SYM/LINE. x0 = position[0] + (margin)*xspacing ; INITIAL X & Y POSITIONS y0 = position[1] - margin*yspacing + yalign*yspacing ; WELL, THIS WORKS! ; ; =====>> OUTPUT TEXT FOR LEGEND, ITEM BY ITEM. ; =====>> FOR EACH ITEM, PLACE SYM/LINE, THEN DELIMITER, ; =====>> THEN TEXT---UPDATING X & Y POSITIONS EACH TIME. ; =====>> THERE ARE A NUMBER OF EXCEPTIONS DONE WITH IF STATEMENTS. ; for iclr = 0,clear do begin y = y0 ; STARTING X & Y POSITIONS x = x0 if ltor then xend = 0 else xend = 1 ; SAVED WIDTH FOR DRAWING BOX if ttob then ii = [0,n-1,1] else ii = [n-1,0,-1] for i = ii[0],ii[1],ii[2] do begin if vertical then x = x0 else y = y0 ; RESET EITHER X OR Y x = x + xspacing ; UPDATE X & Y POSITIONS y = y - yspacing if nlpv eq 0 then goto,TEXT_ONLY ; FLAG FOR TEXT ONLY if (psym[i] eq 0) and (vectorfont[i] eq '') then num = (number + 1) > 3 else num = number if psym[i] lt 0 then num = number > 2 ; TO SHOW CONNECTING LINE if psym[i] eq 0 then expand = 1 else expand = 2 xp = x + expand*pspacing*indgen(num)*xspacing if (psym[i] gt 0) and (num eq 1) and vertical then xp = x + xt/2. yp = y + intarr(num) if vectorfont[i] eq '' then yp = yp + yoff if psym[i] eq 0 then begin xp = [min(xp),max(xp)] ; TO EXPOSE LINESTYLES yp = [min(yp),max(yp)] ; DITTO endif if psym[i] eq 8 then usersym,usersym,fill=fill,color=colors[i] ;; extra by djseed .. psym=88 means use the already defined usersymbol if psym[i] eq 88 then psym[i] =8 if vectorfont[i] ne '' then begin ; if (num eq 1) and vertical then xp = x + xt/2 ; IF 1, CENTERED. xyouts,xp,yp,vectorfont[i],width=width,color=colors[i] $ ,size=charsize,align=xalign,/norm xt = xt > width xp = xp + width/2. endif else begin if symline and (linestyle[i] ge 0) then plots,xp,yp,color=colors[i] $ ,/normal,linestyle=linestyle[i],psym=psym[i],symsize=symsize[i], $ thick=thick[i] endelse if vertical then x = x + xt else if ltor then x = max(xp) else x = min(xp) if symline then x = x + xspacing TEXT_ONLY: xyouts,x,y,delimiter,width=width,/norm,color=textcolors[i],size=charsize,align=xalign x = x + width*xsign if width ne 0 then x = x + 0.5*xspacing xyouts,x,y,items[i],width=width,/norm,color=textcolors[i],size=charsize,align=xalign,charthick=chthk x = x + width*xsign if not vertical and (i lt (n-1)) then x = x+2*xspacing; ADD INTER-ITEM SPACE xfinal = (x + xspacing*margin) if ltor then xend = xfinal > xend else xend = xfinal < xend ; UPDATE END X endfor if (iclr lt clear ) then begin ; =====>> CLEAR AREA x = position[0] y = position[1] if vertical then bottom = n else bottom = 1 ywidth = - (2*margin+bottom-0.5)*yspacing corners = [x,y+ywidth,xend,y] polyfill,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm,color=cclr ; plots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],thick=2 endif else begin ; ; =====>> OUTPUT BORDER ; x = position[0] y = position[1] if vertical then bottom = n else bottom = 1 ywidth = - (2*margin+bottom-0.5)*yspacing corners = [x,y+ywidth,xend,y] if box then plots,[x,xend,xend,x,x],y + [0,0,ywidth,ywidth,0],/norm return endelse endfor end ####################################################### pro lowercasenames, path if n_elements(path) le 0 then begin f = pickfile(tit = 'Select a file to indicate path') if f(0) eq '' then return path = subdir(f(0)) endif if strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then Delim = '\' else Delim = '/' files = findfile(path + Delim + '*') names = files N = n_elements(files) for j 0, N-1 do names(j) = (name_extract(names(j)))(0) for j 0, N-1 do spawn, ' mv '+ path + Delim + names(j) + $ ' ' + path + Delim + strlowcase(names(j) ) end ####################################################### pro l_r_proc_model common l_r_proc, Data,array_I,array_V,header_I,header_V,Sc,x,y,Flux,scan_I,scan_V, $ record_I,record_V,par,sun Rec=Data.N_channels eq 192 suneph,Data.Date,Data.Reference_time,SUN INT_ORD,Data.Interf ne 'E-W',Rec,SUN,P,Nord,Ord,Chan model=CHECKVIS(Rec,Nord,Chan) z=x(Data.number)-Flux.min N_div=8. D_chan=(chan(2,0)-chan(0,0))/N_div for j=0,Nord-1 do begin gate0=(chan(0,j)+D_Chan+[0,(N_div-2)*D_chan]) > 0 < (Data.N_channels-1) if j ne 0 then gate=[gate,gate0] else gate=gate0 endfor for j=0,Nord-1 do begin if j eq 0 then head=z(gate(2*j):gate(2*j+1)) else $ head=[head,z(gate(2*j):gate(2*j+1))] if j eq 0 then divider=model(gate(2*j):gate(2*j+1)) else $ divider=[divider,model(gate(2*j):gate(2*j+1))] endfor factor=min(smooth(median(head,3),3)/divider) Flux={Nord:Nord,Ord:Ord,Chan:Chan,factor:factor,model:model,min:Flux.min, $ weight:1.} end pro l_r_proc_event,ev common l_r_proc, Data,array_I,array_V,header_I,header_V,Sc,x,y,Flux,scan_I,scan_V, $ record_I,record_V,par,sun for j=0,5 do if ev.id eq Data.View(j) then begin if Data.lun_I eq 0 then return if ev.press then Data.press=1 if ev.release then Data.press=0 endif if ev.id ne Data.View(0) or Data.mode ne 'Select channels' then device,/cursor_cross if ev.id eq Data.View(1) then begin window_set,Data.Win(1),sc=Sc.W(1) p=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) widget_control,Data.View_Label(1),set_val= $ string(p(0),p(1),format="(f8.1,', ',f8.1)") IF ev.press THEN BEGIN if Data.Calibrate then begin if Flux.Model(p(0)) eq 0 then begin if Data.Last eq 0 then Flux.min=p(1)+Flux.min else Flux.min=p(1) widget_control,Data.Zero,set_val=strtrim(string(p(1),format="(f8.1)"),2) endif else begin if Data.Last eq 0 then Flux.Factor=p(1)/(Flux.Model(p(0))) else $ Flux.Factor=(p(1)-Flux.min)/(Flux.Model(p(0))) endelse if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) plot,indgen(Data.N_channels)+1,Object > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp Data.Last=1 endif empty ENDIF return endif for j=2,3 do if ev.id eq Data.View(j) then begin window_set,Data.Win(j),sc=Sc.W(j) p=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) widget_control,Data.View_Label(j),set_val= $ string(p(0),p(1),format="(f8.1,', ',f8.1)") return endif for j=4,5 do if ev.id eq Data.View(j) then begin window_set,Data.Win(j),sc=Sc.W(j) p=(convert_coord(ev.x,ev.y,/dev,/to_data))([0,1]) widget_control,Data.View_Label(j),set_val= $ string(p(0),p(1),format="(f8.1,', ',f8.1)")+', '+ $ time_outvalue(p(j eq 5), time=hms(Data.start_time)*3600d0, Dt=Data.Dt) return endif if ev.id eq Data.View(0) then begin Data.Number=ev.y*Data.factor < (Data.Length-1) widget_control,Data.View_Label(0),set_val= $ string(ev.x+1 > 0 < Data.N_channels,Data.Number,format="(f8.1,', ',f8.1)")+', '+ $ time_outvalue(Data.Number, time=hms(Data.start_time)*3600d0, Dt=Data.Dt) wset,Data.Win(0) if Data.Mode eq 'Int_scan' then begin if Data.press then begin if abs(Data.bounds(1)/Data.factor-ev.y) lt abs(Data.bounds(0)/Data.factor-ev.y) $ then ind=1 else ind=0 draw_marker,[195,Data.bounds(ind)/Data.factor],col=!P.Background, 0.8, /left, /fill, /dev draw_marker,[195,ev.y > 0 < (Data.Length-1)/Data.factor],col=!P.color, 0.8, /left, /fill, /dev Data.bounds(ind)=ev.y*Data.factor > 0 < (Data.Length-1) widget_control,Data.Ready,sens=1 widget_control,Data.info,set_val='After marking, press "Ready"' endif return endif if Data.Mode eq 'Select channels' then begin tmp=Data.a w_box_cursor,ev,xy,init=Data.init,cur=tmp Data.a=tmp Data.init=0 Data.xy=xy Data.channel_bounds=xy(*,0) return endif if ev.release and (Data.Object eq 'Single') then begin Data.Last=0 for j=0,1 do widget_control,Data.Right_base(j),map=1-j wset,Data.Win(1) Object=(x(Data.Number) > Data.threshold-Flux.min)*Flux.weight plot,indgen(Data.N_channels)+1,Object, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]*Flux.weight)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor*Flux.weight ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty endif return endif WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "Done": begin WIDGET_CONTROL,ev.top,/DESTROY if Data.lun_I ne 0 then free_lun,Data.lun_I if Data.lun_V ne 0 then free_lun,Data.lun_V if Data.group ne 0L then if widget_info(Data.group,/valid) then $ widget_control,Data.group,/show !P=Data.P_save end "Xloadct": begin widget_control,/hour Xloadct end "Wcalc": begin widget_control,/hour Wcalc end "Parameters": begin if Data.lun_I eq 0 then return widget_control,/hour param_ssrt, Data.date, Data.Reference_time, Data.N_channels eq 192, par=par,sun=sun end "Threshold": begin WIDGET_CONTROL,Data.thres,get_val=a,/hour Data.threshold=float(a(0)) WIDGET_CONTROL,Data.thres,set_val=strtrim(string(Data.threshold,format='(f9.1)'),2) if Data.Lun_I eq 0 then return wset,Data.Win(1) if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) plot,indgen(Data.N_channels)+1,Object > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min empty end "Unzoom": begin for j=0,1 do widget_control,Data.Zoom_Base(j),map=1-j,/hourglass Data.Zoom=0 if Data.Lun_I eq 0 then return wset,Data.Win(1) if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) plot,indgen(Data.N_channels)+1,Object > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end "Zoom": begin for j=0,1 do widget_control,Data.Zoom_Base(j),map=j,/hourglass Data.Zoom=1 if Data.Lun_I eq 0 then return wset,Data.Win(1) if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) plot,indgen(Data.N_channels)+1,Object > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end 'Preview': Data.Mode='Preview' 'Process': begin Data.Mode='Int_scan' Number=(hms(Data.reference_time)-hms(Data.start_time))*3600d0/Data.Dt Case 1 OF Number gt 0 and Number lt Data.Length: $ Data.bounds=[-127,127]+Number > 0 < (Data.Length-1) ELSE: Data.bounds=[-127,127]+Data.Length/2 > 0 < (Data.Length-1) ENDCASE wset,Data.Win(0) draw_marker,[195,Data.bounds(0)/Data.factor],col=!P.color, 0.8, /left, /fill, /dev draw_marker,[195,Data.bounds(1)/Data.factor],col=!P.color, 0.8, /left, /fill, /dev widget_control,Data.info,set_val='Mark fragment to build integrated scan.',/hour end "_3": Data.Width=3 "_5": Data.Width=5 "_7": Data.Width=7 "_9": Data.Width=9 "_11": Data.Width=11 "_13": Data.Width=13 "_15": Data.Width=15 "_17": Data.Width=17 "Zero": begin widget_control,Data.Zero,get_val=tmp,/hour Flux.min=tmp(0) widget_control,Data.Zero,set_val=strtrim(string(Flux.min,format="(f8.1)"),2) if Data.lun_I eq 0 then return Data.Object='Integrated' wset,Data.Win(1) plot,indgen(Data.N_channels)+1,scan_I, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end "Calibrate": begin Data.Calibrate=1 for j=0,1 do widget_control,Data.Calib_base(j), map=1-j end "OK": begin if Data.lun_I eq 0 then return Data.Calibrate=0 for j=0,1 do widget_control,Data.Calib_base(j), map=j,/hour for j=0,1 do widget_control,Data.Right_base(j),map=j widget_control,Data.info,set_val='Press "Calibration" or "Results".' ; *********************************** full=(max(Flux.chan) > (Data.N_channels-1))-(min(Flux.chan) < 0)+1 X_model=findgen(full)+(min(Flux.chan) < 0)+1 order=ord_recognize(Data.Channel,Flux.Nord,Flux.Ord,Flux.Chan) index=(where(order eq Flux.ord))(0) Z_model=sqrt(1-((X_model-Flux.Chan(1,index))/ $ ((Flux.Chan(2,index)-Flux.Chan(0,index))/2))^2 > 0) Flux.weight=120./(total(Z_model)*Flux.factor) Recog=min(scan_I-Flux.min) if (Recog lt 0) and (abs(Recog) gt max(scan_I-Flux.min)*0.01) then $ scan_I=scan_I > ((-max(scan_I-Flux.min)*0.01)+Flux.min) if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) wset,Data.Win(1) plot,indgen(Data.N_channels)+1,(Object-Flux.min)*Flux.weight, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst,ytit='sfu' oplot,indgen(Data.N_channels)+1,(Flux.model*Flux.factor)*Flux.weight ; channel+1 !!!!!!!!!!!!!!!!!!! Data.Object='Single' Scale,tmp,/mem Sc.W(1)=tmp wset,Data.Win(2) plot,indgen(Data.N_channels)+1,(scan_I > Data.threshold -Flux.min )*Flux.weight, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst oplot,indgen(Data.N_channels)+1,scan_V*Flux.weight*10,/noclip ; channel + 1 !!!!!!!!!!!!!!!!!!!!!!! Scale,tmp,/mem & Sc.W(2)=tmp wset,Data.win(0) half_width=fix(2*par.BeamEWchan(1)+0.5) Data.width=2*half_width Data.channel_bounds=Data.channel+[-1,1]*half_width xy=[[Data.channel_bounds],[0,Data.win_size-1]] tmp=Data.a w_box_cursor,[0,0],xy,init=Data.init,cur=tmp,/put Data.a=tmp Data.init=0 Data.xy=xy empty widget_control,Data.info,set_val='Mark channels of interest and press "Ready".' end "Results": for j=0,1 do widget_control,Data.Right_base(j),map=j "Calibration": begin for j=0,1 do begin widget_control,Data.Right_base(j),map=1-j ;widget_control,Data.Calib_base(j), sens=1 endfor widget_control,Data.info,set_val='After calibration, press "OK".' end "Integr.": begin for j=0,1 do widget_control,Data.Toggle_base(j), map=1-j widget_control,Data.Toggle_button(0),set_but=1-ev.select if Data.lun_I eq 0 then return if ev.select then Data.Object='Integrated' else Data.Object='Single' wset,Data.Win(1) plot,indgen(Data.N_channels)+1,scan_I, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end "Single": begin widget_control,Data.Toggle_button(1),set_but=1-ev.select for j=0,1 do widget_control,Data.Toggle_base(j), map=j if Data.lun_I eq 0 then return if ev.select then Data.Object='Single' else Data.Object='Integrated' wset,Data.Win(1) plot,indgen(Data.N_channels)+1,x(Data.Number) > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end "Lshift": begin if Data.lun_I eq 0 then return Flux.Model=Shift(Flux.Model,-1) wset,Data.Win(1) if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) plot,indgen(Data.N_channels)+1,Object > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end "Rshift": begin if Data.lun_I eq 0 then return Flux.Model=Shift(Flux.Model,1) wset,Data.Win(1) if Data.Object eq 'Integrated' then Object=scan_I else Object=x(Data.Number) plot,indgen(Data.N_channels)+1,Object > Data.threshold, $ xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! Scale,tmp,/mem Sc.W(1)=tmp empty end "Open": begin widget_control,/hour File_I=pickfile(/read,path=getenv('spk_dat'),filt='*.awi *.ani') if File_I eq '' then return widget_control,Data.Ready,sens=0 for j=0,1 do widget_control,Data.Right_base(j),map=j,/hour if Data.lun_I ne 0L then free_lun,Data.lun_I if Data.lun_V ne 0L then free_lun,Data.lun_V filter_V=(name_extract(File_I))(2) strput,filter_V,'v',2 filter_V='.'+filter_V CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE File_V=subdir(File_I)+Delim+(name_extract(File_I))(1)+filter_V openr,lun_I,File_I,/get_lun Data.lun_I=lun_I openr,lun_V,File_V,/get_lun Data.lun_V=lun_V widget_control,Data.info,set_val='Reading the file...' gr_header,Data.lun_I,offset_I,header_I,/read,$ comments=comments_I, $ Parameter=Parameter_I, $ Interferometer=Interferometer, $ source_file=source_file, $ first_record=first_record, $ Date=Date, $ Reference_time=Reference_time, $ Reference_Channel=Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Dt, $ Length=Length, $ N_channels=N_channels, $ Creator=Creator, $ Array_size=Array_size, $ Type=Type gr_header,Data.lun_V,offset_V,header_V,/read,$ comments=comments_V, Parameter=Parameter_V Data.Dt=Dt Data.Date=Date Data.Length=Length Data.N_channels=N_channels Data.Start_time=Start_time Data.Reference_time=Reference_time Data.Interf=Interferometer Data.Channel=Channel param_ssrt, Data.date, Data.Reference_time, Data.N_channels eq 192, par=par, /si,sun=sun Data.threshold=(-1000.)*(Data.N_channels ne 192) x=assoc(Data.lun_I, $ make_array(N_channels, $ type=array_size(n_elements(array_size)-2)), $ offset_I) y=assoc(Data.lun_V, $ make_array(N_channels, $ type=array_size(n_elements(array_size)-2)), $ offset_V) wset,Data.Win(0) Data.factor=Data.Length/Data.Win_size+1 Arr_length=Data.Win_size < Data.Length/Data.factor Array_I=(Array_V=intarr(Data.N_channels,Arr_length)) t0=systime(1) & Flag=0 for j=0,Arr_length-1 do begin Array_I(*,j)=x(j*Data.factor) > Data.threshold Array_V(*,j)=y(j*Data.factor) Delta_t=(systime(1)-t0) mod 1 if Delta_t ge 0.2 and Delta_t lt 0.4 then Flag=1 if ((Delta_t ge 0.5) and Flag) then begin Flag=0 widget_control,Data.info,set_val= $ 'Reading the file - '+string(float(j)/Arr_length*100,format='(i2,"%")') endif endfor erase tvscl,Array_I empty widget_control,Data.info,set_val='Press "Tools--Process" to build integrated scan.' l_r_proc_model end "Ready": CASE Data.Mode OF "Int_scan": begin Data.Mode='Select channels' for j=0,1 do begin widget_control,Data.Right_base(j), map=j widget_control,Data.Calib_base(j), /sens widget_control,Data.Toggle_button(j), /sens widget_control,Data.OK_button,/sens endfor widget_control,Data.info,set_val='Building integrated scan...',/hour N_array=(scan_I=(scan_V=fltarr(Data.N_channels))) N_array=N_array+1 Data.bounds=Data.bounds(sort(Data.bounds)) t0=systime(1) Flag=0 for j=Data.bounds(0),Data.bounds(1) do begin index=where(x(j) gt 0) if index(0) ge 0 then begin scan_I(index)=scan_I(index)*(1-1./N_array(index))+(x(j))(index)/N_array(index) scan_V(index)=scan_V(index)*(1-1./N_array(index))+(y(j))(index)/N_array(index) N_array(index)=N_array(index)+1 endif Delta_t=(systime(1)-t0) mod 1 if Delta_t ge 0.2 and Delta_t lt 0.4 then Flag=1 if ((Delta_t ge 0.5) and Flag) then begin Flag=0 widget_control,Data.info,/hour,set_val= $ 'Building integrated scan - '+ $ string(float(j-Data.bounds(0))/(Data.bounds(1)-Data.bounds(0))*100,format='(i2,"%")') endif endfor Wset,Data.Win(2) plot,indgen(Data.N_channels)+1,scan_I,xmar=[6,3],ymar=[2,2],chars=0.8,/xst oplot,indgen(Data.N_channels)+1,scan_V*10,/noclip ; channel + 1 !!!!!!!!!!!!!!!!!!!!!!! Scale,tmp,/mem & Sc.W(2)=tmp widget_control,Data.info,set_val='Press "Calibration" to continue.' empty end "Select channels": begin widget_control,Data.info,set_val='Building time profile...',/hour record_I=(record_V=intarr(Data.Channel_bounds(1)-Data.Channel_bounds(0)+1,Data.Length)) t0=systime(1) & Flag=0 for j=0, Data.Length-1 do begin record_I(*,j)=(x(j))(Data.Channel_bounds(0):Data.Channel_bounds(1)) record_V(*,j)=(y(j))(Data.Channel_bounds(0):Data.Channel_bounds(1)) Delta_t=(systime(1)-t0) mod 1 if Delta_t ge 0.2 and Delta_t lt 0.4 then Flag=1 if ((Delta_t ge 0.5) and Flag) then begin Flag=0 widget_control,Data.info,set_val= $ 'Building time profile - '+string(float(j)/Data.length*100,format='(i2,"%")') endif endfor wset,Data.Win(4) plot_time,total((record_I-Flux.min >0)*Flux.weight,1),xmar=[6,3],ymar=[2,2],chars=0.8,/ynozero, $ dt=Data.dt, start=hms(Data.start_time)*3600d0, $ model='hh:mm:ss',xticks=3,xst=8 tt=total((record_I-Flux.min >0)*Flux.weight,1) time1 = hms(Data.start_time)*3600d0+dindgen((size(record_I))(2))*Data.dt help,time1 ;print,size(record_I) Dst=Data.start_time dtt=data.dt help,dst print,dtt if Data.lun_I eq 0 then return F_status=fstat(Data.lun_I) Filenamem=F_status.name Namem=name_extract(Filenamem) ;print,namem nam=strmid(Namem(0),0,8) ;print,nam save,tt,dtt,Dst,time1,filename='E:\Natasha\idl\moskal\data\'+Nam+'.sav' axis,xaxis=1,/xst, chars=0.8 Scale,tmp,/mem & Sc.W(4)=tmp Wset,Data.Win(5) widget_control,Data.info,set_val='Building contour map...',/hour contour,record_I, $ indgen(Data.Channel_bounds(1)-Data.Channel_bounds(0)+1)+Data.Channel_bounds(0)+1, $ indgen(Data.Length), $ nlev=10,xmar=[6,3],ymar=[2,2],chars=0.8, /yst, /xst Scale,tmp,/mem & Sc.W(5)=tmp wset,Data.Win(1) Object=scan_I Data.Object="Integrated" plot,indgen(Data.N_channels)+1,scan_I, xmar=[6,3],ymar=[2,2],chars=0.8,/xst, $ yran=([0,Flux.factor]+Flux.min)*Data.Zoom oplot,indgen(Data.N_channels)+1,Flux.model*Flux.factor+Flux.min ; channel+1 !!!!!!!!!!!!!!!!!!! widget_control,Data.info,set_val='Ready.' Scale,tmp,/mem Sc.W(1)=tmp empty end ELSE: ENDCASE "Header_I": begin if Data.lun_I eq 0 then return widget_control,/hour xtext,text=header_I end "Header_V": begin if Data.lun_V eq 0 then return widget_control,/hour xtext,text=header_V end "Save": begin if Data.lun_I eq 0 then return F_status=fstat(Data.lun_I) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Filename=F_status.name Name=name_extract(Filename) path=subdir(Filename) model=strmid(Name(1),Name(4)-6,6) Interferometer=Data.Interf if Interferometer eq 'E-W' then filter='*.wrs' else filter='*.nrs' New_Name=newfilename(model=model,filt=filter,path=path) File=pickfile(path=path,file=New_Name,filt=filter) if File eq '' then return if subdir(File) eq '' then File=path+Delim+File openw,lun,File,/get_lun widget_control,Data.info,set_val='Writing the file...' comments='' if Data.N_channels eq 176 then Receiver = 'FDAS' else Receiver = 'AOR' Type='Results' gr_header,lun,offset,header,/write,version='220196', $ comments=comments, $ Parameter='Intensity + Polarization', $ Interferometer=Interferometer, $ source_file=Name(0), $ first_record=0, $ Date=Data.Date, $ Reference_time=Data.Reference_time, $ Reference_Channel=Data.Channel, $ Start_time=Data.Start_time, $ Receiver=Receiver, $ Dt=Data.Dt, $ Length=Data.Length, $ N_channels=Data.N_channels, $ Creator='L_r_proc.pro', $ Array_size=Array_size, $ Type=Type, $ Channel_bounds=Data.channel_bounds, $ i_scan_bounds=Data.bounds, $ d_scan_bounds=Data.bounds, $ zero=Flux.min, $ factor=Flux.factor, $ weight=Flux.weight point_lun,lun,Offset d_scan_I=scan_I d_scan_V=scan_V writeu,lun,scan_I, scan_V, d_scan_I, d_scan_V, $ float((Flux.model*Flux.factor)*Flux.weight), $ record_I, record_V free_lun,lun widget_control,Data.info,set_val='Done.' end ELSE: ENDCASE end pro l_r_proc,group_leader=group_leader common l_r_proc, Data,array_I,array_V,header_I,header_V,Sc,x,y,Flux,scan_I,scan_V, $ record_I,record_V,par,sun if xregistered('l_r_proc') then return if n_elements(group_leader) le 0 then group_leader=0L N=6 device,get_scr=scr Win_size=fix(scr(1)*0.8) init_structure={w_b_state, $ x:0, y:0, press:0, first:1, Xc:[0.,0.], Yc:[0.,0.], $ Output:intarr(2,2), stretch:0., move:0.} Data={view:lonarr(N), win:lonarr(N), prompt:0L, View_Label:lonarr(N), $ lun_I:0L, lun_V:0L, group:group_leader,info:0L,Ready:0L, $ Win_size:Win_size, Right_base:[0L,0L], Zero:0L, OK_button:0L, $ factor:1, N_channels:192, Dt:0.056d0, Length:0L, P_save:!P, $ Start_time:'00:00:00.000', Reference_time:'00:00:00.000', $ Interf:'E-W', Number:0L, Date:'00 00 00', Object:'Single', $ Channel:0, Calib_base:lonarr(2), Calibrate:1, Width:5, Mode:'Preview', $ s:intarr(2,2), press:0, bounds:[0L,0L], Toggle_button:[0L,0L], $ Toggle_base:[0L,0L], $ threshold:(-100.), thres:0L, xy:intarr(2,2), a:init_structure, init:1, $ channel_bounds:[0,0], Zoom:0, Zoom_Base:[0L,0L], Zoom_button:[0L,0L], $ Last:0} !P.color=0 !P.background=!d.n_colors-1 fontsize=12 ;if !version.OS eq 'windows' then font='arial*bold*'+strtrim(fontsize,2) else font='' ;if !version.OS eq 'windows' then font='system*'+strtrim(fontsize,2) else font='' Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} Sc={W:replicate(Ax,N)} Ax=0 Flux={min:0.} main_base=widget_base(/colu,group=group_leader,tit='Long record processing') Upper_base=widget_base(main_base,/row) XPdMenu, ['"Done" Done', $ '"File" {', $ '"Open" Open', $ '"Header I" Header_I', $ '"Header V" Header_V', $ '"Save" Save', $ '}', $ '"Tools" {', $ '"Colors" Xloadct', $ '"Preview" Preview', $ '"Process" Process', $ '"Calculator" Wcalc', $ '"Parameters" Parameters', $ '}', $ '"Help" HELP'], $ Upper_base;,font=font Emptystring=' ' Em=Emptystring+Emptystring+Emptystring label_size=Em+Em ;if font ne '' then if fontsize le 16 then label_size=label_size+Emptystring Data.info=widget_label(Upper_base,val=label_size,/fra) ;,font=font) Data.Ready=widget_button(Upper_base,val='Ready',uval='Ready') ;,font=font) button=widget_button(Upper_base,val='Calibration',uval='Calibration') ;,font=font) button=widget_button(Upper_base,val='Results',uval='Results') ;,font=font) widget_control,Data.Ready,sens=0 R_shift=[ $ [000B, 000B], $ [000B, 000B], $ [016B, 000B], $ [032B, 000B], $ [064B, 000B], $ [128B, 000B], $ [000B, 001B], $ [000B, 002B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [128B, 000B], $ [064B, 000B], $ [032B, 000B], $ [016B, 000B], $ [000B, 000B] $ ] L_shift=[ $ [000B, 000B], $ [000B, 016B], $ [000B, 008B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [128B, 000B], $ [064B, 000B], $ [032B, 000B], $ [064B, 000B], $ [128B, 000B], $ [000B, 001B], $ [000B, 002B], $ [000B, 004B], $ [000B, 008B], $ [000B, 000B] $ ] Zoom = [ $ [128B, 000B], $ [064B, 001B], $ [032B, 002B], $ [016B, 004B], $ [008B, 008B], $ [004B, 016B], $ [002B, 032B], $ [000B, 000B], $ [000B, 000B], $ [002B, 032B], $ [004B, 016B], $ [008B, 008B], $ [016B, 004B], $ [032B, 002B], $ [064B, 001B], $ [128B, 000B] $ ] Unzoom= [ $ [002B, 032B], $ [004B, 016B], $ [008B, 008B], $ [016B, 004B], $ [032B, 002B], $ [064B, 001B], $ [128B, 000B], $ [000B, 000B], $ [000B, 000B], $ [128B, 000B], $ [064B, 001B], $ [032B, 002B], $ [016B, 004B], $ [008B, 008B], $ [004B, 016B], $ [002B, 032B] $ ] Row_Base=widget_base(main_base,/row) Left_base=widget_base(Row_Base,/colu) Plain_base=widget_base(Row_Base) for j=0,1 do Data.Right_base(j)=widget_base(Plain_base,colu=([1,2])(j)) xsize=192+20 Data.view(0)=widget_draw(Left_base,xsi=xsize,ysi=Data.Win_size,/fra,/motion, $ /button) Data.View_Label(0)=widget_label(Left_base,val=Emptystring,/fra) ;,font=font) Row_base=widget_base(Data.Right_base(0),/row) Label_val=['','','Integrated scan', $ 'Dispersion scan','Time profile','Source positions',''] Shift_button0=WIDGET_BUTTON(Row_base,val=L_shift,uval='Lshift') ;,font=font) Shift_button1=WIDGET_BUTTON(Row_base,val=R_shift,uval='Rshift') ;,font=font) Plain_base=widget_base(Row_Base) for j=0,1 do begin Data.Zoom_Base(j)=WIDGET_BASE(Plain_base,/row) Data.Zoom_button(j)=WIDGET_BUTTON(Data.Zoom_Base(j), $ val=([Zoom,Unzoom])([0,2]+j,*), $ uval=(['Zoom','Unzoom'])(j)) ;,font=font) widget_control,Data.Zoom_Base(j),map=1-j endfor Label=widget_label(Row_base,val='Thres.: ') ;,font=font) Data.thres=widget_text(Row_base,/edit,xsize=8,/fra,uval='Threshold', $ val=strtrim(string(Data.threshold,format="(f9.1)"),2)) ;,font=font) Zero_label=WIDGET_LABEL(Row_base,val=' Zero: ') ;,font=font) Data.Zero=WIDGET_TEXT(Row_base, val=strtrim(string(Flux.min,format='(f8.1)'),2), $ /edit,uval='Zero',xsiz=8,/fra) ;,font=font) Plain_base=widget_base(Row_base) for j=0,1 do Data.Calib_base(j)=widget_base(Plain_base,/row) Object_label=WIDGET_LABEL(Data.Calib_base(0),val=' Scan: ') ;,font=font) Plain_base=widget_base(Data.Calib_base(0)) values=['Single','Integr.'] for j=0,1 do begin Data.Toggle_Base(j)=WIDGET_BASE(Plain_base,/row) Data.Toggle_button(j)=WIDGET_BUTTON(Data.Toggle_Base(j),val=values(j),uval=values(j)) ;,font=font) endfor Data.OK_button=WIDGET_BUTTON(Data.Calib_base(0),val='OK',uval='OK') ;,font=font) button=WIDGET_BUTTON(Data.Calib_base(1),val='Calibrate',uval='Calibrate') ;,font=font) for j=0,1 do begin widget_control,Data.Calib_base(j), map=1-j;,sens=1-j widget_control,Data.Toggle_base(j), map=j widget_control,Data.Toggle_button(j), sens=0 ;set_but=1-j widget_control,Data.OK_button,sens=0 endfor Data.view(1)=widget_draw(Data.Right_base(0),xsi=scr(0)*0.95-xsize, $ ysi=scr(0)*0.8-xsize,/fra,/motion, /button) Data.View_Label(1)=widget_label(Data.Right_base(0),val=Emptystring,/fra) ;,font=font) for j=2,N-1 do begin Labels=widget_label(Data.Right_base(1),val=Label_val(j)) ;,font=font) Data.view(j)=widget_draw(Data.Right_base(1),/fra, $ xsi=(scr(0)*0.95-xsize)/2,ysi=scr(1)*0.66/2, /motion, /button) Data.View_Label(j)=widget_label(Data.Right_base(1),val=Emptystring,/fra) ;,font=font) endfor for j=0,1 do widget_control,Data.Right_base(j),map=j widget_control,main_base,/real,/hour widget_control,Data.info,set_val='Please load a file.' for j=0,N-1 do begin widget_control,Data.View(j),get_val=tmp Data.Win(j)=tmp wset,Data.Win(j) erase,!d.n_colors-1 plot,findgen(10),/noerase,/nodata,xst=4,yst=4 Scale,tmp,/mem Sc.W(j)=tmp endfor xmanager,'l_r_proc',main_base,group=group_leader end ####################################################### function magpower, arr, power ;+ ; NAME: ; MAGPOWER ; ; PURPOSE: ; To manipulate with contrast of an image ; ; CATEGORY: ; Image processing. ; ; CALLING SEQUENCE: ; New_array = magpower(array, power) ; ; INPUTS: ; Array: viewed image ; Power: degree to be applied separately to positive and negative values of the ; image. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; None ; ; OUTPUTS: ; Nonlinearly transformed image ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; New_array = (array > 0)^power -(-array > 0)^power ; ; MODIFICATION HISTORY: ; ; UMD, 2001. ; Victor Grechnev (Grechnev@iszf.irk.ru) & Vladimir Garaimov (gvi@astro.umd.edu) ; Initially written. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ; ; - if n_params() eq 1 then power = 0.3 return, (arr > 0.)^power -(-arr>0.)^power end ####################################################### pix = 4.911 pix = 3.911 Center = float([256, 256]) lat = 20. dif = 1 date0 = '16/03/99' time0 = '05:00:00' date1 = '20/03/99' time1 = '05:00:00' dt = float(time_difference(date0, time0, date1, time1)/3600.) suneph, date0, time0, ss radius = ss.r*!radeg*3600/pix window, 0, xs = 512, ys = 512 mgrid, Center, pix, 0, 0, 0, 0, sun = ss x1 = float(tvrd()) yy = sunrotate(x1, Center(0), Center(1), radius, ss.b0*!radeg, 0, dt) if dif then zz = sunrot(x1, date0, time0, date1, time1, [Center, radius], /out) $ else zz = sunrot(x1, date0, time0, date1, time1, [Center, radius], /out, lat = lat) dl = difrot(dt, lat, /ho) tvscl, yy mgrid, Center, pix, 0, 0, dl, 0,sun = ss window,2, xs = 512, ys = 512 tvscl, zz mgrid, Center, pix, 0, 0, dl, 0,sun = ss end ####################################################### function masked_subarray, array, mask, index Sz = size(array) if Sz[0] eq 2 then N = 1 else N = Sz[3] scany = where(total(mask, 1) ne 0) scanx = where(total(mask, 2) ne 0) Xmin = min(scanx, max = Xmax) Ymin = min(scany, max = Ymax) index = [Xmin, Ymin] frag = array[Xmin:Xmax, Ymin:Ymax, *] fragmask = mask[Xmin:Xmax, Ymin:Ymax] for j=0, N-1 do frag[*,*,j] = frag[*,*,j]*fragmask return, frag end ####################################################### function max3, x, history = history, frame = frame, min = amin Sz = size(x) if keyword_set(frame) or 1-keyword_set(history) then begin amin = (maxima = x(*,*,0)) for j = 1, Sz(3) -1 do begin maxima = x(*,*,j) > maxima amin = x(*,*,j) < amin endfor endif else begin maxima = fltarr(Sz(3)) for j = 0, Sz(3) -1 do maxima(j) = max(x(*,*,j)) endelse return, maxima end ####################################################### function mean,x return,total(x)/n_elements(x) end ####################################################### function median1d, x, width, dimension if width le 2 then return,x if n_elements(dimension) le 0 then dimension=2 Sz=size(x) if dimension eq 2 then return, $ transpose(reform(median(reform(transpose(x), Sz(Sz(0)+2)), width), Sz(2), Sz(1))) $ else return, reform(median(reform(x, Sz(Sz(0)+2)), width), Sz(1), Sz(2)) end ####################################################### pro mgrid, centre, pix, Radius, b0, l0, p0, sun = sun if n_tags(sun, /len) eq 112 then begin b0 = sun.b0*!radeg Radius = sun.r*!radeg*3600/pix endif if n_elements(l0) eq 0 then l0 = 0 if n_elements(p0) eq 0 then p0 = 0 if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-Centre(0),!d.x_size-Centre(0)]/Radius !y.range=[-Centre(1),!d.y_size-Centre(1)]/Radius map_set,float(B0), l0, p0, /grid, $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,col=!p.color !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,float(B0), l0, p0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[Centre(0), Radius] / float(!d.x_size) !y.s=[Centre(1), Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, col=!p.color, /lab !P.clip=P_clip_save endelse end ####################################################### ;------------------------------------------------------------- ;+ ; NAME: ; MIDV ; PURPOSE: ; Return value midway between array extremes. ; CATEGORY: ; CALLING SEQUENCE: ; vmd = midv(a) ; INPUTS: ; a = array. in ; KEYWORD PARAMETERS: ; OUTPUTS: ; vmd = (min(a)+max(a))/2. out ; ; COMMON BLOCKS: ; NOTES: ; MODIFICATION HISTORY: ; R. Sterner, 2 Aug, 1989. ; ; Copyright (C) 1989, Johns Hopkins University/Applied Physics Laboratory ; This software may be used, copied, or redistributed as long as it is not ; sold and this copyright notice is reproduced on each copy made. This ; routine is provided as is without any express or implied warranties ; whatsoever. Other limitations apply as described in the file disclaimer.txt. ;- ;------------------------------------------------------------- function midv, x, help = h if (n_params(0) lt 1) or keyword_set(h) then begin print,' Return value midway between array extremes.' print,' vmd = midv(a)' print,' a = array. in' print,' vmd = (min(a)+max(a))/2. out' print,' ' return, -1 end return, .5*(min(x) + max(x)) end ####################################################### function millisec, bintime ;+ ; converts binary time in 10 microseconds starting ; on jan., 1, 1990 into milli seconds since 0 ut. ; ; usage: msec = civ_time(bintime) ; ; where bintime in 10 usec (double) since jan. 1, 1990 00 ut ; msec time in milliseconds since begiinig of day (0 ut). ;- hour = long( ( bintime mod 8.64d09) / 3.6d08 + 1.d-14) mins = long( ( bintime mod 3.60d08) / 6.0d06 + 1.d-14) sec = long( ( bintime mod 6.00d06) / 1.0d05 + 1.d-14) msec = long( ( bintime mod 1.00d05) / 1.0d02 + 1.d-14) usec = long( ( bintime mod 1.00d02) * 10 ) msec = hour*3600.d03+mins*60.d03+sec*1.d03+msec+usec/1000. return, msec end ####################################################### ; this function returns a structure with some standard FITS header ; keywords ; used by rfits and wfits function mkkey_struct null = 1e-44 ; null ne 0.0 one = 1.000001 ; one ne 1.0 tru = 255b fhd = {fitshead, bscale:one, bzero:null, bunit:'',$ date_obs:'', time_obs:'', object:'', instrume:'', $ crval:replicate(null,8), crpix:replicate(one,8), $ cdelt:replicate(one,8), crota:replicate(null,8), $ ctype:strarr(8), offpix:replicate(null,8)} return, fhd end ;head: ; bitpix int not necessary, see size(array) ; naxis int not necessary, see size(array) ; naxisi(8) int not necessary, see size(array) ; bscale float ; bzero float ; bunit string ; object string ; date_obs string ; time_obs string ; instrume string ; crval(8) float ; crpix(8) float ; cdelt(8) float ; ctype(8) string ; crota(8) float ; offpix(8) float ; IMPORTANT: use byte variable for logical keywords in FITS header ; (rfits and wfits make this assumption) ####################################################### function monthnames, number Sz = size(number) type = sz(sz(0)+1) mos = ['jan', 'feb', 'mar', 'apr', 'may', 'jun', 'jul', 'aug', $ 'sep', 'oct', 'nov', 'dec'] if type ne 7 then return, mos(number-1 > 0) else begin num = fix(where(mos eq strlowcase(number)) +1) if n_elements(num) eq 1 then num = num(0) return, num endelse end ####################################################### pro mreadfits, files, info, data, noscale=noscale, $ strtemplate=strtemplate, nodata=nodata, header=header, quiet=quiet, $ outsize=outsize, maxx=maxx, maxy=maxy, add_standard=add_standard, $ comsep=comsep, hissep=hissep, comments=comments, history=history, $ ccnts=ccnts, hcnts=hcnts, nocomments=nocomments, nohistory=nohistory, $ all_keywords=all_keywords, nofill=nofill ;+ ; Name: mreadfits ; ; Purpose: read multiple FITs into data cube, header-> IDL structure array ; ; Input Parameters: ; files - fits files to read ; ; Keyword Parameters: ; strtemplate - template structure for read (reccommended, not required) ; nodata - switch, if set, dont read the data (return only structures) ; header (output) - last fits header as string array ; outsize - 1 or 2 element array ([nx,ny]) specifying the output size ; of data array - default is [max(NAXIS1),max(NAXIS2)] ; add_standard - if set and NO template supplied, add some standard tags ; comments (output) - concatentation of all COMMENT ; ccnts (output) - counts (pointers) to map files -> COMMENT ; history (output) - concatentation of all HISTORY ; hcnts (output) - counts (pointers) to map files -> HISTORY ; all_keywords (input) - if set, then go through all input file and get ; the full list of unique keywords to build the template ; structure (rather than from the first file) ; ; Calling Sequence: ; mreadfits, filelist, index [,data , strtemplate=structure, $ ; outsize=xy, /nodata] ; ; Calling Example: ; mreadfits, spartan_files, index, data, strtemp=spartan_struct() ; mreadfits, eit_files, index, data, strtemp=eit_struct() ; mreadfits,your_files, index, data, strtemp=your_template ; ; mreadfits, files, index, data, outsize=128 ; rebin "on the fly" ; mreadfits, eit_files, index [,/nodata] ; Fast (header only) ; mreadfits, files, index, /add_standard ; add "SSW standards" ; ; [note: xxx_struct.pro are functions which return template structures ; for instrument XXX] ; Serving Suggestions: ; Leaving off DATA parameter (OR using /nodata keyword) results in ; HEADER-ONLY processing for speed. ; ; A useful sequence is: ; -------------------------------------------------------------------- ; IDL> mreadfits, files, index ; headers only->struct ; IDL> ss=where(index.xxx ... AND index.yyy... ) ; vector filter ; IDL> mreadfits,files(ss),index,data [outsize=xy] ; read desired->3D ; -------------------------------------------------------------------- ; ; -------------------------------------------------------------------- ; Example: ; Mixture of 1024^2 512^2 256^2 128^2 can be read and displayed via: ; ; IDL> mreadfits, files, index, data, outsize=256 ; read 3D (256x256xNN) ; IDL> xstepper, data [,get_infox(index) ] ; view 3D cube ; -------------------------------------------------------------------- ; ; History: ; 21-Mar-1996 (S.L.Freeland) PROTOTYPE For EIT/SPARTAN originally ; 23-Mar-1996 (S.L.Freeland) no 'data' parameter implies /nodata ; 28-apr-1996 (S.L.Freeland) fix doc, add header keyword ; 21-oct-1996 (S.L.Freeland) allow naxis3 (3D) (see restrictions) ; 16-jan-1997 (S.L.Freeland) add OUTSIZE keyword and function ; 27-jan-1997 (S.L.Freeland) avoid problem with 3D introduced on 16-jan ; 28-jan-1997 (S.L.Freeland) remove restrictions on 2D/3D data combination ; 24-feb-1997 (S.L.Freeland) use if no template passed ; 27-feb-1997 (S.L.Freeland) add ADD_STANDARD keyword, documentation ; 10-apr-1997 (S.L.Freeland) add COMMENTS, CCNTS, HISTORY, HCNTS ; (see to map file# -> COMMENT ; 4-jun-1997 (S.L.Freeland) call if required ; (adjust some tags for rebinned images) ; 29-Jul-1997 (C.E.DeForest) Accept one-dimensional data products ; (patched call to make_array for the ; case where NAXIS2 is 0) ; 4-Aug-1997 (C.E.DeForest) -Added nocom, nohist, and noscale options. ; -fixed repeating-"mreadfits temporary" ; bug (removed "mreadfits temporary" lines ; ; -Used "temporary" to dispose of initial- ; image array ; 12-Aug-1997 (C.E.DeForest) -Fixed 1-D array reading (switched ; make_array NAXIS2 check from "eq 0" ; to "le 0" to handle NAXIS=1 case). ; 30-Jul-1998 (M.D.Morrison) - Added /ALL_KEYWORDS ; 18-Aug-1998 S.L.Freeland - add /NOFILL keyword ; (pass to fitshead2struct) ; 04-Aug-1999 J.S.Newmark - change loops indices from INT -> LONG ; ; Restrictions: ; use of is STRONGLY RECOMMENDED for consistent output ; (and to facilitate downline structure concatenation operations) ; Most of the problem is due to non-conforming FITS headers ; Improvements to is ongoing which will help to ; relieve this "restriction" ;- nf=n_elements(files) ; ---------------------- define the template structure ---------------- if not data_chk(strtemplate,/struct) then begin head=headfits(files(0)) ; pretty fast header-only read if (keyword_set(all_keywords)) then begin for i=1l,nf-1 do begin head2 = headfits(files(i)) ss1 = where_arr( strmid(head2, 0, 8), strmid(head, 0, 8), /map_ss) ss2 = where(ss1 eq -1, nss2) ;where head2 is not in head if (nss2 ne 0) then begin head = [head, head2(ss2)] end end end strtemplate=fitshead2struct(head,add_standard=add_standard, nofill=nofill) endif ; ---------------------------------------------------------------------- ; --------------------- read all headers first ------------------------- info=replicate(strtemplate,nf) ccnts=lonarr(nf) hcnts=lonarr(nf) comments='' & history='' for i=0l,nf-1 do begin head=headfits(files(i)) ; read header-only alls=lonarr(n_elements(head))+1 ; header map nonnull=strlen(strtrim(head,2)) ne 0 ; non-null map ; ---------- seperate COMMENT and HISTORY records ------------- coms=(strpos(head,'COMMENT') eq 0) ; comment-only map hiss=(strpos(head,'HISTORY') eq 0) ; history-only map comss=where(coms ,ccnt) & comss(0)=comss(0)>0 ; where COMMENT hisss=where(hiss,hcnt) & hisss(0)=hisss(0)>0 ; where HISTORY if not keyword_set(nocomments) then $ comments=[temporary(comments),head(comss)] ; append->output if not keyword_set(nohistory) then $ history =[temporary(history), head(hisss)] ; append->output ccnts(i)=ccnt & hcnts(i)=hcnt ; counter/pointer ; ---------------------------------------------------------------- head=head(where(alls and nonnull and $ (1-(coms*keyword_set(comsep))) and $ ; strip COMMENTS? (future use) (1-(hiss*keyword_set(hissep))))) ; strip HISTORY? (future use) if(total(strpos(head,'COMMENT') eq 0) eq 0) then $ fxaddpar,head,'COMMENT','' ; force at least a blank COMMENT line (CED) if(total(strpos(head,'HISTORY') eq 0) eq 0) then $ fxaddpar,head,'HISTORY','' ; force at least a blank HISTORY line (CED) ; header->structure fits_interp,head,outstr,instruc=strtemplate ; convert to structure info(i)=outstr endfor comments=comments(where(strlen(comments) gt 0) >0) ; Kill blank lines (CED) history = history(where(strlen(history ) gt 0) >0) ; Kill blank lines (CED) ; ----------------------------------------------------------------------- nind=intarr(nf)+1 ; images/file (2D case) pnt=[0,totvect(nind)] ; pointers ; ------------- handle 3D files, if applicable ---------------------- naxis3=gt_tagval(info,/naxis3) ; check&extract NAXIS3 ss3d=where(naxis3 gt 0,ss3dcnt) ; Any 3D files? if ss3dcnt gt 0 then begin outind=replicate(info(0),total(info(ss3d).naxis3) $ ; one index/image + (nf-ss3dcnt)) nind=info.naxis3 > 1 ; generate 2D/3D pnt=[0,totvect(nind)] ; pointers ; for each 3D file, replicate the header structure X #sub images for i=0l,nf-1 do outind(pnt(i))=replicate(info(i),nind(i)) info=temporary(outind) endif ; -------------------------------------------------------- header=head ; return output ; -------------------------------------------------------- ; --------- read/populate the cube unless /nodata set ----------- nodata=keyword_set(nodata) or n_params() lt 3 if not nodata then begin ; "not nodata" is bad grammer ; ----- determine size of output array ----- case n_elements(outsize) of 0: outxy=[max(gt_tagval(info,/naxis1)),max(gt_tagval(info,/naxis2))] 1: outxy=replicate(outsize,2) 2: outxy=outsize else: outxy=outsize(0:1) ; should not happen endcase dat=readfits(files(0),noscale=noscale); get representative image data type data=make_array(outxy(0), outxy(1)*(outxy(1) gt 0) + (outxy(1) le 0), total(nind), type=data_chk(dat,/type)) ; ---------------------- ; ---- flag images which need rebinning ---- sscongrid=gt_tagval(info(pnt),/naxis1) ne outxy(0) or $ gt_tagval(info(pnt),/naxis2) ne outxy(1) ; loop though all files, read data and insert into output array i=0 if sscongrid(i) then dat=congrid(temporary(dat),outxy(0),outxy(1),nind(i), /int) data(0,0,pnt(i))=temporary(dat); insert 2d/3d -> Output array while i lt (nf-1) do begin i=i+1 dat=readfits(files(i),noscale=noscale); read 2D or 3D files if sscongrid(i) then dat=congrid(temporary(dat),outxy(0),outxy(1),nind(i), /int) data(0,0,pnt(i))=temporary(dat(*,*,*)) ; insert 2d/3d -> Output array endwhile if total(sscongrid) gt 0 then mreadfits_fixup,info,data ; adjust tags endif ; ---------------------------------------------------------------- return end ####################################################### ;msun path='c:\idl\lib\istp' if !version.OS eq 'windows' or !version.OS eq 'Win32' then Delim='\' else Delim='/' files=strlowcase(findfile(path+Delim+'*.*')) N=n_elements(files) oldnames=strarr(N) for j=0,N-1 do oldnames(j)=(name_extract(files(j)))(0) oldnames=oldnames(where(oldnames ne '')) N=n_elements(oldnames) ext=strarr(N) for j=0, N-1 do ext(j)=(strsplit(oldnames(j), del='.'))(1) oldnames=oldnames(where(ext eq 'pro')) oldnames=oldnames(sort(oldnames)) N=n_elements(oldnames) files=path+Delim+oldnames name_new='' for kf=0, N-1 do begin file=files(kf) x=strlowcase(strtrim(readform(file), 2)) x=strcompress(x) ind_f=where(strmid(x,0,9) eq 'function ') ind1=max(ind_f) ind_p=where(strmid(x,0,4) eq 'pro ') ind2=max(ind_p) if ind1 ge ind2 then index=ind1 else index=ind2 if index ge 0 then names=(strsplit(x(index)))(1) names=(strsplit(names, del=','))(0) new_path=path+Delim+'new' openr, lun, file,/get st=fstat(lun) x=bytarr(st.size) readu, lun, x free_lun,lun new_name=new_path+Delim+names+'.pro' openw, lun1, new_name,/get writeu, lun1, x free_lun,lun1 endfor ;y=x() end ####################################################### function msxpar, headers, parameter ;+ ; NAME: ; MSXPAR ; ; PURPOSE: ; Obtain the values of a parameter in multiple FITS headers ; ; CATEGORY: ; Input/Output ; ; CALLING SEQUENCE: ; value = msxpar(headers, parameter) ; ; INPUTS: ; Headers: two-dimensional string array containing headers of several FITS files. ; The first dimension is the number of lines in a header, and the second is the ; number of files. ; ; Parameter: String name of the parameter to return, e.g. 'TIME-OBS'. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; None ; ; OUTPUTS: ; Array containing values of the specified keyword parameter in all files. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Function SXPAR is repetitively applied to all the headers. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, Mar, 2000. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ; ; ISTP SD RAS, Mar, 2003. ; VG : Fixed bug if the number of files equals 1. ; ; ;- Sz = size(headers) if Sz[0] eq 1 then N = 1 else N = Sz[Sz[0]] > 1 par = sxpar(headers[*,0], parameter) Szpar = size(par) if N gt 1 then par = make_array(N, type = Szpar[Szpar[0]+1]) else return, par for j = 0, N-1 do par[j] = sxpar(headers[*,j], parameter) return, par end ####################################################### function multiframe, x, N Sz=size(x) Nx=Sz(3) m=(Nx-1)*N+1 y=make_array(sz(1),sz(2),m,type=Sz(Sz(0)+1)) for j=0,m-2 do begin in0=fix(j/N) in1=fix(j/N+1) w0=(j/float(N)-in0) y(*,*,j)=x(*,*,in0)*(1-w0)+x(*,*,in1)*w0 endfor y(*,*,m-1)=x(*,*,Nx-1) return,y end ####################################################### ;+ ; Name: ; MULTIPLOT ; Purpose: ; Create multiple plots with shared axes. ; Explanation: ; This procedure makes a matrix of plots with *SHARED AXES*, either using ; parameters passed to multiplot or !p.multi in a non-standard way. ; It is good for data with one or two shared axes and retains all the ; versatility of the plot commands (e.g. all keywords and log scaling). ; The plots are connected with the shared axes, which saves space by ; omitting redundant ticklabels and titles. Multiplot does this by ; setting !p.position, !x.tickname and !y.tickname automatically. ; A call (multiplot,/reset) restores original values. ; ; Note: This method may be superseded by future improvements in !p.multi ; by RSI. For now, it's a good way to gang plots together. ; CALLING SEQUENCE: ; multiplot[pmulti][,/help][,/initialize][,/reset][,/rowmajor], ; [title='...'],[aspect],[/noerase],[position],[xmargin],[ymargin] ; Examples: ; multiplot,/help ; print this header. ; ; Then copy & paste, from your xterm, the following lines to test: ; ; ; x = findgen(100) ; t=exp(-(x-50)^2/300) ; u=exp(-x/30) ; y = sin(x) ; r = reverse(y*u) ; ; TEST ; multiplot,[1,3],title='TEST' ; H------------------------ ; plot,x,y*u ; E| plot #1 | ; multiplot ; I------------------------ ; plot,x,y*t,ytit='HEIGHT' ; G| plot #2 | ; multiplot ; H------------------------ ; plot,x,r,xtit='PHASE' ; T| plot #3 | ; multiplot,/default ; ------------------------ ; ; PHASE ; ; ; MULTIPLOT ; ; ------------------------- ; ; | | | ; ; | | | ; ; | UL plot | UR plot | ; ; | | | ; !p.multi=[0,2,2,0,0] ; | | | ; multiplot,aspect=0.75 ; y------------------------- ; plot,x,y*u,title='MULTIPLOT' ; l| | | ; multiplot & plot,x,r ; a| | | ; multiplot ; b| LL plot | LR plot | ; plot,x,y*t,ytit='ylabels' ; e| | | ; multiplot ; l| | | ; plot,x,y*t,xtit='xlabels' ; s------------------------- ; multiplot,/reset ; xlabels ; ; ; multiplot,[1,1],/init,/verbose ; one way to return to single plot ; % MULTIPLOT: Initialized for 1x1, plotted across then down (column major). ; Optional Inputs: ; pmulti = 2-element or 5-element vector giving number of plots, e.g., ; multiplot,[1,6] ; 6 plots vertically ; multiplot,[0,4,2,0,0] ; 4 plots along x and 2 along y ; multiplot,[0,4,2,0,1] ; ditto, except rowmajor (down 1st) ; multiplot,[4,2],/rowmajor ; identical to previous line ; Optional Keywords: ; help = flag to print header ; initialize = flag to begin only---no plotting, just setup, ; e.g., multiplot,[4,2],/init,/verbose & multiplot & plot,x,y ; reset = flag to reset system variables to values prior to /init ; default = flag to restore IDL's default value for system variables ; rowmajor = flag to number plots down column first (D=columnmajor) ; verbose = flag to output informational messages ; aspect = the image's aspect ratio (Ex. aspect=1 or aspect=200/250.) ; title = common title for plots ; position = set position for multiplot ; noerase = Set this keyword to disable erasing graphic device ; Outputs: ; !p.position = 4-element vector to place a plot ; !x.tickname = either '' or else 30 ' ' to suppress ticknames ; !y.tickname = either '' or else 30 ' ' to suppress ticknames ; !p.noerase = 1 ; Common blocks: ; multiplot---to hold saved variables and plot counter. See code. ; Side Effects: ; Multiplot sets a number of system variables: !p.position, !p.multi, ; !x.tickname, !y.tickname, !P.noerase---but all can be reset with ; the call: multiplot,/reset ; Restrictions: ; 1. If you use !p.multi as the method of telling how many plots ; are present, you have to set !p.multi at the beginning each time you ; use multiplot or call multiplot with the /reset keyword. ; 2. There's no way to make an xtitle or ytitle span more than one plot, ; except by adding spaces to shift it or to add it manually with xyouts. ; 3. There is no way to make plots of different sizes; each plot ; covers the same area on the screen or paper. ; Procedure: ; This routine makes a matrix of plots with common axes, as opposed to ; the method of !p.multi where axes are separated to allow labels. ; Here the plots are joined and labels are suppressed, except at the ; left edge and the bottom. You tell multiplot how many plots to make ; using either !p.multi (which is then reset) or the parameter pmulti. ; However, multiplot keeps track of the position by itself because ; !p.multi interacts poorly with !p.position. ; Modification history: ; write, 21-23 Mar 94, Fred Knight (knight@ll.mit.edu) ; alter plot command that sets !x.window, etc. per suggestion of ; Mark Hadfield (hadfield@storm.greta.cri.nz), 7 Apr 94, FKK ; add a /default keyword restore IDL's default values of system vars, ; 7 Apr 94, FKK ; modify two more sys vars !x(y).tickformat to suppress user-formatted ; ticknames, per suggestion of Mark Hadfield (qv), 8 Apr 94, FKK ; Converted to IDL V5.0 W. Landsman September 1997 ;- pro multiplot,help=help,pmulti $ ,initialize=initialize, reset=reset, default=default $ ,rowmajor=rowmajor, verbose=verbose, title=title, aspect=aspect $ ,position=position ,noerase=noerase, xmargin=xmargin, ymargin=ymargin ; ; =====>> COMMON ; common multiplot $ ,nplots $ ; [# of plots along x, # of plots along y] ,nleft $ ; # of plots remaining---like the first element of !p.multi ,pdotmulti $ ; saved value of !p.multi ,margins $ ; calculated margins based on !p.multi or pmulti ,pposition $ ; saved value of !p.position ,colmajor $ ; flag for column major order ,pnoerase $ ; saved value of !p.noerase ,xtickname $ ; Original value ,ytickname $ ; Original value ,xtickformat $; Original value ,ytickformat ; Original value ; ; =====>> HELP ; ;on_error,2 if keyword_set(help) then begin & doc_library,'multiplot' & return & endif ; ; =====>> RESTORE IDL's DEFAULT VALUES (kill multiplot's influence) ; if keyword_set(default) then begin last: $ !p.position = 0 !x.tickname = '' !y.tickname = '' !x.tickformat = '' !y.tickformat = '' !p.multi = 0 !p.noerase = 0 nleft = 0 nplots = [1,1] margins = 0 if keyword_set(verbose) then begin message,/inform,'Restore IDL''s defaults for affected system variables.' endif return endif ; ; =====>> RESTORE SAVED SYSTEM VARIABLES ; if keyword_set(reset) then begin if n_elements(pposition) eq 4 then !p.position = pposition !x.tickname = xtickname !y.tickname = ytickname !x.tickformat = xtickformat !y.tickformat = ytickformat !p.multi = pdotmulti !p.noerase = pnoerase nleft = 0 if keyword_set(verbose) then begin coords = '['+string(!p.position,form='(3(f4.2,","),f4.2)')+']' multi = '['+string(!p.multi,form='(4(i2,","),i2)')+']' message,/inform,'Reset. !p.position='+coords+', !p.multi='+multi endif return endif ; ; =====>> SETUP: nplots, MARGINS, & SAVED SYSTEM VARIABLES ; init=0 if (n_elements(pmulti) eq 2) or (n_elements(pmulti) eq 5) then init = 1 if (n_elements(!p.multi) eq 5) then begin if (!p.multi[1] gt 0) and (!p.multi[2] gt 0) then init = (!p.multi[0] eq 0) endif if (init eq 0) and n_elements(nleft) eq 1 then if (nleft eq 0) then goto,last if init or keyword_set(initialize) then begin if not keyword_set(noerase) then erase case n_elements(pmulti) of 0:begin if n_elements(!p.multi) eq 1 then return ; NOTHING TO SET if n_elements(!p.multi) ne 5 then message,'Bogus !p.multi; aborting.' nplots = !p.multi[1:2] > 1 if keyword_set(rowmajor) then colmajor = 0 else colmajor = !p.multi[4] eq 0 end 2:begin nplots = pmulti colmajor = not keyword_set(rowmajor) ; D=colmajor: left to rt 1st end 5:begin nplots = pmulti[1:2] if keyword_set(rowmajor) then colmajor = 0 else colmajor = pmulti[4] eq 0 end else: message,'pmulti can only have 0, 2, or 5 elements.' endcase pposition = !p.position ; save sysvar to be altered xtickname = !x.tickname ytickname = !y.tickname xtickformat = !x.tickformat ytickformat = !y.tickformat pdotmulti = !p.multi nleft = nplots[0]*nplots[1] ; total # of plots !p.multi = 0 ; set window & region if n_elements(xmargin) eq 2 then xmar=xmargin else xmar=!x.margin if n_elements(ymargin) eq 2 then ymar=ymargin else ymar=!y.margin if n_elements(position) ne 0 then begin xypos=position plot,/nodata,xstyle=4,ystyle=4,!x.range,!y.range,/noera,position=xypos end else plot,/nodata,xstyle=4,ystyle=4,!x.range,!y.range,/noera,xmar=xmar,ymar=ymar x_win=!x.window & y_win=!y.window if n_elements(aspect) gt 0 then begin dx=!x.window(1)-!x.window(0) dy=!y.window(1)-!y.window(0) dx=float(dx)*!d.x_vsize dy=float(dy)*!d.y_vsize ndx=dx/nplots(0) mdy=dy/nplots(1) xdy=ndx/mdy if xdy gt aspect(0) then !x.window(1)=!x.window(0)+aspect(0)*mdy*nplots(0)/!d.x_vsize $ else !y.window(1)=!y.window(0)+ndx*nplots(1)/aspect(0)/!d.y_vsize !x.region(1)=!x.region(1)-(x_win(1)-!x.window(1)) !y.region(1)=!y.region(1)-(y_win(1)-!y.window(1)) end if n_elements(title) ne 0 then begin dx=0.5*(!x.window(1)-x_win(0))/(x_win(1)-x_win(0)) dy=1.01*(!y.window(1)-y_win(0))/(y_win(1)-y_win(0)) xyouts,dx,dy,title(0),ali=0.5,charsize=!p.charsize*1.2 end margins = [(!x.window(1)-!x.window(0))/nplots[0],$ (!y.window(1)-!y.window(0))/nplots[1], $ !x.window(0),!y.window(0)] pnoerase = !p.noerase !p.noerase = 1 ; !p.multi does the same if keyword_set(verbose) then begin major = ['across then down (column major).','down then across (row major).'] if colmajor then index = 0 else index = 1 message,/inform,'Initialized for '+strtrim(nplots[0],2) $ +'x'+strtrim(nplots[1],2)+', plotted '+major[index] endif ; print,margins,'=margins' if keyword_set(initialize) then return endif ; ; =====>> Define the plot region without using !p.multi. ; cols = nplots[0] ; for convenience rows = nplots[1] nleft = nleft - 1 >0 ; decrement plots remaining cur = cols*rows - nleft ; current plot #: 1 to cols*rows if colmajor then begin ; location in matrix of plots col = cur mod cols if col eq 0 then col = cols row = (cur-1)/cols + 1 endif else begin ; here (1,2) is 1st col, 2nd row row = cur mod rows if row eq 0 then row = rows col = (cur-1)/rows + 1 endelse pos = [(col-1)*margins[0],(rows-row)*margins[1],col*margins[0],(rows-row+1)*margins[1]] $ + [margins[2],margins[3],margins[2],margins[3]] ;print,row,col,rows,cols,pos ; ; =====>> Finally set the system variables; user shouldn't change them. ; !p.position = pos onbottom = (row eq rows) or (rows eq 1) onleft = (col eq 1) or (cols eq 1) if onbottom then !x.tickname = xtickname else !x.tickname = replicate(' ',30) if onleft then !y.tickname = ytickname else !y.tickname = replicate(' ',30) if onbottom then !x.tickformat = xtickformat else !x.tickformat = '' if onleft then !y.tickformat = ytickformat else !y.tickformat = '' if keyword_set(verbose) then begin coords = '['+string(pos,form='(3(f4.2,","),f4.2)')+']' plotno = 'Setup for plot ['+strtrim(col,2)+','+strtrim(row,2)+'] of ' $ +strtrim(cols,2)+'x'+strtrim(rows,2) message,/inform,plotno+' at '+coords endif ;stop return end ####################################################### pro multiprint_event, ev common mltiprint, a, b, c, d widget_control, ev.top, get_uval=ID widget_control, ev.id, get_uval=uv, /hour if strlowcase(strmid(!version.OS, 0,3)) eq 'win' then Delim='\' else Delim='/' CASE uv OF 'Done': widget_control, ev.top, /destr 'Filter': begin widget_control, ev.id, get_val=tmp ID.Filter = strcompress(tmp(0), /rem) widget_control, id.text, set_val=ID.Filter widget_control, ID.Print, sens = ID.Filter ne '*.*' and ID.Filter ne '*' files = findfile(ID.path+Delim+ID.filter) N=strcompress(n_elements(files), /rem) widget_control, ID.info, set_val=N+' files found' end 'Printer': begin widget_control, ev.id, get_val=tmp ID.Printername = strcompress(tmp(0), /rem) widget_control, id.Printer, set_val=ID.Printername widget_control, ID.Print, sens=1 end 'Path': begin file=pickfile(tit='Select a file to indicate path', filt=ID.Filter) if file eq '' then return else ID.path=subdir(file) files = findfile(ID.path+Delim+ID.filter) N=strcompress(n_elements(files), /rem) widget_control, ID.info, set_val=N+' files found' end 'Print': begin widget_control, ID.Print, sens=0 files = findfile(ID.path+Delim+ID.filter) N=strcompress(n_elements(files), /rem) if files(0) ne '' then for j=0,N-1 do spawn, 'lpr -P'+ID.Printername +' '+ files(j) end ELSE: ENDCASE if uv ne 'Done' then widget_control, ev.top, set_uval=ID end pro multiprint common mltiprint, a, b, c, d cd, current=current if strlowcase(strmid(!version.OS, 0,3)) eq 'win' then filter = '*.*' else $ filter = '*' ID={text:0L, filter:filter, path:current, Print:0L, Info:0L, Printername:'sprn', $ Printer:0L} mainbase=widget_base(tit='Print files', /colu) menubase=widget_base(mainbase, /row) button=widget_button(menubase, val='Done', uval='Done') button=widget_button(menubase, val='Path', uval='Path') label=widget_label(menubase, val='Filter: ') ID.text=widget_text(menubase, val='*', uval='Filter', /edit, xs=10) ID.Print=widget_button(menubase, val='PRINT', uval='Print') label=widget_label(menubase, val='Printer: ') ID.Printer=widget_text(menubase, val=ID.Printername, uval='Printer', /edit, xs=15) ID.Info=widget_label(mainbase, val='Select a path and a filter', /dyn) widget_control, ID.Print, sens=0 widget_control, mainbase, /real, set_uval=ID xmanager, 'multiprint', mainbase end ####################################################### ;+ ; NAME: ; MWRFITS ; PURPOSE: ; Write all standard FITS data types from input arrays or structures. ; ; CALLING SEQUENCE: ; MWRFITS, Input, Filename, [Header], ; /LSCALE , /ISCALE, /BSCALE, ; /USE_COLNUM, /Silent, /Create, /No_comment, /Version, $ ; Alias=, /ASCII, Separator=, Terminator=, Null=, ; /Logical_cols, /Bit_cols, /Nbit_cols, ; Group=, Pscale=, Pzero= ; ; INPUTS: ; Input = Array or structure to be written to FITS file. ; ; -When writing FITS primary data or image extensions ; input should be an array. ; --If data is to be grouped ; the Group keyword should be specified to point to ; a two dimensional array. The first dimension of the ; Group array will be PCOUNT while the second dimension ; should be the same as the last dimension of Input. ; --If Input is undefined, then a dummy primary dataset ; or Image extension is created [This might be done, e.g., ; to put appropriate keywords in a dummy primary ; HDU]. ; ; -When writing an ASCII table extension, Input should ; be a structure array where no element of the structure ; is a structure or array (except see below). ; --A byte array will be written as A field. No checking ; is done to ensure that the values in the byte field ; are valid ASCII. ; --Complex numbers are written to two columns with '_R' and ; '_I' appended to the TTYPE fields (if present). The ; complex number is enclosed in square brackets in the output. ; --Strings are written to fields with the length adjusted ; to accommodate the largest string. Shorter strings are ; blank padded to the right. ; ; -When writing a binary table extension, the input should ; be a structure array with no element of the structure ; being a substructure. ; ; If a structure is specified on input and the output ; file does not exist or the /CREATE keyword is specified ; a dummy primary HDU is created. ; ; Filename = String containing the name of the file to be written. ; By default MWRFITS appends a new extension to existing ; files which are assumed to be valid FITS. The /CREATE ; keyword can be used to ensure that a new FITS file ; is created even if the file already exists. ; ; OUTPUTS: ; ; OPTIONAL INPUTS: ; Header = Header should be a string array. Each element of the ; array is added as a row in the FITS header. No ; parsing is done of this data. MWRFITS will prepend ; required structural (and, if specified, scaling) ; keywords before the rows specified in Header. ; Rows describing columns in the table will be appended ; to the contents of Header. ; Header lines will be extended or truncated to ; 80 characters as necessary. ; If Header is specified then on return Header will have ; the header generated for the specified extension. ; ; OPTIONAL INPUT KEYWORDS: ; ALias= Set up aliases to convert from the IDL structure ; to the FITS column name. The value should be ; a STRARR(2,*) value where the first element of ; each pair of values corresponds to a column ; in the structure and the second is the name ; to be used in the FITS file. ; The order of the alias keyword is compatible with ; use in MRDFITS. ; ASCII - Creates an ASCII table rather than a binary table. ; This keyword may be specified as: ; /ASCII - Use default formats for columns. ; ASCII='format_string' allows the user to specify ; the format of various data types such using the following ; syntax 'column_type:format, column_type:format'. E.g., ; ASCII='A:A1,I:I6,L:I10,B:I4,F:G15.9,D:G23.17,C:G15.9,M:G23.17' ; gives the default formats used for each type. The TFORM ; fields for the real and complex types indicate will use corresponding ; E and D formats when a G format is specified. ; Note that the length of the field for ASCII strings and ; byte arrays is automatically determined for each column. ; BIT_COLS= An array of indices of the bit columns. The data should ; comprise a byte array with the appropriate dimensions. ; If the number of bits per row (see NBIT_COLS) ; is greater than 8, then the first dimension of the array ; should match the number of input bytes per row. ; BSCALE Scale floats, longs, or shorts to unsigned bytes (see LSCALE) ; CREATE If this keyword is non-zero, then a new FITS file will ; be created regardless of whether the file currently ; exists. Otherwise when the file already exists, ; a FITS extension will be appended to the existing file ; which is assumed to be a valid FITS file. ; GROUP= This keyword indicates that GROUPed FITS data is to ; be generated. ; Group should be a 2-D array of the appropriate output type. ; The first dimension will set the number of group parameters. ; The second dimension must agree with the last dimension ; of the Input array. ; ISCALE Scale floats or longs to short integer (see LSCALE) ; LOGICAL_COLS= An array of indices of the logical column numbers. ; These should start with the first column having index 0. ; The structure element should be an array of characters ; with the values 'T' or 'F'. This is not checked. ; LSCALE Scale floating point numbers to long integers. ; This keyword may be specified in three ways. ; /LSCALE (or LSCALE=1) asks for scaling to be automatically ; determined. LSCALE=value divides the input by value. ; I.e., BSCALE=value, BZERO=0. Numbers out of range are ; given the value of NULL if specified, otherwise they are given ; the appropriate extremum value. LSCALE=(value,value) ; uses the first value as BSCALE and the second as BZERO ; (or TSCALE and TZERO for tables). ; NBIT_COLS= The number of bits actually used in the bit array. ; This argument must point to an array of the same dimension ; as BIT_COLS. ; NO_TYPES If the NO_TYPES keyword is specified, then no TTYPE ; keywords will be created for ASCII and BINARY tables. ; No_comment Do not write comment keywords in the header ; NULL= Value to be written for integers/strings which are ; undefined or unwritable. ; PSCALE= An array giving scaling parameters for the group keywords. ; It should have the same dimension as the first dimension ; of Group. ; PZERO= An array giving offset parameters for the group keywords. ; It should have the same dimension as the first dimension ; of Group. ; Separator= This keyword can be specified as a string which will ; be used to separate fields in ASCII tables. By default ; fields are separated by a blank. ; SILENT Suppress informative messages. Errors will still ; be reported. ; Terminator= This keyword can be specified to provide a string which ; will be placed at the end of each row of an ASCII table. ; No terminator is used when not specified. ; If a non-string terminator is specified (including ; when the /terminator form is used), a new line terminator ; is appended. ; USE_COLNUM When creating column names for binary and ASCII tables ; MWRFITS attempts to use structure field name ; values. If USE_COLNUM is specified and non-zero then ; column names will be generated as 'C1, C2, ... 'Cn' ; for the number of columns in the table. ; Version Print the version number of MWRFITS. ; ; EXAMPLE: ; Write a simple array: ; a=fltarr(20,20) ; mwrfits,a,'test.fits' ; ; Append a 3 column, 2 row, binary table extension to file just created. ; a={name:'M31', coords:(30., 20.), distance:2} ; a=replicate(a, 2); ; mwrfits,a,'test.fits' ; ; Now add on an image extension: ; a=lonarr(10,10,10) ; hdr=("COMMENT This is a comment line to put in the header", $ ; "MYKEY = "Some desired keyword value") ; mwrfits,a,'test.fits',hdr ; ; RESTRICTIONS: ; (1) Variable length columns are not supported for anything ; other than simple types (byte, int, long, float, double). ; NOTES: ; This multiple format FITS writer is designed to provide a ; single, simple interface to writing all common types of FITS data. ; Given the number of options within the program and the ; variety of IDL systems available it is likely that a number ; of bugs are yet to be uncovered. If you find an anomaly ; please send a report to: ; Tom McGlynn ; NASA/GSFC Code 660.2 ; tam@silk.gsfc.nasa.gov (or 301-286-7743) ; ; PROCEDURES USED: ; FXPAR(), FXADDPAR, IS_IEEE_BIG(), HOST_TO_IEEE ; MODIfICATION HISTORY: ; Version 0.9: By T. McGlynn 1997-07-23 ; Initial beta release. ; Dec 1, 1997, Lindler, Modified to work under VMS. ; Version 0.91: T. McGlynn 1998-03-09 ; Fixed problem in handling null primary arrays. ; Reconverted to IDL 5.0 format using IDLv4_to_v5 ; Version 0.92: T. McGlynn 1998-09-09 ; Add no_comment flag and keep user comments on fields. ; Fix handling of bit fields. ; Version 0.93: T. McGlynn 1999-03-10 ; Fix table appends on VMS. ; Version 0.93a W. Landsman/D. Schlegel ; Update keyword values in chk_and_upd if data type has changed ; Version 0.94: T. McGlynn 2000-02-02 ; Efficient processing of ASCII tables. ; Use G rather than E formats as defaults for ASCII tables ; and make the default precision long enough that transformations ; binary to/from ASCII are invertible. ; Some loop indices made long. ; Fixed some ends to match block beginnings. ; Version 0.95: T. McGlynn 2000-11-06 ; Several fixes to scaling. Thanks to David Sahnow for ; documenting the problems. ; Added PCOUNT,GCOUNT keywords to Image extensions. ; Version numbers shown in SIMPLE/XTENSION comments ; Version 0.96: T. McGlynn 2001-04-06 ; Changed how files are opened to handle ~ consistently ; Version 1.0: T. McGlynn 2001-12-04 ; Unsigned integers, ; 64 bit integers. ; Aliases ; Variable length arrays ; Some code cleanup ; Version 1.1: T. McGlynn 2002-2-18 ; Fixed major bug in processing of unsigned integers. ; (Thanks to Stephane Beland) ; Version 1.2: Stephane Beland 2003-03-17 ; Fixed problem in creating dummy dataset when passing undefined ; data, caused by an update to FXADDPAR routine. ; ; ;- ; What is the current version of this program. function mwr_version return, '1.2' end ; Find the appropriate offset for a given unsigned type ; or just return 0 if the type is not unsigned. function mwr_unsigned_offset, type if (type eq 12) then begin return, uint(32768) endif else if (type eq 13) then begin return, ulong('2147483648') endif else if (type eq 15) then begin return, ulong64('9223372036854775808') endif return, 0 end ; Add a keyword as non-destructively as possible to a FITS header pro chk_and_upd, header, key, value, comment xcomm = "" if n_elements(comment) gt 0 then xcomm = comment if n_elements(header) eq 0 then begin fxaddpar, header, key, value, xcomm endif else begin oldvalue = fxpar(header, key, count=count, comment=oldcomment) if (count eq 1) then begin qchange = 0 ; Set to 1 if either the type of variable or its ; value changes. size1 = size(oldvalue) & size2 = size(value) if size1[size1[0]+1] NE size2[size2[0]+1] then qchange = 1 $ else if (oldvalue ne value) then qchange = 1 if (qchange) then begin if n_elements(oldcomment) gt 0 then xcomm = oldcomment[0] fxaddpar, header, key, value, xcomm endif endif else begin fxaddpar, header, key, value, xcomm endelse endelse end ; Get the column name appropriate for a given tag function mwr_checktype, tag, alias=alias if not keyword_set(alias) then return, tag sz = size(alias) ; 1 or 2 D string array with first dimension of 2 if (sz[0] eq 1 or sz[1] eq 2) and sz[1] eq 2 and sz[sz[0]+1] eq 7 then begin w = where(tag eq alias[0,*]) if (w[0] eq -1) then begin return, tag endif else begin return, alias[1,w[0]] endelse endif else begin print,'MWRFITS: Warning: Alias values not strarr(2) or strarr(2,*)' endelse return, tag end ; Create an ASCII table pro mwr_ascii, input, siz, lun, bof, header, $ ascii=ascii, $ null=null, $ use_colnum = use_colnum, $ lscale=lscale, iscale=iscale, $ bscale=bscale, $ no_types=no_types, $ separator=separator, $ terminator=terminator, $ no_comment=no_comment, $ silent=silent, $ alias=alias ; Write the header and data for a FITS ASCII table extension. types= ['A', 'I', 'L', 'B', 'F', 'D', 'C', 'M', 'K'] formats=['A1', 'I6', 'I10', 'I4', 'G15.9','G23.17', 'G15.9', 'G23.17','I20'] lengths=[1, 6, 10, 4, 15, 23, 15, 23, 20] ; Check if the user is overriding any default formats. sz = size(ascii) if sz[0] eq 0 and sz[1] eq 7 then begin ascii = strupcase(strcompress(ascii,/remo)) for i=0, n_elements(types)-1 do begin p = strpos(ascii,types[i]+':') if p ge 0 then begin q = strpos(ascii, ',', p+1) if q lt p then q = strlen(ascii)+1 formats[i] = strmid(ascii, p+2, (q-p)-2) len = 0 reads, formats[i], len, format='(1X,I)' lengths[i] = len endif endfor endif i0 = input[0] ntag = n_tags(i0) tags = tag_names(i0) ctypes = lonarr(ntag) strmaxs = lonarr(ntag) if not keyword_set(separator) then separator=' ' slen = strlen(separator) offsets = 0 tforms = '' ttypes = '' offset = 0 totalFormat = "" xsep = ""; for i=0, ntag-1 do begin totalFormat = totalFormat + xsep; sz = size(i0.(i)) if sz[0] ne 0 and (sz[sz[0]+1] ne 1) then begin print, 'MWRFITS Error: ASCII table cannot contain arrays' return endif ctypes[i] = sz[1] xtype = mwr_checktype(tags[i], alias=alias) ttypes = [ttypes, xtype+' '] if sz[0] gt 0 then begin ; Byte array to be handled as a string. nelem = sz[sz[0]+2] ctypes[i] = sz[sz[0]+1] tf = 'A'+strcompress(string(nelem)) tforms = [tforms, tf] offsets = [offsets, offset] totalFormat = totalFormat + tf offset = offset + nelem endif else if sz[1] eq 7 then begin ; Use longest string to get appropriate size. strmax = max(strlen(input.(i))) strmaxs[i] = strmax tf = 'A'+strcompress(string(strmax), /remo) tforms = [tforms, tf] offsets = [offsets, offset] totalFormat = totalFormat + tf ctypes[i] = 7 offset = offset + strmax endif else if sz[1] eq 6 or sz[1] eq 9 then begin ; Complexes handled as two floats. offset = offset + 1 if sz[1] eq 6 then indx = where(types eq 'C') if sz[1] eq 9 then indx = where(types eq 'M') indx = indx[0] fx = formats[indx] if (strmid(fx, 0, 1) eq "G" or strmid(fx, 0, 1) eq "g") then begin if (sz[1] eq 6) then begin fx = "E"+strmid(fx,1, 99) endif else begin fx = "D"+strmid(fx,1, 99) endelse endif tforms = [tforms, fx, fx] offsets = [offsets, offset, offset+lengths[indx]+1] nel = n_elements(ttypes) ttypes = [ttypes[0:nel-2], xtype+'_R', xtype+'_I'] offset = offset + 2*lengths[indx] + 1 totalFormat = totalFormat + '"[",'+formats[indx]+',1x,'+formats[indx]+',"]"' offset = offset+1 endif else begin if sz[1] eq 1 then indx = where(types eq 'B') $ else if sz[1] eq 2 or sz[1] eq 12 then indx = where(types eq 'I') $ else if sz[1] eq 3 or sz[1] eq 13 then indx = where(types eq 'L') $ else if sz[1] eq 4 then indx = where(types eq 'F') $ else if sz[1] eq 5 then indx = where(types eq 'D') $ else if sz[1] eq 14 or sz[1] eq 15 then indx = where(types eq 'K') $ else begin print, 'MWRFITS Error: Invalid type in ASCII table' return endelse indx = indx[0] fx = formats[indx] if (strmid(fx, 0, 1) eq 'G' or strmid(fx, 0, 1) eq 'g') then begin if sz[1] eq 4 then begin fx = 'E'+strmid(fx, 1, 99) endif else begin fx = 'D'+strmid(fx, 1, 99) endelse endif tforms = [tforms, fx] offsets = [offsets, offset] totalFormat = totalFormat + formats[indx] offset = offset + lengths[indx] endelse if i ne ntag-1 then begin offset = offset + slen endif xsep = ", '"+separator+"', " endfor if keyword_set(terminator) then begin sz = size(terminator); if sz[0] ne 0 or sz[1] ne 7 then begin terminator= string(10B) endif endif if keyword_set(terminator) then offset = offset+strlen(terminator) ; Write required FITS keywords. chk_and_upd, header, 'XTENSION', 'TABLE', 'ASCII table extension written by MWRFITS '+mwr_version() chk_and_upd, header, 'BITPIX', 8,'Required Value: ASCII characters' chk_and_upd, header, 'NAXIS', 2,'Required Value' chk_and_upd, header, 'NAXIS1', offset, 'Number of characters in a row' chk_and_upd, header, 'NAXIS2', n_elements(input), 'Number of rows' chk_and_upd, header, 'PCOUNT', 0, 'Required value' chk_and_upd, header, 'GCOUNT', 1, 'Required value' chk_and_upd, header, 'TFIELDS', n_elements(ttypes)-1, 'Number of fields' ; Recall that the TTYPES, TFORMS, and OFFSETS arrays have an ; initial dummy element. ; Write the TTYPE keywords. if not keyword_set(no_types) then begin for i=1, n_elements(ttypes)-1 do begin key = 'TTYPE'+ strcompress(string(i),/remo) if keyword_set(use_colnum) then begin value = 'C'+strcompress(string(i),/remo) endif else begin value = ttypes[i]+' ' endelse chk_and_upd, header, key, value endfor if (not keyword_set(no_comment)) then begin fxaddpar, header, 'COMMENT', ' ', before='TTYPE1' fxaddpar, header, 'COMMENT', ' *** Column names ***', before='TTYPE1' fxaddpar, header, 'COMMENT', ' ', before='TTYPE1' endif endif ; Write the TBCOL keywords. for i=1, n_elements(ttypes)-1 do begin key= 'TBCOL'+strcompress(string(i),/remo) chk_and_upd, header, key, offsets[i]+1 endfor if (not keyword_set(no_comment)) then begin fxaddpar, header, 'COMMENT', ' ', before='TBCOL1' fxaddpar, header, 'COMMENT', ' *** Column offsets ***', before='TBCOL1' fxaddpar, header, 'COMMENT', ' ', before='TBCOL1' endif ; Write the TFORM keywords for i=1, n_elements(ttypes)-1 do begin key= 'TFORM'+strcompress(string(i),/remo) chk_and_upd, header, key, tforms[i] endfor if (not keyword_set(no_comment)) then begin fxaddpar, header, 'COMMENT', ' ', before='TFORM1' fxaddpar, header, 'COMMENT', ' *** Column formats ***', before='TFORM1' fxaddpar, header, 'COMMENT', ' ', before='TFORM1' endif ; Write the header. mwr_header, lun, header ; Now loop over the structure and write out the data. totalFormat = "("+totalFormat+")"; start = 0L last = 1023L while (start lt n_elements(input)) do begin if (last ge n_elements(input)) then begin last = n_elements(input) - 1 endif strings = string(input[start:last], format=totalFormat) if keyword_set(terminator) then begin strings = strings+terminator endif writeu, lun, strings start = last + 1 last = last + 1024 endwhile ; Check to see if any padding is required. nbytes = n_elements(input)*offset padding = 2880 - nbytes mod 2880 if padding ne 0 then begin pad = replicate(32b, padding) endif writeu, lun, pad return end ; Write a dummy primary header-data unit. pro mwr_dummy, lun fxaddpar, header, 'SIMPLE', 'T','Dummy Created by MWRFITS v'+mwr_version() fxaddpar, header, 'BITPIX', 8, 'Dummy primary header created by MWRFITS' fxaddpar, header, 'NAXIS', 0, 'No data is associated with this header' fxaddpar, header, 'EXTEND', 'T', 'Extensions may (will!) be present' mwr_header, lun, header end ; Check if this is a valid pointer array for variable length data. function mwr_validptr, vtypes, nfld, index, array type = -1 offset = 0L for i=0, n_elements(array)-1 do begin if ptr_valid(array[i]) then begin sz = size(*array[i]) if sz[0] gt 1 then begin print,'MWRFITS: Error: Multidimensional Pointer array' return, 0 endif if type eq -1 then begin type = sz[sz[0] + 1] endif else begin if sz[sz[0] + 1] ne type then begin print,'MWRFITS: Error: Inconsistent type in pointer array' return, 0 endif endelse xsz = sz[1] if sz[0] eq 0 then xsz = 1 offset = offset + xsz endif endfor if type eq -1 then begin ; If there is no data assume an I*2 type type = 2 endif if (type lt 1 or type gt 5) and (type lt 12 or type gt 15) then begin print,'MWRFITS: Error: Unsupported type for variable length array' endif types = 'BIJED IJKK' sizes = [1,2,4,4,8,0,0,0,0,0,0,2,4,8,8] if n_elements(vtypes) eq 0 then begin vtype = {status:0, data:array, $ type: strmid(types, type-1, 1), $ itype: type, ilen: sizes[type-1], $ offset:offset } vtypes = replicate(vtype, nfld) endif else begin ; This ensures compatible structures without ; having to used named structures. vtype = vtypes[0] vtype.status = 0 vtype.data = array vtype.type = strmid(types, type-1, 1) vtype.itype = type vtype.ilen = sizes[type-1] vtype.offset = offset vtypes[index] = vtype endelse vtypes[index].status = 1; return, 1 end ; Handle the header for a binary table. pro mwr_tablehdr, lun, input, header, vtypes, $ no_types=no_types, $ logical_cols = logical_cols, $ bit_cols = bit_cols, $ nbit_cols= nbit_cols, $ no_comment=no_comment, $ alias=alias, $ silent=silent if not keyword_set(no_types) then no_types = 0 nfld = n_tags(input[0]) if nfld le 0 then begin print, 'MWRFITS Error: Input contains no structure fields.' return endif tags = tag_names(input) ; Get the number of rows in the table. nrow = n_elements(input) dims = lonarr(nfld) tdims = strarr(nfld) types = strarr(nfld) pointers= lonarr(nfld) ; offsets = null... Don't want to define this ; in advance since reference to ulon64 won't word with IDL < 5.2 ; ; Get the type and length of each column. We do this ; by examining the contents of the first row of the structure. ; nbyte = 0 for i=0, nfld-1 do begin a = input[0].(i) sz = size(a) nelem = sz[sz[0]+2] type_ele = sz[sz[0]+1] if type_ele eq 7 then begin maxstr = max(strlen(input.(i))) endif dims[i] = nelem if (sz[0] lt 1) or (sz[0] eq 1 and type_ele ne 7) then begin tdims[i] = '' endif else begin tdims[i] = '(' if type_ele eq 7 then begin tdims[i] = tdims[i] + strcompress(string(maxstr), /remo) + ',' endif for j=1, sz[0] do begin tdims[i] = tdims[i] + strcompress(sz[j]) if j ne sz[0] then tdims[i] = tdims[i] + ',' endfor tdims[i] = tdims[i] + ')' endelse case type_ele of 1: begin types[i] = 'B' nbyte = nbyte + nelem end 2: begin types[i] = 'I' nbyte = nbyte + 2*nelem end 3: begin types[i] = 'J' nbyte = nbyte + 4*nelem end 4: begin types[i] = 'E' nbyte = nbyte + 4*nelem end 5: begin types[i] = 'D' nbyte = nbyte + 8*nelem end 6: begin types[i] = 'C' nbyte = nbyte + 8*nelem end 7: begin types[i] = 'A' nbyte = nbyte + maxstr*nelem dims[i] = maxstr*nelem end 9: begin types[i] = 'M' nbyte = nbyte + 16*nelem end 10: begin if not mwr_validptr(vtypes, nfld, i, input.(i)) then begin return endif types[i] = 'P'+vtypes[i].type nbyte = nbyte + 8 dims[i] = 1 test = mwr_unsigned_offset(vtypes[i].itype) if test gt 0 then begin if (n_elements(offsets) lt 1) then begin offsets = ulon64arr(nfld) endif offsets[i] = test endif end 12: begin types[i] = 'I' if (n_elements(offsets) lt 1) then begin offsets = ulon64arr(nfld) endif offsets[i] = mwr_unsigned_offset(12); nbyte = nbyte + 2*nelem end 13: begin types[i] = 'J' if (n_elements(offsets) lt 1) then begin offsets = ulon64arr(nfld) endif offsets[i] = mwr_unsigned_offset(13); nbyte = nbyte + 4*nelem end ; 8 byte integers are not standard fits 14: begin if not keyword_set(silent) then begin print, "MWRFITS: Warning: 8 byte integers are non-standard (column "+strtrim(i+1,2)+')' endif types[i] = 'K' nbyte = nbyte + 8*nelem end 15: begin if not keyword_set(silent) then begin print, "MWRFITS: Warning: 8 byte integers are non-standard (column "+strtrim(i+1,2)+')' endif types[i] = 'K' nbyte = nbyte + 8*nelem if (n_elements(offsets) lt 1) then begin offsets = ulon64arr(nfld) endif offsets[i] = mwr_unsigned_offset(15) end 0: begin print,'MWRFITS Error: Undefined structure element??' return end 8: begin print, 'MWRFITS Error: Nested structures' return end else:begin print, 'MWRFITS Error: Cannot parse structure' return end endcase endfor ; Put in the required FITS keywords. chk_and_upd, header, 'XTENSION', 'BINTABLE', 'Binary table written by MWRFITS v'+mwr_version() chk_and_upd, header, 'BITPIX', 8, 'Required value' chk_and_upd, header, 'NAXIS', 2, 'Required value' chk_and_upd, header, 'NAXIS1', nbyte, 'Number of bytes per row' chk_and_upd, header, 'NAXIS2', n_elements(input), 'Number of rows' chk_and_upd, header, 'PCOUNT', 0, 'Normally 0 (no varying arrays)' chk_and_upd, header, 'GCOUNT', 1, 'Required value' chk_and_upd, header, 'TFIELDS', nfld, 'Number of columns in table' ; ; Handle the special cases. ; if keyword_set(logical_cols) then begin nl = n_elements(logical_cols) for i = 0, nl-1 do begin icol = logical_cols[i] if types[icol-1] ne 'A' then begin print,'WARNING: Invalid attempt to create Logical column:',icol goto, next_logical endif types[icol-1] = 'L' next_logical: endfor endif if keyword_set(bit_cols) then begin nb = n_elements(bit_cols) if nb ne n_elements(nbit_cols) then begin print,'WARNING: Bit_cols and Nbit_cols not same size' print,' No bit columns generated.' goto, after_bits endif for i = 0, nb-1 do begin nbyte = (nbit_cols[i]+7)/8 icol = bit_cols[i] if types[icol-1] ne 'B' or (dims[icol-1] ne nbyte) then begin print,'WARNING: Invalid attempt to create bit column:',icol goto, next_bit endif types[icol-1] = 'X' tdims[icol-1] = '' dims[icol-1] = nbit_cols[i] next_bit: endfor after_bits: endif ; Write scaling info as needed. if n_elements(offsets) gt 0 then begin w = where(offsets gt 0) for i=0, n_elements(w) - 1 do begin key = 'TSCAL'+strcompress(string(w[i])+1,/remo) chk_and_upd, header, key, 1 endfor for i=0, n_elements(w) - 1 do begin key = 'TZERO'+strcompress(string(w[i]+1),/remo) chk_and_upd, header, key, offsets[w[i]] endfor if not keyword_set(no_comment) then begin key = 'TSCAL'+strcompress(string(w[0])+1,/remo) fxaddpar, header, 'COMMENT', ' ', before=key fxaddpar, header, 'COMMENT', ' *** Unsigned integer column scalings ***', before=key fxaddpar, header, 'COMMENT', ' ', before=key endif endif ; Now add in the TFORM keywords for i=0, nfld-1 do begin if dims[i] eq 1 then begin form = types[i] endif else begin form=strcompress(string(dims[i]),/remove) + types[i] endelse tfld = 'TFORM'+strcompress(string(i+1),/remove) ; Check to see if there is an existing value for this keyword. ; If it has the proper value we will not modify it. ; This can matter if there is optional information coded ; beyond required TFORM information. oval = fxpar(header, tfld) oval = strcompress(string(oval),/remove_all) if (oval eq '0') or (strmid(oval, 0, strlen(form)) ne form) then begin chk_and_upd, header, tfld, form endif endfor if (not keyword_set(no_comment)) then begin fxaddpar, header, 'COMMENT', ' ', before='TFORM1' fxaddpar, header, 'COMMENT', ' *** Column formats ***', before='TFORM1' fxaddpar, header, 'COMMENT', ' ', before='TFORM1' endif ; Now write TDIM info as needed. for i=nfld-1, 0,-1 do begin if tdims[i] ne '' then begin fxaddpar, header, 'TDIM'+strcompress(string(i+1),/remo), tdims[i],after=tfld endif endfor w=where(tdims ne '') if w[0] ne -1 and not keyword_set(no_comment) then begin fxaddpar, header, 'COMMENT', ' ', after=tfld fxaddpar, header, 'COMMENT', ' *** Column dimensions (2 D or greater) ***', after=tfld fxaddpar, header, 'COMMENT', ' ', after=tfld endif for i=0, nfld-1 do begin if tdims[i] ne '' then begin chk_and_upd, header, 'TDIM'+strcompress(string(i+1),/remo), tdims[i] endif endfor if n_elements(vtypes) gt 0 then begin fxaddpar, header, 'THEAP', nbyte*n_elements(input), 'Offset of start of heap' offset = 0L for i=0,n_elements(vtypes)-1 do begin if vtypes[i].status then offset = offset + vtypes[i].offset*vtypes[i].ilen endfor fxaddpar, header, 'PCOUNT', offset, 'Size of heap' endif ; ; Last add in the TTYPE keywords if desired. ; if not no_types then begin for i=0, nfld - 1 do begin key = 'TTYPE'+strcompress(string(i+1),/remove) if not keyword_set(use_colnums) then begin value= mwr_checktype(tags[i],alias=alias)+' ' endif else begin value = 'C'+strmid(key,5,2) endelse chk_and_upd, header, key, value endfor if (not keyword_set(no_comment)) then begin fxaddpar, header, 'COMMENT', ' ', before='TTYPE1' fxaddpar, header, 'COMMENT', ' *** Column names *** ',before='TTYPE1' fxaddpar, header, 'COMMENT', ' ',before='TTYPE1' endif endif if (not keyword_set(no_comment)) then begin fxaddpar, header, 'COMMENT', ' ', after='TFIELDS' fxaddpar, header, 'COMMENT', ' *** End of mandatory fields ***', after='TFIELDS' fxaddpar, header, 'COMMENT', ' ', after='TFIELDS' endif ; Write to the output device. mwr_header, lun, header end ; Modify the structure to put the pointer column in. function mwr_retable, input, vtypes offset = 0L str = "output=replicate({"; comma ="" tags = tag_names(input); for i=0, n_elements(tags) -1 do begin if vtypes[i].status then begin str = str + comma +tags[i] + ":lonarr(2)" endif else begin str = str + comma + tags[i]+ ":input[0].("+strtrim(i,2)+")" endelse comma= "," endfor str = str + "},"+strtrim(n_elements(input),2)+")" stat = execute(str) if stat eq 0 then begin print,'MWRFITS: Error: Unable to create temporary structure for heap' return, 0 endif for i=0, n_elements(tags)-1 do begin if vtypes[i].status then begin for j=0, n_elements(input)-1 do begin ptr = input[j].(i) if ptr_valid(ptr) then begin sz = size(*ptr) if sz[0] eq 0 then xsz = 1 else xsz= sz[1] output[j].(i)[0] = xsz output[j].(i)[1] = offset offset = offset + vtypes[i].ilen*xsz endif endfor endif endfor return,output end ; Write the heap data. function mwr_writeheap, lun, vtypes offset = 0L flip = not is_ieee_big() for i=0, n_elements(vtypes)-1 do begin if vtypes[i].status then begin itype = vtypes[i].itype unsigned = mwr_unsigned_offset(itype) ptrs = vtypes[i].data for j=0,n_elements(ptrs)-1 do begin if ptr_valid(ptrs[j]) then begin if (unsigned gt 0) then begin *ptrs[j] = *ptrs[j] + unsigned endif if flip then begin x = *ptrs[j] host_to_ieee,x writeu,lun,x endif else begin writeu, lun, *ptrs[j] endelse sz = size(*ptrs[j]) xsz = 1 > sz[0] offset = offset + xsz * vtypes[i].ilen endif endfor endif endfor return, offset end ; Write the brinary table. pro mwr_tabledat, lun, input, header, vtypes ; ; file -- unit to which data is to be written. ; Input -- IDL structure ; Header -- Filled header nfld = n_tags(input) ; Any special processing? for i=0, nfld-1 do begin sz = size(input.(i)) nsz = n_elements(sz) typ = sz[nsz-2] if (typ eq 7) then begin siz = max(strlen(input.(i))) if siz gt 0 then begin blanks = string(bytarr(siz) + 32b) input.(i) = strmid(input.(i)+blanks, 0, siz) endif endif unsigned = mwr_unsigned_offset(typ) if (unsigned gt 0) then begin input.(i) = input.(i) + unsigned endif endfor if n_elements(vtypes) gt 0 then begin input = mwr_retable(input, vtypes) endif ; Use Astron library routine to convert to IEEE (since byteorder ; may be buggy). if not is_ieee_big() then host_to_ieee, input ; Write the data segment. ; writeu, lun, input nbyte = long(fxpar(header, 'NAXIS1')) nrow = n_elements(input) heap = 0 if n_elements(vtypes) gt 0 then begin heap = mwr_writeheap(lun, vtypes) endif siz = nbyte*nrow + heap padding = 2880 - (siz mod 2880) if padding eq 2880 then padding = 0 ; ; If necessary write the padding. ; if padding gt 0 then begin pad = bytarr(padding) ; Should be null-filled by default. writeu, lun, pad endif end ; Scale parameters for GROUPed data. pro mwr_pscale, grp, header, pscale=pscale, pzero=pzero ; This function assumes group is a 2-d array. if not keyword_set(pscale) and not keyword_set(pzero) then return if not keyword_set(pscale) then begin pscale = dblarr(sizg[1]) pscale[*] = 1. endif w = where(pzero eq 0.d0) if w[0] ne 0 then begin print, 'MWRFITS Warning: PSCALE value of 0 found, set to 1.' pscale[w] = 1.d0 endif if keyword_set(pscale) then begin for i=0L, sizg[1]-1 do begin key= 'PSCAL' + strcompress(string(i+1),/remo) chk_and_upd, header, key, pscale[i] endfor endif if not keyword_set(pzero) then begin pzero = dblarr(sizg[1]) pzero[*] = 0. endif else begin for i=0L, sizg[1]-1 do begin key= 'PZERO' + strcompress(string(i+1),/remo) chk_and_upd, header, key, pscale[i] endfor endelse for i=0L, sizg[1]-1 do begin grp[i,*] = grp[i,*]/pscale[i] - pzero[i] endfor end ; Find the appropriate scaling parameters. pro mwr_findscale, flag, array, nbits, scale, offset, error error = 0 if n_elements(flag) eq 2 then begin scale = double(flag[0]) offset = double(flag[1]) endif else if n_elements(flag) eq 1 and flag[0] ne 1 then begin minmum = min(array, max=maxmum) offset = 0.d0 scale = double(flag[0]) endif else if n_elements(flag) ne 1 then begin print, 'MWRFITS Error: Invalid scaling parameters.' error = 1 return endif else begin minmum = min(array, max=maxmum) scale = (maxmum-minmum)/(2.d0^nbits) amin = -(2.d0^(nbits-1)) if (amin gt -130) then amin = 0 ; looking for -128 offset = minmum - scale*amin endelse return end ; Scale and possibly convert array according to information ; in flags. pro mwr_scale, array, scale, offset, lscale=lscale, iscale=iscale, $ bscale=bscale, null=null ; First deallocate scale and offset if n_elements(scale) gt 0 then xx = temporary(scale) if n_elements(offset) gt 0 then xx = temporary(offset) if not keyword_set(lscale) and not keyword_set(iscale) and $ not keyword_set(bscale) then return siz = size(array) if keyword_set(lscale) then begin ; Doesn't make sense to scale data that can be stored exactly. if siz[siz[0]+1] lt 4 then return amin = -2.d0^31 amax = -(amin + 1) mwr_findscale, lscale, array, 32, scale, offset, error endif else if keyword_set(iscale) then begin if siz[siz[0]+1] lt 3 then return amin = -2.d0^15 amax = -(amin + 1) mwr_findscale, iscale, array, 16, scale, offset, error endif else begin if siz[siz[0]+1] lt 2 then return amin = 0 amax = 255 mwr_findscale, bscale, array, 8, scale, offset, error endelse ; Check that there was no error in mwr_findscale if error gt 0 then return if scale le 0.d0 then begin print, 'MWRFITS Error: BSCALE/TSCAL=0' return endif array = round((array-offset)/scale) w=where(array lt 0) w = where(array gt amax) if w[0] ne -1 then begin if keyword_set(null) then array[w] = null else array[w]=amax endif w = where(array lt amin) if w[0] ne -1 then begin if keyword_set(null) then array[w] = null else array[w] = amin endif if keyword_set(lscale) then array = long(array) $ else if keyword_set(iscale) then array = fix(array) $ else array = byte(array) end ; Write a header pro mwr_header, lun, header ; Fill strings to at least 80 characters and then truncate. space = string(replicate(32b, 80)) header = strmid(header+space, 0, 80) w = where(strmid(header,0,8) eq "END ") if w[0] eq -1 then begin header = [header, strmid("END"+space,0,80)] endif else begin if (n_elements(w) gt 1) then begin ; Get rid of extra end keywords; print,"MWRFITS Warning: multiple END keywords found." for irec=0L, n_elements(w)-2 do begin header[w[irec]] = strmid('COMMENT INVALID END REPLACED'+ $ space, 0, 80) endfor endif ; Truncate header array at END keyword. header = header[0:w[n_elements(w)-1]] endelse nrec = n_elements(header) if nrec mod 36 ne 0 then header = [header, replicate(space,36 - nrec mod 36)] writeu, lun, byte(header) end ; Move the group information within the data. pro mwr_groupinfix, data, group, hdr siz = size(data) sizg = size(group) ; Check if group info is same type as data if siz[siz[0]+1] ne sizg[3] then begin case siz[siz[0]+1] of 1: begin mwr_groupscale, 127.d0, group, hdr group = byte(group) end 2: begin mwr_groupscale, 32767.d0, group, hdr group = fix(group) end 3: begin mwr_groupscale, 2147483647.d0, group, hdr group = long(group) end 4: group = float(group) 5: group = double(group) else: begin print,'MWRFITS Internal error: Conversion of group data' return end endcase endif nrow = 1 for i=1, siz[0]-1 do begin nrow = nrow*siz[i] endfor data = reform(data, siz[siz[0]+2]) for i=0L, siz[siz[0]] - 1 do begin if i eq 0 then begin gdata = group[*,0] gdata = reform(gdata) tdata = [ gdata , data[0:nrow-1]] endif else begin start = nrow*i fin = start+nrow-1 gdata = group[*,i] tdata = [tdata, gdata ,data[start:fin]] endelse endfor data = temporary(tdata) end ; If an array is being scaled to integer type, then ; check to see if the group parameters will exceed the maximum ; values allowed. If so scale them and update the header. pro mwr_groupscale, maxval, group, hdr sz = size(group) for i=0L, sz[1]-1 do begin pmax = max(abs(group[i,*])) if (pmax gt maxval) then begin ratio = pmax/maxval psc = 'PSCAL'+strcompress(string(i+1),/remo) currat = fxpar(hdr, psc) if (currat ne 0) then begin fxaddpar, hdr, psc, currat*ratio, 'Scaling overriden by MWRFITS' endif else begin fxaddpar, hdr, psc, ratio, ' Scaling added by MWRFITS' endelse group[i,*] = group[i,*]/ratio endif endfor end ; Write out header and image for IMAGE extensions and primary arrays. pro mwr_image, input, siz, lun, bof, hdr, $ null=null, $ group=group, $ pscale=pscale, pzero=pzero, $ lscale=lscale, iscale=iscale, $ bscale=bscale, $ no_comment=no_comment, $ silent=silent type = siz[siz[0] + 1] bitpixes=[8,8,16,32,-32,-64,-32,0,0,-64,0,0,16,32,64,64] ; Convert complexes to two element real array. if type eq 6 or type eq 9 then begin if not keyword_set(silent) then begin print, "MWRFITS Note: Complex numbers treated as arrays" endif array_dimen=(2) if siz[0] gt 0 then array_dimen=[array_dimen, siz[1:siz[0]]] if siz[siz[0]+1] eq 6 then data = float(input,0,array_dimen) $ else data = double(input,0,array_dimen) ; Convert strings to bytes. endif else if type eq 7 then begin data = input len = max(strlen(input)) if len eq 0 then begin print, 'MWRFITS Error: strings all have zero length' return endif for i=0L, n_elements(input)-1 do begin t = len - strlen(input[i]) if t gt 0 then input[i] = input[i] + string(replicate(32B, len)) endfor ; Note that byte operation works on strings in a special way ; so we don't go through the subterfuge we tried above. data = byte(data) endif else if n_elements(input) gt 0 then data = input ; Convert scalar to 1-d array. if siz[0] eq 0 and siz[1] ne 0 then data=(data) ; Do any scaling of the data. mwr_scale, data, scalval, offsetval, lscale=lscale, $ iscale=iscale, bscale=bscale, null=null ; This may have changed the type. siz = size(data) type = siz[siz[0]+1] ; If grouped data scale the group parameters. if keyword_set(group) then mwr_pscale, group, hdr, pscale=pscale, pzero=pzero if bof then begin chk_and_upd, hdr, 'SIMPLE', 'T','Primary Header created by MWRFITS v'+mwr_version() chk_and_upd, hdr, 'BITPIX', bitpixes[type] chk_and_upd, hdr, 'NAXIS', siz[0] chk_and_upd, hdr, 'EXTEND', 'T', 'Extensions may be present' endif else begin chk_and_upd, hdr, 'XTENSION', 'IMAGE','Image Extension created by MWRFITS v'+mwr_version() chk_and_upd, hdr, 'BITPIX', bitpixes[type] chk_and_upd, hdr, 'NAXIS', siz[0] chk_and_upd, hdr, 'PCOUNT', 0 chk_and_upd, hdr, 'GCOUNT', 1 endelse if keyword_set(group) then begin group_offset = 1 endif else group_offset = 0 if keyword_set(group) then begin chk_and_upd, hdr, 'NAXIS1', 0 endif for i=1L, siz[0]-group_offset do begin chk_and_upd, hdr, 'NAXIS'+strcompress(string(i+group_offset),/remo), siz[i] endfor if keyword_set(group) then begin chk_and_upd, hdr, 'GROUPS', 'T' sizg = size(group) if sizg[0] ne 2 then begin print,'MWRFITS Error: Group data is not 2-d array' return endif if sizg[2] ne siz[siz[0]] then begin print,'MWRFITS Error: Group data has wrong number of rows' return endif chk_and_upd,hdr, 'PCOUNT', sizg[1] chk_and_upd, hdr, 'GCOUNT', siz[siz[0]] endif if n_elements(scalval) gt 0 then begin chk_and_upd, hdr, 'BSCALE', scalval chk_and_upd, hdr, 'BZERO', offsetval endif else begin ; Handle unsigned offsets bzero = mwr_unsigned_offset(type) if bzero gt 0 then begin chk_and_upd,hdr,'BSCALE', 1 chk_and_upd, hdr, 'BZERO', bzero data = data + bzero endif endelse if keyword_set(group) then begin if keyword_set(pscale) then begin if n_elements(pscale) ne sizg[1] then begin print, 'MWRFITS Warning: wrong number of PSCALE values' endif else begin for i=1L, sizg[1] do begin chk_and_upd, hdr, 'PSCALE'+strcompress(string(i),/remo) endfor endelse endif if keyword_set(pzero) then begin if n_elements(pscale) ne sizg[1] then begin print, 'MWRFITS Warning: Wrong number of PSCALE values' endif else begin for i=1L, sizg[1] do begin chk_and_upd, hdr, 'PZERO'+strcompress(string(i),/remo) endfor endelse endif endif bytpix=abs(bitpixes[siz[siz[0]+1]])/8 ; Number of bytes per pixel. npixel = n_elements(data) + n_elements(group) ; Number of pixels. if keyword_set(group) then mwr_groupinfix, data, group, hdr ; Write the FITS header mwr_header, lun, hdr ; This is all we need to do if input is undefined. if (n_elements(input) eq 0) or (siz[0] eq 0) then return ; Write the data. host_to_ieee, data writeu, lun, data nbytes = bytpix*npixel filler = 2880 - nbytes mod 2880 if filler eq 2880 then filler = 0 ; Write any needed filler. if filler gt 0 then writeu, lun, replicate(0B,filler) end ; Main routine -- see documentation at start pro mwrfits, xinput, file, header, $ ascii=ascii, $ separator=separator, $ terminator=terminator, $ create=create, $ null=null, $ group=group, $ pscale=pscale, pzero=pzero, $ alias=alias, $ use_colnum = use_colnum, $ lscale=lscale, iscale=iscale, $ bscale=bscale, $ no_types=no_types, $ silent=silent, $ no_comment=no_comment, $ logical_cols=logical_cols, $ bit_cols=bit_cols, $ nbit_cols=nbit_cols, $ version=version ; Check required keywords. if (keyword_set(Version)) then begin print, "MWRFITS V"+mwr_version()+": February 18, 2002" endif if n_elements(file) eq 0 then begin if (not keyword_set(Version)) then begin print, 'MWRFITS: Usage:' print, ' MWRFITS, struct_name, file, [header,] ' print, ' /CREATE, /SILENT, /NO_TYPES, /NO_COMMENT, ' print, ' GROUP=, PSCALE=, PZERO=,' print, ' LSCALE=, ISCALE=, BSCALE=,' print, ' LOGICAL_COLS=, BIT_COLS=, NBIT_COLS=,' print, ' ASCII=, SEPARATOR=, TERMINATOR=, NULL=' print, ' /USE_COLNUM, ALIAS=' endif return endif ; Save the data into an array/structure that we can modify. if n_elements(xinput) gt 0 then input = xinput on_ioerror, open_error ; Open the input file. ; If the create keyword is not specified we ; try to open the file readonly to see if it ; already exists and if so we append to it. ; An error implies the file does not exist. ; ; We use this rather circuitous route to handle ; the unix ~ construction consistently -- findfile ; doesn't reliably understand that. ; if not keyword_set(create) then begin on_ioerror, not_found openr, lun, file, /get_lun free_lun, lun on_ioerror, null if !version.os eq 'vms' then openu, lun, file, 2880, /block, /none, /get_lun, /append $ else openu, lun, file, /get_lun, /append bof = 0 goto, finished_open endif not_found: on_ioerror, null if !version.os eq 'vms' then openw, lun, file, 2880, /block, /none, /get_lun $ else openw, lun, file, /get_lun bof = 1 finished_open: siz = size(input) if siz[siz[0]+1] ne 8 then begin ; If input is not a structure then call image writing utilities. mwr_image, input, siz, lun, bof, header, $ null=null, $ group=group, $ pscale=pscale, pzero=pzero, $ lscale=lscale, iscale=iscale, $ bscale=bscale, $ no_comment=no_comment, $ silent=silent endif else if keyword_set(ascii) then begin if bof then mwr_dummy, lun ; Create an ASCII table. mwr_ascii, input, siz, lun, bof, header, $ ascii=ascii, $ null=null, $ use_colnum = use_colnum, $ lscale=lscale, iscale=iscale, $ bscale=bscale, $ no_types=no_types, $ separator=separator, $ terminator=terminator, $ no_comment=no_comment, $ alias=alias, $ silent=silent endif else begin if bof then mwr_dummy, lun ; Create a binary table. mwr_tablehdr, lun, input, header, vtypes, $ no_types=no_types, $ logical_cols = logical_cols, $ bit_cols = bit_cols, $ nbit_cols= nbit_cols, $ alias=alias, $ no_comment=no_comment mwr_tabledat, lun, input, header, vtypes endelse free_lun, lun return ; Handle error in opening file. open_error: on_ioerror, null print, 'MWRFITS Error: Cannot open output: ', file if n_elements(lun) gt 0 then free_lun, lun return end ####################################################### function name_extract,INPUT ;+ ; Function NAME_EXTRACT returns the string-type 6-dimen- ; sional array containing extracted file name from the ; input full path name; file name without extension; ; extension and lengthes of all of these values ; correspondingly. All the output values are of lower ; case. ; ; EXAMPLE: ; If INPUT is file C:\DATA\TEST1.DAT: ; A=NAME_EXTRACT(INPUT) ; PRINT,A ; IDL prints: test1.dat test1 dat 9 5 3 ; ; To extract, e.g., the extension only, you ; can print such a statement: ; PRINT,(NAME_EXTRACT(INPUT))(2) ; IDL prints: dat ; ; INPUT ARGUMENT: INPUT - scalar string. ; ;- CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE arr=strarr(6) sz=size(INPUT) if (sz(0) gt 0 ) or sz(1) ne 7 then begin print,'Invalid input argument' goto,exit endif full_name_length=strlen(INPUT) a=strpos(INPUT,Delim) IF a GE 0 THEN BEGIN i=-1 repeat begin i=i+1 a=strpos(INPUT,Delim,full_name_length-i) endrep until a ge 0 name_ext_length=i-1 ENDIF ELSE name_ext_length=full_name_length name_ext=strmid(INPUT, $ full_name_length-name_ext_length, name_ext_length) if strpos(name_ext,'.') lt 0 then ext_length=0 else $ ext_length=name_ext_length-strpos(name_ext,'.')-1 name_length=name_ext_length-ext_length-(ext_length gt 0) name=strmid(name_ext,0,name_length) ext=strmid(name_ext, name_length+1, ext_length) length=[string(name_ext_length),string(name_length), $ string(ext_length)] arr=[name_ext,name,ext,length] exit: return,arr end ####################################################### function name_lun,lun ;+ ; Function name_lun returns the string-type 6-dimen- ; sional array containing file name of the input ; logical unit number selected from full path name; ; file name without extension; extension and lengthes ; of all of these values correspondingly. All the ; output values are of lower case. ; ; EXAMPLE: ; If 1 is opened file C:\DATA\TEST1.DAT: ; A=NAME_LUN(1) ; PRINT,A ; IDL prints: test1.dat test1 dat 9 5 3 ; ; To extract, e.g., the extension only, you ; can print such a statement: ; PRINT,(NAME_LUN(1))(2) ; IDL prints: dat ; ;- Descr_file = FSTAT(lun) err_mess='ERROR: Unit number '+string(lun)+' is not open' if Descr_file.open eq 0 then begin print, strcompress(err_mess) arr=strarr(6) goto,exit endif arr=name_extract(Descr_file.Name) exit: return,arr end ####################################################### pro negative ;+ ; NAME: ; NEGATIVE ; ; PURPOSE: ; To invert an image containing in a current graphics window. ; ; CATEGORY: ; Image display. ; ; CALLING SEQUENCE: ; NEGATIVE ; ; INPUTS: ; None ; ; OPTIONAL INPUT PARAMETERS: ; None. ; ; KEYWORD PARAMETERS: ; None. ; ; OUTPUTS: ; None ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; Colors of the image displayed in the current graphics window ; are inverted. ; ; RESTRICTIONS: ; Screen only is supported. ; ; PROCEDURE: ; The contents of the graphics window is read using TVRD. After ; that, the inverted array is redisplayed. ; ; MODIFICATION HISTORY: ; ISTP SD RAS, Nov, 1999. ; Victor Grechnev (Grechnev@iszf.irk.ru): ; Initially written. ;- w = tvrd() tv, max(w)-w end ####################################################### function newfilename,filter=filter,path=path,model=model ; Returns name of new file after model given. if n_elements(filter) le 0 then filter='' if n_elements(model) le 0 then begin print,'You must define MODEL' & goto,exit endif model_save=model model=strcompress(model,/rem) Length=strlen(model) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE if n_elements(path) gt 0 then $ Name_list=findfile(path+Delim+Filter,count=count) $ else Name_list=findfile(Filter,count=count) count=count > 1 name=strarr(count) & exist_length=intarr(count) Last_char=strarr(count) & First_char=strarr(count) for j=0,n_elements(name_list)-1 do begin name(j)=(name_extract(name_list(j)))(1) exist_length(j)=strlen(name(j)) Last_char(j)=strmid(name(j),exist_length(j)-Length,length) First_char(j)=strmid(name(j),0,exist_length(j)-Length) endfor extension=(name_extract(name_list(0)))(2) if extension ne '' then extension='.'+extension index=(where(Last_char eq model)) if equiv(index,-1) then begin new_name=$ strmid('00000000',0,8-Length)+model+strmid(filter,1,strlen(filter)-1) goto,exit endif name=name(index) exist_length=exist_length(index) Last_char=Last_char(index) First_char=First_char(index) Max_number=max(First_char,imax) Sel=string(strlen(Max_number)) Max_number=Max_number+1 Name_format=strcompress('(I'+Sel+'.'+Sel+')',/rem) Number=string(Max_number,format=Name_format) ;First_char=First_char(where(First_char ne '00' and first_char ne '')) new_name=Number+Last_char(0)+extension exit: model=model_save return,new_name end ####################################################### function normalize,x amax=max(x,min=amin) return,(x-amin)/(amax-amin) end ####################################################### pro oplot_break,x,y,x_break=x_break,y_break=y_break, $ subs_break=subs_break,$ color=color,linestyle=linestyle,thick=thick, $ noclip=noclip,psym=psym,symsize=symsize ; Oplots a curve having nissing points. if n_elements(linestyle) le 0 then linestyle=0 if n_elements(color) le 0 then color=!p.color if n_elements(noclip) le 0 then noclip=0 if n_elements(thick) le 0 then thick=1 if n_elements(psym) le 0 then psym=0 if n_elements(symsize) le 0 then symsize=1 CASE 1 OF n_elements(x_break) gt 0: index0=where(x ne x_break) n_elements(y_break) gt 0: index0=where(y ne y_break) n_elements(subs_break) gt 0: index0= $ where(indgen(n_elements(x)) ne subs_break) ELSE: index0=where(y) ENDCASE split_array,index0,fir=sf,last=sl,num=n N_e=n_elements(x) factor=float(x(N_e-1)-x(0))/(N_e-1) for j=0,n-1 do begin ind=sf(j)+indgen(sl(j)-sf(j)+1) oplot,x(0)+ind*factor,y(sf(j):sl(j)), $ color=color,linestyle=linestyle,noclip=noclip,thick=thick, $ psym=psym,symsize=symsize endfor end ####################################################### pro oplot_peaks,y,width=width,sigma=sigma,linestyle=linestyle, $ max=max,min=min,all=all ; + Oplots vertical lines through local minimum points on the plot ; - which is issued on the graphics window. if n_elements(all) le 0 then all=0 if n_elements(linestyle) le 0 then linestyle=0 CASE 1 OF n_elements(width) le 0 and n_elements(sigma) le 0: z= $ find_peaks(y,all=all) n_elements(width) le 0 and n_elements(sigma) gt 0: z= $ find_peaks(y,sigma=sigma,all=all) n_elements(width) gt 0 and n_elements(sigma) le 0: z= $ find_peaks(y,width=width,all=all) n_elements(width) gt 0 and n_elements(sigma) gt 0: z= $ find_peaks(y,width=width,sigma=sigma,all=all) ENDCASE for j=0,n_elements(z)-1 do plots, z(j), !y.crange, linestyle=linestyle end ####################################################### function ORD_RECOGNIZE,Chanobs,Nord,Ord,Chan ; Recognizes the interference order number for a given channel. N=n_elements(Chanobs) Ord_out=replicate(Ord(0), N) CASE Nord OF 2: begin index=where(Chanobs gt (Chan(2,0)+Chan(0,1))/2) if index(0) ge 0 then Ord_out(index)=Ord(1) end 3: begin index=where(Chanobs gt (Chan(2,0)+Chan(0,1))/2) if index(0) ge 0 then Ord_out(index)=Ord(1) index=where(Chanobs gt (Chan(2,1)+Chan(0,2))/2) if index(0) ge 0 then Ord_out(index)=Ord(2) end ELSE: ENDCASE if N eq 1 then Ord_out=Ord_out(0) return, Ord_out end ####################################################### pro ord_to_time,Date,Interf,Order,Channel, $ Receiver,SUN,time_out,both=both,Radio=Radio if keyword_set(both) or interf then J0=1 else J0=0 if n_elements(Radio) le 0 then Radio=1.175 DDTOR=!DPi/180 D=4.9D0 & C=2.997925D8 & Fi=51.7575D0*!DPi/180 if n_elements(SUN) le 0 then suneph,date,Time,SUN Declg=strmid(SUN.Current_date,12,2) DSign=strmid(SUN.Current_date,11,1) Declm=strmid(SUN.Current_date,15,2) Decls=strmid(SUN.Current_date,18,4) Ddelta=strmid(SUN.Current_date,62,6)*DDTOR/3600d0*24d0 Delta=HMS(Declg,Declm,Decls)*DDTOR for I=0,2 do IF(Dsign(I) EQ '-') then Delta(I)=-Delta(I) F=chanfreq(Channel,receiver) CosP=Order*C/(F*d) P=acos(CosP) CosP=cos([P-SUN.R*Radio,P,P+SUN.R*Radio]) Time='05 00 00' time_out=strarr(3,J0+1) for j=0,J0 do begin for jj=0,2 do begin REPEAT BEGIN Time0=Time H=SUN.W0*(Time-SUN.Tcul)*3600d0 Direction=H/(2*!DPi) IF(Direction LE 0) THEN $ Decl=Delta(1)+Direction*Ddelta(1) $ - Direction^2*(DDelta(1)-DDelta(0))/2 ELSE $ Decl=Delta(1)+Direction*Ddelta(1) $ + Direction^2*(DDelta(2)-DDelta(1))/2 Sin_Cos_H= $ (CosP(jj)+sin(Decl)*cos(Fi))/(cos(Decl)*sin(Fi))*Interf+ $ CosP(jj)/cos(Decl)*(1-Interf) if abs(Sin_Cos_H) gt 1 then begin print,'This order is not visible' & return endif H=acos(Sin_Cos_H)*Interf+ $ ; S-N asin(Sin_Cos_H)*(1-Interf) ; E-W H= H*(1-j)+ $ ; 1st pass (-H*Interf+ $ ; 2nd pass S-N (!dpi-abs(H))*sign(H)*(1-Interf))*j ; 2nd pass E-W T1=SUN.Tcul*3600d0+H/SUN.w0 Time=smh(T1,ms=4) ENDREP UNTIL abs(T1-hms(time0)*3600d0) lt 0.001 time_out(jj,j)=Time endfor endfor if (keyword_set(both) or interf) and $ (not((CosP(1) gt 0) and not(interf))) $ then time_out=time_out([[3,4,5],[0,1,2]]) end ####################################################### pro param_SSRT,Indate,Intime,Inrec,Date=Date,Time=Time, $ Receiver=Receiver, silent=silent,SUN=SUN, $ parameters=parameters,group_leader=group_leader, $ nofile=nofile ; Displays the SSRT parameters in a time moment given. if n_elements(group_leader) le 0 then group_leader=0L if n_params() ge 2 then begin Date=Indate & Time=Intime endif if n_params() eq 3 then Receiver=Inrec if n_elements(Date) le 0 then Date='' if strlen(Date) lt 2 then read,'Date (e.g. 24 08 93) - ', Date if n_elements(Time) le 0 then Time='' if strlen(Time) lt 2 then read,'Time (e.g. 07 04 33.457) - ', Time if n_elements(Receiver) le 0 then begin Receiver=0 & read,'Receiver (0-MFB, 1-AOR) - ', Receiver endif suneph,Date,Time,SUN WIDGET_CONTROL,/hourglass Radio=1.175D D=4.9D & C=2.997925D8 & Fi=51.7575D*!DPi/180 & Nant=128 Sum_chan=[180,192] Bound_Frequencies=chanfreq([1,Sum_chan(Receiver)],Receiver) Fmin=Bound_Frequencies(0) Fmax=Bound_Frequencies(1) F0=(Fmax+Fmin)/2 Df=(Fmax-Fmin)/(Sum_chan(Receiver)-1) Rads=!DPi/180/3600 ; ************* Interferometer E-W ******************** INT_ORD,0,Receiver,SUN,P,NnEW,NordEW,ChanEW NmaxEW=fix(Fmax*D*cos(SUN.Decl)/C) ExpFactorEW=[1.,Coeffr(NordEW(0),band=2), $ Coeffr(NordEW(0),band=4,rec=Receiver)] RoEW=0.886*C/(Nant*F0*D*abs(sin(P(1))))*ExpFactorEW SpacingEW=abs(tan(!Dpi/2-p(1))*Df/F0) A_EW=atan(tan(SUN.H)*sin(SUN.Decl)) G_EW=A_EW+SUN.Dp ;Tmod=Df/F0*tan(abs(SUN.H))/SUN.W0 TmodEW0=abs(asin(NordEW(0)*C/(Fmin*D*cos(SUN.Decl)) < 1 > (-1))- $ asin(NordEW(0)*C/((Fmin+Df)*D*cos(SUN.Decl)) < 1 > (-1)))/SUN.W0 TmodEW1=abs(asin(NordEW(0)*C/(Fmax*D*cos(SUN.Decl)) < 1 > (-1))- $ asin(NordEW(0)*C/((Fmax+Df)*D*cos(SUN.Decl)) < 1 > (-1)))/SUN.W0 TneighEW=abs(asin(NordEW(0)*C/(F0*D*cos(SUN.Decl)))- $ asin((NordEW(0)+1)*C/(F0*D*cos(SUN.Decl)) < 1 > (-1)))/SUN.W0 TPassBeamEW=0.886*C/abs((Nant*F0*D*cos(SUN.H)*cos(SUN.Decl))* $ ExpFactorEW(1))/SUN.W0 ; ************* Interferometer S-N ******************** INT_ORD,1,Receiver,SUN,Q,NnSN,NordSN,ChanSN NmaxSN=fix(Fmax*D*sin(Fi-SUN.Decl)/C) ExpFactorSN=[1.,Coeffr(NordSN(0),band=2), $ Coeffr(NordSN(0),band=4,rec=Receiver)] RoSN=0.886*C/(Nant*F0*D*abs(sin(Q(1))))*ExpFactorSN SpacingSN=abs(tan(!Dpi/2-q(1))*Df/F0) IF SUN.H Ne 0 THEN A_SN= $ -atan(cos(SUN.Decl)/sin(SUN.H)/tan(Fi)+sin(SUN.Decl)/Tan(SUN.H)) $ ELSE A_SN=!DPi/2 G_SN=A_SN+SUN.Dp CDSF=cos(SUN.Decl)*sin(Fi) SDCF=sin(SUN.Decl)*cos(Fi) TmodSN0=abs(acos((NordSN(0)*C/(Fmin*D)+SDCF)/CDSF < 1 > (-1))- $ acos((NordSN(0)*C/((Fmin+Df)*D) +SDCF)/CDSF < 1 > (-1)))/SUN.W0 TmodSN1=abs(acos((NordSN(0)*C/(Fmax*D)+SDCF)/CDSF < 1 > (-1))- $ acos((NordSN(0)*C/((Fmax+Df)*D)+SDCF)/CDSF < 1 > (-1)))/SUN.W0 TneighSN=abs(acos((NordSN(0)*C/(F0*D)+SDCF)/CDSF < 1 > (-1))- $ acos(((NordSN(0)+1)*C/(F0*D)+SDCF)/CDSF < 1 > (-1)))/SUN.W0 TPassBeamSN=0.886*C/abs((Nant*F0*D*sin(SUN.H)*cos(SUN.Decl)* $ sin(Fi))*ExpFactorSN(1))/SUN.W0 ; **************** PRINT DATA ****************** if keyword_set(nofile) then goto,exit name_for_file=strmid(date, 6, 2)+strmid(date, 3, 2)+strmid(date, 0, 2) Filename=newfilename(model=name_for_file,filt='*.par', $ path=getenv('results')) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Filename=getenv('results')+Delim+Filename openw,lun,Filename,/get_lun printf,lun,Date_string(Date),Time, $ format="(5X,'DATE: ',A11,', TIME: ',A12,' UT',/)" printf,lun,smh(SUN.Tcul*3600,/str,ms=2), $ format="(T10,'Culmination: ',A11,/)" printf,lun,SUN.H,SUN.H/!Dpi*180,SUN.H/SUN.W0/3600,format=$ "('Hour angle = ',F8.5,' rad = ',F8.4,' degree = ',F8.5,' hours',/)" IF SUN.Decl lt 0 THEN Dsign='-' ELSE IF SUN.Decl gt 0 THEN Dsign='+' $ ELSE Dsign=' ' printf,lun, Dsign,smh(abs(SUN.Decl)/!DPi*180*3600, /str,ms=1), SUN.Decl, $ SUN.Decl/!DPi*180, format= $ "('Declination = ',A1,A10,' = ',F8.5,' rad = ',F8.4,' degree',/,/)" printf,lun,format="(T15,'INTERFEROMETER E-W')" printf,lun,format="(60('-'),/)" Com_for= $ ["('Bandwidth, kHz',T25,'Beam FWHM',T40,'Spreading factor')", $ "('(CCD elements ',T20,'Arcsec',T30,'Channels')", $ "(' integrated)')", $ "(60('-'))"] First_words= $ ["(T12,'0 (0 CCD)'","(T8,'292 (2 CCD)'","(T8,'583 (4 CCD)'"] for j=0,3 do printf,lun,format=Com_for(j) for j=0,2 do $ printf,lun,RoEW(j)/Rads,RoEW(j)/SpacingEW,ExpFactorEW(j), $ format=First_words(j)+",T30,F4.1,T45,F6.2,T55,F4.2)" printf,lun,format="(60('-'),/)" printf,lun,SpacingEW/!Pi*180*3600,format= $ "('Spacing between frequency lobes (peak to peak) = ',F5.1,' arcsec',/)" printf,lun,NmaxEW,format="(5X,'Maximum order number = ',I2,/)" printf,lun,A_EW/!DPi*180,format= $ "(5X,'Angle measured from the Earth meridium',/,T15,'to the knife-edge beam E-W = ',F7.2,' degree',/)" printf,lun,G_EW/!DPi*180,format= $ "(5X,'Angle measured from the polar axis of the Sun',/,T15,'to the knife-edge beam E-W = ',F7.2,' degree',/)" printf,lun,format="(60('-'))" printf,lun,format="(T4,'Order',T20,'Channels',T41,'Visible')" printf,lun,format="(T15,29('-'),T53,'Centre')" printf,lun,format= $ "(T9,' Left edge*',' Centre ',' Right edge*')" printf,lun,format="(60('-'))" for j=0,NnEW-1 do printf,lun,NordEW(j),ChanEW(*,j), $ (ChanEW(0,j)+ChanEW(2,j))/2, format="(T4,I3,3X,4(F7.1,3X))" printf,lun,format="(60('-'))" printf,lun,p,format="(T4,'P',T11,3(F7.4,3X))" printf,lun,cos(p),format="(T2,'Cos(P)',T10,3(F7.4,3X))" printf,lun,format="(60('-'))" printf,lun,ChanEW(2)-ChanEW(0),2*SUN.R*!Radeg*60,format= $ "(T10,'* Radio diameter (',F6.1,' channels) to optical one',/,'(',F5.2,' arc min) ratio assumed 1.175',/)" printf,lun,TmodEW0,TmodEW1,1/TmodEW0,1/TmodEW1,format= $ "('Period of the beam-induced modulation = ',F6.2,' (fmin) ...',/,F6.2,' (fmax) sec',' (frequency = ',F6.2,' ... ',F6.2,' Hz)',/)" printf,lun,TneighEW,format=$ "('Interval between passages of neighbouring orders = ',F6.1,' sec',/)" printf,lun,TPassBeamEW,format= $ "('Duration of passing beam E-W = ',F4.1,' sec',/,/)" printf,lun,format="(T15,'INTERFEROMETER S-N')" printf,lun,format="(60('-'),/)" for j=0,3 do printf,lun,format=Com_for(j) for j=0,2 do $ printf,lun,RoSN(j)/Rads,RoSN(j)/SpacingSN,ExpFactorSN(j), $ format=First_words(j)+",T30,F4.1,T45,F6.2,T55,F4.2)" printf,lun,format="(60('-'),/)" printf,lun,SpacingSN/!Pi*180*3600,format= $ "('Spacing between frequency lobes (peak to peak) = ',F5.1,' arcsec',/)" printf,lun,NmaxSN,format="(5X,'Maximum order number = ',I2,/)" printf,lun,A_SN/!DPi*180,format= $ "(5X,'Angle measured from the Earth meridium',/,T15,'to the knife-edge beam S-N = ',F7.2,' degree',/)" printf,lun,G_SN/!DPi*180,format= $ "(5X,'Angle measured from the polar axis of the Sun',/,T15,'to the knife-edge beam S-N = ',F7.2,' degree',/)" printf,lun,format="(60('-'))" printf,lun,format="(T4,'Order',T20,'Channels',T41,'Visible')" printf,lun,format="(T15,29('-'),T53,'Centre')" printf,lun,format= $ "(T9,' Left edge*',' Centre ',' Right edge*')" printf,lun,format="(60('-'))" for j=0,NnSN-1 do printf,lun,NordSN(j),ChanSN(*,j), $ (ChanSN(0,j)+ChanSN(2,j))/2, format="(T4,I3,3X,4(F7.1,3X))" printf,lun,format="(60('-'))" printf,lun,Q,format="(T4,'Q',T11,3(F7.4,3X))" printf,lun,cos(Q),format="(T2,'Cos(Q)',T10,3(F7.4,3X))" printf,lun,format="(60('-'))" printf,lun,ChanSN(2)-ChanSN(0),2*SUN.R*!Radeg*60,format= $ "(T10,'* Radio diameter (',F6.1,' channels) to optical one',/,'(',F5.2,' arc min) ratio assumed 1.175',/)" printf,lun,TmodSN0,TmodSN1,1/TmodSN0,1/TmodSN1,format= $ "('Period of the beam-induced modulation = ',F6.2,' (fmin) ... ',/,F6.2,' (fmax) sec',' (frequency = ',F6.2,' ... ',F6.2,' Hz)',/)" printf,lun,TneighSN,format=$ "('Interval between passages of neighbouring orders = ',F6.1,' sec',/)" printf,lun,TPassBeamSN,format= $ "('Duration of passing beam S-N = ',F4.1,' sec',/,/)" free_lun,lun flush,lun if not keyword_set(silent) then xtext,file=Filename,group=group_leader exit: parameters={Date:Date, Time:Time, Rec:Receiver, $ A_EW:A_EW, G_EW:G_EW, A_SN:A_SN, G_SN:G_SN, $ BeamEW:RoEW, BeamEWchan:RoEW/SpacingEW, $ SpacingEW:SpacingEW, TmodEW:[TmodEW0,TmodEW1], $ BeamSN:RoSN, BeamSNchan:RoSN/SpacingSN, $ SpacingSN:SpacingSN, TmodSN:[TmodSN0,TmodSN1]} end ####################################################### function pathname, file, all = all ;+ ; ; NAME: ; PATHNAME ; ; PURPOSE: ; ; Returns pathname of directories ; containing specified files. ; Input argument - filenames with their full pathnames ; ; CATEGORY: ; File reading ; ; CALLING SEQUENCE: ; PNAME = PATHNAME(file) ; ; INPUTS: ; File name. This array may be of ASCII code. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; ALL - output all pathnames of the file set ; ; OUTPUTS: ; String array ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; PROCEDURE: ; Straightforward. ;- CASE strlowcase(!version.os_family) OF 'windows': Delim='\' 'unix': Delim='/' ELSE: begin message, 'Not supported on this platform.' end ENDCASE pos = rstrpos(file, Delim) N = n_elements(file) subdirs = strarr(N) for j=0, N-1 do subdirs[j] = strmid(file[j], 0, pos[j]) if not keyword_set(all) then subdirs = subdirs[uniq(subdirs, sort(subdirs))] if n_elements(subdirs) eq 1 then subdirs = subdirs[0] return, subdirs end ####################################################### function peak_coord, array ;+ ; NAME: ; PEAK_COORD ; ; PURPOSE: ; Measurement of coordinates of the pixel which has the maximum value in a ; 2-dimensional array or in each of slices in a 3-dimensional array. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; Result = PEAK_COORD(Array) ; ; INPUTS: ; Image: A 2- or 3-dimensional array to be analyzed. This array may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; None. ; ; KEYWORD PARAMETERS: ; None. ; ; OUTPUTS: ; Result: In the case of 2-D input array it is 2-element vector containing coordinates of ; the maximum in the array. In the case of 3-D input array of size (K,L,N) it is a ; (2,N)-dimensional array containing coordinates of the peaks in each slice. The result is ; long integer. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Linear subscript IMAX of the maximum is measured using MAX function. ; Two-dimensional coordinates are then found as [IMAX mod K, IMAX / K]. In the ; case of 3-D array, the loop is executed over the number N. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, 1999. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ;- Sz=size(array) if Sz(0) eq 2 then begin amax = max(array, imax) return, ([imax mod Sz(1), imax /Sz(1)]) endif else begin maxima = intarr(2, Sz(Sz(0))) for j=0, Sz(Sz(0))-1 do begin amax = max(array(*,*,j), imax) maxima(*,j) = [imax mod Sz(1), imax /Sz(1)] endfor return, maxima endelse end ####################################################### pro pic_dig,array,x_out,y_out,mode,ymin,ymax ;mode 0-low,1-mean,2- high Sz=size(array) if Sz(0) lt 2 or n_params() lt 3 then message,'Incorrect call.' ;if (!d.flags and 2L^16) ne 0 then widget_control,/hour t=where(array eq 0) N=n_elements(t) a=subs1to2(t,dim=[Sz(2),Sz(1)]) ind=sort(a(0,*)) x=reform(a(0,ind),N) y=reform(a(1,ind),N) x0=x(uniq(x)) N0=n_elements(x0) Ymean=fltarr(N0) if n_params() eq 5 then begin Ymin=(Ymax=Ymean) for j=0,N0-1 do begin index=where(x eq x0(j)) Ymin(j)=min(y(index),max=tmp) Ymax(j)=tmp Ymean(j)=mean(y(index)) endfor endif else begin Ymin=(Ymax=Ymean) for j=0,N0-1 do begin index=where(x eq x0(j)) Ymean(j)=total(y(index))/n_elements((y(index))) Ymin(j)=min(y(index),max=tmp) Ymax(j)=tmp endfor endelse xmin=min(x0,max=xmax) x_out=xmin+findgen(xmax-xmin+1) ;stop Case mode of 0.0: y_out=interpol(ymin, x0, x_out) 1.0: y_out=interpol(ymean, x0, x_out) 2.0: y_out=interpol(ymax, x0, x_out) EndCase if n_params() eq 5 then begin ymin=interpol(ymin, x0, x_out) ymax=interpol(ymax, x0, x_out) endif end ####################################################### pro pic_plot_load, array, file common pic_plot,ID,Data,a,d,trace,Datado CASE 1 OF n_tags(Data) le 1: file=pickfile(/read,filt='*.gif') Data.file eq '': file=pickfile(/read,filt='*.gif') ELSE: file=pickfile(/read,filt='*.gif',file=Data.file, path=subdir(Data.file)) ENDCASE if file eq '' then return widget_control,/hour read_gif,file,array array=bytscl(array) end pro pic_plot_event,ev common pic_plot,ID,Data,a,d,trace,Datado CASE !version.OS OF 'windows': color=255 'Win32': color=255 ELSE: color=127 ENDCASE Sz=size(Data.array) CASE ev.id OF ID.Draw(0): begin wset,ID.Win(0) if n_elements(Data.array) lt 1000 then return widget_control,ID.Label(0),set_val=string(ev.x,ev.y,format="(i4,', ',i4)") device,/cursor_cross if ev.press then Data.press=1 if ev.release then Data.press=0 IF Data.press THEN BEGIN device,set_gr=6 if Data.New eq 0 then begin plots, [0,Sz(1)-1],[1,1]*Data.xy(1),/dev, col=color plots, [1,1]*Data.xy(0),[0,Sz(2)-1],/dev, col=color endif Data.New=0 Data.xy=[ev.x, ev.y] plots, [0,Sz(1)-1],[1,1]*Data.xy(1),/dev, col=color plots, [1,1]*Data.xy(0),[0,Sz(2)-1],/dev, col=color device,set_gr=3 ENDIF return end ID.Draw(1): begin wset,ID.Win(1) if id.Mode eq 'Mark' then begin CASE ID.Select_Mode OF 'Box': begin tmp=a.a w_box_cursor,ev,xy,init=a.init,cur=tmp a.a=tmp a.init=0 a.xy=xy end 'Trace': begin if ev.press then ID.press=1 if ev.release then ID.press=0 if ID.press eq 0 then return if n_elements(trace) eq 1 then trace=[ev.x, ev.y] else begin trace=[[trace], [ev.x, ev.y]] Sz_tr=size(trace) plots,trace(0,Sz_tr(2)-[1,2]), trace(1,Sz_tr(2)-[1,2]), /dev,col=100 empty endelse end ELSE: begin tmp=a.a w_box_cursor,ev,xy,init=a.init,cur=tmp a.a=tmp a.init=0 a.xy=xy end ENDCASE eNDIF if n_elements(Data.array) lt 1000 then return widget_control,ID.Label(1),set_val=string(ev.x,ev.y,format="(i4,', ',i4)") return end ID.Draw(2): begin window_set,ID.Win(2),sc=Data.Sc device,/cursor_cross xy=convert_coord(ev.x, ev.y, /dev, /to_data) if n_elements(Data.array) lt 1000 then return if Data.Calibrated ne 0 and Data.type eq 'UT' then $ widget_control,ID.Label(2),set_val= $ smh(xy(0), ms=1)+', '+ string(xy(1), format="(g10.4)") $ else widget_control,ID.Label(2),set_val=string(xy(0),xy(1), $ format="(g10.4,', ',g10.4)") device,/cursor_cross return end ELSE: ENDCASE widget_control,ev.id,get_uval=uv CASE uv OF "Box": begin ID.Mode='Mark' ID.Select_Mode='Box' end "Trace": begin ID.Mode='Mark' ID.Select_Mode='Trace' trace=0 end "DONE": begin device,/cursor_cross widget_control,ev.top,/destroy end "Help":begin CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE s=findfile(getenv('help_dir')+Delim+'fpicplot.hlp') IF (s(0) EQ '') then return else xtext,file=getenv('help_dir')+Delim+'fpicplot.hlp',group=ev.top end "Load": begin pic_plot_load, array, file if file eq '' then return widget_control,/hour for j=0,2 do begin widget_control,ID.Draw_base(j),map=([1,0,0])(j) wset,ID.Win(j) erase endfor wset,ID.Win(0) erase tvscl,array Sz=size(array) wset,ID.Win(1) erase device,copy=[0,0,Sz(1),Sz(2),0,0,ID.Win(0)] Data={file:file, array_e:array, array:array, calibrated:0, $ Sc:Data.Sc, Undo:'', type:data.type, xy:Data.xy, press:Data.press, $ x0:Data.x0, x1:Data.x1, x0_d:Data.x0_d, x1_d:Data.x1_d, New:1, Counter:Data.Counter } for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) ;-- empty end "Loade": begin arrayn=Data.array CASE 1 OF n_tags(Data) le 1: file=pickfile(/read,filt='*.sav') Data.file eq '': file=pickfile(/read,filt='*.sav') ELSE: file=pickfile(/read,filt='*.sav', path=subdir(Data.file)) ENDCASE if file eq '' then return widget_control,/hour Restore,file Data={file:Data.file, array_e:Data.array_e, array:arrayn, calibrated:Data.calibrated, $ Sc:Data.Sc, Undo:Data.Undo, type:data.type, xy:Data.xy, press:Data.press, $ x0:Data.x0, x1:Data.x1, x0_d:Data.x0_d, x1_d:Data.x1_d, New:Data.New, Counter:Data.Counter } array = arrayn array_e=Data.array_e widget_control,/hour for j=0,2 do begin widget_control,ID.Draw_base(j),map=([1,0,0])(j) wset,ID.Win(j) erase endfor wset,ID.Win(0) erase tvscl,Data.array wset,ID.Win(1) erase tvscl,Data.array_e Sz=size(array) for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) empty end "Save": begin CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE path=subdir(Data.file) New_file=path+Delim+ $ newfilename(model=(name_extract(Data.file))(1),filt='*.dig') file=pickfile(/read,filt='*.dig',file=New_file, path=path) if file eq '' then return widget_control,/hour openw,lun,file,/get_lun writeu,lun,Data.x, Data.y free_lun,lun end "SaveE": begin CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE path=subdir(Data.file) New_file=path+Delim+ $ newfilename(model=(name_extract(Data.file))(1),filt='*.sav') file=pickfile(/read,filt='*.sav',file=New_file, path=path) if file eq '' then return widget_control,/hour save,Data,a,filename=new_file end "Initial": begin for j=0,2 do widget_control,ID.Draw_base(j),map=([1,0,0])(j) wset,ID.Win(0) widget_control,ID.InputX0,/input_focus end "Edited": begin for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) end "Converted": begin for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) wset,ID.Win(2) end "Outside": begin CASE ID.Select_Mode OF 'Trace': begin SzT=size(TRACE) V_x=[transpose(trace(0,*)), trace(0,0)] V_y=[transpose(trace(1,*)), trace(1,0)] ;V_x=[transpose(trace(0,*) < (SzT(1)-1)>0 ), trace(0,0)] ;V_y=[transpose(trace(1,*) < (SzT(1)-1)>0 ), trace(1,0)] trace=0 Szx=size(Data.array) factor=float(!d.x_size)/Szx(1) Dataf=Data.array_e AP=polyfillv(V_x/factor, V_y/factor, !d.x_size/factor, !d.y_size/factor) SzAp=size(AP) IF SzAP(0) eq 0 then return Dataf(polyfillv(V_x/factor, V_y/factor, !d.x_size/factor, !d.y_size/factor))=255b indd=where(Dataf ne 255b) widget_control,/hour Data.array_e(indd)=255b ;----- a.init=1 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross Data.Undo=uv end 'Box': begin Data.array=Data.array_e widget_control,/hour Sz=size(Data.array) Data.array_e(0:a.xy(0,0) < (Sz(1)-1) > 0,*)=255b Data.array_e(a.xy(1,0) < (Sz(1)-1) > 0:*,*)=255b Data.array_e(*,0:a.xy(0,1) < (Sz(2)-1) > 0)=255b Data.array_e(*,a.xy(1,1) < (Sz(2)-1) > 0:*)=255b a.init=1 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross Data.Undo=uv end endcase end "Cut": begin CASE ID.Select_Mode OF 'Trace': begin Datado=Data.array_e V_x=[transpose(trace(0,*)), trace(0,0)] V_y=[transpose(trace(1,*)), trace(1,0)] trace=0 Szx=size(Data.array) factor=float(!d.x_size)/Szx(1) AP=polyfillv(V_x/factor, V_y/factor, !d.x_size/factor, !d.y_size/factor) SzAp=size(AP) IF SzAP(0) eq 0 then return Data.array_e(polyfillv(V_x/factor, V_y/factor, !d.x_size/factor, !d.y_size/factor))=255b wset,ID.Win(1) empty ;----- a.init=1 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross Data.Undo=uv end 'Box': begin Data.array=Data.array_e widget_control,/hour Sz=size(Data.array) Data.array_e(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0)=255b a.init=1 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross Data.Undo=uv end ELSE: RETURN ENDCASE end "Invert": begin Data.array=Data.array_e widget_control,/hour Sz=size(Data.array) Data.array_e(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0)= $ 255b-Data.array_e(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0) a.init=1 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross Data.Undo=uv end "Invert_all": begin Data.array=Data.array_e widget_control,/hour Data.array_e=255b-Data.array_e for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross Data.Undo=uv end "Convert": begin for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,/hour ;mode 0-low,1-mean,2- high mode=1.0 pic_dig,Data.array_e,x,y,mode wset,ID.Win(2) plot, x, y, col=0, back=!d.n_colors-1,/yno, /xst scale,temp,/mem Data={file:Data.file, calibrated:Data.calibrated, $ array_e:Data.array_e, array:Data.array, $ Sc:Data.Sc, Undo:Data.Undo, type:Data.type, xy:Data.xy, $ press:Data.press, x0:Data.x0, x1:Data.x1, x:x, y:y, $ x0_d:Data.x0_d, x1_d:Data.x1_d, New:Data.New, Counter:Data.Counter} array=0 Data.Sc=temp empty device,/cursor_cross widget_control, ID.InputX0, sens=1 widget_control, ID.InputX1, sens=1 widget_control, ID.InputY0, sens=1 widget_control, ID.InputY1, sens=1 widget_control,Id.info,set_val='Move to mode "Initial Image" and input coordinates x,y' end "Convertl": begin for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,/hour ;mode 0-low,1-mean,2- high mode=0.0 pic_dig,Data.array_e,x,y,mode wset,ID.Win(2) plot, x, y, col=0, back=!d.n_colors-1,/yno, /xst scale,temp,/mem Data={file:Data.file, calibrated:Data.calibrated, $ array_e:Data.array_e, array:Data.array, $ Sc:Data.Sc, Undo:Data.Undo, type:Data.type, xy:Data.xy, $ press:Data.press, x0:Data.x0, x1:Data.x1, x:x, y:y, $ x0_d:Data.x0_d, x1_d:Data.x1_d, New:Data.New, Counter:Data.Counter} array=0 Data.Sc=temp empty device,/cursor_cross widget_control, ID.InputX0, sens=1 widget_control, ID.InputX1, sens=1 widget_control, ID.InputY0, sens=1 widget_control, ID.InputY1, sens=1 widget_control,Id.info,set_val='Move to mode "Initial Image" and input coordinates x,y' end "Converth": begin for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,/hour ;mode 0-low,1-mean,2- high mode=2.0 pic_dig,Data.array_e,x,y,mode wset,ID.Win(2) plot, x, y, col=0, back=!d.n_colors-1,/yno, /xst scale,temp,/mem Data={file:Data.file, calibrated:Data.calibrated, $ array_e:Data.array_e, array:Data.array, $ Sc:Data.Sc, Undo:Data.Undo, type:Data.type, xy:Data.xy, $ press:Data.press, x0:Data.x0, x1:Data.x1, x:x, y:y, $ x0_d:Data.x0_d, x1_d:Data.x1_d, New:Data.New, Counter:Data.Counter} array=0 Data.Sc=temp empty device,/cursor_cross widget_control, ID.InputX0, sens=1 widget_control, ID.InputX1, sens=1 widget_control, ID.InputY0, sens=1 widget_control, ID.InputY1, sens=1 widget_control,Id.info,set_val='Move to mode "Initial Image" and input coordinates x,y' end "x0": begin widget_control,ID.InputX0,get_val=tmp Data.x0(0)=strtrim(tmp(0),2) Data.x0_d=Data.xy widget_control,ID.InputY0,/input_focus Data.Counter=Data.Counter+1 if Data.Counter eq 4 then begin widget_control, ID.Calibrate, sens=1 widget_control, ID.Calibratex, sens=1 widget_control, ID.Calibratey, sens=1 widget_control, ID.Calibratexy, sens=1 widget_control,Id.info,set_val='Choose sort of calibration and move to corresponding mode' Data.Counter=0 endif end "y0": begin widget_control,ID.InputY0,get_val=tmp Data.x0(1)=strtrim(tmp(0),2) Data.x0_d=Data.xy widget_control,ID.InputX1,/input_focus Data.Counter=Data.Counter+1 if Data.Counter eq 4 then begin widget_control, ID.Calibrate, sens=1 widget_control, ID.Calibratex, sens=1 widget_control, ID.Calibratey, sens=1 widget_control, ID.Calibratexy, sens=1 widget_control,Id.info,set_val='Choose sort of calibration and move to corresponding mode' Data.Counter=0 endif end "x1": begin widget_control,ID.InputX1,get_val=tmp Data.x1(0)=strtrim(tmp(0),2) Data.x1_d=Data.xy widget_control,ID.InputY1,/input_focus Data.Counter=Data.Counter+1 if Data.Counter eq 4 then begin widget_control, ID.Calibrate, sens=1 widget_control, ID.Calibratex, sens=1 widget_control, ID.Calibratey, sens=1 widget_control, ID.Calibratexy, sens=1 widget_control,Id.info,set_val='Choose sort of calibration and move to corresponding mode' Data.Counter=0 endif end "y1": begin widget_control,ID.InputY1,get_val=tmp Data.x1(1)=strtrim(tmp(0),2) Data.x1_d=Data.xy Data.Counter=Data.Counter+1 if Data.Counter eq 4 then begin widget_control, ID.Calibrate, sens=1 widget_control, ID.Calibratex, sens=1 widget_control, ID.Calibratey, sens=1 widget_control, ID.Calibratexy, sens=1 widget_control,Id.info,set_val='Choose sort of calibration and move to corresponding mode' Data.Counter=0 endif end "Calibrate": begin if strpos(Data.X0(0),':') lt 0 and strpos(Data.X0(0),' ') lt 0 then $ x0=float(Data.X0(0)) else begin x0=hms(Data.X0(0))*3600d0 Data.type='UT' endelse if strpos(Data.X0(1),':') lt 0 and strpos(Data.X0(1),' ') lt 0 then $ y0=float(Data.X0(1)) else begin y0=hms(Data.X0(1))*3600d0 Data.type='UT' endelse if strpos(Data.X1(0),':') lt 0 and strpos(Data.X1(0),' ') lt 0 then $ x1=float(Data.X1(0)) else begin x1=hms(Data.X1(0))*3600d0 Data.type='UT' endelse if strpos(Data.X1(1),':') lt 0 and strpos(Data.X1(1),' ') lt 0 then $ y1=float(Data.X1(1)) else y1=hms(Data.X1(1))*3600d0 Data.x=(Data.x-Data.x0_d(0))/(Data.x1_d(0)-Data.x0_d(0))*(x1-x0)+x0 Data.y=(Data.y-Data.x0_d(1))/(Data.x1_d(1)-Data.x0_d(1))*(y1-y0)+y0 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,/hour wset,ID.Win(2) if Data.type eq 'UT' then xtickform='t_ticks0' else xtickform='' plot, Data.x, Data.y, col=0, back=!d.n_colors-1, /yno, xtickf=xtickform, /xst Data.calibrated=1 scale,temp,/mem Data.Sc=temp empty device,/cursor_cross end "Calibratexy": begin if strpos(Data.X0(0),':') lt 0 and strpos(Data.X0(0),' ') lt 0 then $ x0=float(Data.X0(0)) else begin x0=hms(Data.X0(0))*3600d0 Data.type='UT' endelse if strpos(Data.X0(1),':') lt 0 and strpos(Data.X0(1),' ') lt 0 then $ y0=float(Data.X0(1)) else begin y0=hms(Data.X0(1))*3600d0 Data.type='UT' endelse if strpos(Data.X1(0),':') lt 0 and strpos(Data.X1(0),' ') lt 0 then $ x1=float(Data.X1(0)) else begin x1=hms(Data.X1(0))*3600d0 Data.type='UT' endelse if strpos(Data.X1(1),':') lt 0 and strpos(Data.X1(1),' ') lt 0 then $ y1=float(Data.X1(1)) else y1=hms(Data.X1(1))*3600d0 if x0 le 0 or x1 le 0 or y0 le 0 or y1 le 0 then begin widget_control,Id.info,set_val='x,y must be greater 0,input x and y again' return endif x1=alog10(x1) x0=alog10(x0) y1=alog10(y1) y0=alog10(y0) if (Data.x1_d(0) eq Data.x0_d(0))$ or (Data.x1_d(1) eq Data.x0_d(1))$ or (x1 eq x0) or (y1 eq y0) then begin widget_control,Id.info,set_val='x,y must be greater 0,input x and y again' return end Data.x=10^((Data.x-Data.x0_d(0))/(Data.x1_d(0)-Data.x0_d(0))*(x1-x0)+x0) Data.y=10^((Data.y-Data.x0_d(1))/(Data.x1_d(1)-Data.x0_d(1))*(y1-y0)+y0) for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,Id.info,set_val='' widget_control,/hour wset,ID.Win(2) plot, Data.x, Data.y, col=0, back=!d.n_colors-1, /yno, /xst,yty=1,xty=1 Data.calibrated=1 scale,temp,/mem Data.Sc=temp empty device,/cursor_cross end "Calibratey": begin if strpos(Data.X0(0),':') lt 0 and strpos(Data.X0(0),' ') lt 0 then $ x0=float(Data.X0(0)) else begin x0=hms(Data.X0(0))*3600d0 Data.type='UT' endelse if strpos(Data.X0(1),':') lt 0 and strpos(Data.X0(1),' ') lt 0 then $ y0=float(Data.X0(1)) else begin y0=hms(Data.X0(1))*3600d0 Data.type='UT' endelse if strpos(Data.X1(0),':') lt 0 and strpos(Data.X1(0),' ') lt 0 then $ x1=float(Data.X1(0)) else begin x1=hms(Data.X1(0))*3600d0 Data.type='UT' endelse if strpos(Data.X1(1),':') lt 0 and strpos(Data.X1(1),' ') lt 0 then $ y1=float(Data.X1(1)) else y1=hms(Data.X1(1))*3600d0 if y0 le 0 or y1 le 0 then begin widget_control,Id.info,set_val='y must be greater 0,input y again' return endif y1=alog10(y1) y0=alog10(y0) if (Data.x1_d(0) eq Data.x0_d(0))$ or (Data.x1_d(1) eq Data.x0_d(1))$ or (x1 eq x0) or (y1 eq y0) then begin widget_control,Id.info,set_val='x,y is incorrect,input x and y again' return end Data.x=(Data.x-Data.x0_d(0))/(Data.x1_d(0)-Data.x0_d(0))*(x1-x0)+x0 Data.y=10^((Data.y-Data.x0_d(1))/(Data.x1_d(1)-Data.x0_d(1))*(y1-y0)+y0) for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,Id.info,set_val='' widget_control,/hour wset,ID.Win(2) plot, Data.x, Data.y, col=0, back=!d.n_colors-1, /yno, /xst,yty=1;,xty=1 Data.calibrated=1 scale,temp,/mem Data.Sc=temp empty device,/cursor_cross end "Calibratex": begin if strpos(Data.X0(0),':') lt 0 and strpos(Data.X0(0),' ') lt 0 then $ x0=float(Data.X0(0)) else begin x0=hms(Data.X0(0))*3600d0 Data.type='UT' endelse if strpos(Data.X0(1),':') lt 0 and strpos(Data.X0(1),' ') lt 0 then $ y0=float(Data.X0(1)) else begin y0=hms(Data.X0(1))*3600d0 Data.type='UT' endelse if strpos(Data.X1(0),':') lt 0 and strpos(Data.X1(0),' ') lt 0 then $ x1=float(Data.X1(0)) else begin x1=hms(Data.X1(0))*3600d0 Data.type='UT' endelse if strpos(Data.X1(1),':') lt 0 and strpos(Data.X1(1),' ') lt 0 then $ y1=float(Data.X1(1)) else y1=hms(Data.X1(1))*3600d0 if x0 le 0 or x1 le 0 then begin widget_control,Id.info,set_val='x must be greater 0,input x again' return endif x1=alog10(x1) x0=alog10(x0) if (Data.x1_d(0) eq Data.x0_d(0))$ or (Data.x1_d(1) eq Data.x0_d(1))$ or (x1 eq x0) or (y1 eq y0) then begin widget_control,Id.info,set_val='x,y incorrect,input x and y again' return end Data.x=10^((Data.x-Data.x0_d(0))/(Data.x1_d(0)-Data.x0_d(0))*(x1-x0)+x0) Data.y=(Data.y-Data.x0_d(1))/(Data.x1_d(1)-Data.x0_d(1))*(y1-y0)+y0 for j=0,2 do widget_control,ID.Draw_base(j),map=([0,0,1])(j) widget_control,Id.info,set_val='' widget_control,/hour wset,ID.Win(2) plot, Data.x, Data.y, col=0, back=!d.n_colors-1, /yno, /xst,xty=1 Data.calibrated=1 scale,temp,/mem Data.Sc=temp empty device,/cursor_cross end "Undo": begin widget_control,/hour Sz=size(Data.array) CASE Data.Undo OF "Invert": begin tmp=Data.array_e Data.array_e(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0)= $ 255b-Data.array(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0) end "Cut": begin;*** CASE ID.Select_Mode OF 'Box': begin tmp=Data.array_e Data.array_e(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0)= $ Data.array(a.xy(0,0) < (Sz(1)-1) > 0:a.xy(1,0) < (Sz(1)-1) > 0, $ a.xy(0,1) < (Sz(2)-1) > 0:a.xy(1,1) < (Sz(2)-1) > 0) end 'Trace': begin tmp=Data.array_e Data.array_e=Datado end endcase end "Outside": begin tmp=Data.array_e Data.array_e(0:a.xy(0,0) < (Sz(1)-1) > 0,*)= $ Data.array(0:a.xy(0,0) < (Sz(1)-1) > 0,*) Data.array_e(a.xy(1,0) < (Sz(1)-1) > 0:*,*)= $ Data.array(a.xy(1,0) < (Sz(1)-1) > 0:*,*) Data.array_e(*,0:a.xy(0,1) < (Sz(2)-1) > 0)= $ Data.array(*,0:a.xy(0,1) < (Sz(2)-1) > 0) Data.array_e(*,a.xy(1,1) < (Sz(2)-1) > 0:*)= $ Data.array(*,a.xy(1,1) < (Sz(2)-1) > 0:*) end "Invert_all": begin tmp=Data.array_e Data.array_e=255b-Data.array_e end ELSE: ENDCASE Data.array=tmp for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) wset,ID.Win(1) tvscl,Data.array_e empty device,/cursor_cross a.init=1 end ELSE: ENDCASE end pro pic_plot,group_leader=group_leader common pic_plot,ID,Data,a,d,trace,Datado if n_elements(group_leader) le 0 then group_leader=0L ID={Draw:[0L,0L,0L], Win:[0L,0L,0L], draw_base:[0L,0L,0L], $ Mode:'Init',Mark:0L, Select_Mode:'Box',$ g_leader:group_leader, Label:[0L,0L,0L], $ Load:0L,Loade:0L, Convert:0L,Convertl:0L,Converth:0L,Calibrate:0L, Save:0L,Savee:0L,press:0, $ Cut:0L, Invert_all:0L, Invert:0L, Outside:0L, $ Initial:0L, Edited:0L, Converted:0L,Calibratexy:0L,Calibratey:0L,Calibratex:0L, $ InputX0:0L, InputY0:0L, InputX1:0L, InputY1:0L,Info:0L} pic_plot_load, array, file if file eq '' then return Data={file:file, array_e:array, $ array:array, xy:fltarr(2), $ Sc:{Axes, x:!x, y:!y, z:!z, map:!map}, $ Undo:'', type:'', press:0, calibrated:0, $ x0:strarr(2), x1:strarr(2), $ x0_d:fltarr(2), x1_d:fltarr(2), New:1, Counter:0,$ factor:1., Triangle:fltarr(2,4), $; Attempt:0, Max:0., Scaling:0, $; Plot_Mean:0., Plot_Min:0., Plot_Max:0., Plot_factor:1.} bm_box= [ $ [000B, 000B], $ [000B, 000B], $ [000B, 000B], $ [248B, 031B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [248B, 031B], $ [000B, 000B], $ [000B, 000B], $ [000B, 000B] $ ] bm_trace= [ $ [000B, 000B], $ [192B, 001B], $ [032B, 002B], $ [016B, 004B], $ [008B, 008B], $ [008B, 016B], $ [008B, 032B], $ [004B, 032B], $ [004B, 032B], $ [004B, 032B], $ [004B, 016B], $ [004B, 008B], $ [008B, 008B], $ [112B, 008B], $ [128B, 007B], $ [000B, 000B] $ ] init_structure={w_b_state, $ x:0, y:0, press:0, first:1, Xc:[0.,0.], Yc:[0.,0.], $ Output:intarr(2,2), stretch:0., move:0.} a={init:1, xy:intarr(2,2), a:init_structure} Sz=size(temporary(array)) base=widget_base(/colu,group=group_leader, $ tit='Converter of an image into array') Menu_base=widget_base(base,/row) Emptystring=' ' Em=Emptystring+Emptystring+Emptystring label_size=Em+Em ;if font ne '' then if fontsize le 16 then label_size=label_size+Emptystring junk=widget_button(Menu_base, val="DONE", uv="DONE") junk=widget_button(Menu_base, val="File", /menu) ID.Load=widget_button(junk, val="Load", uv="Load") ID.Loade=widget_button(junk, val="Load Interim Image", uv="Loade") ID.Convert=widget_button(junk, val="Convert mean", uv="Convert") ID.Convertl=widget_button(junk, val="Convert low", uv="Convertl") ID.Converth=widget_button(junk, val="Convert high", uv="Converth") ID.Calibrate=widget_button(junk, val="Calibrate linear", uv="Calibrate") ID.Calibratexy=widget_button(junk, val="Calibrate Logarithmic (xy)", uv="Calibratexy") ID.Calibratex=widget_button(junk, val="Calibrate Logarithmic (x)", uv="Calibratex") ID.Calibratey=widget_button(junk, val="Calibrate Logarithmic (y)", uv="Calibratey") ID.Save=widget_button(junk, val="Save", uv="Save") ID.Savee=widget_button(junk, val="Save Interim Image", uv="SaveE") junk=widget_button(Menu_base, val="Edit", /menu) ID.Cut=widget_button(junk, val="UNDO", uv="Undo") ID.Cut=widget_button(junk, val="Cut", uv="Cut") ID.Invert_all=widget_button(junk, val="Invert all", uv="Invert_all") ID.Invert=widget_button(junk, val="Invert", uv="Invert") ID.Outside=widget_button(junk, val="Erase outside", uv="Outside") junk=widget_button(Menu_base,val="Window", /menu) junk1=widget_button(junk, val="Initial Image", uv='Initial') junk1=widget_button(junk, val="Edited Image", uv='Edited') junk1=widget_button(junk, val="Converted", uv="Converted") junk=widget_button(Menu_base,val="Help", uv='Help') Id.info=widget_label(Menu_base,val=label_size,/fra) ;!,font=font) input_base=widget_base(base,/row) ;edit_base=widget_base(menu_base,/row) junk=widget_label(input_base,val='x0') ID.inputX0=widget_text(input_base,val=' ', xs=10, /edit, uval='x0', /frame) junk=widget_label(input_base,val='y0') ID.inputY0=widget_text(input_base,val=' ', xs=10, /edit, uval='y0', /frame) junk=widget_label(input_base,val='x1') ID.inputX1=widget_text(input_base,val=' ', xs=10, /edit, uval='x1', /frame) junk=widget_label(input_base,val='y1') ID.inputY1=widget_text(input_base,val=' ', xs=10, /edit, uval='y1', /frame) button=widget_button(input_base, val=bm_box, uval='Box') button=widget_button(input_base, val=bm_trace, uval='Trace') widget_control, ID.InputX0, sens=0 widget_control, ID.InputX1, sens=0 widget_control, ID.InputY0, sens=0 widget_control, ID.InputY1, sens=0 device,get_scr=scr Draw_size=[scr(0)*0.96,scr(1)*0.75] Scroll=(Draw_size(0) le Sz(1)) or (Draw_size(1) le Sz(2)) Plain_base=widget_base(base) for j=0,2 do begin ID.Draw_base(j)=widget_base(Plain_base,/colu) if scroll then $ ID.draw(j)=widget_draw(ID.Draw_base(j), xs=Sz(1), ys=Sz(2), $ uv='Window'+strtrim(j,2), /motion, /button, /fra, /scroll, $ x_scroll=Draw_size(0), y_scroll=Draw_size(1)) else $ ID.draw(j)=widget_draw(ID.Draw_base(j), xs=Draw_size(0),ys=Draw_size(1), $ uv='Window'+strtrim(j,2), /motion, /button, /fra) junk=widget_base(ID.Draw_base(j),/row) Label=widget_label(junk, val=(['Initial','Edited','Converted'])(j)+' ') ID.Label(j)=widget_label(junk, /fra, val=' ',xs=Draw_size(0)-100) endfor for j=0,2 do widget_control,ID.Draw_base(j),map=([1,0,0])(j) widget_control, ID.Calibrate, sens=0 widget_control, ID.Calibratex, sens=0 widget_control, ID.Calibratey, sens=0 widget_control, ID.Calibratexy, sens=0 widget_control,base,/real,/hour widget_control, Id.info, set_val='Choose mode drawing and take away spare lines and do "File"-"Convert"' for j=0,2 do begin widget_control,ID.draw(j),get_val=tmp ID.Win(j)=tmp wset, tmp tvscl,data.array endfor wset,ID.Win(2) plot,indgen(10),/nod,xst=4,yst=4, /noer scale,temp,/mem Data.Sc=temp wset,ID.Win(1) for j=0,2 do widget_control,ID.Draw_base(j),map=([0,1,0])(j) empty xmanager,'pic_plot',base,group=group_leader end ####################################################### pro plotframe, center, dx, dy, device = device, data = data, $ normal = normal, linestyle = linestyle, thick = thick, $ color = color, noclip = noclip if n_params() lt 3 then dy = dx if n_elements(device) le 0 then device = 0 if n_elements(normal) le 0 then normal = 0 if n_elements(data) le 0 then data = 1-(device or normal) if n_elements(linestyle) le 0 then linestyle = !p.linestyle if n_elements(thick) le 0 then thick = !p.thick if n_elements(color) le 0 then color = !p.color if n_elements(noclip) le 0 then noclip = 1 plots, center(0)-dx/2., center(1)+[-dy/2., dy/2.-1], $ device = device, data = data, $ normal = normal, linestyle = linestyle, thick = thick, $ color = color, noclip = noclip plots, center(0)+dx/2.-1, center(1)+[-dy/2., dy/2.-1], $ device = device, data = data, $ normal = normal, linestyle = linestyle, thick = thick, $ color = color, noclip = noclip plots, center(0)+[-dx/2., dx/2.-1], center(1)-dy/2., $ device = device, data = data, $ normal = normal, linestyle = linestyle, thick = thick, $ color = color, noclip = noclip plots, center(0)+[-dx/2., dx/2.-1], center(1)+dy/2.-1, $ device = device, data = data, $ normal = normal, linestyle = linestyle, thick = thick, $ color = color, noclip = noclip end ####################################################### pro plotline,k_in,centre,linestyle=linestyle,color=color, $ device=device,normal=normal,data=data,clip=clip,noclip=noclip, $ thick=thick ; Plots a straight line through a point given having ; an inclination required. if N_elements(linestyle) le 0 then linestyle=0 if N_elements(color) le 0 then color=!p.color if N_elements(thick) le 0 then thick=!p.thick Xb=float(!x.window)*!d.x_vsize Yb=float(!y.window)*!d.y_vsize CASE 1 OF keyword_set(noclip): cl= $ transpose([[0,!d.x_vsize], [0,!d.y_vsize]]) (N_elements(clip) le 0): cl= $ transpose([[Xb],[Yb]]) ELSE: cl=(convert_coord(clip([[0,1],[2,3]]), $ device=device, data=data, normal=normal, /to_dev))([0,1],*) ENDCASE Xb=cl([0,2]) & Yb=cl([1,3]) cen=(convert_coord(centre,device=device,data=data, $ normal=normal, /to_dev))([0,1]) CASE 1 OF keyword_set(device): k1=1. keyword_set(normal): k1=float(!d.y_vsize)/!d.x_vsize ELSE: k1=(Yb(1)-Yb(0))/(Xb(1)-Xb(0)) ENDCASE k=(k_in+(k_in eq 0)*1e-7)*k1 B=cen(1)-k*cen(0) X0=(Yb(1)-B)/k < (Yb(0)-B)/k > Xb(0) < Xb(1) X1=(Yb(1)-B)/k > (Yb(0)-B)/k < Xb(1) > Xb(0) Y0=k*X0+B > Yb(0) < Yb(1) Y1=k*X1+B < Yb(1) > Yb(0) CASE 1 OF abs(k) gt 1.e+3: Z=[[X0,X0],[Yb]] abs(k) lt 1.e-3: Z=[[Xb],[Y0,Y0]] ELSE: Z=[[X0,X1],[Y0,Y1]] ENDCASE plots,transpose(Z),/dev,linestyle=linestyle,col=color,thick=thick end ####################################################### pro plotset, x, y, linestyle = linestyle, color = color, thick = thick, $ data = data, normal = normal, device = device if n_elements(linestyle) le 0 then linestyle = !p.linestyle if n_elements(color) le 0 then color = !p.color if n_elements(thick) le 0 then thick = !p.thick if !y.type eq 0 then yrange = !y.crange else yrange = 10.^!y.crange CASE n_params() OF 1: for j=0, n_elements(x)-1 do plots, x(j), yrange, $ linestyle = linestyle, color = color, thick = thick, $ normal = keyword_set(normal), device = keyword_set(device) 2: for j=0, n_elements(y) < n_elements(x)-1 do $ plots, x(y(j) < (n_elements(x)-1)), yrange, $ linestyle = linestyle, color = color, thick = thick, $ normal = keyword_set(normal), device = keyword_set(device) 0: begin message, 'Nothing to plot' return end ELSE: begin message, 'Too many parameters' return end ENDCASE end ####################################################### pro plot_break,x,y,x_break=x_break,y_break=y_break, $ subs_break=subs_break,xrange=xrange,yrange=yrange,noclip=noclip, $ color=color,linestyle=linestyle,title=title,psym=psym, $ subtitle=subtitle,font=font,xmargin=xmargin,ymargin=ymargin, $ xminor=xminor,yminor=yminor,xticks=xticks,xstyle=xstyle, $ yticks=yticks,ystyle=ystyle,xtitle=xtitle,ytitle=ytitle, $ xtickv=xtickv,ytickv=ytickv,xtickn=xtickn,ytickn=ytickn, $ symsize=symsize ; Plots a curve having missing points. if n_elements(linestyle) le 0 then linestyle=0 if n_elements(color) le 0 then color=!p.color if n_elements(xstyle) le 0 then xstyle=0 if n_elements(ystyle) le 0 then ystyle=0 if n_elements(noclip) le 0 then noclip=0 if n_elements(title) le 0 then title=' ' if n_elements(subtitle) le 0 then subtitle=' ' if n_elements(font) le 0 then font=-1 if n_elements(xmargin) le 0 then xmargin=[10,3] if n_elements(ymargin) le 0 then ymargin=[4,2] if n_elements(xminor) le 0 then xminor=0 if n_elements(yminor) le 0 then yminor=0 if n_elements(xticks) le 0 then xticks=0 if n_elements(yticks) le 0 then yticks=0 if n_elements(xtitle) le 0 then xtitle='' if n_elements(ytitle) le 0 then ytitle='' if n_elements(xtickv) le 0 then xtickv=0 if n_elements(ytickv) le 0 then ytickv=0 if n_elements(xtickn) le 0 then xtickn='' if n_elements(ytickn) le 0 then ytickn='' if n_elements(psym) le 0 then psym=0 if n_elements(symsize) le 0 then symsize=1 if n_elements(xrange) le 0 then xrange=[min(x),max(x)] if n_elements(yrange) le 0 then yrange=[min(y) < 0, max(y)] CASE 1 OF n_elements(x_break) gt 0: index0=where(x ne x_break) n_elements(y_break) gt 0: index0=where(y ne y_break) n_elements(subs_break) gt 0: index0= $ where(indgen(n_elements(x)) ne subs_break) ELSE: index0=where(y) ENDCASE split_array,index0,fir=sf,last=sl,num=n plot,[x],[y],/nodata,xrange=xrange,yrange=yrange, $ title=title,subtitle=subtitle,font=font, $ xmargin=xmargin,ymargin=ymargin,xminor=xminor,yminor=yminor, $ xticks=xticks,xstyle=xstyle, yticks=yticks,ystyle=ystyle, $ xtitle=xtitle,ytitle=ytitle, xtickv=xtickv,ytickv=ytickv, $ xtickn=xtickn,ytickn=ytickn N_e=n_elements(x) factor=float(x(N_e-1)-x(0))/(N_e-1) for j=0,n-1 do begin ind=sf(j)+indgen(sl(j)-sf(j)+1) oplot,x(0)+ind*factor,y(sf(j):sl(j)), $ color=color,linestyle=linestyle,noclip=noclip, $ psym=psym,symsize=symsize endfor end ####################################################### pro plot_stick,x,y,xrange=xrange,yrange=yrange,noclip=noclip, $ color=color,linestyle=linestyle,thick=thick,title=title, $ subtitle=subtitle,font=font,xmargin=xmargin,ymargin=ymargin, $ xminor=xminor,yminor=yminor,xticks=xticks,xstyle=xstyle, $ yticks=yticks,ystyle=ystyle,xtitle=xtitle,ytitle=ytitle, $ xtickv=xtickv,ytickv=ytickv,xtickn=xtickn,ytickn=ytickn, $ position=position, normal=normal, data=data, device=device, $ clip=clip, background=background, l_color=l_color, charsize=charsize ; Plots a stick-style plot. x_save=x if n_elements(linestyle) le 0 then linestyle=0 if n_elements(color) le 0 then color=!p.color if n_elements(l_color) le 0 then l_color=!p.color if n_elements(background) le 0 then color=!p.background if n_elements(xstyle) le 0 then xstyle=0 if n_elements(ystyle) le 0 then ystyle=0 if n_elements(noclip) le 0 then noclip=0 if n_elements(title) le 0 then title=' ' if n_elements(subtitle) le 0 then subtitle=' ' if n_elements(font) le 0 then font=-1 if n_elements(xminor) le 0 then xminor=0 if n_elements(yminor) le 0 then yminor=0 if n_elements(xticks) le 0 then xticks=0 if n_elements(yticks) le 0 then yticks=0 if n_elements(xtitle) le 0 then xtitle='' if n_elements(ytitle) le 0 then ytitle='' if n_elements(xtickv) le 0 then xtickv=0 if n_elements(ytickv) le 0 then ytickv=0 if n_elements(xtickn) le 0 then xtickn='' if n_elements(ytickn) le 0 then ytickn='' if n_elements(normal) le 0 then normal=0 if n_elements(data) le 0 then data=1 if n_elements(device) le 0 then device=0 if n_elements(thick) le 0 then thick=1 if n_elements(charsize) le 0 then charsize=!p.charsize if n_elements(xmargin) le 0 then xmargin=[10,3] if n_elements(ymargin) le 0 then ymargin=[4,2] if n_elements(position) le 0 then position= $ [float(xmargin(0))*!d.x_ch_size/!d.x_vsize, $ float(ymargin(0))*!d.y_ch_size/!d.y_vsize, $ 1.-float(xmargin(1))*!d.x_ch_size/!d.x_vsize, $ 1.-float(ymargin(0))*!d.y_ch_size/!d.y_vsize] if n_params() eq 1 then begin y=x x=findgen(n_elements(y)) endif if n_elements(xrange) le 0 then xrange=[min(x),max(x)] if n_elements(yrange) le 0 then yrange=[min(y) < 0, max(y)] plot,x,y,/nodata,xrange=xrange,yrange=yrange, $ title=title,subtitle=subtitle,font=font, $ xmargin=xmargin,ymargin=ymargin,xminor=xminor,yminor=yminor, $ xticks=xticks,xstyle=xstyle, yticks=yticks,ystyle=ystyle, $ xtitle=xtitle,ytitle=ytitle, xtickv=xtickv,ytickv=ytickv, $ xtickn=xtickn,ytickn=ytickn, background=background, $ position=position, normal=normal, data=data, device=device, color=color, $ charsize=charsize if n_elements(clip) le 0 then clip= $ (convert_coord(!P.clip([0, 2]), !P.clip([1, 3]),/dev, /to_data))([0,1,3,4]) j=where((x ge xrange(0)) and (x le xrange(1))) for i=j(0),j(n_elements(j)-1) do plots,[x(i),x(i)],[!y.crange(0),y(i)], $ color=l_color,linestyle=linestyle,noclip=noclip,thick=thick, $ clip=clip x=x_save end ####################################################### pro plot_time,x,range=range,start_time=start_time,Dt=Dt, $ xticks=xticks,model=model,xstyle=xstyle,ystyle=ystyle,yrange=yrange, $ ynozero=ynozero,noclip=noclip,clip=clip,xrange=xrange, $ color=color,linestyle=linestyle,thick=thick,title=title, $ subtitle=subtitle,font=font,xmargin=xmargin,ymargin=ymargin, $ xminor=xminor,yminor=yminor, $ yticks=yticks,xtitle=xtitle,ytitle=ytitle, $ ytickv=ytickv,ytickn=ytickn, noerase=noerase, $ xtickn=xtickn, $ position=position, normal=normal, data=data, device=device, $ psym=psym,symsize=symsize,charsize=charsize,nsum=nsum,nodata=nodata, $ xticklen=xticklen, yticklen=yticklen,background=background ; Plots a temporal series versus absolute time. common time,Tstart,Delta_t,Model_string if n_elements(xtickn) le 0 then xtickformat='ut_ticks' $ else xtickformat='' if n_elements(start_time) le 0 then start_time=0.0d0 if n_elements(Dt) le 0 then Delta_t=1.0d0 else Delta_t=Dt if n_elements(model) le 0 then Model_string='hh:mm:ss.ms' else Model_string=model if n_elements(xticks) le 0 then xticks=4 if n_elements(range) le 0 then range=[0,n_elements(x)-1] if n_elements(xstyle) le 0 then xstyle=0 if n_elements(xticklen) le 0 then xticklen=0 if n_elements(ystyle) le 0 then ystyle=0 if n_elements(xrange) le 0 then xrange=!x.range if n_elements(yrange) le 0 then yrange=!y.range if n_elements(ynozero) le 0 then ynozero=0 if n_elements(linestyle) le 0 then linestyle=0 if n_elements(color) le 0 then color=!p.color if n_elements(background) le 0 then background=!p.background if n_elements(noclip) le 0 then noclip=0 if n_elements(title) le 0 then title=' ' if n_elements(subtitle) le 0 then subtitle=' ' if n_elements(font) le 0 then font=!P.font if n_elements(xminor) le 0 then xminor=0 if n_elements(yminor) le 0 then yminor=0 if n_elements(yticks) le 0 then yticks=0 if n_elements(xtitle) le 0 then xtitle='' if n_elements(ytitle) le 0 then ytitle='' if n_elements(ytickv) le 0 then ytickv=0 if n_elements(yticklen) le 0 then yticklen=0 if n_elements(xtickn) le 0 then xtickn='' if n_elements(ytickn) le 0 then ytickn='' if n_elements(normal) le 0 then normal=0 if n_elements(data) le 0 then data=1 if n_elements(device) le 0 then device=0 if n_elements(thick) le 0 then thick=!P.thick if n_elements(clip) le 0 then clip=!P.clip if n_elements(psym) le 0 then psym=0 if n_elements(symsize) le 0 then symsize=!P.symsize if n_elements(charsize) le 0 then charsize=!P.charsize if n_elements(nsum) le 0 then nsum=1 if n_elements(xmargin) le 0 then xmargin=!x.margin if n_elements(ymargin) le 0 then ymargin=!y.margin if n_elements(nodata) le 0 then nodata=0 Tstart=start_time+range(0)*Delta_t tick=AXIS_DIV(Range,xticks,Minor,/Time,Dt=Delta_t) Tshift=(60d0-((Tstart) mod 60 mod 60))/Delta_t xtickv=Tshift mod tick + dindgen(xticks+1)*tick if xtickv(xticks) gt n_elements(x) then begin xticks=xticks-1 xtickv=xtickv(0:xticks) endif if n_elements(position) le 0 then $ plot,x(range(0):range(1)),xtickf=xtickformat, $ xtickv=xtickv, xticks=xticks,xminor=Minor, $ xstyle=xstyle,ystyle=ystyle,yrange=yrange,ynozero=ynozero, $ title=title,subtitle=subtitle,font=font,xrange=xrange, $ xmargin=xmargin,ymargin=ymargin,yminor=yminor, $ yticks=yticks,xtitle=xtitle,ytitle=ytitle, ytickv=ytickv, $ xtickn=xtickn, $ ytickn=ytickn, nodata=nodata, noerase=noerase, $ normal=normal, data=data, device=device, color=color, $ xticklen=xticklen, yticklen=yticklen, background=background, $ psym=psym,symsize=symsize,charsize=charsize,nsum=nsum else $ plot,x(range(0):range(1)),xtickf=xtickformat, $ xtickv=xtickv, xticks=xticks,xminor=Minor, $ xstyle=xstyle,ystyle=ystyle,yrange=yrange,ynozero=ynozero, $ title=title,subtitle=subtitle,font=font,xrange=xrange, $ xmargin=xmargin,ymargin=ymargin,yminor=yminor, $ yticks=yticks,xtitle=xtitle,ytitle=ytitle, ytickv=ytickv, $ xtickn=xtickn, $ ytickn=ytickn,position=position, nodata=nodata, color=color, $ normal=normal, data=data, device=device, noerase=noerase, $ xticklen=xticklen, yticklen=yticklen, background=background, $ psym=psym,symsize=symsize,charsize=charsize,nsum=nsum empty end ####################################################### pro pl_hist, data bin = max(data)/3e3 Sz = size(data) if Sz(Sz(0)+1) lt 4 then bin = bin > 1 hh = histogram(data, bin = bin, omin = omin) arg = bin*findgen(n_elements(hh))+omin hh = smooth(float(median(hh,3)),3) filtered = fft_filter(hh, 30) peaks = find_peaks(filtered) amax = hh(peaks) sort_ind = reverse(sort(amax)) sky_ind = peaks(sort_ind(1)) qs_ind = peaks(sort_ind(0)) sep = mean(peaks(sort_ind([0,1]))) range = fwhm(arg, hh < hh(sep)) plot, arg, hh, xran = arg(sep) + [-range, range]*0.7 end ####################################################### function profile2, image, point1, point2, arg_x, arg_y, mark = mark Sz=size(image) sx = Sz[1] sy=Sz[2] x = point1[0] y = point1[1] x1 = point2[0] y1 = point2[1] dx = float(x1-x) ;delta x dy = float(y1-y) n = abs(dx) > abs(dy) if n eq 0 then message, 'Zero length line.' ; r = fltarr(n+1) ; if abs(dx) gt abs(dy) then begin if x1 ge x then s=1 else s=-1 sy = (y1-y)/abs(dx) endif else begin if y1 ge y then sy=1 else sy=-1 s = (x1-x)/abs(dy) endelse ; arg = findgen(n+1l) arg_x = long(arg*s+x) ;X values, make into longwords. arg_y = long(arg*sy+y) ;Y values Length = (Sz[0] gt 2)*Sz[3] > 1 prof = make_array(n+1, Length, type = Sz[Sz[0]+1]) im = image[arg_x, arg_y, *] ; for j=0, Length-1 do prof[*, j] = (image[*, *, j])[arg_x, arg_y] for j=0, Length-1 do prof[*, j] = (im[*, *, j])[arg, arg] if keyword_set(mark) then begin tvscl, image[*,*,0] plots, arg_x, arg_y, /dev,/noclip ;Draw the line endif return, prof end ####################################################### function pr_sun, SUN, silent=silent ;+ ; Function PRSUN issues variables containing in the structure ; SUN of type 'SOL_EPHEMERIDE' in the form suitable for reading. ; If keyword parameter SILENT is not set, these variables are ; printed in command log. ;- if strupcase(tag_names(SUN,/str)) ne 'SOL_EPHEMERIDE' then message, $ 'Incorrect type of input variable.' Output=["Current time data, degree:", $ " ", $ "Position angle = "+string(SUN.Dp*!radeg,format="(F6.2)"), $ "Radius = "+string(SUN.R*!radeg*60,format="(F6.2)")+"'", $ "Centre's latitude = "+string(SUN.B0*!radeg,format="(F6.2)"), $ "Centre's Karring. long. = "+string(SUN.Karr*!radeg,format="(F6.1)"), $ "Hour angle = "+string(SUN.H*!radeg,format="(F6.2)"), $ "Declination = "+string(SUN.Decl*!radeg,format="(F6.2)"), $ "Culmination = "+smh(SUN.Tcul*3600d0,/ms)] if not keyword_set(silent) then for j=0,n_elements(Output)-1 do print, Output(j) return, output end ####################################################### function pulse_model, x, rise, decay ; Returns an exponential model of a single pulse of given rise and decay. if n_params() lt 3 then begin print,'You must define rise and decay time' return,0 endif pulse = float(-exp(-x/double(rise)) + exp(-x/double(decay))) > 0 return, pulse/max(pulse) end ####################################################### pro pwd ;+ The routine PWD prints the pathname of working directory. Is quite similar ; to the UNIX command 'pwd'. ;- cd, current=current print, current end ####################################################### function p_to_chan,P,Dir,Receiver, SUN=SUN,Order=Order if n_elements(Receiver) le 0 then Receiver=1 if n_elements(Dir) le 0 then Dir=0 ;E-W D=4.9D0 & C=2.997925D8 & Fi=51.7575D0*!DPi/180 Sum_chan=[180,192] Fmin=chanfreq(1,Receiver) Fmax=chanfreq(Sum_chan(Receiver),Receiver) Order=intarr(4) Ordmin=Fmin*D*Cos(P)/C Ordmax=Fmax*D*Cos(P)/C Ordminmax=[Ordmin,Ordmax] Ordminmax=Ordminmax(sort(Ordminmax)) Ordmin=Ordminmax(0) Ordmax=Ordminmax(1) ; Order(0)=fix(Ordmin+((1-dir)*sign(SUN.H)+dir)) Order(0)=fix(Ordmin-1) Nord=0 ;goto,obhod00 for i=0,2 do begin if(Order(0)+i LE (Ordmax+1)) then begin Nord=i+1 ;Order(i+1)=Order(i)+((1-dir)*sign(SUN.H)+dir) Order(i+1)=Order(i)+1 endif endfor obhod00: goto,obhod01 for i=0,2 do begin if(abs(Order(0))+i LE abs(Ordmax)) then begin Nord=i+1 Order(i+1)=Order(i)+((1-dir)*sign(SUN.H)+dir) endif endfor obhod01: Nord=Nord > 1 Order=Order(0:Nord-1) ;print,Ordmin,Ordmax ;print,Order return,chanfreq((C/(D*cos(P))*Order),Receiver) end ####################################################### function qs_norh, radius, center = center if n_elements(center) ne 2 then center = [256.5, 256.5] widget_control, /hour xt=(yt=fltarr(300)) ;openr, lun, '/home/Grechnev/idl_lib/grlib/rdmodel1.dat', /get openr, lun, 'c:\rsi\idl52\lib\istp\rdmodel1.dat', /get readu, lun, xt, yt free_lun,lun if !version.OS ne 'windows' and !version.OS ne 'Win32' then byteorder, xt, yt, /lsw M=300 dM=15 pix=4.911 yt=[yt, fltarr(dM)] x=fltarr(512, 512) solr=radius/pix solrad=solr*1.2 r=(findgen(M+dM)+1)*solrad/M xt=r/solr for j=0, M+dM-1 do begin N=fix(4*!pi*r(j) > 72*4) t=findgen(N)/(N-1)*2*!pi xx=cos(t)*r(j)+Center(0) yy=sin(t)*r(j)+Center(1) x(xx, yy)=yt(j) endfor x(256-5:256+5, 256-5:256+5) = median(x(256-5:256+5, 256-5:256+5), 3) return, smooth(x,3) end ####################################################### Pro Rdpixg, Image, X0, Y0, Data=Data ;+ ; NAME: ; RDPIXG ; ; PURPOSE: ; Read the value of the pixel under the cursor; display x,y and the pixel value ; ;under ; the cursor; interactively display the X position, Y position, and pixel value ; of the cursor. Modification of the standard routine RDPIX. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; ; RDPIXG, Image [, X0, Y0, Data=Data] ; ; INPUTS: ; Image: The array that represents the image being displayed. This array may be ; of any type. Rather reading pixel values from the display, they are taken ; from this parameter, avoiding scaling difficulties. ; ; OPTIONAL INPUT PARAMETERS: ; X0, Y0: The location of the lower-left corner of the image area on the screen. ; If these parameters are not supplied, they are assumed to be zero. ; ; KEYWORD PARAMETERS: ; DATA: If set and non-zero, data coordinate system is processed established, e.g., ; by the TVCON routine with one argument. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; The X, Y, and value of the pixel under the cursor are continuously displayed. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Instructions are printed and the pixel values are printed as the cursor is moved over ; the image. ; Press the left mouse button to create a new line of output, ; saving the previous line. ; Press the right mouse button to exit the procedure. ; Processing of DATA coordinate system is added. ; Overflow of output format is prevented. ; ; MODIFICATION HISTORY: ; DMS, Dec, 1987. ; Rob Montgomery (rob@hao.ucar.edu), 9/21/92; ; Correct indices for case of !order = 1 ; ; ISTP SD RAS, Feb, 1997. ; Victor Grechnev (Grechnev@iszf.irk.ru): ; Processing of DATA coordinate system is added. ; Overflow of output format is prevented. ; ;- on_error,2 ;Return to caller if an error occurs print,'Press left or center mouse button for new output line." print,'... right mouse button to exit.' s = size(image) if s(0) ne 2 then message, 'Image parameter not 2d.' s(1) = s(1)-1 ;To n-1 s(2) = s(2)-1 !err=0 if n_elements(x0) le 0 then x0 = 0 if n_elements(y0) le 0 then y0 = 0 if s(s(0)+1) ge 4 then form = 'G' else form = 'I' cr = string("15b) ;this codes a newline if !version.release ge 5 and strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then $ form="($,'x=',i4,', y=',i4,', value=',"+form+",a, /)" else $ form="($,'x=',i4,', y=',i4,', value=',"+form+",a)" while !err ne 4 do begin tvrdc,x,y,2,/dev if (!err and 3) ne 0 then begin ;New line? print,form="($,a)",string("12b) while (!err ne 0) do begin wait,.1 & tvrdc,x,y,0,/dev & end endif x = x-x0 & y = y - y0 if keyword_set(data) then begin xy=convert_coord(x,y,/dev,/to_data) x=xy(0) y=xy(1) endif if (x le s(1)) and (y le s(2)) and (x ge 0) and (y ge 0) then begin if (!order eq 1) then yy = s(2) - y else yy = y print,form = form, x,y,Image(x,yy),cr endif endwhile print,form="(/)" end ####################################################### ; $Id: rdpix.pro,v 1.4 1998/01/15 18:43:38 scottm Exp $ ; ; Copyright (c) 1989-1998, Research Systems, Inc. All rights reserved. ; Unauthorized reproduction prohibited. ;Pro RdpixN, Image,X0, Y0 ;Read the value of the pixel under the cursor ;Display x,y and the pixel value under the cursor Pro RdpixN, Image,Image1,Image2,Image3,Image4,Image5,Image6,Image7 ;+ ; NAME: ; RDPIX ; ; PURPOSE: ; Interactively display the X position, Y position, and pixel value ; of the cursor. ; ; CATEGORY: ; Image display. ; ; CALLING SEQUENCE: ; RDPIX, Image [, X0, Y0] ; ; INPUTS: ; Image: The array that represents the image being displayed. This ; array may be of any type. Rather reading pixel values from ; the display, they are taken from this parameter, avoiding ; scaling difficulties. ; ; OPTIONAL INPUT PARAMETERS: ; X0, Y0: The location of the lower-left corner of the image area on ; screen. If these parameters are not supplied, they are ; assumed to be zero. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; The X, Y, and value of the pixel under the cursor are continuously ; displayed. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Instructions are printed and the pixel values are printed as the ; cursor is moved over the image. ; ; Press the left or center mouse button to create a new line of output, ; saving the previous line. ; ; Press the right mouse button to exit the procedure. ; ; MODIFICATION HISTORY: ; DMS, Dec, 1987. ; Rob Montgomery (rob@hao.ucar.edu), 9/21/92; ; Correct indices for case of !order = 1 ; ;- ;print,'Press left or center mouse button for new output line.... right mouse button to exit.' on error,2 ;Return to caller if an error occurs ;print,'HA╞╠╚╥┼ ╦┼┬╙▐ ╚╦╚ ╓┼═╥╨└╦▄═╙▐ ╩╦└┬╚╪╙ ╠█╪╚ ─╦▀ ╟└╧╚╤╚ ╤╥╨╬╩╚>> << ╧╨└┬╙▐ ╩╦└┬╚╪╙ ─╦▀ ┬█╒╬─└' image=image if total(size(image1)) gt 0 then image=[[[image]],[[image1]]] if total(size(image2)) gt 0 then image=[[[image]],[[image2]]] if total(size(image3)) gt 0 then image=[[[image]],[[image3]]] if total(size(image4)) gt 0 then image=[[[image]],[[image4]]] if total(size(image5)) gt 0 then image=[[[image]],[[image5]]] if total(size(image6)) gt 0 then image=[[[image]],[[image6]]] if total(size(image7)) gt 0 then image=[[[image]],[[image7]]] !err=0 ;if n elements(x0) le 0 then x0 = 0 ;if n elements(y0) le 0 then y0 = 0 s = size(image) s[1] = s[1]-1 ;To n-1 s[2] = s[2]-1 if s[s[0]+1] ge 4 then begin form = 'G14.5' form1 = 'F' endif else begin form = 'I' endelse if s[0] eq 2 then repeater = 1 else repeater = string(s[3]) cr = string(15b) ;this codes a newline if s[0] eq 2 then form="("+form+", ' x=',i4,' y=',i4)" else $ form="("+repeater+form+", ' x=',i4,' y=',i4)" buf=bytarr(s[1],15) while !err ne 4 do begin CURSOR,x,y,2,/dev if (!err and 3) ne 0 then begin ;New line? if s[0] eq 2 then print,format = form, Image[x,yy], x,y else $ print,format = form, Image[x,yy,*], x,y while (!err ne 0) do begin wait,.1 & CURSOR,x,y,0,/dev & end endif ;x = x-x0 & ;y = y - y0 if (x le s[1]) and (y le s[2]) and (x ge 0) and (y ge 0) then begin if (!order eq 1) then yy = s[2] - y else yy = y tv, buf, 0,s[2]-12,/DEVICE if s[0] eq 2 then out=string(format = form, Image[x,yy],x,y) else $ out=string(format = form, Image[x,yy,*],x,y) xyouts,0,s[2]-10, out,/DEVICE ;print, out endif endwhile ;print,form="(/)" end ####################################################### function rd_c_log,filename,version=version,log=log,date=date,time=time,error=error F_save=filename filename=strlowcase((name_extract(filename))(0)) if n_elements(version) le 0 then version=0 if n_elements(log) le 0 then log=pickfile(tit='Please select a LOG file') WIDGET_CONTROL,/hour A=[0.,0.,0.] error=0 openr,lun,log,/get_lun File_info=strarr(500) temp='' N_records=0 while not eof(lun) do begin readf,lun,temp File_info(N_records)=temp N_records=N_records+1 endwhile File_info=File_info(0:N_records-1) x=File_info free_lun,lun Found=(j=0) REPEAT BEGIN b=strpos(x(4*j),',') if b ge 0 then begin file=strmid(x(4*j),0,b) Number=fix(strmid(x(4*j),b+1,20)) if file eq filename and Number eq version then Found=1 endif else begin file=x(4*j) if strupcase(file) eq strupcase(filename) then Found=1 endelse j=j+1 ENDREP UNTIL (j gt N_records/4-1) or Found if Found then begin Num=j-1 x=x(4*num:4*num+3) Date=x(1) Time=x(2) x=strtrim(strcompress(x(3)),2) i1=strpos(x,' ') i2=strpos(x,' ',i1+1) A(0)=strmid(x,0,i1) A(1)=strmid(x,i1+1,i2-i1) A(2)=strmid(x,i2+1,20) endif else begin xwarning, ['The log file '+log+' not found.', $ 'You can only view the image.'] error=1 endelse filename=F_save return, A end ####################################################### function rd_fhead, files ;+ ; NAME: ; RD_FHEAD ; ; PURPOSE: ; Read headers of multiple FITS files ; ; CATEGORY: ; Input/Output ; ; CALLING SEQUENCE: ; HEADERS = RD_FHEAD(files) ; ; INPUTS: ; Files: string-type array containing names of FITS files. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; None ; ; OUTPUTS: ; String-type array of headers of the multiple files. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; All FITS files must have the same length of the header. ; ; PROCEDURE: ; The first file is read using READFITS. The length of the header is found. Then ; unformatted reading of all headers is performed as byte arrays. Because the headers only ; are read, the reading is performed quickly. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, Mar, 2000. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ; ;- if n_params() eq 0 then begin files = pickfile(tit = 'Select a file to indicate path', /read) if files(0) eq '' then return, '' endif tmp = readfits(files(0), header, /si) N_files = n_elements(files) N = n_elements(header) headers = strarr(N, N_files) h = bytarr(80, N) for j=0, N_files-1 do begin openr, lun, files(j), /get readu, lun, h headers(*,j) = string(h) free_lun, lun endfor return, headers end ####################################################### function rd_image, filename, r, g, b, type=type, header=header, $ scale=scale if n_params() lt 1 then message,'Incorrect call' Szf=size(filename) if Szf(n_elements(Szf)-2) ne 7 then message,'Filename must be a string' Type=filetype(Filename) CASE Type OF 'FITS': begin index=-1 array=rfitsg(Filename,index=fnum,key_struct=hstruc,header=header,error=err, $ user_struct=ustruc,date_obs=date, $ time_obs=time,scale=keyword_set(scale) ) end 'GIF': begin read_gif,Filename,array,r,g,b header='' end 'BMP': begin array=bmp_read(Filename,r,g,b) header='' end 'TIFF': begin array = TIFF_READ(Filename,r,g,b) header='' end 'JPEG': begin if !version.release lt 5 then begin xwarning,['JPEG Not supported on this release', 'Returning...'] header='' return,'' endif READ_JPEG, Filename, array, ct r = ct(*,0) g = ct(*,1) b = ct(*,2) header='' end ELSE: begin xwarning,['Unrecognized file type.','Returning...'] header='' return,'' end ENDCASE return, array end ####################################################### pro readfa, Array_I, file_I, start_time=start_time, date=date, dt=dt if n_params(File_I) eq 1 then File_I=pickfile(path=getenv('spk_dat')) if File_I eq '' then begin print, 'No file selected. Returning...' return endif openr,lun_I,File_I,/get_lun gr_header, Lun_I,offset_I,header_I,/read,$ comments=comments_I, $ Parameter=Parameter_I, $ Interferometer=Interferometer, $ source_file=source_file, $ first_record=first_record, $ Date=Date, $ Reference_time=Reference_time, $ Reference_Channel=Channel, $ Start_time=Start_time, $ Receiver=Receiver, $ Dt=Dt, $ Length=Length, $ N_channels=N_channels, $ Creator=Creator, $ Array_size=Array_size, $ Type=Type param_ssrt, date, Reference_time, N_channels eq 192, par=par, /si,sun=sun threshold=(-1000.)*(N_channels ne 192) x=assoc(lun_I, $ make_array(N_channels, $ type=array_size(n_elements(array_size)-2)), $ offset_I) Array_I=intarr(N_channels, Length) t0=systime(1) & Flag=0 for j=0, Length-1 do begin Array_I(*,j)=x(j) > threshold endfor end ####################################################### function proc_multi,Input,multi=multi,extr=extr,sum=sum, $ index=index if n_elements(multi) le 0 then multi=1 multi_save=multi if n_elements(sum) le 0 then sum=0 sum_save=sum if multi eq 1 then begin y=Input & index=0 & goto,exit & endif sz=size(Input) if sz(0) gt 1 then Length=sz(2) else begin Length=1 & sum=0 endelse multi=multi < Length & Factor=Length/multi index=Length-(Length mod multi) & y=0 for j=0,Factor-1 do begin jj=j*multi if sum gt 0 then x=total(Input(*,jj:jj+multi-1),2)/float(multi) $ else begin x=Input(*,jj) & for k=1,multi-1 do x=x > Input(*,jj+k) endelse if n_elements(y) eq 1 then y=x else y=[[y],[x]] endfor exit: multi=multi_save sum=sum_save return,y end pro arr_multi,X,Y,Rest,i0=i0,i1=i1,N0=N0,Ncur=Ncur,$ multi=multi,sum=sum,index=index,sz=sz X1=X(*,i0:i1) IF Ncur eq N0 THEN BEGIN if multi eq 1 then Y=X1 else begin Y=proc_multi(X1,multi=multi,sum=sum,index=index) if i0+index lt sz then Rest=X(*,i0+index:*) else Rest=0 endelse ENDIF ELSE BEGIN IF multi eq 1 THEN Y=[[Y],[X1]] ELSE BEGIN sz1=size(Rest) CASE sz1(0) OF 0: sz1=0 1: sz1=1 else: sz1=sz1(2) ENDCASE if sz1 gt 0 then X=[[Rest],[X1]] else X=X1 sz2=size(X) if sz2(0) eq 1 then sz2=1 else sz2=sz2(2) Y=[[Y],[proc_multi(X,multi=multi,sum=sum,index=index)]] sz3=i1-i0+1 if (i0+index lt sz2) and (index lt sz3) then begin Rest=X(*,i0+index:*) & index=sz-sz1 endif else begin Rest=0 & index=sz & X=0 & endelse ENDELSE ENDELSE end pro readblock,Fileformat,Blockset,N_block,PatternV, $ time,attr,I_EW,V_EW,I_SN,V_SN,ReadIEW=ReadIEW, $ ReadVEW=ReadVEW, ReadISN=ReadISN, ReadVSN=ReadVSN b=Blockset(N_block) I_EW=(V_EW=(I_SN=(V_SN=0))) & LEW=(REW=(LSN=(RSN=0))) IF equiv(Fileformat, ['aor','clm']) THEN I_EW=b ELSE BEGIN if equiv(time,0L) then time=b.time else time=[time,b.time] IF equiv(Fileformat, ['aor','0']) or $ equiv(Fileformat, ['aor','-1']) THEN BEGIN I_EW=fix(b.Set32.I) & V_EW=fix(b.Set32.V)-128 if equiv(attr,0B) then attr=b.set32.attr else attr=[attr,b.set32.attr] ENDIF ELSE IF equiv(Fileformat, ['aor','1']) THEN BEGIN if ReadIEW or ReadVEW eq 1 then begin LEW=fix(b.Set32.LEW*PatternV(*,*,0)) REW=fix(b.Set32.REW*PatternV(*,*,0)) endif if ReadISN or ReadVSN eq 1 then begin LSN=fix(b.Set32.LSN*PatternV(*,*,1)) RSN=fix(b.Set32.RSN*PatternV(*,*,1)) endif I_EW=LEW+REW & V_EW=LEW-REW I_SN=LSN+RSN & V_SN=LSN-RSN if equiv(attr,0B) then attr=[[b.set32.AttrEW],[b.set32.AttrSN]] $ else attr=[attr,[[b.set32.AttrEW],[b.set32.AttrSN]]] ENDIF ENDELSE LEW=0 & REW=0 & LSN=0 & RSN=0 end pro readfile,FileName=FileName,bounds=bounds,$ Iew=Iew, Vew=Vew, ISN=ISN, VSN=VSN, time=time, attr=attr, $ start=start, stop=stop, multi=multi, sum=sum, extr=extr, $ date=date,fast=fast ; Performs reading of the SSRT data files. if n_elements(Filename) le 0 then return if n_elements(multi) le 0 then multi=1 if not keyword_set(sum) then sum=0 if n_elements(bounds) le 0 then bounds=[0L,0L] bounds=long(bounds(sort(bounds))) Sum_chan=[180,192] Fyear=0 & Fdate=bytarr(2) & Pattern=intarr(192,2) openr,LUN,FileName,/get_lun Block=SSRT_file_struc(LUN,Fileformat=Fileformat, $ Offset=Offset, Dt=Dt, Date=Date, Length=Length) bounds(0)=bounds(0) > 0 bounds(1)=bounds(1) < (Length-1) ind0=bounds(0) & ind1=bounds(1) IF Fileformat(0) eq 'fdas' THEN BEGIN free_lun,lun if n_elements(IEW) eq 1 then ReadIEW=IEW if n_elements(VEW) eq 1 then ReadVEW=VEW read_fdas,FileName=FileName,bounds=bounds,$ Iew=Iew, Vew=Vew, time=time, attr=attr, $ start=start, stop=stop, multi=multi, sum=sum, extr=extr, $ date=date,ReadIEW=ReadIEW,ReadVEW=ReadVEW return ENDIF ReadIEW=(ReadVEW=(ReadISN=(ReadVSN=0))) IF equiv(Fileformat, ['aor','clm']) THEN BEGIN IEW=Block & ReadIEW=1 & N_block0=0 & N_block1=0 ENDIF ELSE BEGIN N_block0=ind0/32 & N_block1=ind1/32 in0=ind0-N_block0*32 & in1=ind1-N_block0*32 start=ind0 mod 32 & stop=ind1 mod 32 if n_elements(IEW) eq 1 then ReadIEW=IEW if n_elements(VEW) eq 1 then ReadVEW=VEW if n_elements(ISN) eq 1 then ReadISN=ISN if n_elements(VSN) eq 1 then ReadVSN=VSN ENDELSE IF not(equiv(Fileformat,['aor','clm'])) and $ not(equiv(Fileformat,['aor','-1'])) THEN BEGIN readu,LUN,Fyear,Fdate CASE !version.OS OF 'windows': 'Win32': ELSE: byteorder,Fyear,/sswap ENDCASE Year=string(Fyear,format="(I4)") Date=string(Fdate(0),Fdate(1),strmid(Year,2,2),$ format="(3(I2.2,:,' '))") ENDIF IF equiv(Fileformat, ['aor','1']) THEN BEGIN readu,LUN,Pattern CASE !version.OS OF 'windows': 'Win32': ELSE: byteorder,Pattern,/sswap ENDCASE Pattern=Pattern/128.0 & a=replicate(1,32) PatternV=reform([[Pattern(*,0)#a],[Pattern(*,1)#a]],192,32,2) ENDIF ELSE PatternV=0 Blockset=assoc(LUN,Block,Offset) & time_in=0L & attr_in=0B indexIEW=(indexVEW=(indexISN=(indexVSN=0))) RestIEW=(RestVEW=(RestISN=(RestVSN=0))) IF keyword_set(fast) THEN BEGIN if ReadIEW then IEW=intarr(192,(N_block1-N_block0+1)*32) if ReadVEW then VEW=intarr(192,(N_block1-N_block0+1)*32) if ReadISN then ISN=intarr(192,(N_block1-N_block0+1)*32) if ReadVSN then VSN=intarr(192,(N_block1-N_block0+1)*32) FOR N_block=N_block0,N_block1 DO BEGIN readblock,Fileformat,Blockset,N_block,PatternV,time_in, $ attr_in,I_EW,V_EW,I_SN,V_SN,ReadIEW=ReadIEW, $ ReadVEW=ReadVEW,ReadISN=ReadISN,ReadVSN=ReadVSN i0=(N_block-N_block0)*32 i1=i0+31 if ReadIEW then IEW(*,i0:i1)=I_EW if ReadVEW then VEW(*,i0:i1)=V_EW if ReadISN then ISN(*,i0:i1)=I_SN if ReadVSN then VSN(*,i0:i1)=V_SN ENDFOR free_lun,LUN ENDIF ELSE BEGIN FOR N_block=N_block0,N_block1 DO BEGIN readblock,Fileformat,Blockset,N_block,PatternV,time_in, $ attr_in,I_EW,V_EW,I_SN,V_SN,ReadIEW=ReadIEW, $ ReadVEW=ReadVEW,ReadISN=ReadISN,ReadVSN=ReadVSN IF N_block eq N_block0 THEN BEGIN CASE 1 OF ReadIEW : sz=size(I_EW) ReadVEW : sz=size(V_EW) ReadISN : sz=size(I_SN) ReadVSN : sz=size(V_SN) ELSE: sz=[0,0,0] ENDCASE sz=sz(2) ENDIF if indexIEW eq 0 then indexIEW=sz if indexVEW eq 0 then indexVEW=sz if indexISN eq 0 then indexISN=sz if indexVSN eq 0 then indexVSN=sz IF (equiv(Fileformat, ['aor','clm']) or sz eq 0) $ THEN IEW=I_EW ELSE BEGIN if N_block ne N_block0 then i0=0 else i0=start if N_block ne N_block1 then i1=sz-1 else i1=stop if ReadIEW then $ arr_multi,I_EW,IEW,RestIEW,i0=i0,i1=i1,N0=N_block0,Ncur=N_block, $ multi=multi,sum=sum,index=indexIEW,sz=sz if ReadVEW then $ arr_multi,V_EW,VEW,RestVEW,i0=i0,i1=i1,N0=N_block0,Ncur=N_block, $ multi=multi,sum=sum,index=indexVEW,sz=sz if ReadISN then $ arr_multi,I_SN,ISN,RestISN,i0=i0,i1=i1,N0=N_block0,Ncur=N_block, $ multi=multi,sum=sum,index=indexISN,sz=sz if ReadVSN then $ arr_multi,V_SN,VSN,RestVSN,i0=i0,i1=i1,N0=N_block0,Ncur=N_block, $ multi=multi,sum=sum,index=indexVSN,sz=sz ENDELSE ENDFOR free_lun,LUN if ReadIEW then if (size(RestIEW))(0) ne 0 then IEW= $ [[IEW],[proc_multi(RestIEW,multi=multi,sum=sum)]] & RestIEW=0 if ReadVEW then if (size(RestVEW))(0) ne 0 then VEW= $ [[VEW],[proc_multi(RestVEW,multi=multi,sum=sum)]] & RestVEW=0 if ReadISN then if (size(RestISN))(0) ne 0 then ISN= $ [[ISN],[proc_multi(RestISN,multi=multi,sum=sum)]] & RestISN=0 if ReadVSN then if (size(RestVSN))(0) ne 0 then VSN= $ [[VSN],[proc_multi(RestVSN,multi=multi,sum=sum)]] & RestVSN=0 ENDELSE IF Fileformat(0) eq 'aor' and Fileformat(1) ne 'clm' THEN BEGIN CASE !version.OS OF 'windows': 'Win32': ELSE: byteorder, time_in, /lswap ENDCASE time=time_syn(time_in,/sec) & time_in=0 if date eq '08 07 92' then time=time+61 if Fileformat(1) le '0' then attr=temporary(attr_in(in0:in1)) if Fileformat(1) eq '1' then attr=temporary(attr_in(in0:in1,[0,1])) ENDIF end ####################################################### function readform, file ;+ ; NAME: ; READFORM ; ; PURPOSE: ; Formatted reading of the string-type array from a file ; ; CATEGORY: ; Input/Output ; ; CALLING SEQUENCE: ; Text = READFORM(File) ; ; INPUTS: ; File name. This array must be a scalar string. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; None ; ; OUTPUTS: ; String array ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; The unformatted reading from the file is performed to a byte array. Then the number ; of lines is found (as the number of 0A codes), and the reading is performed again, ; but as a string-type array with explicitly specified number of elements. Finally, ; existence of one possible remainder line in the file is checked, and if it exists, ; then it is read and appended to the array. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, Apr, 1998. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ; ; ISTP SD RAS, Mar, 2003. ; VG : Fixed bug when the file contains only one line. ; ; ;- if file eq '' then begin print, 'No file specified. Returning...' return, '' endif widget_control, /hour openr, lun, file, /get st = fstat(lun) data = bytarr(st.size) readu, lun, data point_lun, lun, 0 iii = where(data eq '0A'xB, N) data = strarr(N > 1) readf, lun, data st = fstat(lun) if (st.cur_ptr + 1) lt st.size then begin tmp = '' readf, lun, tmp data = [data, tmp] endif free_lun, lun return, data end ####################################################### function readform_arr, file x=readform(file) x = strcompress(strtrim(x,2)) Nx = n_elements(x) tmp = where(byte(x[0]) eq '20'xb, count) Ny = count + 1 y = strarr(Ny, Nx) for j=0, Nx-1 do y[*,j] = str_sep(x[j], ' ') return, double(transpose(y)) end ####################################################### ;read_channels ;date='061293' date='101094' Filename=getenv('spk_dat')+'\00'+date+'.cha' ;Filename=pickfile(path=getenv('spk_dat'),filt='*.cha',/write) ;if Filename eq '' then goto,exit openr,lun,Filename,/get_lun status=fstat(lun) N_bad_chan=(status.size-42)/18 data=intarr(2,N_bad_chan) emptystring='' readf,lun,emptystring readf,lun,emptystring readf,lun,data free_lun,lun i_Bad_channels=where(Data(1,*)) Bad_channels=Data(0,sort(Data(0,i_Bad_channels))) ;print,data ;print print,Bad_channels exit: end ####################################################### pro read_dig,file,x,y Sz=size(file) if Sz(n_elements(Sz)-2) ne 7 or n_params() ne 3 then message,'Incorrect call' if file eq '' then message,'Incorrect call' openr,lun,file,/get_lun stat=fstat(lun) x=(y=fltarr(stat.size/8)) readu,lun,x,y free_lun,lun end ####################################################### function read_time, Lun, Blocknumber=Blocknumber ; Performs reading of a time record from the SSRT data file. Block=ssrt_file_struc(lun, offset=offset, $ Fileformat=Fileformat,Date=Date) IF equiv(Fileformat,['aor','clm']) then begin time=0D goto,exit ENDIF Blockset=assoc(LUN,Block,Offset) Bl=Blockset(Blocknumber) CASE 1 OF Fileformat(0) eq 'aor': begin time=Bl.time CASE !version.OS OF 'windows': 'Win32': ELSE: byteorder, time, /lswap ENDCASE time=time_syn(time,/sec) if Date eq '08 07 92' then time=time+61 end Fileformat(0) eq 'fdas': begin CASE !version.OS OF 'windows': byteorder, Bl, /sswap 'Win32': byteorder, Bl, /sswap ELSE: ENDCASE a=civ_time(bin_time(Bl.Time_in_R)) Time=a(0)*3600d0+a(1)*60d0+a(2)+a(3)/1000d0 end ELSE: time=0D ENDCASE exit: RETURN,time end ####################################################### function rebin3, x, sizeX, sizeY if n_params() ne 3 then message, 'Incorrect number of arguments' sz =size(x) if sz(0) lt 2 or sz(0) gt 3 then message, $ 'Input argument must be 2- or 3-dimensional array' dimX = [sz(1), sizeX] dimY = [sz(2), sizeY] dimX = dimX(sort(dimX)) dimY = dimX(sort(dimY)) ;if (dimX(1) mod dimX(0) ne 0) or (dimY(1) mod dimY(0) ne 0) then message, $ ; 'Result dimensions must be integer factor of original dimensions' if sz(0) eq 2 then return, rebin(x, sizeX, sizeY) else begin y = make_array(sizeX, sizeY, sz(3), type = sz(sz(0)+1), /nozero) for j=0,sz(3)-1 do y(*,*,j) = rebin(x(*,*,j), sizeX, sizeY) return, y endelse end ####################################################### pro rec1 ;path='e:\grech\text\spb97\income' file=pickfile(tit='Please select a file for conversion') if file eq '' then begin print, "No file selected. Returning..." return endif x=readform(file) y=recod1(x) ;y=strmid(y,0,100) y=cyrconv(y, /to_dos) new_file=(name_extract(file))(1)+'.trd' path=subdir(file) file=pickfile(path=path, /write, file=new_file) if new_file eq '' then begin print, "No file selected. Returning..." return endif openw, lun, file, /get for j=0, n_elements(y)-1 do printf, lun, y(j) free_lun,lun end ####################################################### function recod1, x z=(y=byte(x)) model=transpose(byte(['┼', '÷', '╥', '▐', '╬', '╫', '¿', '┴', '╓', '═', '┘', '╩'])) Out=transpose(byte(['õ', '├', '¨', '¢', 'ý', 'ò', '╙', 'ð', 'ö', 'ü', '√', 'ù'])) model=[model, transpose(byte(['ÿ', '┬', '▌', '¢', '█', '╔', '┌', '─', '╙', '╘', '├', '╧']))] Out=[Out, transpose(byte(['╬', 'ñ', '∙', '┬', '°', 'ø', '÷', 'ô', '¸', 'ª', '¡', 'þ']))] model=[model, transpose(byte(['╨', '╠', '•', '╞', '╪', '╟', '¨', '╤', 'º', '╒', '╦', '╚', '└']))] Out=[Out, transpose(byte(['ÿ', 'û', '╟', '¯', '¹', 'ó', '╧', ' ', '╤', 'º', 'ú', '¿', '■']))] model=[model, transpose(byte(['¯', 'ª', 'ü', 'ó', '▄', 'ø', 'ù']))] Out=[Out, transpose(byte(['╥', '╨', '╦', '╓', '¤', '╒', '╚']))] model=[model, transpose(byte(['ñ', '√', '▀', '■', 'þ', 'ò', 'ý', 'û', 'õ']))] Out=[Out, transpose(byte(['└', '╪', '•', '╫', '═', '┴', '╠', '╩', '┼']))] model=[model, transpose(byte(['ö', '¸', 'ô', '¹', '∙', 'ú', '°']))] Out=[Out, transpose(byte(['╘', '▀', '─', '▌', '█', '╔', '▄']))] for j=0, n_elements(model)-1 do begin ind=where(y eq model(j)) if ind(0) ge 0 then z(ind) = Out(j) endfor return, string(z) end ####################################################### ; function recoder2, x z=(y=byte(x)) model=transpose(byte(['/', 'R', 'V', 'O', 'H', '$', 'X', 'G', 'L', '&', 'Q', 'J'])) Out= transpose(byte(['L', 'o', 's', 'l', 'e', 'A', 'u', 'd', 'i', 'C', 'n', 'g'])) model=[model, transpose(byte(['0', 'D', 'W', 'K', '+', '5', '6', 'F', 'K', 'I', 'U', '7']))] Out=[Out, transpose(byte(['M', 'a', 't', 'h', 'H', 'R', 'S', 'c', 'h', 'f', 'r', 'T']))] model=[model, transpose(byte(['S', ' ', '6', ',', '3', '(', '*', 'P', 'Z', '#']))] Out= [Out, transpose(byte(['p', '(', 'S', 'I', 'P', 'E', 'G', 'm', 'w', '@']))] model=[model, transpose(byte(['1', 'Y', 'E', '.', '\', '(', '*', 'P', 'Z', '#']))] Out= [Out, transpose(byte(['N', 'v', 'b', 'K', 'y', 'E', 'G', 'm', 'w', '@']))] goto, ex ;model=[model, transpose()] ;Out= [Out, transpose(byte(['N', 'v', 'b', 'K', 'y', 'E', 'G', 'm', 'w', '@']))] model=[model, transpose(byte(['¯', 'ª', 'ü', 'ó', '▄', 'ø', 'ù']))] Out=[Out, transpose(byte(['╥', '╨', '╦', '╓', '¤', '╒', '╚']))] model=[model, transpose(byte(['ñ', '√', '▀', '■', 'þ', 'ò', 'ý', 'û', 'õ']))] Out=[Out, transpose(byte(['└', '╪', '•', '╫', '═', '┴', '╠', '╩', '┼']))] model=[model, transpose(byte(['ö', '¸', 'ô', '¹', '∙', 'ú', '°']))] Out=[Out, transpose(byte(['╘', '▀', '─', '▌', '█', '╔', '▄']))] ex: for j=0, n_elements(model)-1 do begin ind=where(y eq model(j)) if ind(0) ge 0 then z(ind) = Out(j) endfor ;return, string(z) end ####################################################### pro recpol,x,y,r,theta,degree=degree,radians=radians ;+ ; Converts Descartes's coordinates ; to polar ones. ;- r=sqrt(x^2+y^2) theta=atan(y, x) if keyword_set(degree) then theta=theta*180d0/!Dpi end ####################################################### pro rem_lf,filter=filter,overwrite=overwrite,file=file, $ all_files=all_files,path=path,confirm=confirm ; Removes the Line Feed codes in the file. ; This routine is used to convert files from MS WINDOWS to UNIX ; format. if n_elements(filter) le 0 then filter='*.*' if n_elements(all_files) le 0 then all_files=0 if n_elements(file) le 0 then file='' else path=subdir(file) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE if file eq '' then path=''; getenv('gr_prg') ;'' CR='0A'xb & LF='0D'xb if keyword_set(all_files) then begin path=subdir(pickfile(filt=filter,tit='Please select a file for converting')) if path ne '' then Files=findfile((path)+Delim+filter) else $ Files=findfile(filter) ; ****************** Excluding subdirectories ************** Files=Files(sort(Files)) & Sz=size(Files) if (Sz)(0) gt 0 then Sz=Sz(1) else Sz=0 for j=0,Sz-1 do if strmid(Files(j),strlen(Files(j))-1,1) eq '\' then $ if n_elements(b) le 0 then b=j else b=[b,j] N_b=n_elements(b) if N_b gt 0 then begin Files_save=Files(b) for j=0,N_b-1 do Files=Files(where(Files ne Files_save(j))) endif ; *********************************************************** IF keyword_set(confirm) THEN BEGIN Print,'y/n:' N_b=n_elements(Files) index=intarr(N_b) for j=0,N_b-1 do begin print,Files(j)+'?' tmp=strlowcase(get_kbrd(1)) index(j)=tmp eq 'y' endfor Files=Files(where(index)) ENDIF ELSE BEGIN a='' xquestion,a,text='You are processing all the files '+path+'\'+filter, $ select=['OK','Cancel'] if a ne 'OK' then begin print,'Operation is canceled' goto,exit endif ENDELSE endif else begin if path ne '' then Files=pickfile(tit='Please select a file for converting', $ filt=filter, file=file, path=path) else $ Files=pickfile(tit='Please select a file for converting', $ filt=filter, file=file) if Files eq '' then goto,exit endelse Loop: for k=0,n_elements(Files)-1 do begin openr,lun,Files(k),/get_lun a=fstat(lun) if a.size eq 0 then goto,No_operation x=bytarr(a.size) readu,lun,x free_lun,lun WIDGET_CONTROL,/hourglass x=x(where(x ne LF)) if not keyword_set(overwrite) then $ Newfilename=path+Delim+(name_extract(Files(k)))(1)+'.lfr' $ else Newfilename=Files(k) openw,lun,Newfilename,/get_lun writeu,lun,x free_lun,lun print,'File '+Newfilename+' is recorded.' No_operation: endfor exit: end ####################################################### file=pickfile(tit='Please select a file to indicate a path') if !version.OS eq 'windows' then Delim='\' else Delim='/' path=subdir(file) print,path all_files=findfile(path+Delim+'*.*') xquestion,a,text=['You are processing all the files: ',all_files] if a eq 'Yes' then begin for j=0,n_elements(all_files)-1 do new_names=strlowcase(all_files) for j=0,n_elements(all_files)-1 do spawn, 'mv '+all_files(j)+' '+new_names(j) print,'Done.' endif else print,'Operation canceled.' end ####################################################### ;revise_fits pro replace_keyword,header,Replace for k=0,n_elements(Replace(0,*))-1 do begin Pos=strpos(header,Replace(0,k)) N=where(Pos ge 0) if n(0) ge 0 then begin tmp=header(N) strput,tmp,Replace(1,k),Pos(N(0)) header(N)=tmp endif endfor end ;path=getenv('optics_dir') path='E:\GRECH\IDL\TEMPO' filter='*.fts' files=pickfile(path=path,filt=filter, tit='Select a file to indicate a path') if files eq '' then goto, exit if !version.OS eq 'windows' then Delim='\' else Delim='/' all_files=findfile(subdir(files)+Delim+filter,count=N_files) if N_files eq 0 then goto,exit short_names=strarr(N_files,2) for j=0,N_files-1 do short_names(j,*)=(name_extract(all_files(j)))([0,1]) Error_file=path+Delim+'revise.log' tmp=findfile(Error_file, count=count) if count lt 1 then openw,lun_er,Error_file,/get else $ openu,lun_er,Error_file,/get FOR I=0,N_files-1 DO BEGIN old_header=headfits(all_files(I)) xx=rfits(all_files(I)) modified_header=old_header CASE 1 OF strpos(strlowcase(short_names(I,1)), 'v') ge 0: Stokes='Polarization' strpos(strlowcase(short_names(I,1)), 'i') ge 0: Stokes='Intensity' strpos(strlowcase(short_names(I,1)), 'r') ge 0: Stokes='Right' strpos(strlowcase(short_names(I,1)), 'l') ge 0: Stokes='Left' ELSE: message, 'Illegal file name' ENDCASE sxaddpar, modified_header,'paramete',Stokes, AFTER ='TELESCOP';, Comment X_obs=fh_r_key(modified_header,'x-extent',error=error) if error ne 1 then sxaddpar, modified_header,'x-obs',X_obs, AFTER ='WAVE' Y_obs=fh_r_key(modified_header,'y-extent',error=error) if error ne 1 then sxaddpar, modified_header,'y-obs',Y_obs, AFTER ='X-OBS' sxdelpar,modified_header,'x-extent' sxdelpar,modified_header,'y-extent' Length=n_elements(modified_header) headlength=(((Length-1)/36)+1)*36 new_header=bytarr(80,headlength) new_header(0,0)=byte(modified_header) header=string(new_header) Replace=[['UT START','UTSTART '], ['UT STOP','UTSTOP '], ['PO','P0'], $ ['UT-START','UTSTART '], ['UT-STOP','UTSTOP ']] replace_keyword,header,Replace Old_Date=fh_r_key(header,'date-obs',/char) Date=strsubst(Old_Date,' ','0') Date=strmid(Date,3,2)+'-'+strmid(Date,0,2)+'-'+strmid(Date,6,2) replace_keyword,header,[Old_date,date] times=['time-obs','utstart','utstop'] for j=0,n_elements(times)-1 do begin Old_Time=fh_r_key(header,times(j),/char) if Old_Time ne 0 then begin Time=strsubst(Old_Time,' ','0') replace_keyword,header,[Old_Time,Time] endif else begin print,'Error! The file '+short_names(I,0)+' could not be processed.' printf,lun_er,short_names(I) goto,Jump endelse endfor openw,lun,path+delim+short_names(I,1)+'.fit',/get writeu,lun,byte(header) writeu,lun,xx free_lun,lun Sz=size(xx) window,2*(I mod 2),xs=sz(1),ys=sz(2),tit=short_names(I,1) tvscl,xx print,'File '+short_names(I,1)+'.fit'+' is recorded.' Jump: ENDFOR free_lun,lun_er exit: end ####################################################### function rfits,filnam,index=fnum,key_struct=hstruc,header=head,error=err, $ user_struct=ustruc,date_obs=date,time_obs=time ;+ ; NAME: ; RFITS ; PURPOSE: ; Reads a standard FITS disk file into an array. ; CATEGORY: ; Input/Output. ; CALLING SEQUENCE: ; result = rfits(filename) ; INPUTS: ; filename = string containing the file name. ; OPTIONAL (KEYWORD) INPUT PARAMETERS: ; index = nonnegative integer. If this parameter is present, ; a period and the index number are appended to the filename ; (e.g., '.34'). This option makes handling of data in the ; MCCD file naming convention easier. ; user_struct = structure for optional FITS keyword parameters (input). ; With this keyword the user can supply a customized ; structure definition for the key_struct keyword. ; If user_struct is not supplied then the default ; structure definition in mkkey_struct() is used. ; OUTPUTS: ; result = byte, integer, long, float, or double array, containing ; the FITS data array. The dimensionality of result reflects ; the structure of the FITS data. ; OPTIONAL (KEYWORD) OUTPUT PARAMETERS: ; key_struct = structure of optional FITS keyword parameters (output). ; The tag names of user_struct are matched with the FITS ; header keywords. Matching header values are placed into ; the appropriate structure elements. ; header = string vector, containing the full FITS header (each element ; of the vector contains one FITS keyword parameter). ; error = I/O error code. Nonzero if an I/O error occurred. ; date_obs = date of observation (string). ; time_obs = time of observation (string). ; date_obs and time_obs only for compatibility with older ; versions of rfits. Use key_struct for new applications. ; COMMON BLOCKS: ; None. ; SIDE EFFECTS: ; None. ; RESTRICTIONS: ; Only simple FITS files are read. FITS extensions (e.g., groups and ; tables) are not supported. ; The data array is not scaled according to BSCALE and BZERO. ; Only header keywords written in fixed format (in columns 11 -30) can ; be interpreted. Complex type keywords cannot be interpreted. ; MODIFICATION HISTORY: ; JPW, Nov, 1989. ; JPW, Nov, 1991. added floating point data type, header structure, ; and modified error handling if file not found. ;- ; open FITS file if n_elements(fnum) ne 0 then file = filnam+'.'+string(format='(i0)',fnum) $ else file = filnam get_lun,unit openr,unit,file,error=err if err ne 0 then begin printf,-2,!err_string goto,done endif ; read the header head = '' repeat begin h = bytarr(80,36) readu,unit,h h = string(h) if n_elements(head) lt 36 then head=h else head=[head,h] flag = 0 for i=0,35 do if strmid(h(i),0,8) eq 'END ' then flag = i+1 endrep until flag gt 0 nh = n_elements(head)-36+i-1 ; get the mandatory keywords ; search BITPIX keyword i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'BITPIX ' or i eq nh) if i eq nh then begin printf,-2,'error: keyword BITPIX not found ' err = 10 goto,done endif bitpix = fix(strmid(head(i),10,20)) ; search NAXIS keyword i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'NAXIS ' or i eq nh) if i eq nh then begin printf,-2,'error: keyword NAXIS not found ' err = 20 goto,done endif naxis = fix(strmid(head(i),10,20)) ; search NAXISi keywords nxi = lonarr(naxis) for j=1,naxis do begin i = -1 repeat i=i+1 until $ (strmid(head(i),0,8) eq 'NAXIS'+strtrim(string(j),2)+' ' or i eq nh) if i eq nh then begin printf,-2,'error: keyword NAXIS',j,' not found ' err = 30 goto,done endif nxi(j-1) = long(strmid(head(i),10,20)) endfor ; search for optional keywords according to structure tag names. ; use supplied structure ustruc, or create default structure usiz = size (ustruc) ; check if ustruc is of type structure if (usiz(usiz(0)+1) eq 8) then hstruc = ustruc else $ hstruc = mkkey_struct() keynam = tag_names(hstruc) ; tag names for use as keywords keynam = strupcase(keynam) ; convert to upper case ; replace _ by - for FITS header asctab = bindgen(256) asctab(byte('_')) = byte('-') keynam = byte(keynam) keynam = asctab(keynam) keynam = string(keynam) ; loop through keywords for i=0,n_tags(hstruc)-1 do begin hdsiz = size(hstruc.(i)) if hdsiz(0) eq 0 then begin ; simple keyword key = strmid(keynam(i)+' ',0,8) k = -1 repeat k=k+1 until (strmid(head(k),0,8) eq key or k eq nh) if k lt nh then begin on_ioerror,elabel1 case hdsiz(hdsiz(0)+1) of 1 : begin ; it's byte, used for logical keyword aux = strtrim(strmid(head(k),10,20),2) if aux eq 'T' then hstruc.(i) = 1b else hstruc.(i) = 0b end 7 : begin ; it's a string spos = 19 > strpos(head(k),"'",19) hstruc.(i) = strmid(head(k),11,spos-11) end else : hstruc.(i) = strmid(head(k),10,20) endcase elabel1: on_ioerror,null endif endif else begin ; indexed keyword, one for each axis for j=0,naxis-1 do begin key = strmid(keynam(i)+strtrim(string(j+1),2)+' ',0,8) k = -1 repeat k=k+1 until (strmid(head(k),0,8) eq key or k eq nh) if k lt nh then begin on_ioerror,elabel2 case hdsiz(hdsiz(0)+1) of 1 : begin ; byte, used for logical keyword aux = strtrim(strmid(head(k),10,20),2) if aux eq 'T' then hstruc.(i)(j) = 1b $ else hstruc.(i)(j) = 0b end 7 : begin ; it's a string spos = 19 > strpos(head(k),"'",19) hstruc.(i)(j) = strmid(head(k),11,spos-11) end else : hstruc.(i)(j) = strmid(head(k),10,20) endcase elabel2: on_ioerror,null endif endfor endelse endfor ; get DATE-OBS and TIME-OBS keywords ; date and time only for compatibility with older versions of rfits. i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'DATE-OBS' or i eq nh) if i eq nh then date = ' 0/ 0/ 0' else begin date = strtrim(strmid(head(i),10,20),2) j = strlen(date) date = strmid(date,1,j-2) endelse i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'TIME-OBS' or i eq nh) if i eq nh then time = ' 0: 0: 0' else begin time = strtrim(strmid(head(i),10,20),2) j = strlen(time) time = strmid(time,1,j-2) endelse ; create data array, and read it case bitpix of 8 : data = make_array(/byte,dimension=nxi,/nozero) 16 : data = make_array(/int,dimension=nxi,/nozero) 32 : data = make_array(/long,dimension=nxi,/nozero) -32 : data = make_array(/float,dimension=nxi,/nozero) -64 : data = make_array(/double,dimension=nxi,/nozero) else : begin printf,-2,'invalid BITPIX keyword ' err = 40 goto,done endelse endcase readu,unit,data if bitpix eq 16 then byteorder, data if bitpix eq -32 then begin byteorder, data, /ntohl endif done: free_lun,unit return,data end ####################################################### function rfitsg,filnam,index=fnum,key_struct=hstruc,header=head,error=err, $ user_struct=ustruc,date_obs=date,time_obs=time,scale=scale ;+ ; NAME: ; RFITSG ; PURPOSE: ; Reads a standard FITS disk file into an array. ; CATEGORY: ; Input/Output. ; CALLING SEQUENCE: ; result = rfitsg(filename) ; INPUTS: ; filename = string containing the file name. ; OPTIONAL (KEYWORD) INPUT PARAMETERS: ; index = nonnegative integer. If this parameter is present, ; a period and the index number are appended to the filename ; (e.g., '.34'). This option makes handling of data in the ; MCCD file naming convention easier. ; user_struct = structure for optional FITS keyword parameters (input). ; With this keyword the user can supply a customized ; structure definition for the key_struct keyword. ; If user_struct is not supplied then the default ; structure definition in mkkey_struct() is used. ; OUTPUTS: ; result = byte, integer, long, float, or double array, containing ; the FITS data array. The dimensionality of result reflects ; the structure of the FITS data. ; OPTIONAL (KEYWORD) OUTPUT PARAMETERS: ; key_struct = structure of optional FITS keyword parameters (output). ; The tag names of user_struct are matched with the FITS ; header keywords. Matching header values are placed into ; the appropriate structure elements. ; header = string vector, containing the full FITS header (each element ; of the vector contains one FITS keyword parameter). ; error = I/O error code. Nonzero if an I/O error occurred. ; date_obs = date of observation (string). ; time_obs = time of observation (string). ; date_obs and time_obs only for compatibility with older ; versions of rfits. Use key_struct for new applications. ; COMMON BLOCKS: ; None. ; SIDE EFFECTS: ; None. ; RESTRICTIONS: ; Only simple FITS files are read. FITS extensions (e.g., groups and ; tables) are not supported. ; The data array is not scaled according to BSCALE and BZERO. ; Only header keywords written in fixed format (in columns 11 -30) can ; be interpreted. Complex type keywords cannot be interpreted. ; MODIFICATION HISTORY: ; JPW, Nov, 1989. ; JPW, Nov, 1991. added floating point data type, header structure, ; and modified error handling if file not found. ;- ; open FITS file if n_elements(fnum) ne 0 then file = filnam+'.'+string(format='(i0)',fnum) $ else file = filnam get_lun,unit openr,unit,file,error=err if err ne 0 then begin printf,-2,!err_string goto,done endif ; read the header head = '' repeat begin h = bytarr(80,36) readu,unit,h h = string(h) if n_elements(head) lt 36 then head=h else head=[head,h] flag = 0 for i=0,35 do if strmid(h(i),0,8) eq 'END ' then flag = i+1 endrep until flag gt 0 nh = n_elements(head)-36+i-1 ; get the mandatory keywords ; search BITPIX keyword i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'BITPIX ' or i eq nh) if i eq nh then begin printf,-2,'error: keyword BITPIX not found ' err = 10 goto,done endif bitpix = fix(strmid(head(i),10,20)) ; search NAXIS keyword i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'NAXIS ' or i eq nh) if i eq nh then begin printf,-2,'error: keyword NAXIS not found ' err = 20 goto,done endif naxis = fix(strmid(head(i),10,20)) ; search NAXISi keywords nxi = lonarr(naxis) for j=1,naxis do begin i = -1 repeat i=i+1 until $ (strmid(head(i),0,8) eq 'NAXIS'+strtrim(string(j),2)+' ' or i eq nh) if i eq nh then begin printf,-2,'error: keyword NAXIS',j,' not found ' err = 30 goto,done endif nxi(j-1) = long(strmid(head(i),10,20)) endfor ; search for optional keywords according to structure tag names. ; use supplied structure ustruc, or create default structure usiz = size (ustruc) ; check if ustruc is of type structure if (usiz(usiz(0)+1) eq 8) then hstruc = ustruc else $ hstruc = mkkey_struct() keynam = tag_names(hstruc) ; tag names for use as keywords keynam = strupcase(keynam) ; convert to upper case ; replace _ by - for FITS header asctab = bindgen(256) asctab(byte('_')) = byte('-') keynam = byte(keynam) keynam = asctab(keynam) keynam = string(keynam) ; loop through keywords for i=0,n_tags(hstruc)-1 do begin hdsiz = size(hstruc.(i)) if hdsiz(0) eq 0 then begin ; simple keyword key = strmid(keynam(i)+' ',0,8) k = -1 repeat k=k+1 until (strmid(head(k),0,8) eq key or k eq nh) if k lt nh then begin on_ioerror,elabel1 case hdsiz(hdsiz(0)+1) of 1 : begin ; it's byte, used for logical keyword aux = strtrim(strmid(head(k),10,20),2) if aux eq 'T' then hstruc.(i) = 1b else hstruc.(i) = 0b end 7 : begin ; it's a string spos = 19 > strpos(head(k),"'",19) hstruc.(i) = strmid(head(k),11,spos-11) end else : hstruc.(i) = strmid(head(k),10,20) endcase elabel1: on_ioerror,null endif endif else begin ; indexed keyword, one for each axis for j=0,naxis-1 do begin key = strmid(keynam(i)+strtrim(string(j+1),2)+' ',0,8) k = -1 repeat k=k+1 until (strmid(head(k),0,8) eq key or k eq nh) if k lt nh then begin on_ioerror,elabel2 case hdsiz(hdsiz(0)+1) of 1 : begin ; byte, used for logical keyword aux = strtrim(strmid(head(k),10,20),2) if aux eq 'T' then hstruc.(i)(j) = 1b $ else hstruc.(i)(j) = 0b end 7 : begin ; it's a string spos = 19 > strpos(head(k),"'",19) hstruc.(i)(j) = strmid(head(k),11,spos-11) end else : hstruc.(i)(j) = strmid(head(k),10,20) endcase elabel2: on_ioerror,null endif endfor endelse endfor ; get DATE-OBS and TIME-OBS keywords ; date and time only for compatibility with older versions of rfits. i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'DATE-OBS' or i eq nh) if i eq nh then date = ' 0/ 0/ 0' else begin date = strtrim(strmid(head(i),10,20),2) j = strlen(date) date = strmid(date,1,j-2) endelse i = -1 repeat i=i+1 until (strmid(head(i),0,8) eq 'TIME-OBS' or i eq nh) if i eq nh then time = ' 0: 0: 0' else begin time = strtrim(strmid(head(i),10,20),2) j = strlen(time) time = strmid(time,1,j-2) endelse ; create data array, and read it case bitpix of 8 : data = make_array(/byte,dimension=nxi,/nozero) 16 : data = make_array(/int,dimension=nxi,/nozero) 32 : data = make_array(/long,dimension=nxi,/nozero) -32 : data = make_array(/float,dimension=nxi,/nozero) -64 : data = make_array(/double,dimension=nxi,/nozero) else : begin printf,-2,'invalid BITPIX keyword ' err = 40 goto,done endelse endcase readu,unit,data if bitpix eq 16 then byteorder, data if bitpix eq -32 then begin byteorder, data, /ntohl endif done: free_lun,unit if keyword_set(scale) then begin if (where(tag_names(hstruc) eq 'BSCALE'))(0) ge 0 then data=data*hstruc.bscale if (where(tag_names(hstruc) eq 'BZERO'))(0) ge 0 then data=data+hstruc.bzero endif return,data end ####################################################### function ring_model, dim, radius, width step = 0.1 N = (dim[0] > dim[1])*sqrt(2)/2/step x = findgen(N)/(N-1) position = radius/float(dim[0])*sqrt(2) width_norm = width/float(dim[0])*sqrt(2) z=((x-position)/width_norm) > (-5) < 5 arg = (z^2*4.*alog(2)) maxval = 64 maxval = 20 index = where(arg gt maxval, count) model1 = exp(-arg < 64) if count gt 0 then model1[index] = 0 xx = (findgen(dim[0])-(dim[0]-1)*0.5) # replicate(1, dim[1]) yy = (findgen(dim[1])-(dim[1]-1)*0.5) ## rEplicate(1, dim[0]) distan = sqrt(xx^2+yy^2) return, model1[distan/step] end ####################################################### pro rotvec, xi, yi, xo, yo, Angle, Factor, Center if n_params() lt 5 then message, 'Insufficient number of arguments.' if n_elements(Factor) le 0 then Factor=1. if n_elements(Center) le 0 then Center=[0., 0.] i=complex(0,1) z=Factor*complex(xi,yi)*exp(i*(angle)) xo=float(z)+Center(0) yo=imaginary(z)+Center(1) end ####################################################### function rot_optimize, x, y, number=number, range=range widget_control, /hourglass if n_elements(number) le 0 then number=10. if n_elements(range) le 0 then range=10. tot=fltarr(number) index=-range/2.+findgen(number)/(number-1)*range Szx=size(x) Radius=(Szx(1) < Szx(2))*0.95/2 N=512 t=findgen(N)/(N-1)*!pi*2 xcir=Szx(1)/2.+Radius*cos(t) ycir=Szx(2)/2.+Radius*sin(t) disk_index=polyfillv(xcir, ycir, Szx(1), Szx(2)) for j=0, number-1 do tot(j)=total(x(disk_index)*(rot(y, index(j), /int, miss=0))(disk_index) ) Nsp=10 index1=-range/2.+findgen(number*Nsp)/(number*Nsp-1)*range tot1=spline(index, tot-min(tot), index1) amax=max(tot1, imax) return, index1(imax) end ####################################################### function rough,x ; Returns rough integer value fkr an input floating-point argument. return, fix(x+(x gt 0)-0.5) end ####################################################### function name_recod,x z=strtrim(strmid(x,0,4),2) CASE z OF 'psi': y='!4w!3' 'ph': y='!4u!3' 'th': y='!4h!3' 'bph': y='B!d!4u!3!n' 'bal': y='B!dl!n' 'bth': y='B!d!4h!3!n' 'br': y='B!dr!n' 'b0': y='B!d0!n' ELSE: y=z ENDCASE return,y end function rud_read,Filename,x,y,service,header CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE if n_elements(Filename) le 0 then Filename=pickfile(/read,path=getenv('zhora_dir')+Delim+'data') if Filename eq '' then begin print,'No file selected' return,0 endif Header='' widget_control,/hour openr,lun,Filename,/get_lun readf,lun,Header N_nn='' readf,lun,N_nn,nn,format='(a5,i4)' N_psi='' readf,lun,N_psi,psi,format='(a5,F9.3)' var_x=(var_y=(var_z='')) readf,lun,var_x,var_y,var_z N_xmin='' readf,lun,N_xmin,xmin,format='(a5,F7.2)' N_xmax='' readf,lun,N_xmax,xmax,format='(a5,F7.2)' N_ymin='' readf,lun,N_ymin,ymin,format='(a5,F7.2)' N_ymax='' readf,lun,N_ymax,ymax,format='(a5,F7.2)' N_nx='' readf,lun,N_nx,nx,format='(a5,i5)' N_ny='' readf,lun,N_ny,ny,format='(a5,i5)' z=fltarr(ny,nx) readf,lun,z free_lun,lun z=transpose(z) x=findgen(nx)/(nx-1.)*(xmax-xmin)+xmin y=findgen(ny)/(ny-1.)*(ymax-ymin)+ymin service={xtitle:name_recod(var_x),ytitle:name_recod(var_y), $ ztitle:name_recod(var_z), parameter_name:name_recod(N_psi), $ parameter:psi,number:nn} return,z end ####################################################### pro rustext, x, charsize = charsize, interval = interval if n_elements(charsize) le 0 then charsize = !p.charsize if n_elements(interval) le 0 then interval = 1 ;device, get_scr = scr ;window,/fre, xs = scr(0)*0.9, ys = scr(1)*0.9 ;erase, !d.table_size-1 interv = '' for j 0,interval-1 do interv = interv +'!C' y = '' for j=0,n_elements(x)-1 do y = y + interv + cyr(x(j)) col = 0 xyouts, 0.01, 0.95, /nor, y, chars = charsize; col = col end ####################################################### function rus_cyr,x b=(a=byte(x)) index_in=[bindgen(48)+128b,bindgen(16)+224b] index_out=192b+bindgen(64) for j=0,63 do begin index=where(a eq index_in(j)) if index(0) ne (-1) then b(index)=index_out(j) endfor return,string(b) end ####################################################### pro scale,SAXES,memorize=memorize,recover=recover ; Saves and restores scaling inherent to a given graphics window. CASE 1 OF keyword_set(memorize): SAxes={Axes, x:!x, y:!y, z:!z, map:!map} keyword_set(recover): BEGIN !x=SAxes.x !y=SAxes.y !z=SAxes.z !map=SAxes.map END ELSE: ENDCASE end ####################################################### function select_peak,y,N ; Returns subscripts corresponding to closest local minimums to ; a given peak in a curve. all_peaks=find_peaks(y,/all) z1=find_peaks(-y,/all) IF z1(0) gt all_peaks(0) then z1=[0,z1] IF z1(n_elements(z1)-1) lt all_peaks(n_elements(all_peaks)-1) $ then z1=[z1,n_elements(y)-1] index0=where(z1 lt N) index0=z1(n_elements(index0)-1) ind=(where(z1 gt N))(0) if ind ge 0 then index1=z1(ind) else index1=n_elements(y)-1 return,[index0,index1] end ####################################################### function select_set, xx, aa Sz=size(xx) if Sz(0) eq 3 then begin N=Sz(3) Rd=fltarr(N) for j=0,N-1 do Rd(j)=distance(xx(*,*,j), aa) endif else begin N=Sz(2) Rd=fltarr(N) for j=0,N-1 do Rd(j)=distance(xx(*,j), aa) endelse amin=min(Rd, imin) return, imin end ####################################################### ; must .run coalign first function shift_align,a,b,inshift=inshift,outshift=outshift,dmin=dmin,dmax=dmax ; shifts b to match a: uses coalign to get shift, grids up and ; back down to get shifted image ; inshift is alternative shift supplied ; outshift returns derived shift ; dmin, dmax are limits on range to use for correlation asz=size(a) bsz=size(b) if ((asz[0] ne bsz[0]) or (asz[1] ne bsz[1]) or (asz[2] ne bsz[2])) $ then begin print,'Dimensions must be the same.' return,-1 endif ; sh is the shift to be given to b to match a if keyword_set(inshift) then sh=inshift else begin amin=a & bmin=b if keyword_set(dmin) then begin amin=a>dmin bmin=b>dmin endif amax=amin & bmax=bmin if keyword_set(dmax) then begin amax=amin 0) plots, 64+entry.map.ipeak.x, 64+entry.map.ipeak.y, $ /dev, syms=1, psym=8, color=color plots, 64+entry.map.vpeak.x, 64+entry.map.vpeak.y, $ /dev, syms=2, psym=1, color=color for j=0,entry.nar-1 do begin xr=entry.region(j).location.x yr=entry.region(j).location.y dx=1 if (xr gt dx) and (yr gt dx) $ and (xr lt (!d.x_size-dx)) and (yr lt (!d.y_size-dx)) then $ xyouts, xr+64, yr+64, entry.region(j).name, align=0.5, /dev, font=0, $ col=color endfor No_AR: end function rd_c_log,filename,version=version,log=log,date=date,time=time,error=error F_save=filename filename=strlowcase((name_extract(filename))(0)) if n_elements(version) le 0 then version=0 if n_elements(log) le 0 then log=pickfile(tit='Please select a LOG file') if (findfile(log))(0) eq '' then begin xwarning, ['The log file '+log+' not found.', $ 'You can only view the image.'] error=1 return,0 endif WIDGET_CONTROL,/hour A=[0.,0.,0.] error=0 openr,lun,log,/get_lun File_info=strarr(500) temp='' N_records=0 while not eof(lun) do begin readf,lun,temp File_info(N_records)=temp N_records=N_records+1 endwhile File_info=File_info(0:N_records-1) x=File_info free_lun,lun Found=(j=0) REPEAT BEGIN b=strpos(x(4*j),',') if b ge 0 then begin file=strmid(x(4*j),0,b) Number=fix(strmid(x(4*j),b+1,20)) if file eq filename and Number eq version then Found=1 endif else begin file=x(4*j) if strupcase(file) eq strupcase(filename) then Found=1 endelse j=j+1 ENDREP UNTIL (j gt N_records/4-1) or Found if Found then begin Num=j-1 x=x(4*num:4*num+3) Date=x(1) Time=x(2) x=strtrim(strcompress(x(3)),2) i1=strpos(x,' ') i2=strpos(x,' ',i1+1) A(0)=strmid(x,0,i1) A(1)=strmid(x,i1+1,i2-i1) A(2)=strmid(x,i2+1,20) endif else begin xwarning, ['The log file '+log+' not found.', $ 'You can only view the image.'] error=1 endelse filename=F_save return, A end pro source_input_optics ; This routine loads optical picture into the window ID.Win(4) ; and sets clipping rectangle in system variable !P corresponding ; to disable clipping Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db WIDGET_CONTROL,/hour Data.Map=(Num=0) if Data.Optics eq '' then path=getenv('optics_dir') $ else path=subdir(Data.Optics) filename=pickfile(path=path,/read,file=Data.Optics) if filename eq '' then return WIDGET_CONTROL,/hour Data.Optics=filename aa=(name_extract(Filename))(1) Nobeyama=0 IF strlowcase(strmid(aa,6,1)) eq 'y' THEN BEGIN YOHKOH=1 Inf1=(Inf2=(Number=(N_size=''))) openr,lun,Filename,/get_lun Descr=fstat(lun) readf,lun,Inf1 readf,lun,Number readf,lun,Inf2 readf,lun,N_size Inf1=Inf1+string(Number) Inf2=Inf2+string(N_size)+'x'+strtrim(N_size,2) Info_strings=strarr(Number) readf,lun,Info_strings Num=xselect(Info_strings,info=[Inf1,Inf2],tit='Please select a record') Offset=Descr.size-1L*N_size*N_size*Number temp=assoc(lun,bytarr(N_size,N_size),Offset) Y_data=temp(Num) free_lun,lun Moment.Date=strmid(aa,4,2)+' '+strmid(aa,2,2)+' '+strmid(aa,0,2) Moment.Time=strmid(Info_strings(Num),16,8) a=strtrim(Info_strings(Num),2) version=strmid(a,0,strpos(a,' ')) ENDIF ELSE BEGIN Y_data=bytscl(rd_image(filename, head=head, type=type, /sc)) if type eq 'FITS' then begin origin=strtrim(fh_r_key(head, 'origin', error=error),2) if error then goto, Continue if origin eq 'nobeyama radio obs' or origin eq 'BADARY' then begin Centre=[256., 256.]+64 Radius=fh_r_key(head, 'solr')/fh_r_key(head, 'cdelt1') Image_Date=fh_r_key(head,'date-obs') Image_Time=fh_r_key(head,'time-obs') Nobeyama=1 endif version='0' YOHKOH=0 endif Continue: version='0' YOHKOH=0 ENDELSE Data={PosEW:[-90.,0.], PosSN:[-90.,0.], PosSUN:[0.,0.], $ BeamEW:0D, B_EW:Data.B_EW, BeamSN:0D, B_SN:Data.B_SN, $ DxEW:[0D,0D,0D], DyEW:[0D,0D,0D], $ DxSN:[0D,0D,0D], DySN:[0D,0D,0D], $ Zoom:0, Press:0, Release:0, $ Mode:'Follow', Mouse:0, Optics:filename, $ ClearEW:1, ClearSN:1, ClearSUN:1, $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', $ Optics_data:temporary(Y_data), $ Point1:[0.,0.], Point2:[0.,0.], Point3:[0.,0.], $ Map:0, Number:strtrim(version,2), $ Shift_EW:Data.Shift_EW, Shift_SN:Data.Shift_SN} wset,ID.Win(4) & erase,0 Sz=(Size(Data.Optics_data))([1,2]) N_sc=((Sz(0) lt 400) and (Sz(1) lt 400))+1 if Nobeyama then goto, Nob ;***************************************************************** ; READING THE COORDINATES OF THE SOLAR DISK FROM THE FILE ;***************************************************************** CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE f=(name_extract(filename))(0) bf=byte(f) ind=where(bf le 57 and bf ge 48) ff=string(bf(ind)) FileDate=strmid(ff,4,2)+' '+strmid(ff,2,2)+' '+strmid(ff,0,2) log=subdir(Data.Optics)+Delim+strcompress(FileDate,/rem)+'.crd' Limb=rd_c_log(filename,version=version,log=log,date=date,time=time,error=error) if error then begin Limb=[[!d.x_size,!d.y_size]/2.,!d.x_size/3.] Image_time=Moment.time Image_date=Moment.date endif else begin Image_time=time Image_date=date endelse Centre=Limb([0,1]) Radius=Limb(2) Nob: ;***************************************************************** dx_size=640 X_shift0=(dx_size-512)/2 X_shift=!d.x_size/2.-Centre(0)+X_shift0 Y_shift=!d.y_size/2.-Centre(1)+X_shift0 if N_sc gt 1 then tv,rebin(Data.Optics_data,512,512),X_shift,Y_shift $ else tv,Data.Optics_data,X_shift,Y_shift WIDGET_CONTROL,ID.Label,set_val=Date_string(Moment.Date)+', '+Moment.Time+' UT' xyouts,0.01,0.94,/nor,Date_string(Image_Date)+'!C'+Image_Time+' UT', $ chars=1.5,col=!d.n_colors-1 SUNo=SUN suneph,Moment.Date,Moment.Time,SUNo temp=!p.color & !p.color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,SUN.B0*!Radeg,0,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, color=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp Data.Map=1 scale,temp,/mem ;if Data.GridType eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp scale,MapAxes0,/mem & SC.MapAxes0=MapAxes0 Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. ;SC.R0=!D.x_vsize/2/Factor*[1,1] SC.R0=Radius SC.Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) ;SC.R0=(convert_coord(R0,/norm,/to_dev))([0,1]) ;plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) empty !P.clip=[0,0,1000,1000] goto, Label00 ;*************************************************************** Optics_data=bytarr(400,400,/nozero) & date=(time='') IF Data.Optics eq '' THEN BEGIN filename=pickfile(path=getenv('optics_dir'),filter='*.pho',/read) if filename eq '' then return ENDIF ELSE filename=Data.Optics WIDGET_CONTROL,/hour openr,lun,filename,/get_lun readf,lun,date,time readu,lun,Optics_data free_lun,lun Data.Optics=filename ;WIDGET_CONTROL,ID.TimelabelIMG,set_value= $ ; Date_string(date)+', '+time+' UT' wset,Id.win(4) erase,0 V_shift=!d.x_vsize*(Factor-1)/2 N=!d.x_vsize/400 if N eq 1 then tvscl, Optics_data,V_shift,V_shift else $ tvscl, rebin(Optics_data,N*400,N*400),V_shift,V_shift Label00: put_ar_data empty !P.clip=[0,0,1000,1000] end pro plot_scans, model=model, intensity=intensity, $ polarisation=polarisation,Xmargin=Xmargin,Xrange=Xrange, $ Scales=Scales,Charsize=Charsize,color=color,s_shift=s_shift,OS=OS Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db ; ********************************************************************* ; Draws scans in INTENSITY and POLARISATION ; as well as the SUN model in the graphics window. ; ********************************************************************* if N_elements(s_shift) le 0 then s_shift=0 if n_elements(color) le 0 then color=0 !p.multi=[0,0,3] Xplot=indgen(n_elements(model))+1 plot,Xplot,model,Xst=9,Xmar=Xmargin,Ymar=[2.5,0.5],Yst=4, $ Xrange=Xrange,xticklen=0.2,charsiz=Charsize,font=0,col=color scale,Smodel,/mem if n_elements(OS) gt 0 then $ oplot,Xplot,OS/1.08,col=color,linest=Ini.lines(1) if n_elements(intensity) gt 1 then begin plot,Xplot+s_shift,intensity,Xst=5,Xmar=Xmargin,Ymar=[1,0],Yst=5, $ Xrange=Xrange, Yrange=[min(intensity),max(intensity)], $ charsiz=Charsize,col=color xyouts,0.02,0.5,'!18I!3',/norm,Charsiz=1.8 endif else SI=Smodel scale,SI,/mem if n_elements(polarisation) gt 1 then begin plot,Xplot+s_shift,polarisation,Xst=5,Xmar=Xmargin,Ymar=[1,0],Yst=4, $ Xrange=Xrange,charsiz=Charsize,col=color xyouts,0.02,0.25,'!18V!3',/norm,Charsiz=1.8 endif else SV=Smodel scale,SV,/mem SCALES={Smodel:Smodel, SI:SI, SV:SV} !p.multi=0 end pro source_draw_win ; This routine draws models of the quiet Sun scans ; as well as the scans themselves if they are available ; in two windows. ; Accordingly, in the third window map grid is drawn. Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db Sum_chan=[176,192] ; ****** DRAW MAIN WINDOW E - W ****** wset,Id.win(0) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char, col=0, $ OS=CHECKVIS(Rec,SSRT.NoEW_OS,SSRT.CEW_OS) SC.ZEWmain=S.Smodel & SC.IEWmain=S.SI & SC.VEWmain=S.SV ; ****** DRAW MAIN WINDOW S - N ****** wset,Id.win(1) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char, col=0, $ OS=CHECKVIS(Rec,SSRT.NoSN_OS,SSRT.CSN_OS) SC.ZSNmain=S.Smodel & SC.ISNmain=S.SI & SC.VSNmain=S.SV ; ****** DRAW SUN MAP WINDOW ****** IF Data.Optics ne '' THEN source_input_optics ELSE BEGIN Data.GridType = 'Heliographical' !p.multi=0 wset,Id.win(4) & Erase,255 MarginY=[1.,1.]*0 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE Limb=[[!d.x_size,!d.y_size]/2.,!d.x_size/3.] Centre=Limb([0,1]) Radius=Limb(2) !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius temp=!p.color & !p.color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,SUN.B0*!Radeg,0,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, color=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp Data.Map=1 scale,MapAxes0,/mem & SC.MapAxes0=MapAxes0 Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. SC.R0=Radius SC.Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) !p.color=temp ENDELSE put_ar_data !P.clip=[0,0,1000,1000] empty end pro Zoomed_sun ; Draws map grid, axes and diurnal parallel in ; the large window for zoomed Sun image. ; Accordingly, both FWHM beam positions for ; both SSRT interferometers are drawn if they are ; defined. Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db ; *** ZOOM WINDOW (SUN MAP) *** window_set,ID.win(5),mul=0 IF Data.Zoom eq 0 THEN BEGIN MarginY=[1.,1.]*0.8 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE map_set,SUN.B0*!Radeg,0,0,/ort,/nobor,/grid,/lab,tit=' ', glinestyle=Ini.lines(1), $ Xmar=MarginX,Ymar=MarginY,col=Data.GridColor,latd=10,lond=10, $ latal=1.,lonal=1. scale,MapAxesZ,/mem & SC.MapAxesZ=MapAxesZ XW=!x.window & YW=!y.window SC.CentreZ=(convert_coord([XW(0)+XW(1),YW(0)+YW(1)]/2.,/nor,/to_dev))([0,1]) SC.RZ=(convert_coord([XW(1)-XW(0),YW(1)-YW(0)]/2.,/nor,/to_dev))([0,1]) plotline,1e6,SC.CentreZ,/dev,col=Data.GridColor,linestyle=Ini.lines(3) plotline,0,SC.CentreZ,/dev,col=Data.GridColor,linestyle=Ini.lines(3) plotline,-tan(SUN.Dp),SC.CentreZ,col=Ini.colors(6),/dev,linestyle=Ini.lines(1) xyouts,0.1,0.95,Date_string(Moment.Date),/nor,col=0 xyouts,0.8,0.95,Moment.Time+' UT',/nor,col=0 Data.Zoom=1 ENDIF ELSE BEGIN scale,SC.MapAxesZ,/rec ENDELSE if SpotCoord(2) le -1 then goto,LZoom sz=size(SpotCoord) if sz(0) eq 1 then in=1 else in=sz(2) for i=0,in-1 do plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 LZoom: B_EW=SC.CentreZ#[1,1,1]+transpose([[Data.DxEW*SC.RZ(0)],[Data.DyEW*SC.RZ(1)]]) for i=0,2,2 do plotline,tan(!Dpi/2-Par.G_EW)*SC.RZ(1)/SC.RZ(0), $ B_EW(*,i), col=0, line=Ini.lines(4),/dev B_SN=SC.CentreZ#[1,1,1]+transpose([[Data.DxSN*SC.RZ(0)],[Data.DySN*SC.RZ(1)]]) for i=0,2,2 do plotline,tan(!Dpi/2-Par.G_SN)*SC.RZ(1)/SC.RZ(0), $ B_SN(*,i),col=0, line=Ini.lines(2),/dev plots,[0.91,0.99],[0.115,0.115],lin=ini.lines(4),/nor plots,[0.91,0.99],[0.075,0.075],lin=ini.lines(2),/nor xyouts,0.85,0.1,'W-E',/nor,charsiz=1.2,col=0 xyouts,0.85,0.06,'S-N',/nor,charsiz=1.2,col=0 end pro Source_event,ev ; Event loop for routine SOURCE Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db CASE !version.OS OF 'windows': Plot_color=255b 'Win32': Plot_color=255b ELSE: Plot_color=127b ENDCASE Sum_chan=[176,192] N=128D & D=4.9D C=2.997925D8 & Fi=SSRT.Fi H=SUN.H & Decl=SUN.Decl P=SSRT.P NoEW=SSRT.NoEW & OEW=SSRT.OEW & CEW=SSRT.CEW A_EW=Par.A_EW & G_EW=Par.G_EW Q=SSRT.Q NoSN=SSRT.NoSN & OSN=SSRT.OSN & CSN=SSRT.CSN A_SN=Par.A_SN & G_SN=Par.G_SN P_OS=SSRT.P_OS NoEW_OS=SSRT.NoEW_OS & OEW_OS=SSRT.OEW_OS & CEW_OS=SSRT.CEW_OS Q_OS=SSRT.Q_OS NoSN_OS=SSRT.NoSN_OS & OSN_OS=SSRT.OSN_OS & CSN_OS=SSRT.CSN_OS Rsol=SUN.R & B0=SUN.B0 & Dp=SUN.Dp F0=SSRT.F0 & Df=SSRT.Df ;** PROCESS DRAWABLE EVENTS ** FOR j=0,5 do $ IF ev.id eq ID.View(j) THEN BEGIN if ev.press ne 0 then Data.press=1 ;Pressed button? if ev.release ne 0 then Data.press=0 ;Released button? ENDIF IF ev.id eq ID.View(0) THEN BEGIN window_set,Id.win(0),sca=SC.IEWmain temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(0), $ set_val=string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if Data.press then begin CASE Data.Mode OF 'Follow': if not Data.ClearEW then begin device,set_graphics_function=6 plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color ; Restore precedent lines Data.PosEW=temp plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color window_set,Id.win(4), sca=SC.MapAxes0 ;SUN MAP WINDOW plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,1),/dev, col=Plot_Color device,set_graphics_function=3 empty endif else Data.ClearEW=0 'Scope': begin Data.PosEW=temp for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=j window_set,Id.win(2) device,set_graphics_function=3 plot_scans, model=CHECKVIS(Rec,NoEW,CEW), sca=SF, $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX,Char=Ini.Char, $ Xran=[Data.PosEW(0)-10,Data.PosEW(0)+10],col=0, $ s_shift=Data.Shift_EW SC.IEWaux=SF.SI empty return end ELSE: ENDCASE endif ENDIF IF ev.id eq ID.View(2) THEN BEGIN window_set,Id.win(2),sca=SC.IEWaux temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(2),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin Data.PosEW=temp & wait,0.2 for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=1-j WIDGET_CONTROL,ID.LabelEWSN(0),set_val= $ string(Data.PosEW(0),Data.PosEW(1),format='(F6.1,",",2X,F6.1)') endif ENDIF IF ((ev.id eq ID.View(0)) or (ev.id eq ID.View(2))) THEN $ IF Data.press eq 0 THEN return ELSE BEGIN if (ev.id eq ID.View(2)) then Data.press=0 ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 ChanEWobs=Data.PosEW(0) OEWobs=ORD_RECOGNIZE(ChanEWobs,NoEW,OEW,CEW) CoordEW=acos(OEWobs*C/chanfreq(ChanEWobs,Rec)/D) Data.BeamEW=0.886*C/(N*F0*D*abs(sin(P(1))))*par.BeamEW(1)/par.BeamEW(0) CoordEW=[CoordEW-Data.BeamEW/2,CoordEW,CoordEW+Data.BeamEW/2] Data.DyEW=[0D,0D,0D] Data.DxEW=(P(1)-coordEW)/cos(G_EW)/Rsol KEW=tan(!Dpi/2-G_EW) BEW=Data.DyEW-KEW*Data.DxEW Data.B_EW=SC.Centre0#[1,1,1]+ $ transpose([[Data.DxEW*SC.R0(0)],[Data.DyEW*SC.R0(1)]]) device,set_graphics_function=6 plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,1),col=Plot_Color,/dev device,set_graphics_function=3 empty return ENDELSE IF ev.id eq ID.View(1) THEN BEGIN window_set,Id.win(1),sca=SC.ISNmain temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(1),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin CASE Data.Mode OF 'Follow': if Data.ClearSN ne 1 then begin device,set_graphics_function=6 plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,col=Plot_Color Data.PosSN=temp plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,col=Plot_Color window_set,Id.win(4), sca=SC.MapAxes0 plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), Data.B_SN(*,1),/dev, col=Plot_Color device,set_graphics_function=3 empty endif else Data.clearSN=0 'Scope': begin Data.PosSN=temp for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=j window_set,Id.win(3) device,set_graphics_function=3 plot_scans, model=CHECKVIS(Rec,NoSN,CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, sca=SF, $ Xran=[Data.PosSN(0)-10,Data.PosSN(0)+10],Char=Ini.Char,col=0, $ s_shift=Data.Shift_SN SC.ISNaux=SF.SI empty & return end ELSE: ENDCASE endif ENDIF IF ev.id eq ID.View(3) THEN BEGIN window_set,Id.win(3),sca=SC.ISNaux temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(3),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin Data.PosSN=temp & wait,0.2 for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=1-j WIDGET_CONTROL,ID.LabelEWSN(1),set_val= $ string(Data.PosSN(0),Data.PosSN(1),format='(F6.1,",",2X,F6.1)') endif ENDIF IF ((ev.id eq ID.View(1)) or (ev.id eq ID.View(3))) THEN $ IF Data.press eq 0 THEN return ELSE BEGIN if (ev.id eq ID.View(3)) then Data.press=0 ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 ChanSNobs=Data.PosSN(0) OSNobs=ORD_RECOGNIZE(ChanSNobs,NoSN,OSN,CSN) CoordSN=acos(OSNobs*C/chanfreq(ChanSNobs,Rec)/D) Data.BeamSN=0.886*C/(N*F0*D*abs(sin(Q(1))))*par.BeamSN(1)/par.BeamSN(0) CoordSN=[CoordSN-Data.BeamSN/2,CoordSN,CoordSN+Data.BeamSN/2] Data.DySN=[0D,0D,0D] Data.DxSN=(CoordSN-Q(1))/abs(cos(G_SN))/Rsol*sign(H) KSN=tan(!Dpi/2-G_SN) BSN=Data.DySN-KSN*Data.DxSN Data.B_SN=SC.Centre0#[1,1,1]+ $ transpose([[Data.DxSN*SC.R0(0)],[Data.DySN*SC.R0(1)]]) device,set_graphics_function=6 plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), $ Data.B_SN(*,1),col=Plot_Color,/dev device,set_graphics_function=3 empty return ENDELSE IF ev.id eq ID.View(4) THEN BEGIN window_set,Id.win(4),sca=SC.MapAxes0 ;Map Window temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.MapLabel,set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (ev.press ne 0) and (Data.Mouse eq 1) then begin ; Mark spot plots,temp,/data,psym=8,syms=0.7 & Data.Mouse=0 empty & return endif if (Data.press gt 0) then begin Data.PosSUN=temp Xsun=([ev.x,ev.y]-SC.Centre0)/SC.R0 Pobs=P(1)-(Xsun(0)*cos(G_EW)-Xsun(1)*sin(G_EW))*Rsol window_set,Id.win(0),sca=SC.IEWmain ;Window E-W F_N=C/(D*cos(Pobs)) device,set_graphics_function=6 if equiv(EW_line_save, fltarr(NoEW)) then New=1 else New=0 for j=0,NoEW-1 do begin if (New ne 1) and (Data.ClearSUN ne 1) then $ plots,[(convert_coord(EW_line_save(j),EW_line_save(j),/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color Cobs=chanfreq(F_N*OEW(j),Rec) EW_line_save(j)=Cobs plots,[(convert_coord(Cobs,Cobs,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color endfor Qobs=Q(1)+(Xsun(0)*cos(G_SN)-Xsun(1)*sin(G_SN))*Rsol*sign(SUN.H)* $ sign(sign(cos(G_SN))+0.5) window_set,Id.win(1),sca=SC.ISNmain ;Window S-N F_N=C/(D*cos(Qobs)) if equiv(SN_line_save, fltarr(NoSN)) then New=1 else New=0 for j=0,NoSN-1 do begin if (New ne 1) and (Data.ClearSUN ne 1) then $ plots,[(convert_coord(SN_line_save(j),SN_line_save(j),/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color Cobs=chanfreq(F_N*OSN(j),Rec) SN_line_save(j)=Cobs plots,[(convert_coord(Cobs,Cobs,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color endfor device,set_graphics_function=3 Data.ClearSUN=0 endif empty return ENDIF IF ev.id eq ID.View(5) THEN BEGIN window_set,Id.win(5),sca=SC.MapAxesZ ;Zoom Window Data.PosSUN=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.ZoomLabel,set_val= $ string(Data.PosSUN(0),Data.PosSUN(1),format='(F6.1,",",2X,F6.1)') if ev.press ne 0 then plots,Data.PosSUN,/data,psym=8,syms=0.7 ; Mark spot empty & return ENDIF ;**************** OTHER EVENTS ********************** WIDGET_CONTROL,ev.id,GET_UVALUE = wuv,/hourglass CASE wuv OF "DONE" : begin WIDGET_CONTROL,/hour if ID.group_leader ne 0L then begin if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show endif !P=P_save ID=(SC=(Moment=(Data=(Ini=(Rec=(Stokes=(SSRT=0))))))) P_save=(SpotCoord=(SUN=(Par=(EW_line_save=(SN_line_save=0))))) xyouts,0,0,'!3 ',/nor WIDGET_CONTROL,ev.top,/DEST end "QuitZoom": for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=1-j "XMTool": XMTool,group=ev.top "Xloadct": Xloadct "Scope": Data.Mode='Scope' "Follow": Data.Mode='Follow' "Calculator": wcalc "Suncalc": begin suncalc,group_leader=ev.top, Moment.Date,Moment.Time end "Help" : begin CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE xtext,file=getenv('help_dir')+Delim+'source.hlp',group=ev.top end "VC": spawn,'vc' "NC": spawn,'nc' "DOS" : spawn "Parameters": param_ssrt,time=Moment.time, Date=Moment.Date,Rec=Rec,group=ev.top "Preprocessing": yp,group=ev.top "Clear": begin Data.ClearEW=(Data.ClearSN=(Data.ClearSUN=1)) Data.PosEW=(Data.PosSN=[-90.,0.]) & Data.PosSUN=[5.,5.] source_draw_win !P.clip=[0,0,1000,1000] end "Slider0": begin WIDGET_CONTROL,ID.SliderLabel(0),set_val='Shift = '+ $ string(ev.value*0.1,format='(f4.1)') Data.Shift_EW=ev.value*0.1 ; ****** DRAW MAIN WINDOW E - W ****** wset,Id.win(0) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char,col=0, s_shift=ev.value*0.1, $ OS=CHECKVIS(Rec,SSRT.NoEW_OS,SSRT.CEW_OS) SC.ZEWmain=S.Smodel & SC.IEWmain=S.SI & SC.VEWmain=S.SV end "Slider1": begin WIDGET_CONTROL,ID.SliderLabel(1),set_val='Shift = '+ $ string(ev.value*0.1,format='(f4.1)') Data.Shift_SN=ev.value*0.1 ; ****** DRAW MAIN WINDOW S - N ****** wset,Id.win(1) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char,col=0,s_shift=ev.value*0.1, $ OS=CHECKVIS(Rec,SSRT.NoSN_OS,SSRT.CSN_OS) SC.ZSNmain=S.Smodel & SC.ISNmain=S.SI & SC.VSNmain=S.SV end "E-W FWHM": begin ; WINDOW E-W window_set,Id.win(0),sca=SC.IEWmain SpacingEW=abs(tan(!Dpi/2-P(1))*Df/F0) Pos=transpose((convert_coord([[Data.PosEW-Data.BeamEW/SpacingEW/2], $ [Data.PosEW+Data.BeamEW/SpacingEW/2]],/to_norm))(0,*)) for i=0,1 do plots,[Pos(i),Pos(i)],[0,1], /norm,col=0 empty end "S-N FWHM": begin ; WINDOW S-N window_set,Id.win(1),sca=SC.ISNmain SpacingSN=abs(tan(!Dpi/2-Q(1))*Df/F0) Pos=transpose((convert_coord([[Data.PosSN-Data.BeamSN/SpacingSN/2], $ [Data.PosSN+Data.BeamSN/SpacingSN/2]],/to_norm))(0,*)) for i=0,1 do plots,[Pos(i),Pos(i)],[0,1], /norm,col=0 empty end "SUN FWHM": begin ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 for i=0,2,2 do plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,i),/dev,col=0 for i=0,2,2 do plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), $ Data.B_SN(*,i),/dev,col=0 empty end "Zoom": begin for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=j Zoomed_sun end "Kbrd": BEGIN kb_in_helio,SpotCoord,prompt='Input spots coordinates', group=ev.top window_set,Id.win(4), sca=SC.MapAxes0 if SpotCoord(2) le -1 then goto,Lkbrd sz=size(SpotCoord) if sz(0) eq 1 then in=1 else in=sz(2) FOR i=0,in-1 DO BEGIN IF SpotCoord(2,i) EQ 1. THEN SpotCoord(*,i)=[(convert_coord(SpotCoord(*,i)*SC.R0+ $ SC.Centre0,/dev,/to_data))([0,1]),0] plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 ENDFOR Lkbrd: WIDGET_CONTROL,ev.top,/show END "File": begin rspotcoord,Moment,Coord,num=in if in eq 1 then b0=0. else b0=fltarr(1,in) Coord=[Coord,b0] if SpotCoord(2) le -1. then SpotCoord=Coord else SpotCoord=[[Coord],[SpotCoord]] window_set,Id.win(4), sca=SC.MapAxes0 for i=0,in-1 do plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 WIDGET_CONTROL,ev.top,/show end "Mouse": Data.Mouse=1 "Image": begin source_input_optics WIDGET_CONTROL,ev.top,/show end "White": Data.Gridcolor=Ini.colors(1) "Mild": Data.Gridcolor=Ini.colors(7) "Medium": Data.Gridcolor=Ini.colors(8) "Sharp": Data.Gridcolor=Ini.colors(9) "Remove": begin if Data.Optics eq '' then erase,255 else source_input_optics CASE Data.GridType OF 'Carrington': window_set,ID.Win(4),scal=SC.MapAxesK 'Heliographical': window_set,ID.Win(4),scal=SC.MapAxes0 ELSE: ENDCASE end "Carrington": begin Data.GridType='Carrington' & Lon=SUN.Karr*!Radeg end "Heliographical":begin Data.GridType = 'Heliographical' & Lon=0. end "Axes": begin temp=!p.color & !p.color=Data.Gridcolor window_set,ID.Win(4) plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev !p.color=temp end "Diurnal parallel": begin temp=!p.color & !p.color=Data.Gridcolor window_set,ID.Win(4) plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) !p.color=temp end "AR_White": put_ar_data, !d.n_colors-1 "AR_Black": put_ar_data, 0 "PS": begin goto,BMP1 set_plot,'PS' Sum_chan=[176,192] !x.thick=(!y.thick=(!P.thick=(!P.charthick=2))) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE PS_Filename=getenv('gr_prg')+Delim+ $ newfilename(model=strcompress(Moment.Date,/rem),filt='*.PS') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 Data.GridType = 'Heliographical' !p.multi=0 MarginY=[1.,1.]*0 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE map_set,SUN.B0*!Radeg,0,0,/ortho,/nobor,/grid,/lab, glinestyle=Ini.lines(1), $ Xmar=MarginX,Ymar=MarginY,latdel=10,londel=10 xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. R0=[!x.window(1)-!x.window(0), !y.window(1)-!y.window(0)]/2. Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) R0=(convert_coord(R0,/norm,/to_dev))([0,1]) plotline,1e6,Centre0,/dev & plotline,0,Centre0,/dev plotline,-tan(SUN.Dp),Centre0,/dev,linestyle=Ini.lines(1) plotline,tan(!Dpi/2-G_EW)*R0(1)/R0(0), $ (Centre0#[1,1,1]+transpose([[Data.DxEW*R0(0)],[Data.DyEW*R0(1)]]))(*,1),/dev,linest=0 ;goto, First_only ChanEWobs=Data.PosEW(0)+2 OEWobs=ORD_RECOGNIZE(ChanEWobs,NoEW,OEW,CEW) CoordEW=acos(OEWobs*C/chanfreq(ChanEWobs,Rec)/D) BeamEW=0.886*C/(N*F0*D*abs(sin(P(1))))*par.BeamEW(1)/par.BeamEW(0) CoordEW=[CoordEW-BeamEW/2,CoordEW,CoordEW+BeamEW/2] DyEW=[0D,0D,0D] DxEW=(P(1)-coordEW)/cos(G_EW)/Rsol KEW=tan(!Dpi/2-G_EW) BEW=DyEW-KEW*DxEW B_EW=Centre0#[1,1,1]+ $ transpose([[DxEW*SC.R0(0)],[DyEW*SC.R0(1)]]) ;plotline,tan(!Dpi/2-G_EW)*R0(1)/R0(0), $ ;(Centre0#[1,1,1]+transpose([[DxEW*R0(0)],[DyEW*R0(1)]]))(*,1),/dev,linest=5 First_only: device,/close PS_Filename=newfilename(model=strcompress(Moment.Date,/rem),filt='*.PS') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Char=Ini.Char, $ s_shift=Data.Shift_EW xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+'!CE-W' plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], /norm,linest=0 ;plots,[(convert_coord(Data.PosEW+2,/to_norm))([0,0])],[0,1], /norm,linest=5 device,/close PS_Filename=newfilename(model=strcompress(Moment.Date,/rem),filt='*.ps') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Char=Ini.Char, $ s_shift=Data.Shift_SN xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+'!CS-N' plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,linest=0 device,/close CASE !version.OS OF 'windows': Initial_device='WIN' 'Win32': Initial_device='WIN' ELSE: Initial_device='X' ENDCASE set_plot,Initial_device !x.thick=(!y.thick=(!P.thick=(!P.charthick=1))) BMP1: Filename0=newfilename(model=strcompress(Moment.Date,/rem)+'s',filt='*.bmp') wset,ID.win(4) write_bmp,Filename0,bytscl(tvrd(),top=196b) Filename1=newfilename(model=strcompress(Moment.Date,/rem)+'s',filt='*.bmp') wset,ID.win(0) write_bmp,Filename1,bytscl(tvrd(),top=196b) Filename2=newfilename(model=strcompress(Moment.Date,/rem)+'s',filt='*.bmp') wset,ID.win(1) write_bmp,Filename2,bytscl(tvrd(),top=196b) end ELSE: ENDCASE IF (wuv eq 'Mild') or (wuv eq 'Medium') or (wuv eq 'Sharp') THEN BEGIN ;WIDGET_CONTROL,ID.GridTypelabel,set_val=Data.GridType,/hour if Data.GridType eq 'Carrington' then temp=SC.MapAxesK else temp=SC.MapAxes0 window_set,ID.Win(4),scal=temp temp=!p.color & !p.color=Data.Gridcolor !P.clip=[0,0,!d.x_size,!d.y_size] map_grid,/label,latdel=10,londel=10,col=Data.Gridcolor, glinestyle=Ini.lines(1) !p.color=temp ENDIF IF (wuv eq 'Heliographical') or (wuv eq 'Carrington') THEN BEGIN ;WIDGET_CONTROL,ID.GridTypelabel,set_val=Data.GridType,/hour wset,ID.Win(4) if Data.Optics eq '' then erase,255 else source_input_optics temp=!p.color & !p.color=Data.Gridcolor ;map_set,SUN.B0*!Radeg,Lon,0, /grid,/label, glinestyle=Ini.lines(1), $ ; /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,SUN.B0*!Radeg,Lon,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,Lon,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, color=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp & scale,temp,/mem if wuv eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp ENDIF empty end pro source,output1, group_leader=group_leader,Date=Date, $ time=time,Rec_Type=Rec_Type,iew=iew,vew=vew,isn=isn,vsn=vsn Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db if xregistered('source') then return CASE !version.OS OF 'windows': begin Factor=1. Delim='\' end 'Win32': begin Factor=1. Delim='\' end ELSE: begin Factor=1.04 Delim='/' end ENDCASE if n_elements(group_leader) le 0 then group_leader = 0 WIDGET_CONTROL,/hourglass SpotCoord=[0.,0.,-1.] ID={View:Lonarr(6), Win:Lonarr(6), Label:0L, ToggleBase:[0L,0L], $ Leftbase:[0L,0L], LabelEW:0L, LabelEWSN:lonarr(4), MapLabel:0L, $ ZoomLabel:0L, Slider:[0L,0L],SliderLabel:[0L,0L],group_leader:group_leader} Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} SC={ZEWmain:Ax, IEWmain:Ax, VEWmain:Ax, $ ZSNmain:Ax, ISNmain:Ax, VSNmain:Ax, $ ZEWaux:Ax, IEWaux:Ax, VEWaux:Ax, $ ZSNaux:Ax, ISNaux:Ax, VSNaux:Ax, $ MapAxes0:Ax, R0:fltarr(2), Centre0:fltarr(2), $ MapAxesK:Ax, RK:fltarr(2), CentreK:fltarr(2), $ MapAxesZ:Ax, RZ:fltarr(2), CentreZ:fltarr(2)} Ax=0 M=strlowcase(findfile('vga_drv.rcg')) if equiv(M,'') then M=1 else begin openr,lun,'vga_drv.rcg',/get_lun readf,lun,M free_lun,lun endelse ;M=0 for L-310 else M=1 (to plot lines with various styles) Ini={Lines:indgen(5)*M(0),$ colors:[0B, $ ; Color Table !d.n_colors-1, $ ; Background 0B, $ ; Main color for inscriptions 255B, $ ; E-W 160B, $ ; Reserved 255B, $ ; S-N 60B, $ ; Diurnal parallel 200B, $ ; Mild grid 100B, $ ; Medium grid 0B], $ ; Sharp grid PmargX:[3.5,3.5], Char:1.5} temp=make_array(2,3,val=2000D) Data={PosEW:[-90.,0.], PosSN:[-90.,0.], PosSUN:[5.,5.], $ BeamEW:0D, B_EW:temp, BeamSN:0D, B_SN:temp, $ DxEW:[0D,0D,0D], DyEW:[0D,0D,0D], $ DxSN:[0D,0D,0D], DySN:[0D,0D,0D], $ Zoom:0, Press:0, Release:0, Mode:'Follow', Mouse:0, Optics:'', $ ClearEW:1, ClearSN:1, ClearSUN:1, $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', $ Optics_data:bytarr(640,640), $ Point1:[0.,0.], Point2:[0.,0.], Point3:[0.,0.], Map:0, Number:'', $ Shift_EW:0., Shift_SN:0.} s=dg_make_struct() if n_elements(db) lt 10 then begin db_file=(findfile(getenv('ar_database')+Delim+'db.sav*'))(0) if db_file eq '' then begin print,'Error: missing database file "db.save". Bye!' return endif restore,db_file endif if n_elements(iew) le 0 then iew=0 if n_elements(vew) le 0 then vew=0 if n_elements(isn) le 0 then isn=0 if n_elements(vsn) le 0 then vsn=0 Stokes={iew:iew, vew:vew, isn:isn, vsn:vsn} if n_elements(Date) le 0 then Date='' if strlen(Date) lt 2 then read,'Date (e.g. 24 08 93) - ', Date if n_elements(Time) le 0 then Time='' if strlen(Time) lt 2 then read,'Time (e.g. 07 04 33.457) - ', Time Moment={Date:Date, Time:Time} if n_elements(Rec_Type) le 0 then begin Rec=0 & read,'Receiver (0-MFB, 1-AOR) - ', Rec endif else Rec=Rec_Type P_save=!P !p.background=Ini.colors(1) & !p.color=Ini.colors(2) Sum_chan=[176,192] Fmin=chanfreq(1,Rec) Fmax=chanfreq(Sum_chan(Rec),Rec) F0=(Fmax+Fmin)/2 Df=(Fmax-Fmin)/(Sum_chan(Rec)-1) param_ssrt,Date,time,Rec,Par=Par,SUN=SUN,/silent INT_ORD,0,Rec,SUN,P,NnEW,NordEW,ChanEW INT_ORD,1,Rec,SUN,Q,NnSN,NordSN,ChanSN ;Radio SUN INT_ORD,0,Rec,SUN,P_OS,NnEW_OS,NordEW_OS,ChanEW_OS,Radio=1. INT_ORD,1,Rec,SUN,Q_OS,NnSN_OS,NordSN_OS,ChanSN_OS,Radio=1. ;Optical SUN SSRT={Fi:51.7575d*!DPi/180, F0:F0, Df:Df, $ P:P, NoEW:NnEW, OEW:NordEW, CEW:ChanEW, $ Q:Q, NoSN:NnSN, OSN:NordSN, CSN:ChanSN, $ P_OS:P_OS, NoEW_OS:NnEW_OS, OEW_OS:NordEW_OS, CEW_OS:ChanEW_OS, $ Q_OS:Q_OS, NoSN_OS:NnSN_OS, OSN_OS:NordSN_OS, CSN_OS:ChanSN_OS} EW_line_save=fltarr(NnEW) SN_line_save=fltarr(NnSN) device,set_graphics_function=3 device,get_scr=scr if scr(1) lt 500 then ZoomWin=scr*0.8 else ZoomWin=scr*0.92 if scr(1) lt 1000 then TV_size=512 else TV_size=640 TV_size=[1,1]*TV_size*Factor Scan_size0=[(scr(0)-TV_size(0))*0.9,scr(1)/2.5] Scan_size1=[TV_size(0),scr(1)/2.3] Xs= [[[Scan_size0]#replicate(1,2)], $ [[Scan_size1]#replicate(1,2)], $ [TV_size], [ZoomWin]] ;***** Drawing widget Mainbase= widget_base(/fra, group=group_leader, $ tit='Coordinates for event of '+Date_string(Moment.Date)) for j=0,1 do ID.ToggleBase(j)=widget_base(Mainbase) ;***** Left Base if scr(1) lt 500 then Wholebase=widget_base(ID.ToggleBase(0),/row,/scroll, $ x_scroll_size=scr(0)*0.96, y_scroll_size=scr(1)*0.91) else $ Wholebase=widget_base(ID.ToggleBase(0),/row) LeftTogglebase=widget_base(Wholebase) for j=0,1 do ID.Leftbase(j)=widget_base(LeftTogglebase,/colu) XPdMenu, ['"DONE" DONE', $ '"Tools" {', $ '"Screen"{', $ '"Mode" {', $ '"Follow" Follow', $ '"Scope" Scope', '}',$ '"Zoom" Zoom', $ '"Clear" Clear','}',$ '"Grid" {', $ '"Diurnal parallel" Diurnal parallel', $ '"Axes" Axes', $ '"Brightness" {', $ '"White" White', $ '"Light" Mild', $ '"Grey" Medium', $ '"Black" Sharp','}', $ '"Longitude" {', $ '"Heliographical" Heliographical', $ '"Carrington" Carrington','}',$ '"Remove" Remove', $ '"AR color" {', $ '"White" AR_White', $ '"Black" AR_Black','}', $ '}', $ '"Beam FWHM" {', $ '"On the E-W scan" E-W FWHM', $ '"On the S-N scan" S-N FWHM', $ '"On the Sun" SUN FWHM','}',$ '"Calculator" Calculator', $ '"Coord. converter" Suncalc', $ '"Parameters" Parameters', $ '"Input of image" {', $ ; '"Keyboard" Kbrd', $ ; '"Mouse" Mouse', $ ; '"File" File', $ '"Optical picture" Image', $ '"Preprocessing" Preprocessing', $ '}',$ '"Xloadct" Xloadct', $ '"XManager Tool" XMTool', $ '"Shell" DOS', $ ; '"Norton Commander" {','"NC" NC', $ ; '"VC" VC','}', $ '}', $ ; '"PS" PS', $ '"Help" Help'], ID.Leftbase(0) ;Emptystring=string(0,format='(30(" "))') Emptystring=' ' ID.label=WIDGET_LABEL(ID.Leftbase(0), val= $ Emptystring+Time+' UT'+Emptystring+'E-W') ;if scr(1) gt 1000 then ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=Xs(0,4), $ ; YS=Xs(1,4), /motion, /button, retain=2) else $ Scroll_size=480 if scr(1) gt 1000 then ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=640, $ YS=640, /motion, /button, retain=2) else $ ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=640, $ YS=640, /motion, /button, retain=2,/scroll, $ x_scroll=Scroll_size,y_scroll=Scroll_size) if strmid(!version.release,0,1) lt 5 then $ ID.Maplabel=WIDGET_LABEL(ID.Leftbase(0), val= $ 'Diurnal parallel'+Emptystring+'S-N') else $ ID.Maplabel=WIDGET_LABEL(ID.Leftbase(0), val= $ 'Diurnal parallel'+Emptystring+'S-N', /dynam) for j=2,3 do begin ID.view(j)=WIDGET_DRAW(ID.Leftbase(1), XS=Xs(0,j), YS=Xs(1,j), /motion, $ /button_events, retain=2) if strmid(!version.release,0,1) lt 5 then $ ID.LabelEWSN(J)=WIDGET_LABEL(ID.Leftbase(1),val=Emptystring) else $ ID.LabelEWSN(J)=WIDGET_LABEL(ID.Leftbase(1),val=Emptystring, /dynam) endfor ZoomBase=WIDGET_BASE(ID.ToggleBase(1),/row) junk=WIDGET_BASE(ZoomBase,/colu) junk1=WIDGET_BUTTON(junk,VAL='DONE',uval='QuitZoom') junk=WIDGET_BASE(ZoomBase,/colu) ID.view(5)=WIDGET_DRAW(junk, XS=Xs(0,5), YS=Xs(1,5), /motion, $ /button_events, retain=2) if strmid(!version.release,0,1) lt 5 then $ ID.ZoomLabel=WIDGET_LABEL(junk,val=Emptystring) else $ ID.ZoomLabel=WIDGET_LABEL(junk,val=Emptystring, /dynam) ;***** Right Base Rightbase=widget_base(Wholebase,/colu) for J=0,1 do begin Slider_Base=WIDGET_BASE(Rightbase,/row) ID.Slider(J)=WIDGET_SLIDER(Slider_Base, $ min=-50,max=50,val=0,uval='Slider'+strtrim(j,2),/suppress) ID.SliderLabel(J)=WIDGET_LABEL(Slider_Base,val='Shift = 0 ') ID.view(J)=WIDGET_DRAW(Rightbase, XS=Xs(0,J),YS=Xs(1,J), /motion, /button_events, retain=2) if strmid(!version.release,0,1) lt 5 then $ ID.LabelEWSN(J)=WIDGET_LABEL(Rightbase,val=Emptystring) else $ ID.LabelEWSN(J)=WIDGET_LABEL(Rightbase,val=Emptystring, /dynam) endfor ;***** WIDGET_CONTROL,ID.Leftbase(1),map=0 WIDGET_CONTROL,ID.Togglebase(1),map=0 WIDGET_CONTROL,Mainbase,/real,/hour for J=0,5 do begin WIDGET_CONTROL,ID.view(J),GET_VALUE=temp & ID.Win(J)=temp wset,ID.Win(J) Erase,255 endfor if scr(1) lt 1000 then WIDGET_CONTROL,ID.view(4),set_draw_view=[1,1]*(640-Scroll_size)/2 WIDGET_CONTROL,/hour loadct,Ini.colors(0) circ source_draw_win xmanager,'Source',Mainbase,group=group_leader end ####################################################### pro put_ar_data, color Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db if n_elements(color) eq 0 then color=0 WIDGET_CONTROL,/hour Db_date=strmid(Moment.date, 6, 2)+'/'+strmid(Moment.date, 3, 2)+'/'+ $ strmid(Moment.date, 0, 2) n=(where(db.date eq Db_date))(0) if n lt 0 then goto, No_AR entry=db(n > 0) plots, 64+entry.map.ipeak.x, 64+entry.map.ipeak.y, $ /dev, syms=1, psym=8, color=color plots, 64+entry.map.vpeak.x, 64+entry.map.vpeak.y, $ /dev, syms=2, psym=1, color=color for j=0,entry.nar-1 do begin xr=entry.region(j).location.x yr=entry.region(j).location.y dx=1 if (xr gt dx) and (yr gt dx) $ and (xr lt (!d.x_size-dx)) and (yr lt (!d.y_size-dx)) then $ xyouts, xr+64, yr+64, entry.region(j).name, align=0.5, /dev, font=0, $ col=color endfor No_AR: end function rd_c_log,filename,version=version,log=log,date=date,time=time,error=error F_save=filename filename=strlowcase((name_extract(filename))(0)) if n_elements(version) le 0 then version=0 if n_elements(log) le 0 then log=pickfile(tit='Please select a LOG file') if (findfile(log))(0) eq '' then begin xwarning, ['The log file '+log+' not found.', $ 'You can only view the image.'] error=1 return,0 endif WIDGET_CONTROL,/hour A=[0.,0.,0.] error=0 openr,lun,log,/get_lun File_info=strarr(500) temp='' N_records=0 while not eof(lun) do begin readf,lun,temp File_info(N_records)=temp N_records=N_records+1 endwhile File_info=File_info(0:N_records-1) x=File_info free_lun,lun Found=(j=0) REPEAT BEGIN b=strpos(x(4*j),',') if b ge 0 then begin file=strmid(x(4*j),0,b) Number=fix(strmid(x(4*j),b+1,20)) if file eq filename and Number eq version then Found=1 endif else begin file=x(4*j) if strupcase(file) eq strupcase(filename) then Found=1 endelse j=j+1 ENDREP UNTIL (j gt N_records/4-1) or Found if Found then begin Num=j-1 x=x(4*num:4*num+3) Date=x(1) Time=x(2) x=strtrim(strcompress(x(3)),2) i1=strpos(x,' ') i2=strpos(x,' ',i1+1) A(0)=strmid(x,0,i1) A(1)=strmid(x,i1+1,i2-i1) A(2)=strmid(x,i2+1,20) endif else begin xwarning, ['The log file '+log+' not found.', $ 'You can only view the image.'] error=1 endelse filename=F_save return, A end pro source_input_optics ; This routine loads optical picture into the window ID.Win(4) ; and sets clipping rectangle in system variable !P corresponding ; to disable clipping Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db WIDGET_CONTROL,/hour Data.Map=(Num=0) if Data.Optics eq '' then path=getenv('optics_dir') $ else path=subdir(Data.Optics) filename=pickfile(path=path,/read,file=Data.Optics) if filename eq '' then return WIDGET_CONTROL,/hour Data.Optics=filename aa=(name_extract(Filename))(1) Nobeyama=0 IF strlowcase(strmid(aa,6,1)) eq 'y' THEN BEGIN YOHKOH=1 Inf1=(Inf2=(Number=(N_size=''))) openr,lun,Filename,/get_lun Descr=fstat(lun) readf,lun,Inf1 readf,lun,Number readf,lun,Inf2 readf,lun,N_size Inf1=Inf1+string(Number) Inf2=Inf2+string(N_size)+'x'+strtrim(N_size,2) Info_strings=strarr(Number) readf,lun,Info_strings Num=xselect(Info_strings,info=[Inf1,Inf2],tit='Please select a record') Offset=Descr.size-1L*N_size*N_size*Number temp=assoc(lun,bytarr(N_size,N_size),Offset) Y_data=temp(Num) free_lun,lun Moment.Date=strmid(aa,4,2)+' '+strmid(aa,2,2)+' '+strmid(aa,0,2) Moment.Time=strmid(Info_strings(Num),16,8) a=strtrim(Info_strings(Num),2) version=strmid(a,0,strpos(a,' ')) ENDIF ELSE BEGIN Y_data=bytscl(rd_image(filename, head=head, type=type, /sc)) if type eq 'FITS' then begin origin=strtrim(fh_r_key(head, 'origin', error=error),2) if error then goto, Continue if origin eq 'nobeyama radio obs' or origin eq 'BADARY' then begin Centre=[256., 256.]+64 Radius=fh_r_key(head, 'solr')/fh_r_key(head, 'cdelt1') Image_Date=fh_r_key(head,'date-obs') Image_Time=fh_r_key(head,'time-obs') Nobeyama=1 endif version='0' YOHKOH=0 endif Continue: version='0' YOHKOH=0 ENDELSE Data={PosEW:[-90.,0.], PosSN:[-90.,0.], PosSUN:[0.,0.], $ BeamEW:0D, B_EW:Data.B_EW, BeamSN:0D, B_SN:Data.B_SN, $ DxEW:[0D,0D,0D], DyEW:[0D,0D,0D], $ DxSN:[0D,0D,0D], DySN:[0D,0D,0D], $ Zoom:0, Press:0, Release:0, $ Mode:'Follow', Mouse:0, Optics:filename, $ ClearEW:1, ClearSN:1, ClearSUN:1, $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', $ Optics_data:temporary(Y_data), $ Point1:[0.,0.], Point2:[0.,0.], Point3:[0.,0.], $ Map:0, Number:strtrim(version,2), $ Shift_EW:Data.Shift_EW, Shift_SN:Data.Shift_SN} wset,ID.Win(4) & erase,0 Sz=(Size(Data.Optics_data))([1,2]) N_sc=((Sz(0) lt 400) and (Sz(1) lt 400))+1 if Nobeyama then goto, Nob ;***************************************************************** ; READING THE COORDINATES OF THE SOLAR DISK FROM THE FILE ;***************************************************************** CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE f=(name_extract(filename))(0) bf=byte(f) ind=where(bf le 57 and bf ge 48) ff=string(bf(ind)) FileDate=strmid(ff,4,2)+' '+strmid(ff,2,2)+' '+strmid(ff,0,2) log=subdir(Data.Optics)+Delim+strcompress(FileDate,/rem)+'.crd' Limb=rd_c_log(filename,version=version,log=log,date=date,time=time,error=error) if error then begin Limb=[[!d.x_size,!d.y_size]/2.,!d.x_size/3.] Image_time=Moment.time Image_date=Moment.date endif else begin Image_time=time Image_date=date endelse Centre=Limb([0,1]) Radius=Limb(2) Nob: ;***************************************************************** dx_size=640 X_shift0=(dx_size-512)/2 X_shift=!d.x_size/2.-Centre(0)+X_shift0 Y_shift=!d.y_size/2.-Centre(1)+X_shift0 if N_sc gt 1 then tv,rebin(Data.Optics_data,512,512),X_shift,Y_shift $ else tv,Data.Optics_data,X_shift,Y_shift WIDGET_CONTROL,ID.Label,set_val=Date_string(Moment.Date)+', '+Moment.Time+' UT' xyouts,0.01,0.94,/nor,Date_string(Image_Date)+'!C'+Image_Time+' UT', $ chars=1.5,col=!d.n_colors-1 SUNo=SUN suneph,Moment.Date,Moment.Time,SUNo temp=!p.color & !p.color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,SUN.B0*!Radeg,0,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, color=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp Data.Map=1 scale,temp,/mem ;if Data.GridType eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp scale,MapAxes0,/mem & SC.MapAxes0=MapAxes0 Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. ;SC.R0=!D.x_vsize/2/Factor*[1,1] SC.R0=Radius SC.Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) ;SC.R0=(convert_coord(R0,/norm,/to_dev))([0,1]) ;plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) empty !P.clip=[0,0,1000,1000] goto, Label00 ;*************************************************************** Optics_data=bytarr(400,400,/nozero) & date=(time='') IF Data.Optics eq '' THEN BEGIN filename=pickfile(path=getenv('optics_dir'),filter='*.pho',/read) if filename eq '' then return ENDIF ELSE filename=Data.Optics WIDGET_CONTROL,/hour openr,lun,filename,/get_lun readf,lun,date,time readu,lun,Optics_data free_lun,lun Data.Optics=filename ;WIDGET_CONTROL,ID.TimelabelIMG,set_value= $ ; Date_string(date)+', '+time+' UT' wset,Id.win(4) erase,0 V_shift=!d.x_vsize*(Factor-1)/2 N=!d.x_vsize/400 if N eq 1 then tvscl, Optics_data,V_shift,V_shift else $ tvscl, rebin(Optics_data,N*400,N*400),V_shift,V_shift Label00: put_ar_data empty !P.clip=[0,0,1000,1000] end pro plot_scans, model=model, intensity=intensity, $ polarisation=polarisation,Xmargin=Xmargin,Xrange=Xrange, $ Scales=Scales,Charsize=Charsize,color=color,s_shift=s_shift,OS=OS Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db ; ********************************************************************* ; Draws scans in INTENSITY and POLARISATION ; as well as the SUN model in the graphics window. ; ********************************************************************* if N_elements(s_shift) le 0 then s_shift=0 if n_elements(color) le 0 then color=0 !p.multi=[0,0,3] Xplot=indgen(n_elements(model))+1 plot,Xplot,model,Xst=9,Xmar=Xmargin,Ymar=[2.5,0.5],Yst=4, $ Xrange=Xrange,xticklen=0.2,charsiz=Charsize,font=0,col=color scale,Smodel,/mem if n_elements(OS) gt 0 then $ oplot,Xplot,OS/1.08,col=color,linest=Ini.lines(1) if n_elements(intensity) gt 1 then begin plot,Xplot+s_shift,intensity,Xst=5,Xmar=Xmargin,Ymar=[1,0],Yst=5, $ Xrange=Xrange, Yrange=[min(intensity),max(intensity)], $ charsiz=Charsize,col=color xyouts,0.02,0.5,'!18I!3',/norm,Charsiz=1.8 endif else SI=Smodel scale,SI,/mem if n_elements(polarisation) gt 1 then begin plot,Xplot+s_shift,polarisation,Xst=5,Xmar=Xmargin,Ymar=[1,0],Yst=4, $ Xrange=Xrange,charsiz=Charsize,col=color xyouts,0.02,0.25,'!18V!3',/norm,Charsiz=1.8 endif else SV=Smodel scale,SV,/mem SCALES={Smodel:Smodel, SI:SI, SV:SV} !p.multi=0 end pro source_draw_win ; This routine draws models of the quiet Sun scans ; as well as the scans themselves if they are available ; in two windows. ; Accordingly, in the third window map grid is drawn. Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db Sum_chan=[176,192] ; ****** DRAW MAIN WINDOW E - W ****** wset,Id.win(0) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char, col=0, $ OS=CHECKVIS(Rec,SSRT.NoEW_OS,SSRT.CEW_OS) SC.ZEWmain=S.Smodel & SC.IEWmain=S.SI & SC.VEWmain=S.SV ; ****** DRAW MAIN WINDOW S - N ****** wset,Id.win(1) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char, col=0, $ OS=CHECKVIS(Rec,SSRT.NoSN_OS,SSRT.CSN_OS) SC.ZSNmain=S.Smodel & SC.ISNmain=S.SI & SC.VSNmain=S.SV ; ****** DRAW SUN MAP WINDOW ****** IF Data.Optics ne '' THEN source_input_optics ELSE BEGIN Data.GridType = 'Heliographical' !p.multi=0 wset,Id.win(4) & Erase,255 MarginY=[1.,1.]*0 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE Limb=[[!d.x_size,!d.y_size]/2.,!d.x_size/3.] Centre=Limb([0,1]) Radius=Limb(2) !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius temp=!p.color & !p.color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,SUN.B0*!Radeg,0,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, color=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp Data.Map=1 scale,MapAxes0,/mem & SC.MapAxes0=MapAxes0 Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. SC.R0=Radius SC.Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) !p.color=temp ENDELSE put_ar_data !P.clip=[0,0,1000,1000] empty end pro Zoomed_sun ; Draws map grid, axes and diurnal parallel in ; the large window for zoomed Sun image. ; Accordingly, both FWHM beam positions for ; both SSRT interferometers are drawn if they are ; defined. Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db ; *** ZOOM WINDOW (SUN MAP) *** window_set,ID.win(5),mul=0 IF Data.Zoom eq 0 THEN BEGIN MarginY=[1.,1.]*0.8 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE map_set,SUN.B0*!Radeg,0,0,/ort,/nobor,/grid,/lab,tit=' ', glinestyle=Ini.lines(1), $ Xmar=MarginX,Ymar=MarginY,col=Data.GridColor,latd=10,lond=10, $ latal=1.,lonal=1. scale,MapAxesZ,/mem & SC.MapAxesZ=MapAxesZ XW=!x.window & YW=!y.window SC.CentreZ=(convert_coord([XW(0)+XW(1),YW(0)+YW(1)]/2.,/nor,/to_dev))([0,1]) SC.RZ=(convert_coord([XW(1)-XW(0),YW(1)-YW(0)]/2.,/nor,/to_dev))([0,1]) plotline,1e6,SC.CentreZ,/dev,col=Data.GridColor,linestyle=Ini.lines(3) plotline,0,SC.CentreZ,/dev,col=Data.GridColor,linestyle=Ini.lines(3) plotline,-tan(SUN.Dp),SC.CentreZ,col=Ini.colors(6),/dev,linestyle=Ini.lines(1) xyouts,0.1,0.95,Date_string(Moment.Date),/nor,col=0 xyouts,0.8,0.95,Moment.Time+' UT',/nor,col=0 Data.Zoom=1 ENDIF ELSE BEGIN scale,SC.MapAxesZ,/rec ENDELSE if SpotCoord(2) le -1 then goto,LZoom sz=size(SpotCoord) if sz(0) eq 1 then in=1 else in=sz(2) for i=0,in-1 do plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 LZoom: B_EW=SC.CentreZ#[1,1,1]+transpose([[Data.DxEW*SC.RZ(0)],[Data.DyEW*SC.RZ(1)]]) for i=0,2,2 do plotline,tan(!Dpi/2-Par.G_EW)*SC.RZ(1)/SC.RZ(0), $ B_EW(*,i), col=0, line=Ini.lines(4),/dev B_SN=SC.CentreZ#[1,1,1]+transpose([[Data.DxSN*SC.RZ(0)],[Data.DySN*SC.RZ(1)]]) for i=0,2,2 do plotline,tan(!Dpi/2-Par.G_SN)*SC.RZ(1)/SC.RZ(0), $ B_SN(*,i),col=0, line=Ini.lines(2),/dev plots,[0.91,0.99],[0.115,0.115],lin=ini.lines(4),/nor plots,[0.91,0.99],[0.075,0.075],lin=ini.lines(2),/nor xyouts,0.85,0.1,'W-E',/nor,charsiz=1.2,col=0 xyouts,0.85,0.06,'S-N',/nor,charsiz=1.2,col=0 end pro Source_event,ev ; Event loop for routine SOURCE Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db CASE !version.OS OF 'windows': Plot_color=255b 'Win32': Plot_color=255b ELSE: Plot_color=127b ENDCASE Sum_chan=[176,192] N=128D & D=4.9D C=2.997925D8 & Fi=SSRT.Fi H=SUN.H & Decl=SUN.Decl P=SSRT.P NoEW=SSRT.NoEW & OEW=SSRT.OEW & CEW=SSRT.CEW A_EW=Par.A_EW & G_EW=Par.G_EW Q=SSRT.Q NoSN=SSRT.NoSN & OSN=SSRT.OSN & CSN=SSRT.CSN A_SN=Par.A_SN & G_SN=Par.G_SN P_OS=SSRT.P_OS NoEW_OS=SSRT.NoEW_OS & OEW_OS=SSRT.OEW_OS & CEW_OS=SSRT.CEW_OS Q_OS=SSRT.Q_OS NoSN_OS=SSRT.NoSN_OS & OSN_OS=SSRT.OSN_OS & CSN_OS=SSRT.CSN_OS Rsol=SUN.R & B0=SUN.B0 & Dp=SUN.Dp F0=SSRT.F0 & Df=SSRT.Df ;** PROCESS DRAWABLE EVENTS ** FOR j=0,5 do $ IF ev.id eq ID.View(j) THEN BEGIN if ev.press ne 0 then Data.press=1 ;Pressed button? if ev.release ne 0 then Data.press=0 ;Released button? ENDIF IF ev.id eq ID.View(0) THEN BEGIN window_set,Id.win(0),sca=SC.IEWmain temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(0), $ set_val=string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if Data.press then begin CASE Data.Mode OF 'Follow': if not Data.ClearEW then begin device,set_graphics_function=6 plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color ; Restore precedent lines Data.PosEW=temp plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color window_set,Id.win(4), sca=SC.MapAxes0 ;SUN MAP WINDOW plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,1),/dev, col=Plot_Color device,set_graphics_function=3 empty endif else Data.ClearEW=0 'Scope': begin Data.PosEW=temp for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=j window_set,Id.win(2) device,set_graphics_function=3 plot_scans, model=CHECKVIS(Rec,NoEW,CEW), sca=SF, $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX,Char=Ini.Char, $ Xran=[Data.PosEW(0)-10,Data.PosEW(0)+10],col=0, $ s_shift=Data.Shift_EW SC.IEWaux=SF.SI empty return end ELSE: ENDCASE endif ENDIF IF ev.id eq ID.View(2) THEN BEGIN window_set,Id.win(2),sca=SC.IEWaux temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(2),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin Data.PosEW=temp & wait,0.2 for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=1-j WIDGET_CONTROL,ID.LabelEWSN(0),set_val= $ string(Data.PosEW(0),Data.PosEW(1),format='(F6.1,",",2X,F6.1)') endif ENDIF IF ((ev.id eq ID.View(0)) or (ev.id eq ID.View(2))) THEN $ IF Data.press eq 0 THEN return ELSE BEGIN if (ev.id eq ID.View(2)) then Data.press=0 ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 ChanEWobs=Data.PosEW(0) OEWobs=ORD_RECOGNIZE(ChanEWobs,NoEW,OEW,CEW) CoordEW=acos(OEWobs*C/chanfreq(ChanEWobs,Rec)/D) Data.BeamEW=0.886*C/(N*F0*D*abs(sin(P(1))))*par.BeamEW(1)/par.BeamEW(0) CoordEW=[CoordEW-Data.BeamEW/2,CoordEW,CoordEW+Data.BeamEW/2] Data.DyEW=[0D,0D,0D] Data.DxEW=(P(1)-coordEW)/cos(G_EW)/Rsol KEW=tan(!Dpi/2-G_EW) BEW=Data.DyEW-KEW*Data.DxEW Data.B_EW=SC.Centre0#[1,1,1]+ $ transpose([[Data.DxEW*SC.R0(0)],[Data.DyEW*SC.R0(1)]]) device,set_graphics_function=6 plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,1),col=Plot_Color,/dev device,set_graphics_function=3 empty return ENDELSE IF ev.id eq ID.View(1) THEN BEGIN window_set,Id.win(1),sca=SC.ISNmain temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(1),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin CASE Data.Mode OF 'Follow': if Data.ClearSN ne 1 then begin device,set_graphics_function=6 plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,col=Plot_Color Data.PosSN=temp plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,col=Plot_Color window_set,Id.win(4), sca=SC.MapAxes0 plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), Data.B_SN(*,1),/dev, col=Plot_Color device,set_graphics_function=3 empty endif else Data.clearSN=0 'Scope': begin Data.PosSN=temp for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=j window_set,Id.win(3) device,set_graphics_function=3 plot_scans, model=CHECKVIS(Rec,NoSN,CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, sca=SF, $ Xran=[Data.PosSN(0)-10,Data.PosSN(0)+10],Char=Ini.Char,col=0, $ s_shift=Data.Shift_SN SC.ISNaux=SF.SI empty & return end ELSE: ENDCASE endif ENDIF IF ev.id eq ID.View(3) THEN BEGIN window_set,Id.win(3),sca=SC.ISNaux temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(3),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin Data.PosSN=temp & wait,0.2 for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=1-j WIDGET_CONTROL,ID.LabelEWSN(1),set_val= $ string(Data.PosSN(0),Data.PosSN(1),format='(F6.1,",",2X,F6.1)') endif ENDIF IF ((ev.id eq ID.View(1)) or (ev.id eq ID.View(3))) THEN $ IF Data.press eq 0 THEN return ELSE BEGIN if (ev.id eq ID.View(3)) then Data.press=0 ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 ChanSNobs=Data.PosSN(0) OSNobs=ORD_RECOGNIZE(ChanSNobs,NoSN,OSN,CSN) CoordSN=acos(OSNobs*C/chanfreq(ChanSNobs,Rec)/D) Data.BeamSN=0.886*C/(N*F0*D*abs(sin(Q(1))))*par.BeamSN(1)/par.BeamSN(0) CoordSN=[CoordSN-Data.BeamSN/2,CoordSN,CoordSN+Data.BeamSN/2] Data.DySN=[0D,0D,0D] Data.DxSN=(CoordSN-Q(1))/abs(cos(G_SN))/Rsol*sign(H) KSN=tan(!Dpi/2-G_SN) BSN=Data.DySN-KSN*Data.DxSN Data.B_SN=SC.Centre0#[1,1,1]+ $ transpose([[Data.DxSN*SC.R0(0)],[Data.DySN*SC.R0(1)]]) device,set_graphics_function=6 plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), $ Data.B_SN(*,1),col=Plot_Color,/dev device,set_graphics_function=3 empty return ENDELSE IF ev.id eq ID.View(4) THEN BEGIN window_set,Id.win(4),sca=SC.MapAxes0 ;Map Window temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.MapLabel,set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (ev.press ne 0) and (Data.Mouse eq 1) then begin ; Mark spot plots,temp,/data,psym=8,syms=0.7 & Data.Mouse=0 empty & return endif if (Data.press gt 0) then begin Data.PosSUN=temp Xsun=([ev.x,ev.y]-SC.Centre0)/SC.R0 Pobs=P(1)-(Xsun(0)*cos(G_EW)-Xsun(1)*sin(G_EW))*Rsol window_set,Id.win(0),sca=SC.IEWmain ;Window E-W F_N=C/(D*cos(Pobs)) device,set_graphics_function=6 if equiv(EW_line_save, fltarr(NoEW)) then New=1 else New=0 for j=0,NoEW-1 do begin if (New ne 1) and (Data.ClearSUN ne 1) then $ plots,[(convert_coord(EW_line_save(j),EW_line_save(j),/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color Cobs=chanfreq(F_N*OEW(j),Rec) EW_line_save(j)=Cobs plots,[(convert_coord(Cobs,Cobs,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color endfor Qobs=Q(1)+(Xsun(0)*cos(G_SN)-Xsun(1)*sin(G_SN))*Rsol*sign(SUN.H)* $ sign(sign(cos(G_SN))+0.5) window_set,Id.win(1),sca=SC.ISNmain ;Window S-N F_N=C/(D*cos(Qobs)) if equiv(SN_line_save, fltarr(NoSN)) then New=1 else New=0 for j=0,NoSN-1 do begin if (New ne 1) and (Data.ClearSUN ne 1) then $ plots,[(convert_coord(SN_line_save(j),SN_line_save(j),/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color Cobs=chanfreq(F_N*OSN(j),Rec) SN_line_save(j)=Cobs plots,[(convert_coord(Cobs,Cobs,/to_norm))([0,0])],[0,1], $ /norm,col=Plot_Color endfor device,set_graphics_function=3 Data.ClearSUN=0 endif empty return ENDIF IF ev.id eq ID.View(5) THEN BEGIN window_set,Id.win(5),sca=SC.MapAxesZ ;Zoom Window Data.PosSUN=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.ZoomLabel,set_val= $ string(Data.PosSUN(0),Data.PosSUN(1),format='(F6.1,",",2X,F6.1)') if ev.press ne 0 then plots,Data.PosSUN,/data,psym=8,syms=0.7 ; Mark spot empty & return ENDIF ;**************** OTHER EVENTS ********************** WIDGET_CONTROL,ev.id,GET_UVALUE = wuv,/hourglass CASE wuv OF "DONE" : begin WIDGET_CONTROL,/hour if ID.group_leader ne 0L then begin if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show endif !P=P_save ID=(SC=(Moment=(Data=(Ini=(Rec=(Stokes=(SSRT=0))))))) P_save=(SpotCoord=(SUN=(Par=(EW_line_save=(SN_line_save=0))))) xyouts,0,0,'!3 ',/nor WIDGET_CONTROL,ev.top,/DEST end "QuitZoom": for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=1-j "XMTool": XMTool,group=ev.top "Xloadct": Xloadct "Scope": Data.Mode='Scope' "Follow": Data.Mode='Follow' "Calculator": wcalc "Suncalc": begin suncalc,group_leader=ev.top, Moment.Date,Moment.Time end "Help" : begin CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE xtext,file=getenv('help_dir')+Delim+'source.hlp',group=ev.top end "VC": spawn,'vc' "NC": spawn,'nc' "DOS" : spawn "Parameters": param_ssrt,time=Moment.time, Date=Moment.Date,Rec=Rec,group=ev.top "Preprocessing": yp,group=ev.top "Clear": begin Data.ClearEW=(Data.ClearSN=(Data.ClearSUN=1)) Data.PosEW=(Data.PosSN=[-90.,0.]) & Data.PosSUN=[5.,5.] source_draw_win !P.clip=[0,0,1000,1000] end "Slider0": begin WIDGET_CONTROL,ID.SliderLabel(0),set_val='Shift = '+ $ string(ev.value*0.1,format='(f4.1)') Data.Shift_EW=ev.value*0.1 ; ****** DRAW MAIN WINDOW E - W ****** wset,Id.win(0) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char,col=0, s_shift=ev.value*0.1, $ OS=CHECKVIS(Rec,SSRT.NoEW_OS,SSRT.CEW_OS) SC.ZEWmain=S.Smodel & SC.IEWmain=S.SI & SC.VEWmain=S.SV end "Slider1": begin WIDGET_CONTROL,ID.SliderLabel(1),set_val='Shift = '+ $ string(ev.value*0.1,format='(f4.1)') Data.Shift_SN=ev.value*0.1 ; ****** DRAW MAIN WINDOW S - N ****** wset,Id.win(1) & erase,255 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Scales=S, $ Char=Ini.Char,col=0,s_shift=ev.value*0.1, $ OS=CHECKVIS(Rec,SSRT.NoSN_OS,SSRT.CSN_OS) SC.ZSNmain=S.Smodel & SC.ISNmain=S.SI & SC.VSNmain=S.SV end "E-W FWHM": begin ; WINDOW E-W window_set,Id.win(0),sca=SC.IEWmain SpacingEW=abs(tan(!Dpi/2-P(1))*Df/F0) Pos=transpose((convert_coord([[Data.PosEW-Data.BeamEW/SpacingEW/2], $ [Data.PosEW+Data.BeamEW/SpacingEW/2]],/to_norm))(0,*)) for i=0,1 do plots,[Pos(i),Pos(i)],[0,1], /norm,col=0 empty end "S-N FWHM": begin ; WINDOW S-N window_set,Id.win(1),sca=SC.ISNmain SpacingSN=abs(tan(!Dpi/2-Q(1))*Df/F0) Pos=transpose((convert_coord([[Data.PosSN-Data.BeamSN/SpacingSN/2], $ [Data.PosSN+Data.BeamSN/SpacingSN/2]],/to_norm))(0,*)) for i=0,1 do plots,[Pos(i),Pos(i)],[0,1], /norm,col=0 empty end "SUN FWHM": begin ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 for i=0,2,2 do plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,i),/dev,col=0 for i=0,2,2 do plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), $ Data.B_SN(*,i),/dev,col=0 empty end "Zoom": begin for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=j Zoomed_sun end "Kbrd": BEGIN kb_in_helio,SpotCoord,prompt='Input spots coordinates', group=ev.top window_set,Id.win(4), sca=SC.MapAxes0 if SpotCoord(2) le -1 then goto,Lkbrd sz=size(SpotCoord) if sz(0) eq 1 then in=1 else in=sz(2) FOR i=0,in-1 DO BEGIN IF SpotCoord(2,i) EQ 1. THEN SpotCoord(*,i)=[(convert_coord(SpotCoord(*,i)*SC.R0+ $ SC.Centre0,/dev,/to_data))([0,1]),0] plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 ENDFOR Lkbrd: WIDGET_CONTROL,ev.top,/show END "File": begin rspotcoord,Moment,Coord,num=in if in eq 1 then b0=0. else b0=fltarr(1,in) Coord=[Coord,b0] if SpotCoord(2) le -1. then SpotCoord=Coord else SpotCoord=[[Coord],[SpotCoord]] window_set,Id.win(4), sca=SC.MapAxes0 for i=0,in-1 do plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 WIDGET_CONTROL,ev.top,/show end "Mouse": Data.Mouse=1 "Image": begin source_input_optics WIDGET_CONTROL,ev.top,/show end "White": Data.Gridcolor=Ini.colors(1) "Mild": Data.Gridcolor=Ini.colors(7) "Medium": Data.Gridcolor=Ini.colors(8) "Sharp": Data.Gridcolor=Ini.colors(9) "Remove": begin if Data.Optics eq '' then erase,255 else source_input_optics CASE Data.GridType OF 'Carrington': window_set,ID.Win(4),scal=SC.MapAxesK 'Heliographical': window_set,ID.Win(4),scal=SC.MapAxes0 ELSE: ENDCASE end "Carrington": begin Data.GridType='Carrington' & Lon=SUN.Karr*!Radeg end "Heliographical":begin Data.GridType = 'Heliographical' & Lon=0. end "Axes": begin temp=!p.color & !p.color=Data.Gridcolor window_set,ID.Win(4) plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev !p.color=temp end "Diurnal parallel": begin temp=!p.color & !p.color=Data.Gridcolor window_set,ID.Win(4) plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) !p.color=temp end "AR_White": put_ar_data, !d.n_colors-1 "AR_Black": put_ar_data, 0 "PS": begin goto,BMP1 set_plot,'PS' Sum_chan=[176,192] !x.thick=(!y.thick=(!P.thick=(!P.charthick=2))) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE PS_Filename=getenv('gr_prg')+Delim+ $ newfilename(model=strcompress(Moment.Date,/rem),filt='*.PS') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 Data.GridType = 'Heliographical' !p.multi=0 MarginY=[1.,1.]*0 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE map_set,SUN.B0*!Radeg,0,0,/ortho,/nobor,/grid,/lab, glinestyle=Ini.lines(1), $ Xmar=MarginX,Ymar=MarginY,latdel=10,londel=10 xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. R0=[!x.window(1)-!x.window(0), !y.window(1)-!y.window(0)]/2. Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) R0=(convert_coord(R0,/norm,/to_dev))([0,1]) plotline,1e6,Centre0,/dev & plotline,0,Centre0,/dev plotline,-tan(SUN.Dp),Centre0,/dev,linestyle=Ini.lines(1) plotline,tan(!Dpi/2-G_EW)*R0(1)/R0(0), $ (Centre0#[1,1,1]+transpose([[Data.DxEW*R0(0)],[Data.DyEW*R0(1)]]))(*,1),/dev,linest=0 ;goto, First_only ChanEWobs=Data.PosEW(0)+2 OEWobs=ORD_RECOGNIZE(ChanEWobs,NoEW,OEW,CEW) CoordEW=acos(OEWobs*C/chanfreq(ChanEWobs,Rec)/D) BeamEW=0.886*C/(N*F0*D*abs(sin(P(1))))*par.BeamEW(1)/par.BeamEW(0) CoordEW=[CoordEW-BeamEW/2,CoordEW,CoordEW+BeamEW/2] DyEW=[0D,0D,0D] DxEW=(P(1)-coordEW)/cos(G_EW)/Rsol KEW=tan(!Dpi/2-G_EW) BEW=DyEW-KEW*DxEW B_EW=Centre0#[1,1,1]+ $ transpose([[DxEW*SC.R0(0)],[DyEW*SC.R0(1)]]) ;plotline,tan(!Dpi/2-G_EW)*R0(1)/R0(0), $ ;(Centre0#[1,1,1]+transpose([[DxEW*R0(0)],[DyEW*R0(1)]]))(*,1),/dev,linest=5 First_only: device,/close PS_Filename=newfilename(model=strcompress(Moment.Date,/rem),filt='*.PS') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Char=Ini.Char, $ s_shift=Data.Shift_EW xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+'!CE-W' plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], /norm,linest=0 ;plots,[(convert_coord(Data.PosEW+2,/to_norm))([0,0])],[0,1], /norm,linest=5 device,/close PS_Filename=newfilename(model=strcompress(Moment.Date,/rem),filt='*.ps') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Char=Ini.Char, $ s_shift=Data.Shift_SN xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+'!CS-N' plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,linest=0 device,/close CASE !version.OS OF 'windows': Initial_device='WIN' 'Win32': Initial_device='WIN' ELSE: Initial_device='X' ENDCASE set_plot,Initial_device !x.thick=(!y.thick=(!P.thick=(!P.charthick=1))) BMP1: Filename0=newfilename(model=strcompress(Moment.Date,/rem)+'s',filt='*.bmp') wset,ID.win(4) write_bmp,Filename0,bytscl(tvrd(),top=196b) Filename1=newfilename(model=strcompress(Moment.Date,/rem)+'s',filt='*.bmp') wset,ID.win(0) write_bmp,Filename1,bytscl(tvrd(),top=196b) Filename2=newfilename(model=strcompress(Moment.Date,/rem)+'s',filt='*.bmp') wset,ID.win(1) write_bmp,Filename2,bytscl(tvrd(),top=196b) end ELSE: ENDCASE IF (wuv eq 'Mild') or (wuv eq 'Medium') or (wuv eq 'Sharp') THEN BEGIN ;WIDGET_CONTROL,ID.GridTypelabel,set_val=Data.GridType,/hour if Data.GridType eq 'Carrington' then temp=SC.MapAxesK else temp=SC.MapAxes0 window_set,ID.Win(4),scal=temp temp=!p.color & !p.color=Data.Gridcolor !P.clip=[0,0,!d.x_size,!d.y_size] map_grid,/label,latdel=10,londel=10,col=Data.Gridcolor, glinestyle=Ini.lines(1) !p.color=temp ENDIF IF (wuv eq 'Heliographical') or (wuv eq 'Carrington') THEN BEGIN ;WIDGET_CONTROL,ID.GridTypelabel,set_val=Data.GridType,/hour wset,ID.Win(4) if Data.Optics eq '' then erase,255 else source_input_optics temp=!p.color & !p.color=Data.Gridcolor ;map_set,SUN.B0*!Radeg,Lon,0, /grid,/label, glinestyle=Ini.lines(1), $ ; /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/Radius !y.range=[-1,1]*0.5*!d.y_size/Radius map_set,SUN.B0*!Radeg,Lon,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,Lon,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, color=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp & scale,temp,/mem if wuv eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp ENDIF empty end pro source,output1, group_leader=group_leader,Date=Date, $ time=time,Rec_Type=Rec_Type,iew=iew,vew=vew,isn=isn,vsn=vsn Common Exch_source,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Common AR_database, db if xregistered('source') then return CASE !version.OS OF 'windows': begin Factor=1. Delim='\' end 'Win32': begin Factor=1. Delim='\' end ELSE: begin Factor=1.04 Delim='/' end ENDCASE if n_elements(group_leader) le 0 then group_leader = 0 WIDGET_CONTROL,/hourglass SpotCoord=[0.,0.,-1.] ID={View:Lonarr(6), Win:Lonarr(6), Label:0L, ToggleBase:[0L,0L], $ Leftbase:[0L,0L], LabelEW:0L, LabelEWSN:lonarr(4), MapLabel:0L, $ ZoomLabel:0L, Slider:[0L,0L],SliderLabel:[0L,0L],group_leader:group_leader} Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} SC={ZEWmain:Ax, IEWmain:Ax, VEWmain:Ax, $ ZSNmain:Ax, ISNmain:Ax, VSNmain:Ax, $ ZEWaux:Ax, IEWaux:Ax, VEWaux:Ax, $ ZSNaux:Ax, ISNaux:Ax, VSNaux:Ax, $ MapAxes0:Ax, R0:fltarr(2), Centre0:fltarr(2), $ MapAxesK:Ax, RK:fltarr(2), CentreK:fltarr(2), $ MapAxesZ:Ax, RZ:fltarr(2), CentreZ:fltarr(2)} Ax=0 M=strlowcase(findfile('vga_drv.rcg')) if equiv(M,'') then M=1 else begin openr,lun,'vga_drv.rcg',/get_lun readf,lun,M free_lun,lun endelse ;M=0 for L-310 else M=1 (to plot lines with various styles) Ini={Lines:indgen(5)*M(0),$ colors:[0B, $ ; Color Table !d.n_colors-1, $ ; Background 0B, $ ; Main color for inscriptions 255B, $ ; E-W 160B, $ ; Reserved 255B, $ ; S-N 60B, $ ; Diurnal parallel 200B, $ ; Mild grid 100B, $ ; Medium grid 0B], $ ; Sharp grid PmargX:[3.5,3.5], Char:1.5} temp=make_array(2,3,val=2000D) Data={PosEW:[-90.,0.], PosSN:[-90.,0.], PosSUN:[5.,5.], $ BeamEW:0D, B_EW:temp, BeamSN:0D, B_SN:temp, $ DxEW:[0D,0D,0D], DyEW:[0D,0D,0D], $ DxSN:[0D,0D,0D], DySN:[0D,0D,0D], $ Zoom:0, Press:0, Release:0, Mode:'Follow', Mouse:0, Optics:'', $ ClearEW:1, ClearSN:1, ClearSUN:1, $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', $ Optics_data:bytarr(640,640), $ Point1:[0.,0.], Point2:[0.,0.], Point3:[0.,0.], Map:0, Number:'', $ Shift_EW:0., Shift_SN:0.} s=make_struct() if n_elements(db) lt 10 then begin db_file=(findfile(getenv('ar_database')+Delim+'db.sav*'))(0) if db_file eq '' then begin print,'Error: missing database file "db.save". Bye!' return endif restore,db_file endif if n_elements(iew) le 0 then iew=0 if n_elements(vew) le 0 then vew=0 if n_elements(isn) le 0 then isn=0 if n_elements(vsn) le 0 then vsn=0 Stokes={iew:iew, vew:vew, isn:isn, vsn:vsn} if n_elements(Date) le 0 then Date='' if strlen(Date) lt 2 then read,'Date (e.g. 24 08 93) - ', Date if n_elements(Time) le 0 then Time='' if strlen(Time) lt 2 then read,'Time (e.g. 07 04 33.457) - ', Time Moment={Date:Date, Time:Time} if n_elements(Rec_Type) le 0 then begin Rec=0 & read,'Receiver (0-MFB, 1-AOR) - ', Rec endif else Rec=Rec_Type P_save=!P !p.background=Ini.colors(1) & !p.color=Ini.colors(2) Sum_chan=[176,192] Fmin=chanfreq(1,Rec) Fmax=chanfreq(Sum_chan(Rec),Rec) F0=(Fmax+Fmin)/2 Df=(Fmax-Fmin)/(Sum_chan(Rec)-1) param_ssrt,Date,time,Rec,Par=Par,SUN=SUN,/silent INT_ORD,0,Rec,SUN,P,NnEW,NordEW,ChanEW INT_ORD,1,Rec,SUN,Q,NnSN,NordSN,ChanSN ;Radio SUN INT_ORD,0,Rec,SUN,P_OS,NnEW_OS,NordEW_OS,ChanEW_OS,Radio=1. INT_ORD,1,Rec,SUN,Q_OS,NnSN_OS,NordSN_OS,ChanSN_OS,Radio=1. ;Optical SUN SSRT={Fi:51.7575d*!DPi/180, F0:F0, Df:Df, $ P:P, NoEW:NnEW, OEW:NordEW, CEW:ChanEW, $ Q:Q, NoSN:NnSN, OSN:NordSN, CSN:ChanSN, $ P_OS:P_OS, NoEW_OS:NnEW_OS, OEW_OS:NordEW_OS, CEW_OS:ChanEW_OS, $ Q_OS:Q_OS, NoSN_OS:NnSN_OS, OSN_OS:NordSN_OS, CSN_OS:ChanSN_OS} EW_line_save=fltarr(NnEW) SN_line_save=fltarr(NnSN) device,set_graphics_function=3 device,get_scr=scr if scr(1) lt 500 then ZoomWin=scr*0.8 else ZoomWin=scr*0.92 if scr(1) lt 1000 then TV_size=512 else TV_size=640 TV_size=[1,1]*TV_size*Factor Scan_size0=[(scr(0)-TV_size(0))*0.9,scr(1)/2.5] Scan_size1=[TV_size(0),scr(1)/2.3] Xs= [[[Scan_size0]#replicate(1,2)], $ [[Scan_size1]#replicate(1,2)], $ [TV_size], [ZoomWin]] ;***** Drawing widget Mainbase= widget_base(/fra, group=group_leader, $ tit='Coordinates for event of '+Date_string(Moment.Date)) for j=0,1 do ID.ToggleBase(j)=widget_base(Mainbase) ;***** Left Base if scr(1) lt 500 then Wholebase=widget_base(ID.ToggleBase(0),/row,/scroll, $ x_scroll_size=scr(0)*0.96, y_scroll_size=scr(1)*0.91) else $ Wholebase=widget_base(ID.ToggleBase(0),/row) LeftTogglebase=widget_base(Wholebase) for j=0,1 do ID.Leftbase(j)=widget_base(LeftTogglebase,/colu) XPdMenu, ['"DONE" DONE', $ '"Tools" {', $ '"Screen"{', $ '"Mode" {', $ '"Follow" Follow', $ '"Scope" Scope', '}',$ '"Zoom" Zoom', $ '"Clear" Clear','}',$ '"Grid" {', $ '"Diurnal parallel" Diurnal parallel', $ '"Axes" Axes', $ '"Brightness" {', $ '"White" White', $ '"Light" Mild', $ '"Grey" Medium', $ '"Black" Sharp','}', $ '"Longitude" {', $ '"Heliographical" Heliographical', $ '"Carrington" Carrington','}',$ '"Remove" Remove', $ '"AR color" {', $ '"White" AR_White', $ '"Black" AR_Black','}', $ '}', $ '"Beam FWHM" {', $ '"On the E-W scan" E-W FWHM', $ '"On the S-N scan" S-N FWHM', $ '"On the Sun" SUN FWHM','}',$ '"Calculator" Calculator', $ '"Coord. converter" Suncalc', $ '"Parameters" Parameters', $ '"Input of image" {', $ ; '"Keyboard" Kbrd', $ ; '"Mouse" Mouse', $ ; '"File" File', $ '"Optical picture" Image', $ '"Preprocessing" Preprocessing', $ '}',$ '"Xloadct" Xloadct', $ '"XManager Tool" XMTool', $ '"Shell" DOS', $ ; '"Norton Commander" {','"NC" NC', $ ; '"VC" VC','}', $ '}', $ ; '"PS" PS', $ '"Help" Help'], ID.Leftbase(0) ;Emptystring=string(0,format='(30(" "))') Emptystring=' ' ID.label=WIDGET_LABEL(ID.Leftbase(0), val= $ Emptystring+Time+' UT'+Emptystring+'E-W') ;if scr(1) gt 1000 then ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=Xs(0,4), $ ; YS=Xs(1,4), /motion, /button, retain=2) else $ Scroll_size=480 if scr(1) gt 1000 then ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=640, $ YS=640, /motion, /button, retain=2) else $ ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=640, $ YS=640, /motion, /button, retain=2,/scroll, $ x_scroll=Scroll_size,y_scroll=Scroll_size) if strmid(!version.release,0,1) lt 5 then $ ID.Maplabel=WIDGET_LABEL(ID.Leftbase(0), val= $ 'Diurnal parallel'+Emptystring+'S-N') else $ ID.Maplabel=WIDGET_LABEL(ID.Leftbase(0), val= $ 'Diurnal parallel'+Emptystring+'S-N', /dynam) for j=2,3 do begin ID.view(j)=WIDGET_DRAW(ID.Leftbase(1), XS=Xs(0,j), YS=Xs(1,j), /motion, $ /button_events, retain=2) if strmid(!version.release,0,1) lt 5 then $ ID.LabelEWSN(J)=WIDGET_LABEL(ID.Leftbase(1),val=Emptystring) else $ ID.LabelEWSN(J)=WIDGET_LABEL(ID.Leftbase(1),val=Emptystring, /dynam) endfor ZoomBase=WIDGET_BASE(ID.ToggleBase(1),/row) junk=WIDGET_BASE(ZoomBase,/colu) junk1=WIDGET_BUTTON(junk,VAL='DONE',uval='QuitZoom') junk=WIDGET_BASE(ZoomBase,/colu) ID.view(5)=WIDGET_DRAW(junk, XS=Xs(0,5), YS=Xs(1,5), /motion, $ /button_events, retain=2) if strmid(!version.release,0,1) lt 5 then $ ID.ZoomLabel=WIDGET_LABEL(junk,val=Emptystring) else $ ID.ZoomLabel=WIDGET_LABEL(junk,val=Emptystring, /dynam) ;***** Right Base Rightbase=widget_base(Wholebase,/colu) for J=0,1 do begin Slider_Base=WIDGET_BASE(Rightbase,/row) ID.Slider(J)=WIDGET_SLIDER(Slider_Base, $ min=-50,max=50,val=0,uval='Slider'+strtrim(j,2),/suppress) ID.SliderLabel(J)=WIDGET_LABEL(Slider_Base,val='Shift = 0 ') ID.view(J)=WIDGET_DRAW(Rightbase, XS=Xs(0,J),YS=Xs(1,J), /motion, /button_events, retain=2) if strmid(!version.release,0,1) lt 5 then $ ID.LabelEWSN(J)=WIDGET_LABEL(Rightbase,val=Emptystring) else $ ID.LabelEWSN(J)=WIDGET_LABEL(Rightbase,val=Emptystring, /dynam) endfor ;***** WIDGET_CONTROL,ID.Leftbase(1),map=0 WIDGET_CONTROL,ID.Togglebase(1),map=0 WIDGET_CONTROL,Mainbase,/real,/hour for J=0,5 do begin WIDGET_CONTROL,ID.view(J),GET_VALUE=temp & ID.Win(J)=temp wset,ID.Win(J) Erase,255 endfor if scr(1) lt 1000 then WIDGET_CONTROL,ID.view(4),set_draw_view=[1,1]*(640-Scroll_size)/2 WIDGET_CONTROL,/hour loadct,Ini.colors(0) circ source_draw_win xmanager,'Source',Mainbase,group=group_leader end ####################################################### pro source_size_model,time Common Exch_source_size,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SUN,Par,P_save,Results,Fileres,Flux suneph,Moment.Date,time,SUN INT_ORD,Data.Interf ne 'E-W',Rec,SUN,P,Nord,Ord,Chan model=CHECKVIS(Rec,Nord,Chan) z=Stokes(*,Data.number)-Flux.min N_div=8. D_chan=(chan(2,0)-chan(0,0))/N_div for j=0,Nord-1 do begin gate0=(chan(0,j)+D_Chan+[0,(N_div-2)*D_chan]) > 0 < (Data.N_channels-1) if j ne 0 then gate=[gate,gate0] else gate=gate0 endfor for j=0,Nord-1 do begin if j eq 0 then head=z(gate(2*j):gate(2*j+1)) else $ head=[head,z(gate(2*j):gate(2*j+1))] if j eq 0 then divider=model(gate(2*j):gate(2*j+1)) else $ divider=[divider,model(gate(2*j):gate(2*j+1))] endfor factor=min(smooth(median(head,3),3)/divider) Flux={Nord:Nord,Ord:Ord,Chan:Chan,factor:factor,model:model,min:Flux.min, $ weight:0.} end pro source_size_res ; This routine saves results obtained with the routine SOURCE_SIZE ; into the file *******.rsz (****** - Date) Common Exch_source_size,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SUN,Par,P_save,Results,Fileres,Flux WIDGET_CONTROL,/hourglass Rads=!DPi/180/3600 Fileres=newfilename(model=strcompress(Moment.Date,/rem),filt='*.rsz', $ path=getenv('results')) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Fileres=getenv('results')+Delim+Fileres openw,lun,Fileres,/get_lun Com_format= $ ["('Bandwidth, kHz',T25,'Beam FWHM',T40,'Spreading factor')", $ "('(CCD elements ',T20,'Arcsec',T30,'Channels')", $ "(' integrated)')", $ "(60('-'))"] First_words=["(T12,'0 (0 CCD)'","(T8,'292 (2 CCD)'","(T8,'583 (4 CCD)'"] printf,lun,format="(T30,'SOURCE SIZE PROCESSING',/,/)" printf,lun,format="(60('-'),/)" printf,lun,Date_string(Moment.Date),Results.Current_Time, Results.Base_Time, $ Data.Dt*(Data.number-Data.Base_scan),format= $ "(T10,'DATE: ',A11,', SPIKE: ',A12,' UT,',/,'Base scan: ',A12,' UT',' (time difference = ',F8.3,' sec)',/)" printf,lun,Data.interf,format="(T10,'INTERFEROMETER ',A3,' PROCESSED')" printf,lun,format="(60('-'),/)" printf,lun,Results.Width, Results.width/Results.Beam_chan(0)*Results.Beam(0)/Rads, $ format="('Response size = ',F5.1,' channels = ',F5.1,' arcsec')" FOR j=0,2 DO BEGIN if Results.width gt Results.Beam_chan(j) then printf,lun, Results.Width0(j), $ Results.width0(j)/Results.Beam_chan(0)*Results.Beam(0)/Rads, j*2, format= $ "('Source size = ',F5.1,' channels = ',F5.1,' arcsec (',I1,' CCD channels integrated)')" $ else printf,lun,Results.Width,Results.Beam_chan(j),format= $ "('Response size of ',F5.1,' observed less then beam width ',F5.1,' (',I1,' CCD channels integrated)')" ENDFOR printf,lun,format="(30('-'),/)" printf,lun,fix(Results.ysmax+0.5),Results.sigma, Results.imax+1, $ format="('Amplitude = ',I4,'; Sigma = ',F7.2,'; Channel number = ',F5.1,' (1 - 192)',/)" printf,lun,format="(60('-'),/)" for j=0,3 do printf,lun,format=Com_format(j) for j=0,2 do printf,lun,Results.Beam(j)/Rads,Results.Beam(j)/Results.Spacing, $ Results.Beam(j)/Results.Beam(0), $ format=First_words(j)+",T30,F4.1,T45,F6.2,T55,F4.2)" printf,lun,format="(60('-'),/)" printf,lun,Results.Spacing/!Pi*180*3600,format= $ "('Spacing between frequency lobes (peak to peak) = ',F5.1,' arcsec',/)" printf,lun,Results.Tmod(0),Results.Tmod(1), $ 1/Results.Tmod(0),1/Results.Tmod(1),format= $ "('Period of the beam-induced modulation = ',F6.2,' (fmin) ...',/,F6.2,' (fmax) sec',' (frequency = ',F6.2,' ... ',F6.2,' Hz)',/)" free_lun,lun flush,lun end pro source_size_c_u,x ; This routine is called when the widget SOURCE_SIZE dies. ; It restores system variable !P, ; restores vector drawn font index 3, ; saves coordinates of spots in file *******.spt (****** - Date), ; minimizes memory allocated by variables contained in ; common block Exch_source. Common Exch_source_size,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SUN,Par,P_save,Results,Fileres,Flux WIDGET_CONTROL,/hourglass !P=P_save if ID.group_leader ne 0L then begin if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show endif Results=(ID=(SC=(Moment=(Data=(Ini=(Rec=(Stokes=(SSRT=0)))))))) P_save=(SUN=(Par=0)) xyouts,0,0,'!3 ',/nor end pro source_size_draw_win ; This routine draws models of the quiet Sun scans ; as well as the scans themselves if they are available ; in two windows. ; Accordingly, in the third window map grid is drawn. Common Exch_source_size,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SUN,Par,P_save,Results,Fileres,Flux X=indgen(Data.N_channels)+1 ; ****** DRAW TV WINDOW ****** wset,Id.win(0) & erase tv_axes,Stokes,/scale,font=0,xoffset=30 Scale,temp,/mem & SC.Tv=temp ; ****** DRAW SURFACE WINDOW ****** wset,Id.win(1) & erase surface,Stokes,xmar=[4.2],ymar=[3,0.5],/hor ; ****** Fictive drawing SCAN WINDOW ****** wset,Id.win(2) & erase plot,X,X,xst=4,yst=4,/nodata Scale,temp,/mem & SC.Scan=temp ; ****** Fictive drawing WINDOW for differential scan ****** wset,Id.win(3) & erase plot,X,X,xst=4,yst=4,/nodata Scale,temp,/mem & SC.Dif=temp ; ****** Fictive drawing Show WINDOW ****** wset,Id.win(4) & erase plot,X,X,xst=4,yst=4,/nodata Scale,temp,/mem & SC.Show=temp !P.clip=[0,0,1000,1000] empty end pro Source_size_event,ev ; Event loop for routine SOURCE_SIZE Common Exch_source_size,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SUN,Par,P_save,Results,Fileres,Flux X=indgen(Data.N_channels)+1 ;** PROCESS DRAWABLE EVENTS ** IF ev.id eq ID.View(0) THEN BEGIN window_set,ID.Win(0),scale=Sc.Tv p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) N=long(p(1) < ((size(Stokes))(2)-1L) > 0L ) Current_Time=time_outvalue(N, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) WIDGET_CONTROL,ID.Timelabel,set_val=' Scan '+strtrim(N,2)+', '+Current_Time if ev.press then begin WIDGET_CONTROL,/hourglass X_mark=(convert_coord(Data.N_channels+10, 0, /DATA, /TO_DEVICE))(0) draw_marker,[X_mark,Data.Marker],col=!P.Background, 0.8, /left, /fill, /dev draw_marker,[X_mark,ev.y],col=!P.color, 0.8, /left, /fill, /dev Data.Marker=ev.y Data.number=N > 1 wset,ID.Win(2) plot,X,Stokes(*,Data.number),font=0, yticks=4, xmargin=[5,1], ymargin=[2,2], $ tit=' Scan '+strtrim(Data.number,2)+', '+Current_Time, $ xminor=4, yminor=4, xstyle=1 oplot,X,Stokes(*,Data.number)-Stokes(*,Data.number-1),/noc oplot,Flux.model*Flux.factor+Flux.min,col=Ini.colors(5) Scale,temp,/mem & SC.Scan=temp Modestring='Sc '+strtrim(Data.number,2)+' - Sc '+strtrim(Data.Base_scan,2) Base_Time=time_outvalue(Data.Base_scan, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(3) plot,X,Stokes(*,Data.number)-Data.base,font=0, yticks=4, $ xmargin=[5,1], ymargin=[2,2], tit=Modestring+', '+Base_Time, $ xminor=4, yminor=4, xstyle=1 Scale,temp,/mem & SC.Dif=temp endif return ENDIF IF ev.id eq ID.View(2) THEN BEGIN window_set,ID.Win(2),scale=Sc.Scan p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) p(0)=p(0) < ((size(Stokes))(1)-1) > 0 WIDGET_CONTROL,ID.Valuelabel(0),set_val='Channel '+strtrim(fix(p(0)+1),2)+ $ ', value = '+strtrim(fix(p(1)),2) IF ev.press THEN BEGIN CASE 1 OF Flux.Model(p(0)) eq 0: begin Flux.min=p(1) end ELSE: begin Flux.Factor=(p(1)-Flux.min)/(Flux.Model(p(0))) end ENDCASE Current_Time=time_outvalue(Data.Number, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) plot,X,Stokes(*,Data.number),font=0, yticks=4, xmargin=[5,1], ymargin=[2,2], $ tit=' Scan '+strtrim(Data.number,2)+', '+Current_Time, $ xminor=4, yminor=4, xstyle=1 oplot,X,Stokes(*,Data.number)-Stokes(*,Data.number-1),/noc oplot,Flux.model*Flux.factor+Flux.min,col=Ini.colors(5) Scale,temp,/mem & SC.Scan=temp ENDIF return ENDIF IF ev.id eq ID.View(3) THEN BEGIN window_set,ID.Win(3),scale=Sc.Dif p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) p(0)=p(0) < ((size(Stokes))(1)-1) > 0 WIDGET_CONTROL,ID.Valuelabel(1),set_val='Channel '+strtrim(fix(p(0)+1),2)+ $ ', value ='+strtrim(fix(p(1)),2) if ev.press then begin Width_process: WIDGET_CONTROL,/HOUR Current_Time=time_outvalue(Data.number, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) Dif_scan=Stokes(*,Data.number)-Data.base-Data.Line peak=select_peak(Dif_scan,p(0)) CASE Data.Method OF 'Full': begin fwhm_value=fwhm(X,Dif_scan, /follow,x_peak=p(0)+1) area=[p(0)-fwhm_value*0.8 > 0 < peak(0), $ p(0)+fwhm_value*0.8 < (n_elements(Dif_scan)-1) > peak(1)] Sc_max=max(Dif_scan(area(0):area(1)),N_max) N_max=N_max+area(0) peak=[N_max-fwhm_value*0.8 > 0 < peak(0), $ N_max+fwhm_value*0.8 < (n_elements(Dif_scan)-1) > peak(1)] end ELSE: begin fwhm_value=fwhm(X(peak(0):peak(1)),Dif_scan(peak(0):peak(1))) end ENDCASE if Data.interf eq 'E-W' then begin Beam_chan=par.beamEWchan & Beam=par.beamEW Spacing=par.SpacingEW & Tmod=par.TmodEW endif else begin Beam_chan=par.beamSNchan & Beam=par.beamSN Spacing=par.SpacingSN & Tmod=par.TmodSN endelse Width=2*(fwhm_value > Beam_chan(1)) borders=[fix(peak(0)-Width) > 0,fix(peak(1)+Width+0.5) < (Data.N_channels-1)] Scan_max=max(Stokes(*,Data.number)-Data.Base,min=Scan_min) Base_Time=time_outvalue(Data.Base_scan, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) Modestring='Sc '+strtrim(Data.number,2)+' - Sc '+strtrim(Data.Base_scan,2) wset,ID.Win(3) plot,X,Stokes(*,Data.number)-Data.Base,font=0, yticks=4, xmargin=[5,1], $ ymargin=[2,2], tit=Modestring+', '+Base_Time, xminor=4, yminor=4, xstyle=1 Scale,temp,/mem & SC.Dif=temp for j=0,1 do plots, [1,1]*borders(j)+1,[Scan_min < 0,Scan_max],linestyle=1*Data.M ; *********************************** full=(max(Flux.chan) > (Data.N_channels-1))-(min(Flux.chan) < 0)+1 X_model=findgen(full)+(min(Flux.chan) < 0)+1 order=ord_recognize(Data.number,Flux.Nord,Flux.Ord,Flux.Chan) index=(where(order eq Flux.ord))(0) Z_model=sqrt(1-((X_model-Flux.Chan(1,index))/ $ ((Flux.Chan(2,index)-Flux.Chan(0,index))/2))^2 > 0) Flux.weight=120./(total(Z_model)*Flux.factor) peak=select_peak(Dif_scan,p(0)) Flux_value=total(Dif_scan(borders(0):borders(1)) > 0)*Flux.weight WIDGET_CONTROL,ID.Infolabel3,set_val='Flux = '+ $ strtrim(string(Flux_value,format='(f6.1)'),2) wset,ID.Win(4) N=borders(1)-borders(0)+1 xx=indgen(N)+borders(0) y=Dif_scan(borders(0):borders(1)) s=10. & T=findgen(N*s)/s+borders(0) peak_area=[peak(0)-borders(0), peak(1)-borders(0)]*s ys=SPLINE(xx,Y,T) ysmax=max(ys(peak_area(0):peak_area(1)),imax,min=ysmin) plot_stick,X,Dif_scan, xran=borders, yran=[ysmin < 0, ysmax*1.1 > 0], $ tit=Current_Time, subt='Base scan: '+Base_Time, $ font=0, xmargin=[5,1.5], ymargin=[4.5,2], $ xminor=4, yminor=4, xticks=3, yticks=4, col=200 Scale,temp,/mem & SC.Show=temp oplot,T+1,ys,lines=0*Data.M,clip=[borders(0),ysmin < 0,borders(1),ysmax*1.1] width=fwhm(T(Peak_area(0):Peak_area(1)),ys(Peak_area(0):Peak_area(1)), $ x_peak=T(0)+peak_area(0)/s+imax/s, follow=(Data.Method eq 'Full')) width0=sqrt((width^2-Beam_chan^2) > 0) peak_area1=[borders(0)-3*width > 0,borders(1)+3*width < (Data.N_channels-1)] z=(sinc((0.885892*!dpi/2)*((T-borders(0))*s-(imax+peak_area(0)))/ $ (Beam_chan(1)*s/2)))^2*ysmax oplot,T+1,z,lines=1*Data.M,clip=[borders(0),ysmin < 0,borders(1),ysmax*1.1],color=100 Rads=!DPi/180/3600 source=strtrim(string(width0(1)/Beam_chan(0)*Beam(0)/Rads,format='(F5.1)'),2)+'" = ' window_set,ID.Win(3),scale=SC.Dif for j=0,1 do plots, [1,1]*peak_area1(j)+1,[Scan_min/2,Scan_max/2],linestyle=2*Data.M, $ color=100 sigma=stdev([(Stokes(*,Data.number)-Data.Base)(0:peak_area1(0)), $ (Stokes(*,Data.number)-Data.Base)(peak_area1(1):*)]) WIDGET_CONTROL,ID.InfoLabel1, set_val= $ 'Source = '+source+strtrim(string(width0(1),format='(F5.1)'),2)+' chan.' WIDGET_CONTROL,ID.InfoLabel2, set_val= $ 'Sigma = '+strtrim(string(sigma,format='(F7.2)'),2) Results={X:X, Dif_scan:Dif_scan,borders:borders,Current_time:Current_time, $ Base_time:Base_time,s:s,T:T,ys:ys,ysmax:ysmax,ysmin:ysmin, $ imax:T(0)+peak_area(0)/s+imax/s, $ z:z,Beam:Beam, Beam_chan:Beam_chan, Spacing:Spacing, Tmod:Tmod, $ Width:Width, Width0:Width0, peak:peak,sigma:sigma} endif return ENDIF IF ev.id eq ID.View(4) THEN BEGIN window_set,ID.Win(4),scale=Sc.Show p=(convert_coord(ev.x, ev.y, /TO_DATA, /DEVICE))([0,1]) p(0)=p(0) < ((size(Stokes))(1)-1) > 0 WIDGET_CONTROL,ID.Valuelabel(1),set_val='Channel '+strtrim(fix(p(0)+1),2)+ $ ', value ='+strtrim(fix(p(1)),2) if ev.press then begin window_set,ID.Win(3),scale=Sc.Dif goto, Width_process endif ENDIF FOR j=1,5 do $ IF ev.id eq ID.View(j) THEN BEGIN if ev.press then Data.press=1 ;Pressed button? if ev.release then Data.press=0 ;Released button? return ENDIF ;**************** OTHER EVENTS ********************** WIDGET_CONTROL,ev.id,GET_UVALUE = wuv,/hour CASE wuv OF "DONE" : WIDGET_CONTROL,ev.top,/DEST "XMTool": begin WIDGET_CONTROL,/hourglass XMTool,group=ev.top end "Xloadct": begin WIDGET_CONTROL,/hourglass Xloadct,group=ev.top end "Calculator": begin WIDGET_CONTROL,/hourglass wcalc end "Help" : begin WIDGET_CONTROL,/hourglass CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE xtext,file=getenv('help_dir')+Delim+'source_s.hlp',group=ev.top end "VC": spawn,'vc' "NC": spawn,'nc' "DOS" : spawn "Archiver": begin WIDGET_CONTROL,/hourglass pushd,getenv('spk_dat') spawn,'rar' popd end "Parameters": begin WIDGET_CONTROL,/hourglass param_ssrt,time=Moment.time, Date=Moment.Date,Rec=Rec,group=ev.top end "Base": begin Data.Base_scan=Data.number Data.Base=Data.Base+Stokes(*,Data.Base_scan) Modestring='Sc '+strtrim(Data.number,2)+' - Sc '+strtrim(Data.Base_scan,2) Time=time_outvalue(Data.Base_scan, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(3) plot,X,Stokes(*,Data.number)-Data.Base,font=0, yticks=4, xmargin=[5,1], $ ymargin=[2,2], tit=Modestring+', '+Time, xminor=4, yminor=4, xstyle=1 Scale,temp,/mem & SC.Dif=temp end "Nothing": begin Data.Line=(Data.Base=fltarr(Data.N_channels)) Modestring='Sc '+strtrim(Data.number,2) Time=time_outvalue(Data.Base_scan, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(3) plot,X,Stokes(*,Data.number)-Data.Base,font=0, yticks=4, xmargin=[5,1], $ ymargin=[2,2], tit=Modestring+', '+Time, xminor=4, yminor=4, xstyle=1 Scale,temp,/mem & SC.Dif=temp end "Level": begin if n_tags(Results) gt 2 then peak=Results.peak else begin tmp=Stokes(*,Data.number) amax=max(tmp,imax) peak=select_peak(tmp,imax) endelse level=Stokes(peak(0),Data.number) < Stokes(peak(1),Data.number) Data.Base=Data.Base+level Modestring='Sc '+strtrim(Data.number,2) Time=time_outvalue(Data.Base_scan, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(3) plot,X,Stokes(*,Data.number)-Data.Base,font=0, yticks=4, xmargin=[5,1], $ ymargin=[2,2], tit=Modestring+', '+Time, xminor=4, yminor=4, xstyle=1 Scale,temp,/mem & SC.Dif=temp end "Line": begin if n_tags(Results) gt 2 then peak=Results.peak else begin tmp=Stokes(*,Data.number) amax=max(tmp,imax) peak=select_peak(tmp,imax) endelse k=(Stokes(peak(1),Data.number)-Data.Base(peak(1))- $ (Stokes(peak(0),Data.number)-Data.Base(peak(0))))/(peak(1)-peak(0)) Data.Line=Stokes(peak(0),Data.number)-Data.Base(peak(0))+k*(X-peak(0)) Modestring='Sc '+strtrim(Data.number,2) Time=time_outvalue(Data.Base_scan, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(3) plot,X,Stokes(*,Data.number)-Data.Base,font=0, yticks=4, xmargin=[5,1], $ ymargin=[2,2], tit=Modestring+', '+Time, xminor=4, yminor=4, xstyle=1 oplot,data.line,lines=2*Data.M Scale,temp,/mem & SC.Dif=temp end "Zoom": begin WIDGET_CONTROL,/hourglass for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=j wset,ID.Win(5) Sz=Size(Results) IF Sz(n_elements(Sz)-2) ne 8L THEN BEGIN xyouts,0.5,0.5,'Nothing to show',/norm,align=0.5,font=0 return ENDIF plot_stick,Results.X,Results.Dif_scan, xran=Results.borders, $ yran=[Results.ysmin < 0, Results.ysmax*1.1], /xst, $ tit=Results.Current_Time, subt='Base scan: '+Results.Base_Time, $ font=0, xmargin=[5,1.5], ymargin=[4.5,2], $ xminor=4, yminor=4, $ ;xticks=3, yticks=4, col=200 oplot, Results.T+1, Results.ys,lines=0*Data.M, $ clip=[Results.borders(0), Results.ysmin < 0, $ Results.borders(1), Results.ysmax*1.1] oplot, Results.T+1, Results.z,lines=1*Data.M,clip=[Results.borders(0), $ Results.ysmin < 0, Results.borders(1),Results.ysmax*1.1],color=100 Rads=!DPi/180/3600 Response=strtrim(string(Results.width/Results.Beam_chan(0)*Results.Beam(0)/Rads, $ format='(F5.1)'),2)+'" = ' WIDGET_CONTROL,ID.ZoomLabel1,set_val=$ 'Response size = '+Response+strtrim(string(Results.width,format='(F5.1)'),2)+ $ ' channels; Beam = '+strtrim(string(Results.Beam(1)/Rads,format='(F5.1)'),2)+ $ '" = '+strtrim(string(Results.Beam_chan(1),format='(F5.1)'),2)+' channels' Source=strtrim(string(Results.width0(1)/Results.Beam_chan(0)*Results.Beam(0)/Rads, $ format='(F5.1)'),2)+'" = ' WIDGET_CONTROL,ID.ZoomLabel2,set_val=$ 'Source size = '+Source+strtrim(string(Results.width0(1),format='(F5.1)'),2)+ $ ' channels; Sigma (ampl.) = '+strtrim(string(Results.sigma,format='(F7.2)'),2) end "QuitZoom": for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=1-j "Local": begin Data.Method='Local' WIDGET_CONTROL,ID.FWHM_Label,set_val='FWHM: '+Data.Method end "Full": begin Data.Method='Full' WIDGET_CONTROL,ID.FWHM_Label,set_val='FWHM: '+Data.Method end "Results": begin source_size_res WIDGET_CONTROL,/hourglass xtext,file=Fileres end "Zero": begin WIDGET_CONTROL,ID.Zero,get_val=tmp tmp=strtrim(tmp(0),2) Flux.min=float(tmp) WIDGET_CONTROL,ID.Zero,set_val=tmp end "Lshift": begin Flux.Model=Shift(Flux.Model,-1) Current_Time=time_outvalue(Data.Number, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(2) plot,X,Stokes(*,Data.number),font=0, yticks=4, xmargin=[5,1], ymargin=[2,2], $ tit=' Scan '+strtrim(Data.number,2)+', '+Current_Time, $ xminor=4, yminor=4, xstyle=1 oplot,X,Stokes(*,Data.number)-Stokes(*,Data.number-1),/noc oplot,Flux.model*Flux.factor+Flux.min,col=Ini.colors(5) Scale,temp,/mem & SC.Scan=temp end "Rshift": begin Flux.Model=Shift(Flux.Model,1) Current_Time=time_outvalue(Data.Number, time=time_str_to_sec(Moment.time), $ Dt=Data.Dt*Data.multi) wset,ID.Win(2) plot,X,Stokes(*,Data.number),font=0, yticks=4, xmargin=[5,1], ymargin=[2,2], $ tit=' Scan '+strtrim(Data.number,2)+', '+Current_Time, $ xminor=4, yminor=4, xstyle=1 oplot,X,Stokes(*,Data.number)-Stokes(*,Data.number-1),/noc oplot,Flux.model*Flux.factor+Flux.min,col=Ini.colors(5) Scale,temp,/mem & SC.Scan=temp end ELSE: ENDCASE empty end pro source_size,output, group_leader=group_leader,Date=Date, $ time=time,Receiver=Receiver,input=input,Dt=Dt,multi=multi, $ interferometer=interferometer Common Exch_source_size,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SUN,Par,P_save,Results,Fileres,Flux if xregistered('source_size') then return if n_elements(Dt) le 0 then Dt=0.056d0 if n_elements(multi) le 0 then multi=1 if n_elements(interferometer) le 0 then interferometer='E-W' if n_elements(group_leader) le 0 then group_leader = 0L Sum_chan=[176,192] Rads=!DPi/180d0/3600d0 ID={View:Lonarr(6), Win:Lonarr(6), Label:0L, ToggleBase:[0L,0L], $ Leftbase:[0L,0L], ZoomLabel1:0L , ZoomLabel2:0L , Timelabel:0L, $ InfoLabel1:0L, InfoLabel2:0L, group_leader:group_leader, $ ValueLabel:[0L,0L], FWHM_Label:0L, BaseBut:0L, SpikeBut:0L, $ InfoLabel3:0L, Zero:0L} Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} SC={Tv:Ax, Scan:Ax, Dif:Ax, Show:Ax} Ax=0 Ini={Lines:indgen(5), $ colors:[0B, $ ; Color Table 255B, $ ; Background 0B, $ ; Main color for inscriptions 255B, $ ; E-W 160B, $ ; Reserved 160B, $ ; S-N 60B, $ ; Diurnal parallel 200B, $ ; Mild grid 100B, $ ; Medium grid 0B], $ ; Sharp grid PmargX:[3.5,3.5], Char:1.5} WIDGET_CONTROL,/hourglass M=strlowcase(findfile('vga_drv.rcg')) if equiv(M,'') then M=1 else begin openr,lun,'vga_drv.rcg',/get_lun readf,lun,M free_lun,lun endelse ;M=0 for L-310 else M=1 (to plot lines with various styles) N_channels=Sum_Chan(Receiver) Data={Zoom:0, Press:0, Release:0, Mode:'Follow', Mouse:0, Optics:'', $ N_channels:N_channels, Base: fltarr(N_channels), Line: fltarr(N_channels), $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', Dt:Dt, multi:multi, $ interf:interferometer, Base_scan:0L, Spike_scan:-1L, number:0L, M:M(0), $ Marker:0, Method:'Local'} Stokes=input Flux={min:float(min(Stokes > 0))} if n_elements(group_leader) le 0 then group_leader = 0L if n_elements(Date) le 0 then Date='' if strlen(Date) lt 2 then read,'Date (e.g. 24 08 93) - ', Date if n_elements(Time) le 0 then Time='' if strlen(Time) lt 2 then read,'Time (e.g. 07 04 33.457) - ', Time Moment={Date:Date, Time:Time} if n_elements(Receiver) le 0 then begin Rec=0 & read,'Receiver (0-MFB, 1-AOR) - ', Rec endif else Rec=Receiver P_save=!P loadct,Ini.colors(0) !p.background=Ini.colors(1) & !p.color=Ini.colors(2) Fmin=chanfreq(1,Rec) Fmax=chanfreq(Sum_chan(Rec),Rec) F0=(Fmax+Fmin)/2 Df=(Fmax-Fmin)/(Sum_chan(Rec)-1) param_ssrt,Date,time,Rec,Par=Par,SUN=SUN,/silent INT_ORD,0,Rec,SUN,P,NnEW,NordEW,ChanEW INT_ORD,1,Rec,SUN,Q,NnSN,NordSN,ChanSN SSRT={Fi:51.7575d0*!DPi/180, F0:F0, Df:Df, $ P:P, NoEW:NnEW, OEW:NordEW, CEW:ChanEW, $ Q:Q, NoSN:NnSN, OSN:NordSN, CSN:ChanSN} source_size_model,time dxsize=30. & dxe=25. sz=(size(Stokes))([1,2]) device,set_graphics_function=3 device,get_scr=scr Width0=(sz(0) > 150)+dxsize+dxe Width1=(Width2=(scr(0)*0.95-Width0)/2.) Gap=90. Xs= [[[Width0,(scr(1)-Gap)/2.]#replicate(1,2)], $ [[Width1,(scr(1)-Gap)/2.3]#replicate(1,2)], $ [Width2,(scr(1)-Gap)*0.7], $ [scr(0)*0.8,scr(1)*0.8]] ;***** Drawing widget Mainbase= widget_base(/fra, group=group_leader, $ tit='Source size for event of '+Date_string(Moment.Date)) for j=0,1 do ID.ToggleBase(j)=widget_base(Mainbase) ;***** Left Base Wholebase=widget_base(ID.ToggleBase(0),/column) Upperbase=widget_base(Wholebase,/row) XPdMenu, ['"DONE" DONE', $ '"Tools" {', $ '"Zoom" Zoom', $ '"FWHM Method" {', $ '"Local peak" Local', $ '"Full" Full','}', $ '"Calculator" Calculator', $ '"Parameters" Parameters', $ '"Results" Results', $ '"Color table" Xloadct', $ '"XManager Tool" XMTool', $ '"DOS" DOS', $ '"Norton Commander" {','"NC" NC', $ '"VC" VC','}', $ '"Archiver" Archiver','}', $ '"Subtract" {', $ '"Base scan" Base', $ '"Line" Line', $ '"Level" Level', $ '"Nothing" Nothing','}', $ '"Help" Help'], Upperbase R_shift = [ $ [000B, 000B], $ [000B, 000B], $ [016B, 000B], $ [032B, 000B], $ [064B, 000B], $ [128B, 000B], $ [000B, 001B], $ [000B, 002B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [128B, 000B], $ [064B, 000B], $ [032B, 000B], $ [016B, 000B], $ [000B, 000B] $ ] L_shift = [ $ [000B, 000B], $ [000B, 016B], $ [000B, 008B], $ [000B, 004B], $ [000B, 002B], $ [000B, 001B], $ [128B, 000B], $ [064B, 000B], $ [032B, 000B], $ [064B, 000B], $ [128B, 000B], $ [000B, 001B], $ [000B, 002B], $ [000B, 004B], $ [000B, 008B], $ [000B, 000B] $ ] Emptystring=string(replicate('20'xb,20)) Interf_label=WIDGET_LABEL(Upperbase, /fra,val=' '+interferometer+' ') Shift_base=WIDGET_BASE(Upperbase,/row) Shift_button0=WIDGET_BUTTON(Shift_base,val=L_shift,uval='Lshift') Shift_button1=WIDGET_BUTTON(Shift_base,val=R_shift,uval='Rshift') Zero_base=WIDGET_BASE(Upperbase,/row,/fra) Zero_label=WIDGET_LABEL(Zero_base,val=' Zero: ') ID.Zero=WIDGET_TEXT(Zero_base, val=string(Flux.min,format='(f8.1)'),/edit,uval='Zero',xsiz=10) Savebase=WIDGET_BASE(Upperbase,/row,/nonexcl,/fra) But=WIDGET_BUTTON(Savebase,val='Save results',uval='Save') if strmid(!version.release, 0, 1) lt 5 then $ ID.Timelabel=WIDGET_LABEL(Upperbase, val=Emptystring+Emptystring+Emptystring) else $ ID.Timelabel=WIDGET_LABEL(Upperbase, val=Emptystring+Emptystring+Emptystring, /dynam) LeftTogglebase=widget_base(Wholebase) for j=0,1 do ID.Leftbase(j)=widget_base(LeftTogglebase,/row) viewbase0=WIDGET_BASE(ID.Leftbase(0), /colu) for j=0,1 do begin ID.view(j)=WIDGET_DRAW(viewbase0, XS=Xs(0,j), YS=Xs(1,j), /motion, /button_events) endfor viewbase1=WIDGET_BASE(ID.Leftbase(0), /colu) for j=2,3 do begin ID.view(j)=WIDGET_DRAW(viewbase1, XS=Xs(0,j), YS=Xs(1,j), /motion, /button_events) if strmid(!version.release, 0, 1) lt 5 then $ ID.ValueLabel(j-2)=WIDGET_LABEL(viewbase1, val=' ' ,/frame) else $ ID.ValueLabel(j-2)=WIDGET_LABEL(viewbase1, val=' ' ,/frame, /dynam) endfor viewbase2=WIDGET_BASE(ID.Leftbase(0), /colu) ID.FWHM_Label=WIDGET_LABEL(viewbase2,val='FWHM: '+Data.Method) ID.view(4)=WIDGET_DRAW(viewbase2, XS=Xs(0,4), YS=Xs(1,4), /motion, /button_events,/frame) ; INFO: if Data.interf eq 'E-W' then begin Beam=Par.BeamEW(1)/Rads Spacing=par.SpacingEW/Rads endif else begin Beam=Par.BeamSN(1)/Rads Spacing=par.SpacingSN/Rads endelse infobase=WIDGET_BASE(viewbase2,/colu,/frame) label=WIDGET_LABEL(infobase,val='Beam = '+string(Beam,format='(F5.1)')+'"') label=WIDGET_LABEL(infobase,val='Spacing = '+string(Spacing,format='(F5.1)')+'"') ID.InfoLabel1=WIDGET_LABEL(infobase,val='Source size = '+emptystring) ID.InfoLabel2=WIDGET_LABEL(infobase,val='Sigma = '+emptystring) ID.InfoLabel3=WIDGET_LABEL(infobase,val='Flux = '+emptystring) ZoomBase=WIDGET_BASE(ID.ToggleBase(1),/row) junk=WIDGET_BASE(ZoomBase,/colu) junk1=WIDGET_BUTTON(junk,VAL='QUIT',uval='QuitZoom') junk=WIDGET_BASE(ZoomBase,/colu) ID.view(5)=WIDGET_DRAW(junk, XS=Xs(0,5), YS=Xs(1,5), /motion, /button_events) if strmid(!version.release,0,1) lt 5 then begin ID.ZoomLabel1=WIDGET_LABEL(junk,val=Emptystring) ID.ZoomLabel2=WIDGET_LABEL(junk,val=Emptystring) endif else begin if strmid(!version.release, 0, 1) lt 5 then begin ID.ZoomLabel1=WIDGET_LABEL(junk,val=Emptystring) ID.ZoomLabel2=WIDGET_LABEL(junk,val=Emptystring) endif else begin ID.ZoomLabel1=WIDGET_LABEL(junk,val=Emptystring, /dynam) ID.ZoomLabel2=WIDGET_LABEL(junk,val=Emptystring, /dynam) endelse endelse ;***** WIDGET_CONTROL,ID.Leftbase(1),map=0 WIDGET_CONTROL,ID.Togglebase(1),map=0 WIDGET_CONTROL,Mainbase,/real,/hour for J=0,5 do begin WIDGET_CONTROL,ID.view(J),GET_VALUE=temp & ID.Win(J)=temp wset,ID.Win(J) & Erase endfor WIDGET_CONTROL,/hour circ source_size_draw_win xmanager,'Source_size',Mainbase,group=group_leader, cleanup='source_size_c_u' end ####################################################### pro split_array,x,index, Number=Number, $ first_subscript=first_subscript, last_subscript=last_subscript ; Splits a given index array after missing values. a=x-x(0) n_e=n_elements(a) a_last=a(n_e-1) normal_length=a_last-a(0)+1 index=0L if normal_length eq n_e then begin index=[0,n_e-1] N_el_index=2 goto,exit endif b=a b0=b(0) REPEAT BEGIN n_e=n_elements(b) normal_length=b(n_e-1)+1 current_index=where(b eq indgen(normal_length)) ind=[current_index(0),current_index(n_elements(current_index)-1)] if n_elements(index) eq 1 then index=ind+b0 else index=[index,ind+b0] if ind(1) eq a_last then goto,exit b=b(ind(1)+1 < (n_e-1):*) b0=b(0)+b0 b=b-b(0) N_el_index=n_elements(index) ENDREP UNTIL index(N_el_index-1) eq a_last exit: index=index+x(0) Number=N_el_index/2 Arg=indgen(Number)*2 first_subscript=index(Arg) last_subscript=index(Arg+1) end ####################################################### pro ssrt_event,ev common ssrt,ID, red, green, blue common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE path=getenv('ssrt_demo')+Delim widget_control,ev.id,get_uval=uv,/hour CASE uv OF 'DONE': widget_control, ev.top, /destr 'Restore': tvlct, red, green, blue '1D Fast': alt 'Sh': sh,group=ev.top 'Coordinates': ewsn_view,group=ev.top 'Alignment': file_align,group=ev.top 'Processing': l_r_proc,group=ev.top 'Map': ssrt_map_view, group=ev.top 'Map_enh': _s_m_imp, group=ev.top 'I_p': yp, group=ev.top 'Array_view': array_view, group=ev.top 'Image_view': show_picture, group=ev.top 'Pic_Plot': pic_plot, group=ev.top 'Overview': show_picture, file=path+'overview.gif', group=ev.top ,/def 'Central part': show_picture, file=path+'center.gif', group=ev.top ,/def 'Southern line': show_picture, file=path+'south.gif', group=ev.top ,/def 'Tunnel': show_picture, file=path+'tunnel.gif', group=ev.top ,/def 'Description': xtext,file=path+'descr.txt' 'Xloadct': Xloadct,group=ev.top 'MSW_U': rem_lf,/over,filt='*.*' 'U_MSW': add_lf,/over,filt='*.*' ELSE: help,uv,/st ENDCASE end pro ssrt common ssrt,ID, red, green, blue common colors, r_orig, g_orig, b_orig, r_curr, g_curr, b_curr gr ID={draw:lonarr(5), win:lonarr(5)} if xregistered('ssrt') then return base=widget_base(tit='SSRT data processing tools',/colu) menubase=widget_base(base,/row) button=widget_button(menubase,val='DONE',uval='DONE') button=widget_button(menubase,val='Restore colors',uval='Restore') CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE path=getenv('ssrt_demo')+Delim file1=path+'ssrtsign.gif' read_gif,file1,x1 Sz1=size(x1) file2=path+'ssrt_q.gif' read_gif,file2,x2 Sz2=size(x2) file2a=path+'ct_ssrt.dat' r2=(g2=(b2=bytarr(236))) openr,lun,file2a,/get readu,lun,r2,g2,b2 free_lun,lun file3=path+'map0.gif' read_gif,file3,x3 Sz3=size(x3) file4=path+'1021.gif' read_gif,file4,x4 Sz4=size(x4) button_values=[ 'Coordinates, size and flux of the source', $ 'Alignment of the record', $ 'Processing of the aligned record', $ 'Viewer of original SSRT data'] but_uval=['Coordinates','Alignment','Processing','Sh'] drawbase=widget_base(base, /row) drawbase1=widget_base(drawbase, /colu) drawbase2=widget_base(drawbase, /colu) ID.draw(0)=widget_draw(drawbase1, xs=Sz1(1),ys=sz1(2), /button, uv='General') button=widget_button(drawbase1,val='About',uval='Description') ID.draw(1)=widget_draw(drawbase1, xs=Sz1(1) > Sz3(1),ys=sz1(2) > Sz3(1)) junk=widget_button(drawbase1,val='2d maps',/menu) button=widget_button(junk,val='Map viewer',uval='Map') button=widget_button(junk,val='Map enhancer',uval='Map_enh') button=widget_button(junk,val='Interactive preprocessing',uval='I_p') ID.draw(2)=widget_draw(drawbase2, xs=Sz2(1),ys=sz2(2)) junk=widget_button(drawbase2,val='Photos',/menu) button=widget_button(junk,val='Overview',uval='Overview') button=widget_button(junk,val='Central part',uval='Central part') button=widget_button(junk,val='Southern line',uval='Southern line') button=widget_button(junk,val='Tunnel',uval='Tunnel') drawbase3=widget_base(drawbase2, /row) left_draw_base=widget_base(drawbase3, /colu) right_draw_base=widget_base(drawbase3, /colu) ID.draw(3)=widget_draw(left_draw_base, xs=Sz2(1)*0.48,ys=sz1(2)*0.8) button1=widget_button(left_draw_base,val='1D fast records', /menu);uval='1D Fast' for j=0,3 do button=widget_button(button1,val=button_values(j),uval=but_uval(j)) ID.draw(4)=widget_draw(right_draw_base, xs=Sz2(1)*0.48,ys=sz1(2)*0.8) junk=widget_button(right_draw_base,val='Tools', /menu) button=widget_button(junk,val='Adjust palette',uval='Xloadct') junk1=widget_button(junk,val='Viewers', /menu) button=widget_button(junk1,val='Array viewer',uval='Array_view') button=widget_button(junk1,val='Image viewer',uval='Image_view') junk1=widget_button(junk,val='Converters', /menu) button=widget_button(junk1,val='MS Windows --> UNIX',uval='MSW_U') button=widget_button(junk1,val='UNIX --> MS Windows',uval='U_MSW') button=widget_button(junk1,val='Image --> Array',uval='Pic_Plot') ; junk1=widget_button(junk,val='Miscellaneous', /menu) ; button=widget_button(junk1,val='Image --> Array',uval='Pic_Plot') widget_control, base, /real, /hour for j=0,4 do begin widget_control, ID.draw(j), get_val=tmp ID.win(j)=tmp endfor wset, ID.win(0) y=x1 i=[0,4,5,10,15,16,17,18,20,255] for j=0,9 do y(where(x1 eq i(j)))=!d.n_colors-10+j tv,y tail=[ [0,0,0], $ [0,128,0], $ [0,128,128], $ [0,128,255], $ [192,192,192], $ [255,0,0], $ [255,255,0], $ [0,255,0], $ [0,0,255], $ [255,255,255]] tail=transpose(tail) wset, ID.win(1) erase, !d.n_colors-1 tv,bytscl(x3,top=!d.n_colors-71-10)+71b, ((Sz1(1)-Sz3(1)) > 0)/2,0 r=interpolate(r2,findgen(!d.n_colors-10)/(!d.n_colors-11)*255) g=interpolate(g2,findgen(!d.n_colors-10)/(!d.n_colors-11)*255) b=interpolate(b2,findgen(!d.n_colors-10)/(!d.n_colors-11)*255) red=[r,tail(*,0)] green=[g,tail(*,1)] blue=[b,tail(*,2)] tvlct, red, green, blue wset, ID.win(2) tv,bytscl(x2,top=!d.n_colors-30)+6b wset, ID.win(3) openr,lun,path+'fdas.dat',/get_lun x=intarr(176,50) readu,lun,x free_lun,lun CASE !version.OS OF 'windows': 'Win32': ELSE: byteorder, x ENDCASE shade_surf,x,shade=bytscl(alog(x+3), top=100), back=!d.n_colors-1, $ xmar=[5,0],ymar=[2,3],zmar=[0,0],col=10 wset, ID.win(4) ;TV,bytscl(x4,top=!d.n_colors-70)+6b tv,bytscl(x4,top=!d.n_colors-100)+!d.n_colors/4+5 ;erase,15;!d.n_colors-1 empty xmanager, 'ssrt', base end ####################################################### function SSRT_file_struc,lun,Fileformat=Fileformat, $ Offset=Offset, Blocklength=Blocklength, Length=Length, $ Num_blocks=Num_blocks, Dt=Dt, Date=Date, I_file=I_file Descr_file = FSTAT(lun) if keyword_set(I_file) then begin Block={T_F_Block_1,Time:intarr(2),data:intarr(254,/Nozero)} Offset=512L FileFormat=['rout','1'] rec_length = Descr_file.size-Offset N_scans=256 goto, Label endif ; The SSRT data files structure. Sum_chan=[180,192] file_date=strmid((name_lun(lun))(1),2,6) file_ext=strlowcase((name_lun(lun))(2)) Fyear = strmid(file_date,4,2) Fmonth = strmid(file_date,2,2) Fday = strmid(file_date,0,2) Date=string(Fday,Fmonth,Fyear, format="(2(I2.2,' '),I2)") IF file_ext eq 'bst' or file_ext eq 'bso' or $ file_ext eq 'spk' or file_ext eq 'spo' THEN $ Fileformat=['aor','0'] $ ELSE IF file_ext eq 'dat' THEN Fileformat=['fdas','0'] $ ELSE IF file_ext eq 'fds' THEN Fileformat=['fdas','1'] $ ELSE IF file_ext eq 'clm' THEN Fileformat=['aor','clm'] $ ELSE IF file_ext eq 'ccd' THEN Fileformat=['aor','cor0'] $ ELSE Fileformat=['rout','1'] IF Fileformat(0) eq 'aor' THEN BEGIN Rec_Type=1 if (Fyear gt 93) or (Fyear eq 93 and Fmonth gt 6) or $ (Fyear eq 93 and Fmonth eq 6 and Fday ge 7) then $ if Fileformat(1) ne 'clm' then Fileformat(1)='1' if (Fyear gt 96) or (Fyear eq 96 and Fmonth gt 4) or $ (Fyear eq 96 and Fmonth eq 4 and Fday ge 1) then $ if Fileformat(1) ne 'clm' then Fileformat(1)='cor1' ENDIF ELSE Rec_Type=0 if (Fileformat(1) eq 'cor0') then rec_type=1 ;***************************************************** Num_pat = 2L*Sum_chan(1) Offset=(4L+2*Num_pat*equiv(Fileformat, ['aor','1']))* $ (Fileformat(0) eq 'aor') rec_length = Descr_file.size-Offset N_scans=32L ;***************************************************** CASE 1 OF equiv(Fileformat, ['aor','0']): begin ScansetAOR0={ScansetAOR0,Attr:0B, I:bytarr(192),V:bytarr(192)} Block={BlockAOR0,time:0L, Set32:replicate(ScansetAOR0,32)} Blocklength = n_tags(Block,/length) Num_blocks = rec_length/Blocklength Length=32L*Num_blocks IF (double(rec_length)/Blocklength ne double(Num_blocks)) $ AND (Fyear eq '92') THEN BEGIN Offset=0L rec_length = Descr_file.size-Offset Num_blocks = rec_length/Blocklength Length=32L*Num_blocks Fileformat=['aor','-1'] if double(rec_length)/Blocklength ne double(Num_blocks) $ then begin print,'ERROR of file length' print,'Cannot recognize format' endif ENDIF Dt=0.056D end equiv(Fileformat, ['aor','1']): begin ScansetAOR1={ScansetAOR1, AttrEW:0B, LEW:bytarr(192), $ REW:bytarr(192), AttrSN:0B, LSN:bytarr(192), RSN:bytarr(192)} Block={BlockAOR1,time:0L, Set32:replicate(ScansetAOR1,32)} Dt=0.056D end equiv(Fileformat, ['aor','cor0']): begin ScansetAORcor0={ScansetAORcor0, AttrEW:0B, LEW:bytarr(192), $ REW:bytarr(192), AttrSN:0B, LSN:bytarr(192), RSN:bytarr(192), $ AttrSUM:0B, LSUM:bytarr(192), RSUM:bytarr(192)} Block={BlockAORcor0,time:0L, Set32:replicate(ScansetAORcor0,32)} Dt=0.056D end equiv(Fileformat, ['aor','cor1']): begin ScansetAORcor1={ScansetAORcor1, Attr:0, $ LSUM:intarr(384), $ LEW:intarr(384), $ LSN:intarr(384), $ RSUM:intarr(384), $ REW:intarr(384), $ RSN:intarr(384)} Block={BlockAORcor1,time:0L, Set32:replicate(ScansetAORcor1,16)} Dt=0.056D end equiv(Fileformat, ['aor','clm']): begin Block=fltarr(Descr_file.size/4) Length=(Num_blocks=1L) Offset=0L Dt=0.56D Blocklength=Descr_file.size/4 end equiv(Fileformat, ['fdas','0']) or $ equiv(Fileformat, ['fdas','1']): begin Dt=0.014d0 Offset=0L N_scans=1L N_channels_total = 180 N_channels_actual = 176 Dummy_channels = intarr(N_channels_total-N_channels_actual) Block={FDAS_Block, Time_in_R:intarr(4), $ Descriptor_R:0L, $ Right:intarr(N_channels_actual),$ Dummy_channels_R:Dummy_channels,$ Time_in_L:intarr(4), $ Descriptor_L:0L, $ Left:intarr(N_channels_actual), $ Dummy_channels_L:Dummy_channels} end ENDCASE ;***************************************************** Label: IF not equiv(Fileformat, ['aor','clm']) THEN BEGIN Blocklength = n_tags(Block,/length) Num_blocks = rec_length/Blocklength Length=N_scans*Num_blocks IF double(rec_length)/Blocklength ne double(Num_blocks) $ then print,'ERROR of file length' ENDIF RETURN,Block end ####################################################### pro ssrt_map_view_convert,x,index common ssrt_map_view,a,ID,header0,header1,Image0,Image_curr0,Image1,Image_curr1 p=convert_coord(x(0),x(1),/dev,/to_data) Rect=string((x-a.Centre(index,*))(0)/a.R(index), $ (x-a.Centre(index,*))(1)/a.R(index), $ format="(F5.2,', ',F5.2)") WIDGET_CONTROL,ID.Coord(index),set_val=Rect WIDGET_CONTROL,ID.Rect(index),set_val=Rect radius=1./a.R(index)* $ sqrt(((x-a.Centre(index,*))(0))^2+((x-a.Centre(index,*))(1))^2) if radius lt 1 then Dist=asin(radius)*!radeg else Dist=90. Dist=string(Dist,format="(F5.2)")+' deg' WIDGET_CONTROL,ID.Dist(index),set_val=Dist if a.map eq 0 then return if p(0) lt 0 then dirX='E' else dirX='W' if p(1) lt 0 then dirY='S' else dirY='N' Helio=string(dirX,abs(p(0)),dirY,abs(p(1)),format="(A1,F4.1,', ',A1,F4.1)") WIDGET_CONTROL,ID.Helio(index),set_val=Helio if index then SUN=a.SUN1 else SUN=a.SUN0 if n_tags(a) gt 9 then begin Klong=p(0)+SUN.Karr*!radeg Klong=(Klong+360*(Klong lt 0)) mod 360 Karr=string(Klong,p(1),format="(F5.1,', ',F5.1)") WIDGET_CONTROL,ID.Karr(index),set_val=Karr endif Helio=strcompress(Helio,/rem) Karr=strcompress(Karr,/rem) Rect=strcompress(Rect,/rem) Dist=strcompress(Dist) text=string(' ',format= $ "(a1,'"+a.Date+"',T12,'"+a.Time+"',T26,'"+Helio+"',T39,'"+Karr+"',T52,'"+Rect+"',T65,'"+Dist+"')") ID.number=ID.number+1 ID={win:ID.win,Karr:ID.Karr,Helio:ID.Helio,Rect:ID.Rect,Dist:ID.Dist, $ Date:ID.Date,Time:ID.Time,View:ID.View,Coord:ID.Coord,Data:ID.Data, $ linestyle:ID.linestyle,color:ID.color, group_leader:ID.group_leader, $ Text:ID.Text, Save_button:ID.Save_button, $ Save:ID.Save, Filename:ID.Filename, number:ID.number, $ Name:ID.Name, Results:[ID.Results,text], path:ID.path} end pro ssrt_map_view_event,ev common ssrt_map_view,a,ID,header0,header1,Image0,Image_curr0,Image1,Image_curr1 for k=0,1 do begin if ev.id eq ID.View(k) then begin if ev.press then a.press=1 if ev.release then a.press=0 if k then Sc=a.Sc1 else Sc=a.Sc0 Window_set,ID.win(k),scale=Sc p=convert_coord(ev.x,ev.y,/dev,/to_data) WIDGET_CONTROL,ID.Coord(k),set_val= $ string((ev.x-a.Centre(k,0))/a.R(k),(ev.y-a.Centre(k,1))/a.R(k), $ format="(F5.2,', ',F5.2)") x=[ev.x,ev.y] if a.press then ssrt_map_view_convert, x, k return endif endfor ;if ev.id eq ID.View(1) then return WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv.Name OF "DONE": begin WIDGET_CONTROL,ev.top,/DESTROY,/hour if ID.Save then begin openw,Lun,ID.Filename,/get_lun printf,Lun,ID.Results free_lun,Lun endif if ID.group_leader ne 0L then begin if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show endif !P=a.P a=(ID=0) end "Xloadct": begin widget_control,/hour Xloadct end "Header": begin widget_control,/hour if uv.index then xtext,text=header1 else xtext,text=header0 end "Calculator": begin widget_control,/hour wcalc end "Load": begin index=-1 filnam=pickfile(/read,path=ID.path,filt='*.fit *.fts') if filnam eq '' then return ID.path=subdir(filnam) widget_control,/hour x=rfits(filnam,index=fnum,key_struct=hstruc,header=head,error=err, $ user_struct=ustruc,date_obs=date,time_obs=time) Szx=size(x) factor=float(!d.x_size)/Szx(1) if uv.index then header1=head else header0=head ;day=strmid(date,3,2) ;if strmid(day,0,1) eq ' ' then strput,day,'0',0 ;month=strmid(date,0,2) ;if strmid(month,0,1) eq ' ' then strput,month,'0',0 ;date=day+' '+month+' '+strmid(date,6,2) day=strmid(date,0,2) if strmid(day,0,1) eq ' ' then strput,day,'0',0 month=strmid(date,3,2) if strmid(month,0,1) eq ' ' then strput,month,'0',0 date=day+' '+month+' '+strmid(date,6,2) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Name=getenv('astr_data')+Delim+'sol'+strmid(a.Date,6,2)+'.dat' WIDGET_CONTROL,ID.Date(uv.index),set_value=Date,/hour WIDGET_CONTROL,ID.Time(uv.index),set_value=Time suneph,date,time,SUN text_data=pr_sun(SUN, /si) for j=0,8 do WIDGET_CONTROL,ID.Data(uv.index,j),set_val=text_data(j) Radius=fh_r_key(head,'radius', error=error) if error then Radius=SUN.R*!radeg*60 X_origin=fh_r_key(head,'x-origin', error=error) Y_origin=fh_r_key(head,'y-origin', error=error) X_cent=fh_r_key(head,'center-X', error=error) Y_cent=fh_r_key(head,'center-Y', error=error) X_obs=fh_r_key(head,'X-obs', error=error) Y_obs=fh_r_key(head,'Y-obs', error=error) P0=fh_r_key(head,'P0', error=error) a.R(uv.index)=Radius*Szx(1)/X_obs*factor a.Centre(uv.index,*)= [(X_cent-X_origin)/X_obs*!d.x_size, $ (Y_cent-Y_origin)/Y_obs*!d.y_size] !x.style=(!y.style=1) !x.range=[-1,1]*0.5*!d.x_size/a.R(uv.index) !y.range=[-1,1]*0.5*!d.y_size/a.R(uv.index) origin=strtrim(fh_r_key(head,'origin', error=error, /char),2) if origin eq 'BADARY' then Angle=SUN.DP*!Radeg else Angle=0 x=rot(x, Angle, 1, a.Centre(uv.index,0)/factor, a.Centre(uv.index,1)/factor) wset,ID.Win(uv.index) erase if factor ne 1 then x=congrid(x,!d.x_size,!d.y_size) tvscl,x temp=!p.color & !p.color=ID.color map_set,SUN.B0*!Radeg,0,-SUN.DP*!Radeg*0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color,/noerase !p.color=temp !x.style=(!y.style=(!x.range=(!y.range=0))) ;plotline,-tan(SUN.Dp),[1,1]*0.5*!d.x_vsize,lines=ID.linestyle,/dev ;plots,[1,1]/2.*!d.x_vsize,[0,!d.x_vsize], $ ; /dev,linestyle=ID.linestyle,col=ID.color ;plots,[0,!d.x_vsize],!d.x_vsize/2.*[1,1], $ ; /dev,linestyle=ID.linestyle,col=ID.color Scale,temp,/mem if uv.index then a={P:a.P, Date:Date, time:time, R:a.R, Centre:a.Centre, $ SUN0:a.SUN0, SUN1:SUN, press:a.press, map:1, Sc1:temp, Sc0:a.Sc0} else $ a={P:a.P, Date:Date, time:time, R:a.R, Centre:a.Centre, $ SUN0:SUN, SUN1:a.SUN1, press:a.press, map:1, Sc0:temp, Sc1:a.Sc1} empty end "Date": begin WIDGET_CONTROL,ev.id,get_value=temp a.Date=strtrim(strcompress(temp(0)),2) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Name=getenv('astr_data')+Delim+'sol'+strmid(a.Date,6,2)+'.dat' if (findfile(Name))(0) eq '' then begin WIDGET_CONTROL,ev.id,set_value='incorrect' return endif WIDGET_CONTROL,ev.id,set_value=a.Date,/hour if n_tags(a) gt 9 then begin if uv.index then SUN=a.SUN1 else SUN=a.SUN0 endif if a.time ne '' then begin suneph,a.date,a.time,SUN text_data=pr_sun(SUN, /si) for j=0,8 do WIDGET_CONTROL,ID.Data(0,j),set_val=text_data(j) map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color plotline,-tan(SUN.Dp),[1,1]*0.5*!d.x_vsize,lines=ID.linestyle,/dev plots,[1,1]/2.*!d.x_vsize,[0,!d.x_vsize], $ /dev,linestyle=ID.linestyle,col=ID.color plots,[0,!d.x_vsize],!d.x_vsize/2.*[1,1], $ /dev,linestyle=ID.linestyle,col=ID.color Scale,temp,/mem if uv.index then a={P:a.P, Date:Date, time:time, R:a.R, Centre:a.Centre, $ SUN0:a.SUN0, SUN1:SUN, press:a.press, map:1, Sc1:temp, Sc0:a.Sc0} else $ a={P:a.P, Date:Date, time:time, R:a.R, Centre:a.Centre, $ SUN0:SUN, SUN1:a.SUN1, press:a.press, map:1, Sc0:temp, Sc1:a.Sc1} empty endif WIDGET_CONTROL,ID.Time(0),/input end "Time": begin WIDGET_CONTROL,ev.id,get_value=temp a.time=strtrim(strcompress(temp(0)),2) WIDGET_CONTROL,ev.id,set_value=a.time,/hour if n_tags(a) gt 9 then begin if uv.index then SUN=a.SUN1 else SUN=a.SUN0 endif if a.date ne '' then begin suneph,a.date,a.time,SUN text_data=pr_sun(SUN, /si) for j=0,8 do WIDGET_CONTROL,ID.Data(0,j),set_val=text_data(j) if not(a.map) then begin map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color plotline,-tan(SUN.Dp),[1,1]*0.5*!d.x_vsize,lines=ID.linestyle,/dev plots,[1,1]*!d.x_vsize/2.,[0,!d.x_vsize], $ /dev,linestyle=ID.linestyle,col=ID.color plots,[0,!d.x_vsize],!d.x_vsize/2.*[1,1], $ /dev,linestyle=ID.linestyle,col=ID.color Scale,temp,/mem if uv.index then a.Sc1=temp else a.Sc0=temp endif if uv.index then a={P:a.P, Date:Date, time:time, R:a.R, Centre:a.Centre, $ SUN0:a.SUN0, SUN1:SUN, press:a.press, map:1, Sc1:temp, Sc0:a.Sc0} else $ a={P:a.P, Date:Date, time:time, R:a.R, Centre:a.Centre, $ SUN0:SUN, SUN1:a.SUN1, press:a.press, map:1, Sc0:temp, Sc1:a.Sc1} empty endif end "Helio": begin WIDGET_CONTROL,ev.id,GET_V=b if (b(0) eq '') and n_elements(b) gt 1 then b=b(1:*) b=strlowcase(strcompress(b(0),/rem)) i1=strpos(b,',') i2=strlen(b) lon=float(strmid(b, 1, i1-1)) lat=float(strmid(b, i1+2, i2-i1-2)) lonsign=strmid(b,0,1) latsign=strmid(b,i1+1,1) if lonsign eq 'e' or lonsign eq '-' then lon=-lon if latsign eq 's' or latsign eq '-' then lat=-lat Coord=convert_coord(lon,lat,/to_dev,/data) if Coord(0) le !d.x_size and Coord(1) le !d.y_size then begin if uv.index then Sc=a.Sc1 else Sc=a.Sc0 Window_set,ID.win(uv.index),scale=Sc tvcrs,lon,lat,/data ssrt_map_view_convert,Coord,uv.index endif else begin WIDGET_CONTROL,/hour xwarning, 'These coordinates are not allowed' endelse end "Karr": if n_tags(a) lt 10 then begin WIDGET_CONTROL,/hour xwarning, 'First of all please enter date and time' return endif else begin WIDGET_CONTROL,ev.id,GET_V=b if (b(0) eq '') and n_elements(b) gt 1 then b=b(1:*) b=strlowcase(strcompress(b(0),/rem)) i1=strpos(b,',') i2=strlen(b) if uv.index then SUN=a.SUN1 else SUN=a.SUN0 lon=float(strmid(b, 0, i1))-SUN.Karr*!radeg lat=float(strmid(b, i1+1, i2-i1)) Coord=convert_coord(lon,lat,/to_dev,/data) if Coord(0) le !d.x_size and Coord(1) le !d.y_size then begin if uv.index then Sc=a.Sc1 else Sc=a.Sc0 Window_set,ID.win(uv.index),scale=Sc tvcrs,lon,lat,/data ssrt_map_view_convert,Coord,uv.index endif else begin WIDGET_CONTROL,/hour xwarning, 'These coordinates are not allowed' endelse endelse "Rect": begin WIDGET_CONTROL,ev.id,GET_V=b if (b(0) eq '') and n_elements(b) gt 1 then b=b(1:*) b=strlowcase(strcompress(b(0),/rem)) i1=strpos(b,',') i2=strlen(b) x=float(strmid(b, 0, i1)) y=float(strmid(b, i1+1, i2-i1)) if (x^2+y^2) le 1 then begin ;x=x*a.R/2.+a.Centre(0) ;y=y*a.R/2.+a.Centre(1) x=x*a.R(uv.index)+a.Centre(uv.index,0) y=y*a.R(uv.index)+a.Centre(uv.index,1) if uv.index then Sc=a.Sc1 else Sc=a.Sc0 Window_set,ID.win(uv.index),scale=Sc tvcrs,x,y,/dev ssrt_map_view_convert,[x,y],uv.index endif else begin WIDGET_CONTROL,/hour xwarning, 'These coordinates are not allowed' endelse end "Clear": begin WIDGET_CONTROL,ID.Coord(0),set_val='' WIDGET_CONTROL,ID.Rect(0),set_val='' WIDGET_CONTROL,ID.Helio(0),set_val='' WIDGET_CONTROL,ID.Karr(0),set_val='' WIDGET_CONTROL,ID.Dist(0),set_val='' end "Save": begin ID.Save=ev.select if ID.Save then Name=ID.Filename else Name='' WIDGET_CONTROL,ID.Name,set_val=Name end "List": begin WIDGET_CONTROL,/hourglass xtext,text=ID.Results end "Name": begin WIDGET_CONTROL,ID.Name,get_val=temp ID.Filename=temp(0) end ELSE: ENDCASE end pro ssrt_map_view,group_leader=group_leader,SUN=SUN, $ modal=modal,Date,Time common ssrt_map_view,a,ID,header0,header1,Image0,Image_curr0,Image1,Image_curr1 loadct,3 if xregistered('ssrt_map_view') then return header='' if n_elements(group_leader) le 0 then group_leader=0L if n_elements(modal) le 0 then modal=0 if n_params() eq 2 then suneph,Date,Time,SUN if n_elements(Date) le 0 then Date='' if n_elements(Time) le 0 then Time='' WIDGET_CONTROL,/hour M=strlowcase(findfile('vga_drv.rcg')) if equiv(M,'') then M=1 else begin openr,lun,'vga_drv.rcg',/get_lun readf,lun,M free_lun,lun endelse ;M=0 for L-310 else M=1 (to plot lines with various styles) LA=lonarr(2) ID={win:LA, Karr:LA, Helio:LA, Rect:LA, Dist:LA, $ Date:LA, Time:LA, View:LA, Coord:LA, Data:lonarr(2,9), $ linestyle:M,color:60B, group_leader:group_leader,Text:'', $ Save_button:0L, Save:0, Filename:'', number:0L, Results:strarr(4), $ Name:0L, path:getenv('optics_dir')} device,get_screen_size=screen Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} R=200 S={SOL_EPHEMERIDE, Current_date:strarr(4), Date:'', Time:'', H:0.d0, $ Decl:0.d0, W0:0.d0, Tcul:0.d0, R:0.d0, Dp:0.d0, B0:0.d0, Karr:0.d0} if n_elements(SUN) le 0 then SS=S else SS=SUN a={P:!P, Date:Date, Time:Time, R:[R,R], Centre:fltarr(2,2), $ press:0, map:0, SUN0:SS, SUN1:SS, Sc0:Ax, Sc1:Ax} Ax=0 !P.color=0 !P.background=255b Mainbase=widget_base(/colu, tit='Viewer for SSRT maps', $ group_leader=group_leader) Menubase=widget_base(Mainbase,/row) button=widget_button(MenuBase,val='DONE', uval={Name:"DONE"}) button=widget_button(MenuBase,val='File', /menu) junk=widget_button(button,val='Left', /menu) junk1=widget_button(junk,val='Load', uval={Name:"Load", index:0}) junk1=widget_button(junk,val='Header', uval={Name:"Header", index:0}) junk1=widget_button(junk,val='Save results', uval={Name:"Save", index:0}) junk=widget_button(button,val='Right', /menu) junk1=widget_button(junk,val='Load', uval={Name:"Load", index:1}) junk1=widget_button(junk,val='Header', uval={Name:"Header", index:1}) junk1=widget_button(junk,val='Save results', uval={Name:"Save", index:1}) button=widget_button(MenuBase,val='Tools', /menu) junk=widget_button(button,val='List', uval={Name:"List"}) junk=widget_button(button,val='Clear', uval={Name:"Clear"}) junk=widget_button(button,val='Palette', uval={Name:"Xloadct"}) junk=widget_button(button,val='Calculator', uval={Name:"Calculator"}) junk=widget_button(button,val='Parameters of SSRT', uval={Name:"Parameters"}) junk=widget_button(button,val='Heiocentric', uval={Name:"Heliocentric"}) junk=widget_button(button,val='Geocentric', uval={Name:"Geocentric"}) junk=widget_button(button,val='XManager Tool', uval={Name:"XMTool"}) junk=widget_button(button,val='Shell', /menu) junk1=widget_button(junk,val='OS', uval={Name:"DOS"}) junk1=widget_button(junk,val='NC', uval={Name:"NC"}) junk1=widget_button(junk,val='VC', uval={Name:"VC"}) junk1=widget_button(junk,val='Archiver', uval={Name:"Archiver"}) Savebase=widget_base(Menubase,/row,/nonexcl,/frame) Save_button=widget_button(Savebase,val='Save results',uval={Name:'Save'}) ID.Filename=newfilename(filter='*.lst',model='coord') label=WIDGET_LABEL(Menubase,val='File: ') ID.Name=WIDGET_Text(Menubase,val='',/edit,uval={Name:'Name'},/fra, xsi=15) WIDGET_CONTROL,Save_button,set_but=ID.save Rowbase=widget_base(Mainbase,/row) Drawbase=[0L, 0L] device,get_scr=scr CASE 1 OF scr(0) lt 800: drawsize=300 scr(0) eq 800: drawsize=380 (scr(0) gt 800) and (scr(0) lt 1000): drawsize=400 scr(0) gt 1000: drawsize=500 ENDCASE Ncrdb=5 for k=0,1 do begin Drawbase(k)=widget_base(Rowbase,/colu) CoordBase=lonarr(Ncrdb) TimeBase=widget_base(Drawbase(k),/row) label=WIDGET_LABEL(TimeBase,val=' Date ') ID.Date(k)=WIDGET_TEXT(TimeBase,xsi=10,/fra,/edit,uval={Name:'Date', index:k}) label=WIDGET_LABEL(TimeBase,val=' Time ') ID.Time(k)=WIDGET_TEXT(TimeBase,xsi=10,/fra,/edit,uval={Name:'Time', index:k}) label=WIDGET_LABEL(TimeBase,val=' UT ') button=WIDGET_BUTTON(TimeBase, /menu,val='Ephemeride') for j=0,8 do ID.Data(k,j)=widget_button(button,val=' ',uval={Name:' '}) AuxRowBase=widget_base(Drawbase(k),/row) for j=0,Ncrdb-1 do CoordBase(j)=widget_base(AuxRowBase,/colu) label=WIDGET_LABEL(CoordBase(0),val='Heliograph.') ID.Helio(k)=WIDGET_TEXT(CoordBase(0),xsi=12,/fra,/edit, $ uval={Name:'Helio', index:k}) label=WIDGET_LABEL(CoordBase(1),val="Karringt.") ID.Karr(k)=WIDGET_TEXT(CoordBase(1),xsi=10,/fra,/edit, $ uval={Name:'Karr', index:k}) label=WIDGET_LABEL(CoordBase(2),val='Rectang.') ID.Rect(k)=WIDGET_TEXT(CoordBase(2),xsi=10,/fra,/edit, $ uval={Name:'Rect', index:k}) label=WIDGET_LABEL(CoordBase(3),val='Distance') ID.Dist(k)=WIDGET_TEXT(CoordBase(3),xsi=10,/fra,uval={Name:' '}) ID.View(k)=widget_draw(Drawbase(k),xsi=drawsize,ysi=drawsize,/button,/motion, $ retain=2,/frame) ID.Coord(k)=WIDGET_LABEL(Drawbase(k),val=' ') endfor WIDGET_CONTROL,Mainbase,/REALIZE,/HOUR for j=0,1 do begin WIDGET_CONTROL,ID.View(j),GET_VALUE=temp ID.Win(j)=temp wset,ID.win(j) erase,255 endfor for k=0,1 do begin wset,ID.win(k) if n_elements(SUN) le 0 then plot,indgen(10),/nod,xst=4,yst=4 else begin text_data=pr_sun(SUN, /si) for j=0,8 do WIDGET_CONTROL,ID.Data(k,j),set_val=text_data(j),/hour map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color plotline,-tan(SUN.Dp),[1,1]*!d.x_vsize*0.5,lines=ID.linestyle,/dev plots,[1,1]*0.5*!d.x_vsize,[0,!d.x_vsize], $ /dev,linestyle=ID.linestyle,col=ID.color plots,[0,!d.x_vsize],[1,1]*0.5*!d.x_vsize, $ /dev,linestyle=ID.linestyle,col=ID.color a.map=1 WIDGET_CONTROL,ID.Time,set_val=SUN.Time WIDGET_CONTROL,ID.Date,set_val=SUN.Date endelse a.Centre=[1,1]#[1,1]*0.5*!d.x_vsize a.R=[1,1]*0.5*!d.x_vsize Scale,temp,/mem if k then a.Sc1=temp else a.Sc0=temp endfor empty text0=string(' ',format="(a1,T10,'Coordinates issued by the program ssrt_map_view')") text1=string(' ',format= $ "(a1,T5,'Date',T15,'Time',T25,'Helio',T39,'Karringt.',T50,'Rect. Norm.',T65,'Ang. dist.')") ID.Results=[text0,'',text1,''] xmanager,'ssrt_map_view',Mainbase,modal=modal end ####################################################### Function STDEV, Array, Mean ; ;+ ; NAME: ; STDEV ; ; PURPOSE: ; Compute the standard deviation and, optionally, the ; mean of any array. ; ; CATEGORY: ; G1- Simple calculations on statistical data. ; ; CALLING SEQUENCE: ; Result = STDEV(Array [, Mean]) ; ; INPUTS: ; Array: The data array. Array may be any type except string. ; ; OUTPUTS: ; STDEV returns the standard deviation (sample variance ; because the divisor is N-1) of Array. ; ; OPTIONAL OUTPUT PARAMETERS: ; Mean: Upon return, this parameter contains the mean of the values ; in the data array. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Mean = TOTAL(Array)/N_ELEMENTS(Array) ; Stdev = SQRT(TOTAL((Array-Mean)^2/(N-1))) ; ; MODIFICATION HISTORY: ; DMS, RSI, Sept. 1983. ;- on_error,2 ;return to caller if error n = n_elements(array) ;# of points. if n le 1 then message, 'Number of data points must be > 1' ; mean = total(array)/n ;yes. return,sqrt(total((array-mean)^2)/(n-1)) end ####################################################### function stretch_image, x, kx, ky, interp=interp, missing=missing Sz=size(x) P= [[-Sz(1)/2.*(1./kx-1.), 0],[1./kx, 0]] Q= [[-Sz(2)/2.*(1./ky-1.), 1./ky],[0, 0]] if n_elements(missing) le 0 then return, POLY_2D(x, P, Q, keyword_set(interp)) $ else return, POLY_2D(x, P, Q, keyword_set(interp), miss=missing) end ####################################################### function strsubst,x,model,substitute if n_params() lt 3 then message,'3 arguments needed.' Found=substring(x,Model) if Found(0) lt 0 then return,x Bx=byte(x) Bs=byte(substitute) Nx=n_elements(Bx) Nm=strlen(model) Ns=n_elements(Bs) Nf=n_elements(Found) Ny=Nx+(Ns-Nm)*Nf Y=bytarr(Ny) for j=0,Nf-1 do begin if j eq 0 then begin if Found(0) eq 0 then Y=Bs else Y=[BX(0:Found(j)-1),Bs] endif else begin Y=[Y,BX(Found(j-1)+Nm:Found(j)-1),Bs] endelse endfor if Found(Nf-1)+Nm lt (Nx-1) then Y=[Y,BX(Found(Nf-1)+Nm:*)] return,string(Y) end ####################################################### function subdir,b ;+ Returns pathname of the subdirectory ; containing given file. ;- Input argument - pathname of the file CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE j=0 while strpos(b,Delim,j) ge 0 do j=j+1 return,strmid(b,0,j-1) end ####################################################### function subs1to2,ind,dimension=dimension,array=array ; Converts 1-d subscript to 2-d if n_elements(dimension) gt 0 then sz=dimension else sz=size(array) index=long(ind+0.5) M=sz(1) return,transpose([[fix(index mod M)],[fix(index/M)]]) end ####################################################### function substring,x,model bx=byte(x) bm=byte(model) ind=where(bx eq bm(0)) Nx= n_elements(bx) Nm= n_elements(bm) if ind(0) lt 0 or ind(0) gt Nx-Nm then return,-1L for j=0L,n_elements(ind)-1 do begin if ind(j) gt Nx-Nm then return,-1L if equiv(bx(ind(j):ind(j)+Nm-1),bm) then begin if n_elements(Found) le 0 then Found=ind(j) else Found=[Found,ind(j)] endif endfor if n_elements(Found) le 0 then Found=-1L return,Found end ####################################################### pro suncalc_cleanup,x common suncalc_EXC,a,ID,Factor WIDGET_CONTROL,/hour if ID.Save then begin CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE openw,Lun,getenv('results')+Delim+ID.Filename, /get_lun printf,Lun,ID.Results free_lun,Lun endif if ID.group_leader ne 0L then begin if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show endif !P=a.P a=(ID=0) end function suncalc_text,SUN return, $ ["Position angle = "+string(SUN.Dp*!radeg,format="(F6.2)"), $ "Radius = "+string(SUN.R*!radeg*60,format="(F6.2)")+"'", $ "Centre's latitude = "+string(SUN.B0*!radeg,format="(F6.2)"), $ "Centre's Carring. long. = "+string(SUN.Karr*!radeg,format="(F6.1)"), $ "Hour angle = "+string(SUN.H*!radeg,format="(F6.2)"), $ "Declination = "+string(SUN.Decl*!radeg,format="(F6.2)"), $ "Culmination = "+smh(SUN.Tcul*3600d0,/ms)] end pro suncalc_convert,x common suncalc_EXC,a,ID,Factor Centre=[1,1]*0.5*!d.x_vsize p=convert_coord(x(0),x(1),/dev,/to_data) Rect=string(2.*(x-Centre)(0)/a.R,2.*(x-Centre)(1)/a.R, $ format="(F5.2,', ',F5.2)") WIDGET_CONTROL,ID.Coord,set_val=Rect WIDGET_CONTROL,ID.Rect,set_val=Rect ;radius=sqrt(((2.*(x-Centre)(0)/a.R)^2+(2.*(x-Centre)(1)/a.R)^2)) radius=2./a.R*sqrt(((x-Centre)(0))^2+((x-Centre)(1))^2) if radius lt 1 then Dist=asin(radius)*!radeg else Dist=90. Dist=string(Dist,format="(F5.2)")+' deg' WIDGET_CONTROL,ID.Dist,set_val=Dist if a.map eq 0 then return if p(0) lt 0 then dirX='E' else dirX='W' if p(1) lt 0 then dirY='S' else dirY='N' Helio=string(dirX,abs(p(0)),dirY,abs(p(1)),format="(A1,F4.1,', ',A1,F4.1)") WIDGET_CONTROL,ID.Helio,set_val=Helio if n_tags(a) gt 6 then begin Klong=p(0)+a.SUN.Karr*!radeg Klong=(Klong+360*(Klong lt 0)) mod 360 Carr=string(Klong,p(1),format="(F5.1,', ',F5.1)") WIDGET_CONTROL,ID.Carr,set_val=Carr endif Helio=strcompress(Helio,/rem) Carr=strcompress(Carr,/rem) Rect=strcompress(Rect,/rem) Dist=strcompress(Dist) text=string(' ',format= $ "(a1,'"+a.Date+"',T12,'"+a.Time+"',T26,'"+Helio+"',T39,'"+Carr+"',T52,'"+Rect+"',T65,'"+Dist+"')") ID.number=ID.number+1 ID={win:ID.win,Carr:ID.Carr,Helio:ID.Helio,Rect:ID.Rect,Dist:ID.Dist, $ Date:ID.Date,Time:ID.Time,View:ID.View,Coord:ID.Coord,Data:ID.Data, $ linestyle:ID.linestyle,color:ID.color, group_leader:ID.group_leader, $ Text:ID.Text, Save_button:ID.Save_button, $ Save:ID.Save, Filename:ID.Filename, number:ID.number, $ Name:ID.Name, Results:[ID.Results,text]} end pro suncalc_event,ev common suncalc_EXC,a,ID,Factor Centre=[1,1]*0.5*!d.x_vsize if ev.id eq ID.View then begin if ev.press then a.press=1 if ev.release then a.press=0 Window_set,ID.win,scale=a.Sc p=convert_coord(ev.x,ev.y,/dev,/to_data) WIDGET_CONTROL,ID.Coord,set_val= $ string(2.*(ev.x-Centre(0))/a.R,2.*(ev.y-Centre(1))/a.R, $ format="(F5.2,', ',F5.2)") x=[ev.x,ev.y] if a.press then suncalc_convert,x return endif WIDGET_CONTROL,ev.id,GET_UVALUE = wuv CASE wuv OF "DONE": WIDGET_CONTROL,ev.top,/DESTROY "Date": begin WIDGET_CONTROL,ev.id,get_value=temp a.Date=strtrim(strcompress(temp(0)),2) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Name=getenv('astr_data')+Delim+'sol'+strmid(a.Date,6,2)+'.dat' if (findfile(Name))(0) eq '' then begin WIDGET_CONTROL,ev.id,set_value='incorrect' return endif WIDGET_CONTROL,ev.id,set_value=a.Date,/hour if n_tags(a) gt 6 then SUN=a.SUN if a.time ne '' then begin suneph,a.date,a.time,SUN WIDGET_CONTROL,ID.Data,set_val=suncalc_text(SUN) map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color plotline,-tan(SUN.Dp),[1,1]*0.5*!d.x_vsize,lines=ID.linestyle,/dev plots,[1,1]/2.*!d.x_vsize,[0,!d.x_vsize], $ /dev,linestyle=ID.linestyle,col=ID.color plots,[0,!d.x_vsize],!d.x_vsize/2.*[1,1], $ /dev,linestyle=ID.linestyle,col=ID.color Scale,temp,/mem a={P:a.P,Date:a.Date,time:a.time,R:a.R,SUN:SUN,press:a.press, $ map:1, Sc:temp} empty endif WIDGET_CONTROL,ID.Time,/input end "Time": begin WIDGET_CONTROL,ev.id,get_value=temp a.time=strtrim(strcompress(temp(0)),2) WIDGET_CONTROL,ev.id,set_value=a.time,/hour if n_tags(a) gt 6 then SUN=a.SUN if a.date ne '' then begin suneph,a.date,a.time,SUN WIDGET_CONTROL,ID.Data,set_val=suncalc_text(SUN) if not(a.map) then begin map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color plotline,-tan(SUN.Dp),[1,1]*0.5*!d.x_vsize,lines=ID.linestyle,/dev plots,[1,1]*!d.x_vsize/2.,[0,!d.x_vsize], $ /dev,linestyle=ID.linestyle,col=ID.color plots,[0,!d.x_vsize],!d.x_vsize/2.*[1,1], $ /dev,linestyle=ID.linestyle,col=ID.color Scale,temp,/mem a.Sc=temp endif a={P:a.P,Date:a.Date,time:a.time,R:a.R,SUN:SUN,press:a.press, $ map:1, Sc:a.Sc} empty endif WIDGET_CONTROL,ID.Date,/input end "Helio": begin WIDGET_CONTROL,ev.id,GET_V=b if (b(0) eq '') and n_elements(b) gt 1 then b=b(1:*) b=strlowcase(strcompress(b(0),/rem)) i1=strpos(b,',') i2=strlen(b) lon=float(strmid(b, 1, i1-1)) lat=float(strmid(b, i1+2, i2-i1-2)) lonsign=strmid(b,0,1) latsign=strmid(b,i1+1,1) if lonsign eq 'e' or lonsign eq '-' then lon=-lon if latsign eq 's' or latsign eq '-' then lat=-lat Coord=convert_coord(lon,lat,/to_dev,/data) if Coord(0) le !d.x_vsize and Coord(1) le !d.x_vsize then begin Window_set,ID.win,scale=a.Sc tvcrs,lon,lat,/data suncalc_convert,Coord endif else begin WIDGET_CONTROL,/hour xwarning, 'These coordinates are not allowed' endelse end "Carr": if n_tags(a) lt 7 then begin WIDGET_CONTROL,/hour xwarning, 'First of all please enter date and time' return endif else begin WIDGET_CONTROL,ev.id,GET_V=b if (b(0) eq '') and n_elements(b) gt 1 then b=b(1:*) b=strlowcase(strcompress(b(0),/rem)) i1=strpos(b,',') i2=strlen(b) lon=float(strmid(b, 0, i1))-a.SUN.Karr*!radeg lat=float(strmid(b, i1+1, i2-i1)) Coord=convert_coord(lon,lat,/to_dev,/data) if Coord(0) le a.R and Coord(1) le a.R then begin Window_set,ID.win,scale=a.Sc tvcrs,lon,lat,/data suncalc_convert,Coord endif else begin WIDGET_CONTROL,/hour xwarning, 'These coordinates are not allowed' endelse endelse "Rect": begin WIDGET_CONTROL,ev.id,GET_V=b if (b(0) eq '') and n_elements(b) gt 1 then b=b(1:*) b=strlowcase(strcompress(b(0),/rem)) i1=strpos(b,',') i2=strlen(b) x=float(strmid(b, 0, i1)) y=float(strmid(b, i1+1, i2-i1)) if (x^2+y^2) le 1 then begin x=x*a.R/2.+Centre(0) y=y*a.R/2.+Centre(1) Window_set,ID.win,scale=a.Sc tvcrs,x,y,/dev suncalc_convert,[x,y] endif else begin WIDGET_CONTROL,/hour xwarning, 'These coordinates are not allowed' endelse end "Clear": begin WIDGET_CONTROL,ID.Coord,set_val='' WIDGET_CONTROL,ID.Rect,set_val='' WIDGET_CONTROL,ID.Helio,set_val='' WIDGET_CONTROL,ID.Carr,set_val='' WIDGET_CONTROL,ID.Dist,set_val='' end "Save": begin ID.Save=ev.select if ID.Save then Name=ID.Filename else Name='' WIDGET_CONTROL,ID.Name,set_val=Name end "List": begin WIDGET_CONTROL,/hourglass xtext,text=ID.Results end "Name": begin WIDGET_CONTROL,ID.Name,get_val=temp ID.Filename=temp(0) end ELSE: ENDCASE end pro suncalc,group_leader=group_leader,SUN=SUN, $ modal=modal,Date,Time common suncalc_EXC,a,ID,Factor if xregistered('suncalc') then return if n_elements(group_leader) le 0 then group_leader=0L if n_elements(modal) le 0 then modal=0 if n_params() eq 2 then suneph,Date,Time,SUN if n_elements(Date) le 0 then Date='' if n_elements(Time) le 0 then Time='' CASE !version.OS OF 'windows': Factor=1. 'Win32': Factor=1. ELSE: Factor=1.04 ENDCASE WIDGET_CONTROL,/hour M=strlowcase(findfile('vga_drv.rcg')) if equiv(M,'') then M=1 else begin openr,lun,'vga_drv.rcg',/get_lun readf,lun,M free_lun,lun endelse ;M=0 for L-310 else M=1 (to plot lines with various styles) ID={win:0L,Carr:0L,Helio:0L,Rect:0L,Dist:0L, $ Date:0L,Time:0L,View:0L,Coord:0L,Data:0L, $ linestyle:M,color:100B, group_leader:group_leader,Text:'', $ Save_button:0L, Save:1, Filename:'', number:0L, Results:strarr(4),Name:0L} device,get_screen_size=screen R=0.7*screen(1) Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} if n_elements(SUN) le 0 then $ a={P:!P,Date:Date,Time:Time,R:R,press:0,map:0, Sc:Ax} $ else a={P:!P,Date:Date,Time:Time,R:R,press:0,map:0,SUN:SUN, Sc:Ax} Ax=0 !P.color=0 !P.background=255b Mainbase=widget_base(/colu, tit='Coordinates on the Sun', $ group_leader=group_leader) Menubase=widget_base(Mainbase,/row) XPdMenu, ['"DONE" DONE', $ '"List" List', $ '"Clear" Clear'], Menubase Savebase=widget_base(Menubase,/row,/nonexcl,/frame) Save_button=widget_button(Savebase,val='Save results',uval='Save') ID.Filename=newfilename(filter='*.lst',model='coord', path=getenv('results')) label=WIDGET_LABEL(Menubase,val='File: ') ID.Name=WIDGET_Text(Menubase,val=ID.Filename,/edit,uval='Name') WIDGET_CONTROL,Save_button,/set_but base1=widget_base(Mainbase,/row) label=WIDGET_LABEL(base1,val=' Date ') ID.Date=WIDGET_TEXT(base1,xsi=15,/fra,/edit,uval='Date') label=WIDGET_LABEL(base1,val=' Time ') ID.Time=WIDGET_TEXT(base1,xsi=15,/fra,/edit,uval='Time') label=WIDGET_LABEL(base1,val=' UT') Rowbase=widget_base(Mainbase,/row) Columnbase=widget_base(Rowbase,/colu) base1=widget_base(Columnbase,/row) ID.Helio=WIDGET_TEXT(base1,xsi=15,/fra,/edit,uval='Helio') label=WIDGET_LABEL(base1,val='Heliographical') base1=widget_base(Columnbase,/row) ID.Carr=WIDGET_TEXT(base1,xsi=15,/fra,/edit,uval='Carr') label=WIDGET_LABEL(base1,val="Carrington's") base1=widget_base(Columnbase,/row) ID.Rect=WIDGET_TEXT(base1,xsi=15,/fra,/edit,uval='Rect') label=WIDGET_LABEL(base1,val='Rectangular') base1=widget_base(Columnbase,/row) ID.Dist=WIDGET_TEXT(base1,xsi=15,/fra,uval=' ') label=WIDGET_LABEL(base1,val='Distance') label=WIDGET_LABEL(Columnbase,val='Data (degree)') ID.Data=WIDGET_TEXT(Columnbase,xsi=33,/fra, $ uval=' ',ysize=7) Drawbase=widget_base(Rowbase,/colu) ID.View=widget_draw(Drawbase,xsi=R*Factor,ysi=R*Factor,/button,/motion, retain=2) ID.Coord=WIDGET_LABEL(Drawbase,val=' ') WIDGET_CONTROL,Mainbase,/REALIZE,/HOUR WIDGET_CONTROL,ID.View,GET_VALUE=temp ID.Win=temp wset,ID.win if n_elements(SUN) le 0 then $ draw_circle,[1,1]*!d.x_vsize*0.5,R*0.5, /axes else begin WIDGET_CONTROL,ID.Data,set_val=suncalc_text(SUN),/hour map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, $ glinestyle=ID.linestyle,Xmar=[0,0],Ymar=[0,0], $ latdel=10,londel=10,col=ID.color plotline,-tan(SUN.Dp),[1,1]*!d.x_vsize*0.5,lines=ID.linestyle,/dev plots,[1,1]*0.5*!d.x_vsize,[0,!d.x_vsize], $ /dev,linestyle=ID.linestyle,col=ID.color plots,[0,!d.x_vsize],[1,1]*0.5*!d.x_vsize, $ /dev,linestyle=ID.linestyle,col=ID.color Scale,temp,/mem a.Sc=temp a.map=1 WIDGET_CONTROL,ID.Time,set_val=SUN.Time WIDGET_CONTROL,ID.Date,set_val=SUN.Date endelse WIDGET_CONTROL,ID.Date,/input,/hour empty text0=string(' ',format="(a1,T10,'Coordinates issued by the program SUNCALC')") text1=string(' ',format= $ "(a1,T5,'Date',T15,'Time',T25,'Helio',T39,'Carringt.',T50,'Rect. Norm.',T65,'Ang. dist.')") ID.Results=[text0,'',text1,''] xmanager,'suncalc',Mainbase,cleanup='suncalc_cleanup',modal=modal end ####################################################### pro suneph,Date,Time,SUN,path=path, universal=universal ;+ ; This procedure reads contents of the file containing solar data ; (e.g. for year 1993 - file "sol93.dat") and interpolates data to the ; observation time. File sol**.dat is assumed to be placed into the ; directory described by the environment variable "astr_data". If it is ; not the case, you must specify keyword parameter "path". ; ; Input arguments Date and Time are strings, ; e.g. Date=12 07 94 - July 12, 1994; ; Time=21 23 45.385 - 21 hour 23 min 45.385 sec UT. ; Second fractions are not obliged. ; ; All the output values are collected into the structure SUN ; named SOL_EPHEMERIDE. ; ; Output values are concerned to the observation time: ; SUN.H - hour angle; ; SUN.Decl - declination; ; SUN.W0 - angular velocity of the diurnal rotation of ; the Earth, rad/sec; ; SUN.Tcul - culmination time for the given day in hours; ; SUN.R - optical radius of the Sun; ; SUN.Dp - position angle, i.e the angle between the ; polar axes of the Sun and the meridium being ; counted to the east from the meridium (diurnal parallel); ; SUN.B0 - altitude of the solar center; ; SUN.Karr - Karrington longitude of the solar center. ; All the output values are floating-point, double precision and are ; measured (except for Tcul and W0) in radians. ; ; SUN.Current_date - buffer strings containing summary information read ; from file (about three consequtive days around current date). ; SUN.Current_date(3) contains current year. ; ;- DDTOR=!DPi/180 sz=size(SUN) sun_type=sz(n_elements(sz)-2) if sun_type eq 8 then if strupcase(tag_names(SUN,/str)) eq $ 'SOL_EPHEMERIDE' then begin SUN.Date=Date SUN.Time=Time Month=strmid(SUN.Current_date(1),5,2) Nday=strmid(SUN.Current_date(1),7,2) if strmid(Nday,0,1) eq ' ' then Nd='0'+strmid(Nday,1,1) else Nd=Nday if strmid(Month,0,1) eq ' ' then Mn='0'+strmid(Month,1,1) else Mn=Month ;Date_Buf=Nd+' '+Mn+' '+strmid(SUN.Current_date(3),2,2) Date_Buf=Nd+'/'+Mn+'/'+strmid(SUN.Current_date(3),2,2) Date_ = Date strput, Date_, '/', 2 strput, Date_, '/', 5 If Date_ eq Date_Buf then begin Current_date=SUN.Current_date goto, Current endif endif New: Year=strmid(Date,6,2) Current_date=['','','',Year] if Year gt 50 then Current_date(3)='19'+Year else Current_date(3)='20'+Year if n_elements(path) le 0 then path=getenv('astr_data') CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE Name=path+Delim+'sol'+Year+'.dat' NdayI=fix(strmid(Date,0,2)) MonthI=fix(strmid(Date,3,2)) if(float(Year)/4 eq fix(Year)/4 and Year ne '00') then Mvys=1 else Mvys=0 M=MonthI IF(NdayI EQ 1) THEN BEGIN MonthP=MonthI-1 IF(M EQ 5 OR M EQ 7 OR M EQ 10 OR M EQ 12)THEN NdayP=30 $ ELSE IF (M EQ 3 AND Mvys EQ 1) THEN NdayP=29 $ ELSE IF (M EQ 3 AND Mvys EQ 0) THEN NdayP=28 ELSE NdayP=31 ENDIF ELSE BEGIN NdayP=NdayI-1 MonthP=MonthI ENDELSE print,'reading the file ',Name if !d.flags and 2l^16 ne 0 then WIDGET_CONTROL,/hour openr,lun,Name,ERROR=err,/get_lun IF(err NE 0) then PRINTF,-2,!ERR_STRING header=strarr(3) status=fstat(lun) readf,lun,header point_lun,-lun,header_length date0='01 01 '+year t_dif=time_difference(date0,time,date,time)/3600d0/24 IF t_dif GT 10 THEN BEGIN Last_record=status.size-200 point_lun,lun, Last_record a=bytarr(200) readu,lun,a ind=where(a eq '0a'xb) point_lun,lun, Last_record+ind(0)+1 ws='' readf,lun,ws point_lun,-lun, Last_pointer Last_Date=strmid(ws,7,2)+' '+strmid(ws,5,2)+' '+Year if time_difference(date,time,Last_Date,time) lt 0 then begin free_lun,lun message,'Error! Ephemeride for this date is not available.' endif ndays=fix(time_difference(date0,time,Last_Date,time)/3600d0/24+0.5)+1 string_length=(Last_pointer-header_length)/float(ndays+1) first_step= long((t_dif-5)*string_length)+header_length point_lun,lun, first_step temp=bytarr(150) readu,lun,temp ind=where(temp eq '0a'xb) point_lun,lun, first_step+ind(0)+1 ENDIF Data_string='' I=0 WHILE I lt 3 DO BEGIN readf,lun,Data_string Current_date(I)=Data_string Month=fix(strmid(Current_date(0),5,2)) Nday=fix(strmid(Current_date(0),7,2)) IF(Month EQ MonthP AND Nday EQ NdayP OR MonthP EQ 0) THEN I=I+1 ENDWHILE free_lun,lun Current: Declg=strmid(Current_date,12,2) DSign=strmid(Current_date,11,1) Declm=strmid(Current_date,15,2) Decls=strmid(Current_date,18,4) Hculm=strmid(Current_date,24,2) Mculm=strmid(Current_date,27,2) Sculm=strmid(Current_date,30,4) Rsun=strmid(Current_date,35,5)*DDTOR/60 Dpar=strmid(Current_date,42,5)*DDTOR B0in=strmid(Current_date,49,4)*DDTOR Karr=strmid(Current_date,55,6)*DDTOR Ddelta=strmid(Current_date,62,6)*DDTOR/3600d0*24d0 Tculm=HMS(Hculm,Mculm,Sculm) Tcul=Tculm(1) Delta=HMS(Declg,Declm,Decls)*DDTOR for I=0,2 do IF(Dsign(I) EQ '-') then Delta(I)=-Delta(I) Tobs=HMS(Time) Tobs=Tobs-24*(Tobs ge (Tcul+12))*(1-keyword_set(universal)) IF((Tobs-Tcul) LE 0) THEN Tdiur=Tculm(1)-Tculm(0)+24 ELSE $ Tdiur=Tculm(2)-Tculm(1)+24 W0=2*!DPi/Tdiur Hangle=W0*(Tobs-Tcul) W0=W0/3600d0 Direction=Hangle/(2*!DPi) IF(Direction LE 0) THEN BEGIN Decl=Delta(1)+Direction*Ddelta(1)-Direction^2*(DDelta(1)-DDelta(0))/2 Dp=Dpar(1)+Direction*(Dpar(1)-Dpar(0)) B0=B0in(1)+Direction*(B0in(1)-B0in(0)) ;Klong=Karr(1)+Direction*(Karr(1)-Karr(0)) Klong=Karr(1)+Direction*(Karr(1)-Karr(0)-2*!DPi*(Karr(1) gt Karr(0))) Rsol=(Rsun(1)+Direction*(Rsun(1)-Rsun(0))) ENDIF ELSE BEGIN Decl=Delta(1)+Direction*Ddelta(1)+Direction^2*(DDelta(2)-DDelta(1))/2 Dp=Dpar(1)+Direction*(Dpar(2)-Dpar(1)) B0=B0in(1)+Direction*(B0in(2)-B0in(1)) ;Klong=Karr(1)+Direction*(Karr(2)-Karr(1)) Klong=Karr(1)+Direction*(Karr(2)-Karr(1)-2*!DPi*(Karr(2) gt Karr(1))) Rsol=(Rsun(1)+Direction*(Rsun(2)-Rsun(1))) ENDELSE Klong=Klong+2*!DPi*(Klong lt 0)-2*!DPi*(Klong gt 2*!DPi) SUN={SOL_EPHEMERIDE, Current_date:Current_date, Date:Date, Time:Time, H:Hangle, $ Decl:Decl, W0:W0, Tcul:Tcul, R:Rsol, Dp:Dp, B0:B0, Karr:Klong} exit: end ####################################################### function sunrot, Data, date, time, date1, time1, LIMB, $ LATITUDE=LATITUDE, SHOW=SHOW, outside=outside, missing=missing ;+ Compensation of differential rotation of the Sun. ; If keyword parameter LATITUDE is present, the 'solid' rotation ; is performed, and LATITUDE is interpreted is the reference one. ; Example: ; ; Data=rfits(pickfile(/read,filt='*.fts')) ; Sz=size(Data) ; window,/free,xsize=Sz(1),ysize=Sz(2),xpos=0,ypos=0 ; LIMB=[Center_X, Center_Y, Radius] ; Date='01 01 93' ; Time='02:07:35' ; Date1='02 01 93' ; Time='05:17:47' ; Rotated_Sun=sunrot(Data,date,time,date1,time1,LIMB) ; tvscl,Rotated_Sun ;- if n_params() lt 6 then message, 'Insufficient number of arguments' if n_elements(missing) le 0 then missing=0 dt=time_difference(date, time, date1, time1)/3600d0/24 WIDGET_CONTROL,/hour Sz=size(Data) type=Sz(Sz(0)+1) suneph,date,time,SUN Lonmin=-89. Lonmax=89. Latmin=float(-89+SUN.B0*!Radeg) Latmax=float(89+SUN.B0*!Radeg) Centre=float(Limb([0,1])) Radius=float(Limb(2)) ;***************************************************************** window,/free,xs=Sz(1),ys=Sz(2), pixmap=1-keyword_set(show) N_win=!d.window if keyword_set(show) then tvscl,data if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-Centre(0),!d.x_size-Centre(0)]/Radius !y.range=[-Centre(1),!d.y_size-Centre(1)]/Radius map_set,float(SUN.B0*!Radeg),0,0, /grid, $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,col=100 !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,float(SUN.B0*!Radeg),0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[Centre(0), Radius] / float(!d.x_size) !y.s=[Centre(1), Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, col=100 !P.clip=P_clip_save endelse Nm=512*2 arg=(findgen(Nm)-Nm/4)*(!Pi*2./Nm) ax=cos(arg) ay=sin(arg) xcir=ax*(Radius-2)+Centre(0) ycir=ay*(Radius-2)+Centre(1) Disk_index=(polyfillv(xcir,ycir,Sz(1),Sz(2))) xcir=ax*Radius+Centre(0) ycir=ay*Radius+Centre(1) median_value=100b z=make_array(Sz(1),Sz(2), type=type) z(polyfillv(xcir,ycir,Sz(1),Sz(2)))=median_value Planecoord=(subs1to2(Disk_index,dimension=[Sz(1),Sz(2)])) if keyword_set(outside) then Disk=z eq 0 Sphcoord=(convert_coord(Planecoord,/dev,/to_data))([0,1],*) bad_ind=where( $ (Sphcoord(0,*) le Lonmin) and $ (Sphcoord(0,*) ge Lonmax) and $ (Sphcoord(1,*) le Latmin) and $ (Sphcoord(1,*) ge Latmax) ) if bad_ind(0) ge 0 then Sphcoord(*,bad_ind)=0 if n_elements(LATITUDE) le 0 then $ Sphcoord(0,*)=Sphcoord(0,*)-difrot(dt,Sphcoord(1,*),/days,/degree) else $ Sphcoord(0,*)=Sphcoord(0,*)-difrot(dt,Sphcoord(1,*),/days,/degree, $ lat=LATITUDE) NewPlanecoord=(convert_coord(temporary(Sphcoord),/data,/to_dev))([0,1],*) index=where((NewPlanecoord(0,*) lt 1000) and (NewPlanecoord(1,*) lt 1000)) Flag=median_value-z if index(0) ge 0 then begin z(NewPlanecoord(0,index),NewPlanecoord(1,index))= $ Data(Planecoord(0,index),Planecoord(1,index)) Flag(NewPlanecoord(0,index),NewPlanecoord(1,index))=255b if keyword_set(outside) then Disk(NewPlanecoord(0,index),NewPlanecoord(1,index))=0 endif if keyword_set(show) then tvscl, z index=0 NewPlanecoord=0 Planecoord=0 index=where(flag eq 0) Flag=0 if index(0) ge 0 then begin Planecoord=(subs1to2(temporary(index),dimension=[Sz(1),Sz(2)])) Sphcoord=(convert_coord(Planecoord,/dev,/to_data))([0,1],*) Sphcoord(0,*)=Sphcoord(0,*) mod 360 < Latmax > Latmin Sphcoord(1,*)=Sphcoord(1,*) mod 360 < Lonmax > Lonmin if n_elements(LATITUDE) le 0 then $ Sphcoord(0,*)=Sphcoord(0,*)+difrot(dt,Sphcoord(1,*),/days,/degree) $ > Latmin < Latmax else $ Sphcoord(0,*)=Sphcoord(0,*)+difrot(dt,Sphcoord(1,*),/days,/degree, lat=LATITUDE) $ > Latmin < Latmax NewPlanecoord=(convert_coord(temporary(Sphcoord),/data,/to_dev))([0,1],*) z(Planecoord(0,*),Planecoord(1,*))=Data(NewPlanecoord(0,*),NewPlanecoord(1,*)) if keyword_set(show) then tvscl, z NewPlanecoord=0 Planecoord=0 endif meridian=indgen(Latmax-Latmin+1)+Latmin if dt gt 0 then begin if n_elements(LATITUDE) le 0 then $ ;Edge=(convert_coord(-90 > Lonmin < Lonmax-difrot(dt,0,/days,/degree) mod 360, $ ; meridian,/data,/to_dev))([0,1],*) else $ ;Edge=(convert_coord(-90 > Lonmin < Lonmax-difrot(dt,0,/days,/degree, lat=LATITUDE) mod 360, $ ; meridian,/data,/to_dev))([0,1],*) range=[Nm/2, n_elements(xcir)-1] ;empty_field=polyfillv( $ ; [xcir(range(0):range(1)),transpose(Edge(0,*))], $ ; [ycir(range(0):range(1)),transpose(Edge(1,*))], Sz(1),Sz(2)) endif else begin if n_elements(LATITUDE) le 0 then $ ;Edge=(convert_coord(90 > Lonmin < Lonmax-difrot(dt,0,/days,/degree), $ ; meridian,/data,/to_dev))([0,1],*) else $ ;Edge=(convert_coord(90 > Lonmin < Lonmax-difrot(dt,0,/days,/degree, lat=LATITUDE), $ ; meridian,/data,/to_dev))([0,1],*) range=[0, Nm/2-1] ;empty_field=polyfillv( $ ; [transpose(Edge(0,*)),reverse(xcir(range(0):range(1)),1)], $ ; [transpose(Edge(1,*)),reverse(ycir(range(0):range(1)),1)], Sz(1),Sz(2)) endelse ;if empty_field(0) ge 0 then z(empty_field)=missing ;z(Edge(0,*), Edge(1,*))=missing if keyword_set(show) then tvscl, z if keyword_set(show) then empty if not keyword_set(show) then wdelete,N_win if strmid(!version.release,0,1) ge 5 then begin z1=z*0 z1(Disk_index)=z(Disk_index) Disk_index=0 z=temporary(z1) if keyword_set(show) then tvscl, z endif if keyword_set(outside) then z=z+Data*Disk return, z end ####################################################### function sunrota, sun, date0, time0, date1, time1, Radius Sz = size(sun) x0_ = float(Sz(1)/2) y0_ = float(Sz(2)/2) r0 = float(Radius) if strlen(date0) eq 8 then date6_0 = date0 else $ date6_0 = strmid(date0, 8, 2) + '/' + strmid(date0, 5, 2) + '/' + strmid(date0, 2,2) day0 = strmid(date6_0, 0,2) month0 = monthnames(fix(strmid(date6_0, 3,2))) year0 = strmid(date6_0, 6,2) un_time0 = day0 + '-' + month0 + '-' + year0 + ' ' + time0 if strlen(date1) eq 8 then date6_1 = date1 else $ date6_1 = strmid(date1, 8, 2) + '/' + strmid(date1, 5, 2) + '/' + strmid(date1, 2,2) day1 = strmid(date6_1, 0,2) month1 = monthnames(fix(strmid(date6_1, 3,2))) year1 = strmid(date6_1, 6,2) un_time1 = day1 + '-' + month1 + '-' + year1 + ' ' + time1 rb0p = get_rb0p(un_time0) b0 = rb0p(1)*!radeg p0 = 0. rdeg = float(time_difference(date6_0, time0, date6_1, time1)/3600.) dim=size(sun) rsun=float(sun) image=rsun zmin=min(rsun) nx=dim(1) ny=dim(2) l0=rdeg*360.0/27.2753/24.0 x0 =x0_-1. ;IDL convention y0 =y0_-1. ;IDL convention ir =r0 ;solar radius in units of EW pixels ix =findgen(nx) for iy=0,ny-1 do begin ; if (long(iy/50) eq float(iy)/50.) then PRINT,'processing line =',iy yy =iy xx =ix ind =where((xx-x0)^2+(yy-y0)^2 lt (ir^2)) if (ind(0) ne -1) then begin x =xx(ind) heliotrans, x0, y0, 0., p0, b0, 0., x, yy, ir, hlong, hlat ; diffrot=(2.7*(sin(hlat*!pi/180.))^2)*rdeg/24. diffrot=-(2.7*abs(sin(hlat*!pi/180.)))*rdeg/24.*0. hlong = hlong + diffrot ;differential rotation + rotation heliotrans2, x0, y0, 0., 0., b0, l0, hlong, hlat, ir, ix2, iy2 i1=long(ix2-0.5) > 0 i2=i1+1 < (nx-1) j1=long(iy2-0.5) > 0 j2=j1+1 < (ny-1) z1=image(i1,j1) z2=image(i2,j1) z3=image(i2,j2) z4=image(i1,j2) t=ix2-0.5-float(i1) u=iy2-0.5-float(j1) zz=(1-t)*(1-u)*z1+t*(1-u)*z2+t*u*z3+(1-t)*u*z4 ;bilinear interpol. rsun(ind,iy)=float(zz) endif endfor return,rsun end ####################################################### PRO HELIOTRANS,X0,Y0,CROTA2,POS,BLAT,BLONG,IX,IY,IR,HLONG,HLAT ;transforms spherical coordinates [IX-X0,IY-Y0,IR] into cartesian coordinates ;[HLONG,HLAT] of heliografic longitude/latitude. ; ;X0, Y0 are pixel coords of disk center ;POS is position angle to rotate, CROTA2 is rotation angle of image: both zero ;BLAT,BLONG is heliografic longitude and latitude of disk center. ;IX, IY are coords to be rotated: one may be an array (pixels) ;IR is solar radius in units of pixels: height of rotating surface ;HLONG, HLAT are helio lat and long - the output PI =ACOS(-1.) &DPOS =POS+CROTA2 X =FLOAT(IX-X0) &Y =FLOAT(IY-Y0) POSRAD =-DPOS*PI/180. &BLATRAD=BLAT*PI/180. SINPOS =SIN(POSRAD) &COSPOS =COS(POSRAD) SINBLAT =SIN(BLATRAD) &COSBLAT=COS(BLATRAD) RXY =SQRT(X^2+Y^2) RR =FLOAT(IR) > RXY Z2 =RR^2-Y^2-X^2 ;z-coordinate squared Z =SQRT(Z2 > 0) ;z-coordinate XX =X*COSPOS-Y*SINPOS ;rotation position angle Y1 =X*SINPOS+Y*COSPOS YY =Z*SINBLAT+Y1*COSBLAT ;rotation by BLAT V2 =(RR^2-YY^2) V =SQRT(V2 > 0) ;radius proj in equator-plane SINPHI =IX*0.+1. ind =where(v gt 0) SINPHI(ind)=(XX(ind)/V(ind)) ;longitude difference from center SINPHI =SINPHI > (IX*0.-1.) SINPHI =SINPHI < (IX*0.+1.) DLON =XX*0. ind =where(sinphi ne 0) DLON(ind)=(180./PI)*ASIN(SINPHI(ind)) ;longitude difference in degree HLONG =BLONG+DLON ;heliographic longitude SINLAT =(YY/RR) HLAT =(180./PI)*ASIN(SINLAT) ;heliographic latitude END ; ******************************************* PRO HELIOTRANS2,X0,Y0,CROTA2,POS,BLAT,BLONG,HLONG,HLAT,IR,IX,IY ;transforms cartesian coordinates [HLONG,HLAT] of heliografic ;longitude/latitude into spherical coordinates [X,Y,R]=[IX-X0,IY-Y0,IR] ;POS is position angle, CROTA2 = rotation angle of image ;BLAT,BLONG is heliografic longitude and latitude of disk center. PI =ACOS(-1.) &EPS =1.E-8 DPOS =POS+CROTA2 &DLON =HLONG-BLONG POSRAD =+DPOS*PI/180. &BLATRAD=+BLAT*PI/180. SINPOS =SIN(POSRAD) &COSPOS =COS(POSRAD) SINBLAT =SIN(BLATRAD) &COSBLAT=COS(BLATRAD) SINPHI =SIN(DLON*PI/180.) &SINLAT =SIN(HLAT*PI/180.) Y1 =IR*SINLAT ;HLONG-SIN equatorial coord X1 =SQRT(IR^2-Y1^2)*SINPHI ;HLAT-SIN equatorial coord. Z1 =SQRT(IR^2-Y1^2-X1^2 > EPS);z-coordinate X2 =X1 ;x-coordinate Y2 =-Z1*SINBLAT+Y1*COSBLAT ;disk center at BLAT,BLONG X3 =X2*COSPOS-Y2*SINPOS ;position angle rotation Y3 =X2*SINPOS+Y2*COSPOS ;position angle rotation IX =X3+X0 ;RA-SIN with image center at X0 IY =Y3+Y0 ;DEC-SIN with image center at Y0 END ; ******************************************* function sunrotas, data, from_time, to_time, Radius dim = size(data) x0_ = (dim[1]-1)*0.5 y0_ = (dim[2]-1)*0.5 r0 = float(Radius) rb0p = get_rb0p(from_time) b0 = rb0p[1]*!radeg p0 = 0. rdeg = (anytim(to_time) - anytim(from_time))/3600. rsun = float(data) image = rsun zmin = min(rsun) nx = dim[1] ny = dim[2] l0=rdeg*360.0/27.2753/24.0 x0 =x0_-1. ;IDL convention y0 =y0_-1. ;IDL convention ir =r0 ;solar radius in units of EW pixels ix =findgen(nx) for iy=0,ny-1 do begin yy =iy xx =ix ind =where((xx-x0)^2+(yy-y0)^2 lt (ir^2), count) if count gt 0 then begin x = xx[ind] heliotrans, x0, y0, 0., p0, b0, 0., x, yy, ir, hlong, hlat ; diffrot=(2.7*(sin(hlat*!pi/180.))^2)*rdeg/24. diffrot = 0 hlong = hlong + diffrot ;differential rotation + rotation heliotrans2, x0, y0, 0., 0., b0, l0, hlong, hlat, ir, ix2, iy2 i1=long(ix2-0.5) > 0 i2=i1+1 < (nx-1) j1=long(iy2-0.5) > 0 j2=j1+1 < (ny-1) z1=image[i1,j1] z2=image[i2,j1] z3=image[i2,j2] z4=image[i1,j2] t=ix2-0.5-float(i1) u=iy2-0.5-float(j1) zz=(1-t)*(1-u)*z1+t*(1-u)*z2+t*u*z3+(1-t)*u*z4 ;bilinear interpol. rsun[ind,iy]=float(zz) endif endfor return,rsun end ####################################################### function sunrotate,sun,x0_,y0_,r0,b0,p0,rdeg dim=size(sun) rsun=float(sun) image=rsun zmin=min(rsun) nx=dim(1) ny=dim(2) l0=rdeg*360.0/27.2753/24.0 x0 =x0_-1. ;IDL convention y0 =y0_-1. ;IDL convention ir =r0 ;solar radius in units of EW pixels pi =acos(-1.) ix =findgen(nx) for iy=0,ny-1 do begin ; if (long(iy/50) eq float(iy)/50.) then PRINT,'processing line =',iy yy =iy xx =ix ind =where((xx-x0)^2+(yy-y0)^2 lt (ir^2)) if (ind(0) ne -1) then begin x =xx(ind) heliotrans,x0,y0,0.0,p0,b0,0.0,x,yy,ir,hlong,hlat diffrot=l0*(3.0/13.45)*(sin(hlat*pi/180.)) ; diffrot=(13.39-2.7*(sin(hlat*pi/180.))^2)*rdeg/24. hlong =hlong+diffrot ;differential rotation + rotation heliotrans2,x0,y0,0.0,0.0,b0,l0,hlong,hlat,ir,ix2,iy2 i1=long(ix2-0.5) > 0 &i2=i1+1 < (nx-1) j1=long(iy2-0.5) > 0 &j2=j1+1 < (ny-1) z1=image(i1,j1) &z2=image(i2,j1) z3=image(i2,j2) &z4=image(i1,j2) t =ix2-0.5-float(i1) &u=iy2-0.5-float(j1) zz=(1-t)*(1-u)*z1+t*(1-u)*z2+t*u*z3+(1-t)*u*z4 ;bilinear interpol. rsun(ind,iy)=float(zz) endif endfor return,rsun end ####################################################### function sunrot_a, sun, date0, time0, date1, time1, Limb x0_ = float(Limb(0)) y0_ = float(Limb(1)) r0 = float(Limb(2)) suneph, date0, time0, ss b0 = ss.b0*!radeg p0 = 0. rdeg = float(time_difference(date0, time0, date1, time1)/3600.) dim=size(sun) rsun=float(sun) image=rsun zmin=min(rsun) nx=dim(1) ny=dim(2) l0=rdeg*360.0/27.2753/24.0 x0 =x0_-1. ;IDL convention y0 =y0_-1. ;IDL convention ir =r0 ;solar radius in units of EW pixels ix =findgen(nx) for iy=0,ny-1 do begin ; if (long(iy/50) eq float(iy)/50.) then PRINT,'processing line =',iy yy =iy xx =ix ind =where((xx-x0)^2+(yy-y0)^2 lt (ir^2)) if (ind(0) ne -1) then begin x =xx(ind) heliotrans, x0, y0, 0., p0, b0, 0., x, yy, ir, hlong, hlat ; diffrot=(2.7*(sin(hlat*!pi/180.))^2)*rdeg/24. diffrot=-(2.7*abs(sin(hlat*!pi/180.)))*rdeg/24.*0. hlong = hlong + diffrot ;differential rotation + rotation heliotrans2, x0, y0, 0., 0., b0, l0, hlong, hlat, ir, ix2, iy2 i1=long(ix2-0.5) > 0 i2=i1+1 < (nx-1) j1=long(iy2-0.5) > 0 j2=j1+1 < (ny-1) z1=image(i1,j1) z2=image(i2,j1) z3=image(i2,j2) z4=image(i1,j2) t=ix2-0.5-float(i1) u=iy2-0.5-float(j1) zz=(1-t)*(1-u)*z1+t*(1-u)*z2+t*u*z3+(1-t)*u*z4 ;bilinear interpol. rsun(ind,iy)=float(zz) endif endfor return,rsun end ####################################################### function sunrot_a, sun, date0, time0, date1, time1, Limb x0_ = float(Limb(0)) y0_ = float(Limb(1)) r0 = float(Limb(2)) suneph, date0, time0, ss b0 = ss.b0*!radeg p0 = 0. rdeg = float(time_difference(date0, time0, date1, time1)/3600.) dim=size(sun) rsun=float(sun) image=rsun zmin=min(rsun) nx=dim(1) ny=dim(2) l0=rdeg*360.0/27.2753/24.0 x0 =x0_-1. ;IDL convention y0 =y0_-1. ;IDL convention ir =r0 ;solar radius in units of EW pixels ix =findgen(nx) for iy=0,ny-1 do begin ; if (long(iy/50) eq float(iy)/50.) then PRINT,'processing line =',iy yy =iy xx =ix ind =where((xx-x0)^2+(yy-y0)^2 lt (ir^2)) if (ind(0) ne -1) then begin x =xx(ind) heliotrans, x0, y0, 0., p0, b0, 0., x, yy, ir, hlong, hlat ; diffrot=(2.7*(sin(hlat*!pi/180.))^2)*rdeg/24. diffrot=-(2.7*abs(sin(hlat*!pi/180.)))*rdeg/24.*0. hlong = hlong + diffrot ;differential rotation + rotation heliotrans2, x0, y0, 0., 0., b0, l0, hlong, hlat, ir, ix2, iy2 i1=long(ix2-0.5) > 0 i2=i1+1 < (nx-1) j1=long(iy2-0.5) > 0 j2=j1+1 < (ny-1) z1=image(i1,j1) z2=image(i2,j1) z3=image(i2,j2) z4=image(i1,j2) t=ix2-0.5-float(i1) u=iy2-0.5-float(j1) zz=(1-t)*(1-u)*z1+t*(1-u)*z2+t*u*z3+(1-t)*u*z4 ;bilinear interpol. rsun(ind,iy)=float(zz) endif endfor return,rsun end ####################################################### path = 'F:\data\2000-11-23\eit\' eit_files = findfile(path + 'efz*') eit_files = eit_files[sort(eit_files)] N = n_elements(eit_files) eit_files = eit_files[0:5 < (N-1)] data0 = readfits(eit_files[0], header0) reference_time = sxpar(header0, 'date_obs') pix0 = 2.4555 exptime0 = sxpar(header0, 'exptime') eit = fltarr(1024, 1024, N) for j=0, N-1 do begin eit_prep, eit_files[j], outheader, image, /fill rb0p = get_rb0p(sxpar(outheader, 'date_obs')) eit0 = rot(float(image)/sxpar(outheader, 'exptime')*exptime0, $ sxpar(outheader, 'sc_roll'), rb0p[0]/pix0/sxpar(outheader, 'solar_r'), $ sxpar(outheader, 'crpix1'), sxpar(outheader, 'crpix2'), $ /int, miss = 0) eit[*,*,j] = sunrotas(eit0, sxpar(outheader, 'date_obs'), reference_time, rb0p[0]/pix0) endfor end ####################################################### function swap_array, array Sz=size(array) N=Sz(1) CASE Sz(0) OF 2: begin ft1=make_array(size=size(array)) ft1(0:Sz[1]/2-1, 0:Sz[2]/2-1)=array(Sz[1]/2:*, Sz[2]/2:*) ft1(0:Sz[1]/2-1, Sz[2]/2:*)=array(Sz[1]/2:*, 0:Sz[2]/2-1) ft1(Sz[1]/2:*, 0:Sz[2]/2-1)=array(0:Sz[1]/2-1, Sz[2]/2:*) ft1(Sz[1]/2:*, Sz[2]/2:*)=array(0:Sz[1]/2-1, 0:Sz[2]/2-1) end 1: begin ft1=make_array(size=size(array)) ft1(0:N/2-1)=array(N/2:*) ft1(N/2:*)=array(0:N/2-1) end ENDCASE return, ft1 end ####################################################### function swap_array, array Sz=size(array) N=Sz(1) CASE Sz(0) OF 2: begin ft1=make_array(size=size(array)) ft1(0:N/2-1, 0:N/2-1)=array(N/2:*, N/2:*) ft1(0:N/2-1, N/2:*)=array(N/2:*, 0:N/2-1) ft1(N/2:*, 0:N/2-1)=array(0:N/2-1, N/2:*) ft1(N/2:*, N/2:*)=array(0:N/2-1, 0:N/2-1) end 1: begin ft1=make_array(size=size(array)) ft1(0:N/2-1)=array(N/2:*) ft1(N/2:*)=array(0:N/2-1) end ENDCASE return, ft1 end ####################################################### function sxt_compose, index_pfi, pfi, sat_pfi, index, total = total expdur = gt_expdur(index_pfi(index)) expdur = max(expdur)/float(expdur) nonsat = pfi(*,*,index)*(1.-sat_pfi(*,*,index)) for j = 0, n_elements(expdur)-1 do nonsat(*,*,j) = nonsat(*,*,j)*expdur(j) if not keyword_set(total) then return, max3(nonsat) else $ return, total(nonsat, 3)/n_elements(expdur) end ####################################################### function s_align,iew,Date,time_sec,Receiver,Dt,Dir, $ fast=fast,single=single,interpolate=interpolate, $ start_time=start_time,SUN=SUN,Channel=Channel, $ polarization=polarization,Current_Channel=Current_Channel, $ Order=Order, log_only=log_only, shift_bounds=shift_bounds if n_elements(Channel) le 0 then amax=max(iew(*,0),Channel) D=4.9D0 & C=2.997925D8 & Fi=51.7575D0*!DPi/180 Sum_chan=[176,192] WIDGET_CONTROL,/HOUR N=Sum_chan(Receiver) N_scans=(size(iew))(2) if n_elements(start_time) le 0 then $ start_time=time_sec(0)+Dt*(N_scans-1)/2. suneph,Date,smh(time_sec(0)+Dt*(N_scans-1)/2.,ms=3),SUN SUNs=SUN type=size(start_time) type=type(n_elements(type)-2) if type eq 7 then $ reference_time=start_time else reference_time=smh(start_time,ms=3) suneph,Date,reference_time,SUNs INT_ORD,dir,Receiver,SUN,P,Nord,Ord0,Chan INT_ORD,dir,Receiver,SUNs,Ps,Nords,Ords,Chans Ord=ORD_RECOGNIZE(Channel,Nords,Ords,Chans) ;print,Ord Pstart=acos(Ord*C/(chanfreq(Channel,Receiver)*D) > (-1) < 1) P_cur=(Pstart-Ps(1))+P(1) Chan_cur=p_to_chan(P_cur, Dir,Receiver, SUN=SUN, Orde=Ord) Chan_cur_save=Chan_cur Chan_min=min(abs(Chan_cur-Sum_chan(Receiver)/2), imin) Chan_cur=Chan_cur(imin) Ord_cur=Ord(where(Chan_cur eq Chan_cur_save)) if n_elements(Ord_cur) eq 1 then Ord_cur=Ord_cur(0) Chan_ref=Chan(*,where(Ord_cur eq Ord0)) C_shift_start=Chan_cur-Channel Order=Ord_cur Current_channel=Chan_cur factor=(Chan_ref(2)-Chan_ref(0))/(Chans(2,0)-Chans(0,0)) factor=float(1.+factor)/2. ;factor=1. Fmin_max=chanfreq([1,([180,192])(Receiver)],Receiver) Df0=Fmin_max(1)-Fmin_max(0) F0=(Fmin_max(1)+Fmin_max(0))/2. C_shift0=F0/(Df0/(N-1))*SUN.W0 CASE dir OF 0: C_shift=C_shift0/tan(SUN.H)* $ (dindgen(N_scans)-0.5*(N_scans-1))*dt-C_shift_start 1: C_shift=-C_shift0*sin(SUN.H)/(cos(SUN.H)-tan(SUN.Decl)/tan(Fi))* $ (dindgen(N_scans)-0.5*(N_scans-1))*dt-C_shift_start ELSE: message,'Incorrect input of the interferometer' ENDCASE shift_bounds=[min(C_shift),max(C_shift)] CASE 1 OF keyword_set(log_only): return,0 keyword_set(fast): begin scan=iew for i=0,N_scans-1 do scan(*,i)=shift(scan(*,i), c_shift(i)) end keyword_set(interpolate): begin scan=iew if keyword_set(polarization) then amin=0 else amin=-32000 Argument=float(findgen(N+2)*factor+(N+1)*(1-factor)/2.)+(Channel-(N+1)/2.)*(1-factor) for i=0,N_scans-1 do begin scan(*,i)=(interpolate([amin,scan(*,i),amin], $ Argument-c_shift(i)))(1:N) ind=c_shift(i)*(c_shift(i) ge 0)+(N-1+rough(c_shift(i)))*(c_shift(i) lt 0) scan([ind,ind+1]<(N-1),i)=amin ;if c_shift ge 0 then scan(c_shift(i),i)=amin else scan(N-1+c_shift(i),i)=amin endfor end keyword_set(single): begin s=10 shift_min=min(c_shift,max=shift_max) scan=fltarr((N-1+abs(shift_min-1)+(shift_max+1))*s+1) number=intarr((N-1+abs(shift_min-1)+(shift_max+1))*s+1) register=findgen((N-1+abs(shift_min-1)+(shift_max+1))*s+1) register0=findgen(N) for j=0,n_scans-1 do begin channels=float((C_shift(j)-shift_min)*s)+register i=long(channels(register0*s)+0.5) scan(i)=scan(i)+iew(*,j) number(i)=number(i)+1 endfor index=where(number ne 0) scan(index)=scan(index)/number(index) end ELSE: ENDCASE return,scan end ####################################################### pro teem_rel, Te, dTe, valid, arg1, arg2, level=level, validlev=validlev, $ qtest=qtest, image = img, show = show, zero = zero ;+ ; NAME: ; tv_teem ; PURPOSE: ; Plot the results from sxt_teem ; CALLING SEQUENCE: ; tv_teem,te[,dte,valid] ; tv_teem,EM[,dEM,valid] ; tv_teem,te,em,dte,dem,valid ; More than 3 arguments ; OPTIONAL INPUT PARAMETER: ; level = Cutoff value of dTe for plotting Te ; MODIFICATION HISTORY: ; 1-mar-93, J. R. Lemen, LPARL (adapted from J. McTiernan's t664_screen) ;- nparams = n_params() ; Get the number of parameters max_level = !d.n_colors - 1 ; Get the number of colors for the display ieq0 = where(Te le 0.,neq0) ; Get the invalid cases ine0 = where(Te gt 0.,nne0) ; Valid cases if nne0 gt 0 then min_img = min(Te(ine0))*(1-keyword_set(zero)) else min_img = 0 img = Te if neq0 gt 0 then img(ieq0) = min_img sz = size(Te) n_x = sz(1) n_y = sz(2) bin = !d.y_size / n_y if nparams gt 1 then begin if n_elements(level) eq 0 then level = .7 kk = where(dte gt level,nkk) if nkk gt 0 then img(kk) = min_img endif if not keyword_set(show) then return erase tv, rebin(bytscl(img, top = max_level), bin*n_x, bin*n_y, /sample) ; Add on the titles/scale if possible: if bin*n_x lt !d.x_size then begin bar = transpose(bytscl(indgen(bin*n_y))) bar = rebin(bar, 16,bin*n_y,/sample) tv,bar,n_x*bin,0 ; Now label 16-2 levels ymin = min(img) & ymax = max(img) & dy = (ymax-ymin) / (16.-1) x0 = n_x * bin + n_elements(bar(*,0)) + 8 for i=1,14 do xyouts,x0,(i/15.)*bin*n_y, $ string(ymin+i*dy,format='(f5.2)'),charsize=1.26,/dev endif if keyword_set(qtest) then stop ;*** end ####################################################### FUNCTION TP_SMH, Time hour = long(Time)/3600 minute = long(Time-3600*hour)/60 sec = Time mod 60 sec_int=double(fix(sec)) msec=(sec-sec_int)*1d3 hour=hour mod 24 return, strmid(string(transpose([[hour], [minute], [sec_int], [msec]]), format = "(I2.2,':',I2.2,':',I2.2,'.', I3.3)"), 0, 8) END pro timeplot, time, data, nsum=nsum, psym=psym, symsize=symsize, $ xstyle=xstyle, ystyle=ystyle, millisec=millisec, $ diagnostic=diagnostic,color=color, xticklen=xticklen, subtitle=subtitle, $ yticklen=yticklen, xmargin=xmargin, ymargin=ymargin, title=title, $ xtitle=xtitle, ytitle=ytitle, xthick=xthick, ythick=ythick, $ noerase=noerase, background=background, $ charsize=charsize, position=position, xticks=xticks, yticks=yticks, $ xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, $ xtickv=xtickv, ytickv=ytickv, xeminor=xminor, yminor=yminor, ynozero = ynozero, $ xrange = xrange, yrange = yrange, ytype = ytype, linestyle = linestyle, $ max = max, min = min if N_params() LT 2 then begin print,'timeplot, time, data, nsum=nsum, psym=psym, simsize=symsize' print,'xstyle=xstyle, ystyle=ystyle, millisec=millisec' print,'diagnostic=diagnostic,color=color, xticklen=xticklen, subtitle=subtitle' print,'yticklen=yticklen, xmargin=xmargin, ymargin=ymargin, title=title' print,'xtitle=xtitle, ytitle=ytitle, xthick=xthick, ythick=ythick' print,'noerase=noerase, background=background' print,'charsize=charsize, position=position, xticks=xticks, yticks=yticks' print,'xtickformat=xtickformat, ytickformat=ytickformat' print,'xtickname=xtickname, ytickname=ytickname' print,'xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor, ynozero = ynozero' print,'xrange = xrange, yrange = yrange, ytype = ytype' return endif if n_elements(ytype) le 0 then ytype=!y.type if n_elements(nsum) le 0 then nsum=1 if n_elements(psym) le 0 then psym=!p.psym if n_elements(symsize) le 0 then symsize=!p.symsize if n_elements(xstyle) le 0 then xstyle=!x.style if n_elements(ystyle) le 0 then ystyle=!y.style if n_elements(color) le 0 then color=!P.color if n_elements(xticklen) le 0 then xticklen=!x.ticklen if n_elements(yticklen) le 0 then yticklen=!y.ticklen if n_elements(xmargin) le 0 then xmargin=!x.margin if n_elements(ymargin) le 0 then ymargin=!y.margin if n_elements(ytitle) le 0 then ytitle=!y.title if n_elements(xtitle) le 0 then xtitle=!x.title if n_elements(title) le 0 then title=!p.title if n_elements(xthick) le 0 then xthick=!x.thick if n_elements(ythick) le 0 then ythick=!y.thick if n_elements(noerase) le 0 then noerase=!p.noerase if n_elements(background) le 0 then background=!p.background if n_elements(charsize) le 0 then charsize=!P.charsize if n_elements(xticks) le 0 then xticks=!x.ticks if n_elements(yticks) le 0 then yticks=!y.ticks if n_elements(xtickv) le 0 then xtickv=!x.tickv if n_elements(ytickv) le 0 then ytickv=!y.tickv if n_elements(xtickformat) le 0 then xtickformat=!x.tickformat if n_elements(ytickformat) le 0 then ytickformat=!y.tickformat ;if n_elements(xtickname) le 0 then xtickname=!x.tickname if n_elements(ytickname) le 0 then ytickname=!y.tickname if n_elements(xminor) le 0 then xminor=!x.minor if n_elements(yminor) le 0 then yminor=!y.minor if n_elements(ynozero) le 0 then ynozero=0 if n_elements(yrange) le 0 then yrange=!y.range if n_elements(xrange) le 0 then xrange=!x.range if n_elements(xrange) le 0 then linestyle = !p.linestyle if n_tags(time) gt 0 then begin names = tag_names(time) if (where(names eq 'TIME'))(0) ge 0 then begin t=time.time day = time(0).day endif if (where(names eq 'GEN'))(0) ge 0 then begin t=time.gen.time day = time(0).gen.day endif if !version.release ge 5 then jul = julday( 1, 1, 1979, 23,55,0)+day+0.5 $ else jul = julday( 1, 1, 1979)+day+0.5 date = '!C'+caldatg(jul) endif else begin t = time date ='' endelse if n_elements(subtitle) le 0 then subtitle=date tmax = max(t, min = tmin) if tmax gt 2e6 and tmax lt 1e8 then t = t/1000d0 t=t-(long(t(0)/86400)*86400d0) ;if not keyword_set(universal) then t=t-24d0*3600*(t gt 12d0*3600) ;t=t-24d0*3600*(t gt 12d0*3600) ;-------------------- ; net universalnosti -obichnii sluchai if t[0] ge t[n_elements(t)-1] then universal=1 else universal=0 ;print, universal if universal eq 1 then t=t-24d0*3600*(t gt 12d0*3600) tmin=min(t) tmax=max(t) xran=xrange if abs(xrange[0]) + abs(xrange[1]) ne 0 then begin if universal eq 0 then xran=xran-24d0*3600*(xran gt 12d0*3600) ; if not keyword_set(universal) then xran=xran-24d0*3600*(xran gt 12d0*3600) tmin=min(xran) tmax=max(xran) endif tmin0=tmin tmax0=tmax if xstyle eq 1 then begin ;tmin0=time(0) ;tmax0=time(n_elements(time)-1) ; tmin0=t(0) ; tmax0=t(n_elements(time)-1) endif drange=tmax-tmin if keyword_set(diagnostic) then print,'tmin0=',smh(tmin, ms = 3),' tmax0=',smh(tmax, ms = 3),' drange0=',drange a2: hour=long(Tmin)/3600 minute=long(tmin-3600*hour)/60 sec=tmin mod 60 hour1=long(Tmax)/3600 minute1=long(tmax-3600*hour1)/60 sec1=tmax mod 60 if tmin lt 0 then begin ; tmin - negative time case 1 of drange ge 60:begin ;shift of boundaries case 1 of minute gt -15 : tmin=hour*3600 minute le -15 and minute gt -30 : tmin=hour*3600-30*60 minute lt -30 and minute gt -45 : tmin=hour*3600-30*60 minute le -45 and minute gt -60 : tmin=hour*3600-60*60 else: endcase end drange lt 60 :begin ;shift of boundaries case 1 of sec lt 0 and sec gt -15 : tmin=hour*3600+minute*60 sec le -15 and sec gt -30 : tmin=hour*3600+minute*60-30 sec lt -30 and sec gt -45 : tmin=hour*3600+minute*60-30 sec le -45 and sec gt -60 : tmin=hour*3600+minute*60-60 else: endcase end else: endcase hour=long(Tmin)/3600 minute=long(tmin-3600*hour)/60 sec=tmin mod 60 drange=tmax-tmin if keyword_set(diagnostic) then print,'new ',smh(tmin, ms = 3),' ',smh(tmax, ms = 3),' ',DRANGE endif ;calculated drange with new value case 1 of drange ge 60 and drange le 3600:begin case 1 of sec gt 0 and sec lt 15 : tmin=hour*3600+minute*60 sec ge 15 and sec lt 30 : tmin=hour*3600+minute*60+30 sec gt 30 and sec lt 45 : tmin=hour*3600+minute*60+30 sec ge 45 and sec lt 60 : tmin=hour*3600+minute*60+60 else: endcase case 1 of sec1 gt 0 and sec lt 15 : tmax=hour1*3600+minute1*60 (sec1 ge 15) and (sec1 lt 30) : tmax=hour1*3600+minute1*60+30 (sec1 gt 30) and (sec1 lt 45) : tmax=hour1*3600+minute1*60+30 (sec1 ge 45) and (sec1 lt 60) : tmax=hour1*3600+minute1*60+60 else: endcase end drange ge 3600:begin ;shift of boundaries case 1 of minute ge 0 and minute lt 15 : tmin=hour*3600 minute ge 15 and minute lt 30 : tmin=hour*3600+30*60 minute gt 30 and minute lt 45 : tmin=hour*3600+30*60 minute ge 45 and minute lt 60 : tmin=hour*3600+60*60 else: endcase case 1 of minute1 ge 0 and minute1 lt 15 : tmax=hour1*3600 (minute1 ge 15) and (minute1 lt 30) : tmax=hour1*3600+30*60 (minute1 gt 30) and (minute1 lt 45) : tmax=hour1*3600+30*60 (minute1 ge 45) and (minute1 lt 60) : tmax=hour1*3600+60*60 else: endcase end drange le (-3600):begin ;shift of boundaries case 1 of minute le 0 and minute gt -15 : tmin=hour*3600 minute le -15 and minute gt -30 : tmin=hour*3600-30*60 minute lt -30 and minute gt -45 : tmin=hour*3600-30*60 minute le -45 and minute gt -60 : tmin=hour*3600-60*60 else: tmin=tmin endcase case 1 of minute1 le 0 and minute1 gt -15 : tmax=hour1*3600 (minute1 le -15) and (minute1 gt -30) : tmax=hour1*3600-30*60 (minute1 lt -30) and (minute1 gt -45) : tmax=hour1*3600-30*60 (minute1 le -45) and (minute1 gt -60) : tmax=hour1*3600-60*60 else: tmax=tmax endcase end drange le (-60) and drange ge (-3600):begin ;shift of boundaries case 1 of sec lt 0 and sec gt -15 : tmin=hour*3600+minute*60 sec le -15 and sec gt -30 : tmin=hour*3600+minute*60-30 sec lt -30 and sec gt -45 : tmin=hour*3600+minute*60-30 sec le -45 and sec gt -60 : tmin=hour*3600+minute*60-60 else: endcase case 1 of (sec1 lt 0) and (sec1 gt -15) : tmax=hour1*3600+minute1*60 (sec1 le -15) and (sec1 gt -30) : tmax=hour1*3600+minute1*60-30 (sec1 lt -30) and (sec1 gt -45) : tmax=hour1*3600+minute1*60-30 (sec1 le -45) and (sec1 gt -60) : tmax=hour1*3600+minute1*60-60 else: endcase end else:begin tmin=tmin tmax=tmax end endcase ;=== a3: ;sdelali sdvig drange=tmax-tmin tick_units=1.d0 * [10^findgen(5)*1.0d-3,10^findgen(4)*.002,10^findgen(4)*.005,$ 20.,30.,60.,60.*[2,4,5,6,10,15,20,30,60],3600.*[2.+findgen(5),8.,10.,12.],$ 86400.*[findgen(6)+1.,10.,20.,30.,60.]] minor_units=1.d0 * [.0001,.0002,.001,.002,.01,.02, .1, .2, 1.0, 2.0, 5.0, 10., 20., 60.,$ 120.,300.,600.,3600.,7200.,14400.,3600.*[6.,12.],$ 86400.*[1.,2.,5.,10.]] w_ok=where( (drange/tick_units lt 7) and (drange/tick_units ge 2),n_ok) nn_ok=min(w_ok) tick_unit = tick_units(nn_ok) m_ok =ceil(max( abs(drange/tick_units(w_ok)))) ;number of intervals xrn=tmin int=min(tick_units(w_ok)) ; number of seconds within one interval xrk=xrn+m_ok*int if keyword_set(diagnostic) then begin print,'final ',smh(tmin, ms = 3),' ',smh(tmax, ms = 3),' ',DRANGE print,'n_inter=',m_ok,'*',min(tick_units(w_ok)),' = ',m_ok*min(tick_units(w_ok)) print,'calc ',smh(xrn, ms = 3)," ", smh(xrk, ms = 3) endif ;tmax0 is outside of the calculated boundary if xrk lt tmax0 then begin ;--------- ;shift of boundaries case 1 of drange ge 60 and drange le 3600: case 1 of sec1 ge 0 and sec1 lt 30 : tmax=hour1*3600+minute1*60+30 sec1 ge 30 and sec1 lt 60 : tmax=hour1*3600+minute1*60+60 else: endcase drange gt 3600: case 1 of minute1 ge 0 and minute1 lt 30 : tmax=hour1*3600+30*60 minute1 ge 30 and minute1 lt 60 : tmax=hour1*3600+60*60 else: endcase else: endcase if keyword_set(diagnostic) then print,' tmax0 > right calculate limit, make new iteration' goto,a3 endif if keyword_set(xminor) then goto,a1 wminors=where(tick_unit mod minor_units lt 1.e-5*tick_unit, count) if count eq 0 then xminor = 0 else begin nminors=tick_unit/minor_units(wminors) index = WHERE (nminors lt 15,count) ;Use Count to get the number of nonzero elements. if count eq 0 then begin xminor=min(index) goto,a1 endif index = WHERE (nminors lt 12,count) if count eq 0 then xminor=min(nminors) if xticks le 4 then xminor=max(nminors[where (nminors lt 15)]) else xminor=max(nminors [where (nminors lt 12)]) endelse if (tick_unit eq 1) or (tick_unit eq 0.1) or (tick_unit eq 0.01) then xminor=10. a1: if keyword_set(diagnostic) then print,'minor= ',int/xminor ;chemu ravna cena deleniya xtickv=tmin+findgen(m_ok+1)*min(tick_units(w_ok)) ;Hide marginal tick marks ; if tmin0 gt xtickv[0] then xtickv=xtickv[1:*];!!! if tmax0 gt xtickv[n_elements(xtickv)-1] then xtickv=xtickv[0:(n_elements(xtickv)-2)] if keyword_set(xstyle) and xstyle eq 1 then begin if tmax0 lt xtickv[n_elements(xtickv)-1] then xtickv=xtickv[0:(n_elements(xtickv)-2)] endif xticks = n_elements(xtickv)-1 ;---------------------------------- IF not (keyword_set(xtickformat)) THEN BEGIN vxtickname = TP_SMH(xtickv+24.*(xtickv lt 0)*3600.) if (where(strmid(vxtickname, 6,2) ne '00'))[0] lt 0 then vxtickname = strmid(vxtickname, 0,5) ENDIF ELSE vxtickname = replicate('', n_elements(xtickv)) if n_elements(xtickname) gt 0 then begin no_ticks = where(xtickname[0:(n_elements(xtickname) < n_elements(vxtickname)-1)] eq ' ', count) if count ne 0 then vxtickname[no_ticks]=' ' endif ;--- if n_elements(position) le 0 then $ plot, t, data, nsum=nsum, subt = subtitle, $ xst=xstyle, yst=ystyle, psym=psym, symsize=symsize, $ noerase=noerase, nodata=nodata, color=color, xticklen=xticklen, $ yticklen=yticklen, xmargin=xmargin, ymargin=ymargin, title=title, $ xtitle=xtitle, ytitle=ytitle, xthick=xthick, $ charsize=charsize, xticks=xticks, yticks=yticks, ythick=ythick, $ ytickformat=ytickformat, xtickname=vxtickname, $ ytickname=ytickname, ynozero = ynozero, xrange = xran, $ yrange = yrange, ytype = ytype,$ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor, $ linestyle = linestyle, xtickf = tickf, max = max, min = min else $ plot, t, data, nsum=nsum, subt = subtitle, $ xst=xstyle, yst=ystyle, psym=psym, symsize=symsize, $ noerase=noerase, nodata=nodata, color=color, xticklen=xticklen, $ yticklen=yticklen, xmargin=xmargin, ymargin=ymargin, title=title, $ xtitle=xtitle, ytitle=ytitle, xthick=xthick, $ charsize=charsize, xticks=xticks, yticks=yticks, ythick=ythick, $ ytickformat=ytickformat, xtickname=vxtickname, $ ytickname=ytickname,position=position, ynozero = ynozero, $ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor, $ xrange = xran, yrange = yrange, ytype = ytype,xtickf = tickf, $ linestyle = linestyle, max = max, min = min end ####################################################### pro timeprof, Array, device=device, data=data, $ logarithmic=log, ynozero = ynozero ;+ ; NAME: ; TIMEPROF ; ; PURPOSE: ; Interactively plot profile of a 3-dimensional array along the ; third dimension through the pixel where the cursor is currently ; placed. The profile is displayed in a separate window. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; TIMEPROF, Array ; ; INPUTS: ; Array: The array to be analyzed. This array may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; DATA: If set and non-zero, DATA coordinate system is processed. ; ; DEVICE: If set and non-zero, DEVICE coordinate system is processed (by default). ; ; LOGARITHMIC: If set and non-zero, Y axis is of logarithmic type. ; ; YNOZERO: If set and non-zero, prevents setting the minimum Y axis value to zero. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; New window is created and used for the profile. When done, the new window ; is deleted. The X and Y of the pixel under the cursor are continuously displayed. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Press the right mouse button to exit the procedure. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, 1999. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ;- Sz=size(Array) orig_win=!d.window X_orig = !X Y_orig = !Y wset,orig_win tvcrs,Sz(1)/2,Sz(2)/2,/dev window,/free new_win=!d.window amax=max(Array, min=amin) if keyword_set(log) then begin if amax le 0 then amax = amax > 1 if amin le 0 then amin = amin > 1 endif old_font=!p.font !p.font = 0 vecx = findgen(Sz(3)) old_data=' ' while 1 do begin wset,orig_win ;Image window !X = X_orig !Y = Y_orig if keyword_set(data) then cursor,x,y,2,/data else $ cursor,x,y,2,/dev ;Read position first=1 wset,new_win plot,[0, Sz(3)-1],[amax, amin],/nodata,title='Time Profile', ytype= $ keyword_set(log), ynozero = keyword_set(ynozero), $ col = !d.table_size-1 prof=Array(x > 0 < (Sz(1)-1), y > 0 < (Sz(2)-1), *) if !err eq 4 then begin ;Quit wset,orig_win tvcrs,Sz(1)/2, Sz(2)/2,/dev ;curs to old window tvcrs,0 ;Invisible wdelete, new_win !p.font = old_font !X = X_orig !Y = Y_orig print,x,y return endif if first eq 0 then plots, vecx, prof, col=0 else first=0 plots, vecx, prof, $ col = !d.table_size-1 Yout = (Xout=3) aa = string(x > 0 < (Sz(1)-1), y > 0 < (Sz(2)-1), format = '(i6, i6)') xyouts, Xout, Yout, old_data, /dev, font=0, col=!p.background xyouts, Xout, Yout, aa, /dev, font=0, col = !d.table_size-1 old_data=aa endwhile end ####################################################### function No_ticks,axis,index,value return,'' end pro time_axis,x_arg,y_arg,z_arg,range=range,start_time=start_time,Dt=Dt, $ xticks=xticks,model=model,xstyle=xstyle,ystyle=ystyle,yrange=yrange, $ ynozero=ynozero,noclip=noclip,clip=clip,xrange=xrange, $ color=color,linestyle=linestyle,thick=thick,ztitle=ztitle, $ subtitle=subtitle,font=font,xmargin=xmargin,ymargin=ymargin, $ xminor=xminor,yminor=yminor, $ yticks=yticks,xtitle=xtitle,ytitle=ytitle, $ ytickv=ytickv,ytickn=ytickn, noerase=noerase, $ position=position, normal=normal, data=data, device=device, $ charsize=charsize,nodata=nodata, $ xticklen=xticklen, yticklen=yticklen, $ xaxis=xaxis,yaxis=yaxis,zaxis=zaxis,xtickname=xtickname common time,Tstart,Delta_t,Model_string if n_elements(start_time) le 0 then start_time=0.0d0 if n_elements(Dt) le 0 then Delta_t=1.0d0 else Delta_t=Dt if n_elements(model) le 0 then Model_string='hh:mm:ss.ms' else Model_string=model if n_elements(xticks) le 0 then xticks=4 if n_elements(range) le 0 then range=[0,n_elements(x)-1] if n_elements(xstyle) le 0 then xstyle=0 if n_elements(xticklen) le 0 then xticklen=0 if n_elements(ystyle) le 0 then ystyle=0 if n_elements(xrange) le 0 then xrange=!x.range if n_elements(yrange) le 0 then yrange=!y.range if n_elements(ynozero) le 0 then ynozero=0 if n_elements(linestyle) le 0 then linestyle=0 if n_elements(color) le 0 then color=!p.color if n_elements(noclip) le 0 then noclip=0 if n_elements(ztitle) le 0 then ztitle=' ' if n_elements(subtitle) le 0 then subtitle=' ' if n_elements(font) le 0 then font=-1 if n_elements(xminor) le 0 then xminor=0 if n_elements(yminor) le 0 then yminor=0 if n_elements(yticks) le 0 then yticks=0 if n_elements(xtitle) le 0 then xtitle='' if n_elements(ytitle) le 0 then ytitle='' if n_elements(ytickv) le 0 then ytickv=0 if n_elements(yticklen) le 0 then yticklen=0 if n_elements(ytickn) le 0 then ytickn='' if n_elements(normal) le 0 then normal=0 if n_elements(data) le 0 then data=1 if n_elements(device) le 0 then device=0 if n_elements(thick) le 0 then thick=1 if n_elements(clip) le 0 then clip=!P.clip if n_elements(charsize) le 0 then charsize=1 if n_elements(xmargin) le 0 then xmargin=[10,3] if n_elements(ymargin) le 0 then ymargin=[4,2] if n_elements(nodata) le 0 then nodata=0 Tstart=start_time+range(0)*Delta_t tick=AXIS_DIV(Range,xticks,Minor,/Time,Dt=Delta_t) Tshift=(60d0-((Tstart) mod 60 mod 60))/Delta_t xtickv=Tshift mod tick + dindgen(xticks+1)*tick if xtickv(xticks) gt n_elements(x) then begin xticks=xticks-1 xtickv=xtickv(0:xticks) endif if n_elements(xtickname) le 0 then begin Format_Function='ut_ticks' xtickname='' endif else Format_Function='No_ticks' Axis, x_arg,y_arg,z_arg,xtickname=xtickname, $ xaxis=xaxis,$;,yaxis=yaxis,zaxis=zaxis, $ xtickf=Format_Function, $ xtickv=xtickv, xticks=xticks,xminor=Minor, $ xstyle=xstyle,ystyle=ystyle,yrange=yrange,ynozero=ynozero, $ ztitle=ztitle,subtitle=subtitle,font=font,xrange=xrange, $ xmargin=xmargin,ymargin=ymargin,yminor=yminor, $ yticks=yticks,xtitle=xtitle,ytitle=ytitle, ytickv=ytickv, $ ytickn=ytickn,nodata=nodata, color=color, $ normal=normal, data=data, device=device, noerase=noerase, $ xticklen=xticklen, yticklen=yticklen, $ charsize=charsize;,position=position empty end ####################################################### function time_difference,date1,time1,date2,time2 ; Calculates temporal difference between two dates. t1=double(strmid(time1,0,2))+double(strmid(time1,3,2))/60+ $ double(strmid(time1,6,10))/3600 t2=double(strmid(time2,0,2))+double(strmid(time2,3,2))/60+ $ double(strmid(time2,6,10))/3600 d1=[strmid(date1,6,2),strmid(date1,3,2),strmid(date1,0,2),t1] d2=[strmid(date2,6,2),strmid(date2,3,2),strmid(date2,0,2),t2] d1(0,*) = d1(0,*)+2000*(d1(0,*) lt 50) d2(0,*) = d2(0,*)+2000*(d2(0,*) lt 50) juldate, d1, jd1 juldate, d2, jd2 return,(jd2-jd1)*24*3600 end ####################################################### function Time_Outvalue,val,time=time,Dt=Dt,space=space ; A sUpporting function for displaying time. if n_elements(Dt) le 0 then Dt=0.056D value=smh(time(0)+double(val)*Dt,/str,ms=3) a=' ' if n_elements(space) gt 0 then if space gt 0 then $ value=string(a,format='('+string(space)+'(" "),A12'+')')+value RETURN, value end ####################################################### function time_str_to_sec,x ;+ For input argument being time as a string ; returns time expressed in seconds ;- return,double(strmid(x,0,2))*3600d0+double(strmid(x,3,2))*60d0+double(strmid(x,6,10)) end ####################################################### function Time_Syn,time,str=str,sec=sec ; Converts binary-decimal code of time recorded in the AOR data ; files into a string or an amount of seconds. Shift=[-30,-26,-23,-19,-16,-12,-8,-4,0] Mask=[3,15,7,15,7,15,15,15,15] N=n_elements(time) T_out=make_array(N, type=(7-(n_elements(sec) gt 0)*2)) T_str=strarr(N) for i=0,N-1 do begin T=Ishft(Time(i),Shift) and Mask T_str(i)=string(T(*),format="(2(I1,I1,':'),2(I1),'.',3(I1))") endfor IF keyword_set(STR) or not keyword_set(SEC) THEN T_out= T_str $ ELSE T_out=HMS(strmid(T_str,0,2),strmid(T_str,3,2),strmid(T_str,6,6))*3600D if N eq 1 then T_out=T_out(0) RETURN,T_out end ####################################################### function total_flux, x, pixel_size = pixel_size, frequency = frequency ;+ ; NAME: ; TOTAL_FLUX ; ; PURPOSE: ; Returns vector of totals over each frame in 3-dimensional array. ; When both PIXEL_SIZE and FREQUENCY are specified, the output ; value is expressed in Solar Flux Units. ; ; CATEGORY: ; Image analysis. ; ; CALLING SEQUENCE: ; TF = TOTAL_FLUX(Array[, PIXEL_SIZE=PIXEL_SIZE, FREQUENCY=FREQUENCY]) ; ; INPUTS: ; Array: The array to be analyzed. This array may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; None ; ; KEYWORD PARAMETERS: ; PIXEL_SIZE: Size of pixels of the Array expressed in arc seconds. ; Pixels are intended to be square-shaped. ; FREQUENCY: Working frequency expressed in GHz. ; ; OUTPUTS: ; Total over two first dimensions. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; None. ; ; RESTRICTIONS: ; Both keyword parameters PIXEL_SIZE and FREQUENCY must be specified ; to cause output to be expressed in s.f.u. ; ; PROCEDURE: ; RESULT = total(total(Array, 1), 1) ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, 1999. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, 2000, Jan. ; Victor Grechnev (Grechnev@iszf.irk.ru) ; Keyword parameters FREQUENCY and PIXEL_SIZE added. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ;- k_B = 1.3804200e-23 ; Boltzmann's constant c = 2.9979250e+08 ; Speed of light tf = total(total(x, 1), 1) CASE 1 OF keyword_set(pixel_size) and keyword_set(frequency): begin lam = c/(frequency*1d9) ; Wavelength sfu=float(2*k_B/lam^2*(pixel_size/3600d0*!dtor)^2*1d22) tf = tf*sfu end (keyword_set(pixel_size) and not(keyword_set(frequency))) or $ (not(keyword_set(pixel_size)) and keyword_set(frequency)): $ begin print, 'Both Frequency and Pixel_size must be specified. ' print, 'Returning no-normalized total only.' end ELSE: ENDCASE return, tf end ####################################################### function trend, x, width if n_elements(width) le 0 then width=10 x1=median(x,width/2 > 2) y=x1 for j=0L, n_elements(x)-1 do $ y(j)=min(x1(j-width/2. > 0: j+width/2.-1 <(n_elements(x)-1))) return, smooth(y, width) end ####################################################### pro tvcon, Image, x_arg, y_arg, xstyle=xstyle, ystyle=ystyle, $ color=color, xticklen=xticklen, subtitle=subtitle, $ yticklen=yticklen, xmargin=xmargin, ymargin=ymargin, title=title, $ xtitle=xtitle, ytitle=ytitle, xthick=xthick, ythick=ythick, $ noerase=noerase, background=background, scale=scale, $ charsize=charsize, position=position, xticks=xticks, yticks=yticks, $ xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, $ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor, $ xrange = xrange, yrange = yrange, $ xgridstyle=xgridstyle,ygridstyle=ygridstyle, sample = sample, $ fit_window = fit_window, resize = resize ;+ ; NAME: ; TVCON ; ; PURPOSE: ; Displays an image in the brightness representation surrounded with coordinate axes to fit ; current graphics device (TV + CONgrid). Similar to the standard routine ; IMAGE_CONT, but without contours. Various keyword parameters added. ; ; CATEGORY: ; General graphics. ; ; CALLING SEQUENCE: ; TVCON, Image [, X_arg, Y_arg] ; ; INPUTS: ; Image: Array to be displayed. This array may be of any type. ; ; OPTIONAL INPUT PARAMETERS: ; X_arg: Argument along X axis. If supplied, then Y_arg must be supplied also. ; The dimensions of X_arg, Y_arg must correspond to the dimensions of the Image. ; Usage of these arguments is the same as for the CONTOUR routine. ; ; Y_arg: Argument along Y axis. If supplied, then X_arg must be supplied also. The ; dimensions of X_arg, Y_arg must correspond to the dimensions of the Image. ; ; KEYWORD PARAMETERS: ; Scale: If set and equal to zero, then the array Image is displayed as is, without scaling ; of brigthness (TV). Otherwise (by default), scaling is performed (TVSCL). ; ; Resize: Scalar integer or floating-point number specifying the number of pixels ; to resize the Image when output to PostScript is performed. By default, ; the Image is not resized if its least dimension exceed 500, otherwise ; its dimensions are resized in such a way that the least dimension becomes 500. ; This enhances the quality of the image in the printout. ; ; If many images are sent to the PostScript file, then its size can become huge ; when all of them are resized in such a way. To prevent this, set Resize to a ; less value. ; ; Fit_window: If set and nonzero, then the plotting region fits displayable area similar to ; setting xmargin = [0,0] and ymargin = [0,0] ; ; Standard keywords: background charsize color noerase position subtitle title [xy]margin ; [xy]minor [xy]style [xy]thick [xy]tickformat [xy]ticklen [xy]tickname ; [xy]ticks [xy]tickv [xy]title ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; The array is displayed on the current graphics device. ; ; RESTRICTIONS: ; If either of X_arg, Y_arg is supplied, then both of them must present. The dimensions of ; X_arg, Y_arg must correspond to the dimensions of the Image. ; ; The image always fits the displayable region of the graphics device, and the aspect ratio ; is not maintained. ; ; PROCEDURE: ; TV(SCL) + CONGRID are used. In case of PostScript device, pixels of the Image are ; scaled, instead of use the CONGRID routine. ; ; MODIFICATION HISTORY: ; ; ISTP SD RAS, 1999. ; Victor Grechnev (Grechnev@iszf.irk.ru): Initially written. ; ; ISTP SD RAS, 2000, Jan. ; Victor Grechnev (Grechnev@iszf.irk.ru) ; Keyword parameters FREQUENCY and PIXEL_SIZE added. ; ; ISTP SD RAS, Jul, 2002. ; Natalia Meshalkina (nata@iszf.irk.ru): Help added. ;- Sz=size(Image) if Sz(0) ne 2 then message, 'The argument must be 2-d array' if n_elements(xstyle) le 0 then xstyle=!x.style if n_elements(ystyle) le 0 then ystyle=!y.style if n_elements(color) le 0 then color=!P.color if n_elements(xticklen) le 0 then xticklen=!x.ticklen if n_elements(yticklen) le 0 then yticklen=!y.ticklen if n_elements(xmargin) le 0 then xmargin=!x.margin if n_elements(ymargin) le 0 then ymargin=!y.margin if n_elements(ytitle) le 0 then ytitle=!y.title if n_elements(xtitle) le 0 then xtitle=!x.title if n_elements(title) le 0 then title=!p.title if n_elements(subtitle) le 0 then subtitle=!p.subtitle if n_elements(xthick) le 0 then xthick=!x.thick if n_elements(ythick) le 0 then ythick=!y.thick if n_elements(noerase) le 0 then noerase=!p.noerase if n_elements(background) le 0 then background=!p.background if n_elements(scale) le 0 then scale=1 if n_elements(charsize) le 0 then charsize=!P.charsize if n_elements(xticks) le 0 then xticks=!x.ticks if n_elements(yticks) le 0 then yticks=!y.ticks if n_elements(xtickv) le 0 then xtickv=!x.tickv if n_elements(ytickv) le 0 then ytickv=!y.tickv if n_elements(xtickformat) le 0 then xtickformat=!x.tickformat if n_elements(ytickformat) le 0 then ytickformat=!y.tickformat if n_elements(xtickname) le 0 then xtickname=!x.tickname if n_elements(ytickname) le 0 then ytickname=!y.tickname if n_elements(xminor) le 0 then xminor=!x.minor if n_elements(yminor) le 0 then yminor=!y.minor if n_elements(xgridstyle) le 0 then xgridstyle=0 if n_elements(ygridstyle) le 0 then ygridstyle=0 if n_elements(xrange) le 0 then xrange=!x.range if n_elements(yrange) le 0 then yrange=!y.range if keyword_set(fit_window) then begin xmargin = [0,0] ymargin = [0,0] endif Pmsave=!P.multi N=Sz(1) > Sz(2) > 20 arguments=1 if n_elements(x_arg) le 0 then begin x_arg=findgen(N)/(N-1)*(Sz(1)-1) arguments=0 endif if n_elements(y_arg) le 0 then y_arg=findgen(N)/(N-1)*(Sz(2)-1) if n_elements(position) le 0 then $ plot, x_arg, y_arg, xst=5,yst=5,/nodata,xmargin=xmargin,ymargin=ymargin, $ noerase=noerase,charsize=charsize, xticks=xticks, yticks=yticks, $ xtickformat=xtickformat, ytickformat=ytickformat, $ background=background,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xrange = xrange, yrange = yrange, $ xtickname=xtickname, ytickname=ytickname else $ plot, x_arg, y_arg, xst=5,yst=5,/nodata,xmargin=xmargin,ymargin=ymargin, $ noerase=noerase,charsize=charsize, position=position, xticks=xticks, $ yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ background=background,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xrange = xrange, yrange = yrange, $ xtickname=xtickname, ytickname=ytickname Pmsave1=!P.multi !P.multi=Pmsave int = 1-(keyword_set(sample)) SzN = Sz(1:2) if max(SzN/500.) lt 1 or n_elements(resize) gt 0 then begin if n_elements(resize) le 0 then resize = 500. if SzN(0) gt SzN(1) then SzN = SzN*float(resize(0))/SzN(0) else SzN = SzN*float(resize(0))/SzN(1) endif if scale then begin if !d.name ne 'PS' then $ tvscl, congrid(Image, !d.x_size*(!x.window(1)-!x.window(0)), $ !d.y_size*(!y.window(1)-!y.window(0)), int=int, /minus),$ !d.x_size*!x.window(0),!d.y_size*!y.window(0) else $ tvscl, congrid(Image, SzN(0), SzN(1), int = int), $ xsize=!d.x_size*(!x.window(1)-!x.window(0)), $ ysize=!d.y_size*(!y.window(1)-!y.window(0)), $, !d.x_size*!x.window(0),!d.y_size*!y.window(0),/dev endif else begin if !d.name ne 'PS' then $ tv, congrid(Image, !d.x_size*(!x.window(1)-!x.window(0)), $ !d.y_size*(!y.window(1)-!y.window(0)), int=int, /minus),$ !d.x_size*!x.window(0),!d.y_size*!y.window(0) else $ tv, congrid(Image, SzN(0), SzN(1), int = int), $ xsize=!d.x_size*(!x.window(1)-!x.window(0)), $ ysize=!d.y_size*(!y.window(1)-!y.window(0)), $, !d.x_size*!x.window(0),!d.y_size*!y.window(0),/dev endelse CASE arguments OF 0: begin IF n_elements(position) le 0 then $ plot, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase, /nodata, color=color, xticklen=xticklen, $ yticklen=yticklen, xmargin=xmargin,ymargin=ymargin, title=title, $ subtitle=subtitle, xtitle=xtitle, ytitle=ytitle, xthick=xthick, $ charsize=charsize, xticks=xticks, yticks=yticks, ythick=ythick, $ xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xrange = xrange, yrange = yrange, $ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor else $ plot, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase, /nodata, color=color, xticklen=xticklen, $ yticklen=yticklen, xmargin=xmargin, ymargin=ymargin, title=title, $ subtitle=subtitle, xtitle=xtitle, ytitle=ytitle, xthick=xthick, $ charsize=charsize, xticks=xticks, yticks=yticks, ythick=ythick, $ xtickformat=xtickformat, ytickformat=ytickformat, xtickname=xtickname, $ ytickname=ytickname, position=position,xgridstyle=xgridstyle,ygridstyle=ygridstyle, $ xrange = xrange, yrange = yrange, $ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor end 1: begin if n_elements(position) le 0 then $ contour, Image, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase, xmargin=xmargin, ymargin=ymargin, title=title, /nodata, $ color=color, xticklen=xticklen, yticklen=yticklen, $ subtitle=subtitle, xtitle=xtitle, ytitle=ytitle, xthick=xthick, $ charsize=charsize, xticks=xticks, ythick=ythick, $ yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, $ xgridstyle=xgridstyle,ygridstyle=ygridstyle,$ xrange = xrange, yrange = yrange, $ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor else $ contour, Image, x_arg, y_arg, xst=(1 or xstyle), yst=(1 or ystyle), $ /noerase, xmargin=xmargin, ymargin=ymargin, title=title, /nodata, $ color=color, xticklen=xticklen, yticklen=yticklen, $ subtitle=subtitle, xtitle=xtitle, ytitle=ytitle, xthick=xthick, $ charsize=charsize, xticks=xticks, ythick=ythick, $ yticks=yticks, xtickformat=xtickformat, ytickformat=ytickformat, $ xtickname=xtickname, ytickname=ytickname, position=position, $ xgridstyle=xgridstyle,ygridstyle=ygridstyle,$ xrange = xrange, yrange = yrange, $ xtickv=xtickv, ytickv=ytickv, xminor=xminor, yminor=yminor end ENDCASE !P.multi=Pmsave1 end ####################################################### pro tv_axes,data,ysize=ysize,xoffset=xoffset, $ yoffset=yoffset, tick_pix_min_value=tick_pix_min_value, $ yfactor=yfactor,xfactor=xfactor,sample=sample,scale=scale, $ negative=negative,font=font,charsize=charsize ; Draws quickly TV image with axes (faster but worse than using CONGRID). if not keyword_set(scale) then scale=0 if not keyword_set(negative) then negative=0 if n_elements(sample) le 0 then sample=0 if n_elements(font) le 0 then font=-1 if n_elements(charsize) le 0 then charsize=1 if n_elements(xoffset) le 0 then xoffset=40. if n_elements(yoffset) le 0 then yoffset=50. if n_elements(ysize) le 0 then ysize=!d.y_size-yoffset-10 if n_elements(tick_pix_min_value) le 0 then $ tick_pix_min_value=40 sz=(size(data))([1,2]) if n_elements(yfactor) le 0 then yfactor=-1 if yfactor le 0 then yfactor=fix(ysize/sz(1)) > 1 det=[negative, (scale ne 0), (yfactor ne 1)] erase CASE 1 OF equiv(det,[0,0,0]): tv, data,xoffset,yoffset equiv(det,[0,0,1]): tv, rebin(data,sz(0), $ sz(1)*yfactor, sam=sample), xoffset,yoffset equiv(det,[0,1,0]): tv, bytscl(data),xoffset,yoffset equiv(det,[0,1,1]): tv, bytscl(rebin(data,sz(0), $ sz(1)*yfactor, sam=sample)), xoffset,yoffset equiv(det,[1,0,0]): tv, 255B-data,xoffset,yoffset equiv(det,[1,0,1]): tv, 255B-rebin(data,sz(0), $ sz(1)*yfactor, sam=sample), xoffset,yoffset equiv(det,[1,1,0]): tv, 255B-bytscl(data),xoffset,yoffset equiv(det,[1,1,1]): tv, 255B-bytscl(rebin(data,sz(0), $ sz(1)*yfactor, sam=sample)), xoffset,yoffset ELSE: ENDCASE p_area=reform((convert_coord([xoffset-1, xoffset+sz(0)+1 < (!d.x_vsize-1)], $ [yoffset-1, yoffset+sz(1)*yfactor+1 < (!d.y_vsize-1)], $ /dev,/to_norm))([0,1],*),4) Ypixsize=(p_area(3)-p_area(1))*!d.y_vsize Xpixsize=(p_area(2)-p_area(0))*!d.x_vsize xticklen=6./Ypixsize yticklen=6./Xpixsize plot,findgen(Xpixsize+2)*Ypixsize/(Xpixsize+1), $ /noerase,/nodata,charsize=charsize, $ pos=p_area, xst=1,yst=1,font=font, $ xtickl=-xticklen, ytickl=-yticklen, $ xran=[-0.5,Xpixsize-0.5], $ yran=[-0.5,Ypixsize-0.5]/yfactor end ####################################################### FUNCTION T_TICKS0,axis, index, value ; Makes ticks of the absolute time. ticks = SMH(value+24.*(value lt 0)*3600., ms=0) if abs(!x.crange(1)-!x.crange(0)) gt 1e4 then ticks = strmid(ticks, 0, 5) return, ticks ; RETURN,smh(value, ms=0) END ####################################################### FUNCTION T_TICKS1,axis, index, value ; Makes ticks of the absolute time. return, SMH(value+24.*(value lt 0)*3600., ms=1) ; RETURN,smh(value, ms=1) END ####################################################### FUNCTION T_TICKS2,axis, index, value ; Makes ticks of the absolute time. ticks = SMH(value+24.*(value lt 0)*3600., ms=0) ;if abs(!x.crange(1)-!x.crange(0)) gt 1e4 then ticks = strmid(ticks, 0, 5) return, ticks ; RETURN,smh(value, ms=0) END ####################################################### function us_date, x return, strmid(x,3,2)+'/'+strmid(x,0,2)+'/'+strmid(x,6,2) end ####################################################### ####################################################### FUNCTION UT_TICK0,axis, index, value ; Makes ticks of the absolute time. output=smh(value*3600d0,ms=0) goto, label ; Common Time,Tbeg,Dt,Model if n_elements(Model) le 0 then Model='hh:mm:ss.msmsms' if n_elements(Tbeg) le 0 then Tbeg=0d0 if n_elements(Dt) le 0 then Dt=1d0 x=SMH((value*double(Dt)+double(Tbeg)),ms=3) CASE strlowcase(Model(0)) OF 'hh:mm': Output=strmid(x,0,5) 'mm:ss': begin x=SMH((value*double(Dt)+double(Tbeg))) Output=strmid(x,3,5) end 'ss': Output=strmid(x,6,6) 'hh:mm:ss': Output=SMH((value*double(Dt)+double(Tbeg))) 'hh:mm:ss.ms': Output=SMH((value*double(Dt)+double(Tbeg)),ms=1) 'hh:mm:ss.msms': Output=SMH((value*double(Dt)+double(Tbeg)),ms=2) ELSE: Output=x ENDCASE label: RETURN,Output END ####################################################### FUNCTION UT_TICK1,axis, index, value ; Makes ticks of the absolute time. output=smh(value*3600d0,ms=1) goto, label ; Common Time,Tbeg,Dt,Model if n_elements(Model) le 0 then Model='hh:mm:ss.msmsms' if n_elements(Tbeg) le 0 then Tbeg=0d0 if n_elements(Dt) le 0 then Dt=1d0 x=SMH((value*double(Dt)+double(Tbeg)),ms=3) CASE strlowcase(Model(0)) OF 'hh:mm': Output=strmid(x,0,5) 'mm:ss': begin x=SMH((value*double(Dt)+double(Tbeg))) Output=strmid(x,3,5) end 'ss': Output=strmid(x,6,6) 'hh:mm:ss': Output=SMH((value*double(Dt)+double(Tbeg))) 'hh:mm:ss.ms': Output=SMH((value*double(Dt)+double(Tbeg)),ms=1) 'hh:mm:ss.msms': Output=SMH((value*double(Dt)+double(Tbeg)),ms=2) ELSE: Output=x ENDCASE label: RETURN,Output END ####################################################### FUNCTION UT_TICKS,axis, index, value ; Makes ticks of the absolute time. Common Time,Tbeg,Dt,Model if n_elements(Model) le 0 then Model='hh:mm:ss.msmsms' if n_elements(Tbeg) le 0 then Tbeg=0d0 if n_elements(Dt) le 0 then Dt=1d0 x=SMH((value*double(Dt)+double(Tbeg)),ms=3) CASE strlowcase(Model(0)) OF 'hh:mm': Output=strmid(x,0,5) 'mm:ss': begin x=SMH((value*double(Dt)+double(Tbeg))) Output=strmid(x,3,5) end 'ss': Output=strmid(x,6,6) 'hh:mm:ss': Output=SMH((value*double(Dt)+double(Tbeg))) 'hh:mm:ss.ms': Output=SMH((value*double(Dt)+double(Tbeg)),ms=1) 'hh:mm:ss.msms': Output=SMH((value*double(Dt)+double(Tbeg)),ms=2) ELSE: Output=x ENDCASE RETURN,Output END ####################################################### function varmap, x Sz = size(x) if Sz(0) ne 3 then message, 'Argument must be 3-D array' return, sqrt(total(temporary(x*x), 3)/Sz(3) - total(x, 3)^2/Sz(3)^2) end ####################################################### PRO VELOVECG,U,V,X,Y, Missing = Missing, Length = length, Dots = dots, $ Title = title, position=position, noerase=noerase, color=color, $ xaxis=xaxis, yaxis=yaxis ; ;+ ; NAME: ; VELOVECG ; ; PURPOSE: ; Produce a two-dimensional velocity field plot. ; ; A directed arrow is drawn at each point showing the direction and ; magnitude of the field. ; ; CATEGORY: ; Plotting, two-dimensional. ; ; CALLING SEQUENCE: ; VELOVECG, U, V [, X, Y] ; ; INPUTS: ; U: The X component of the two-dimensional field. ; U must be a two-dimensional array. ; ; V: The Y component of the two dimensional field. Y must have ; the same dimensions as X. The vector at point (i,j) has a ; magnitude of: ; ; (U(i,j)^2 + V(i,j)^2)^0.5 ; ; and a direction of: ; ; ATAN2(V(i,j),U(i,j)). ; ; OPTIONAL INPUT PARAMETERS: ; X: Optional abcissae values. X must be a vector with a length ; equal to the first dimension of U and V. ; ; Y: Optional ordinate values. Y must be a vector with a length ; equal to the first dimension of U and V. ; ; KEYWORD INPUT PARAMETERS: ; MISSING: Missing data value. Vectors with a LENGTH greater ; than MISSING are ignored. ; ; LENGTH: Length factor. The default of 1.0 makes the longest (U,V) ; vector the length of a cell. ; ; DOTS: Set this keyword to 1 to place a dot at each missing point. ; Set this keyword to 0 or omit it to draw nothing for missing ; points. Has effect only if MISSING is specified. ; ; TITLE: A string containing the plot title. ; ; POSITION: A four-element, floating-point vector of normalized ; coordinates for the rectangular plot window. ; This vector has the form [X0, Y0, X1, Y1], where (X0, Y0) ; is the origin, and (X1, Y1) is the upper-right corner. ; ; NOERASE: Set this keyword to inhibit erase before plot. ; ; COLOR: The color index used for the plot. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; Plotting on the selected device is performed. System ; variables concerning plotting are changed. ; ; RESTRICTIONS: ; None. ; ; PROCEDURE: ; Straightforward. The system variables !XTITLE, !YTITLE and ; !MTITLE can be set to title the axes. ; ; MODIFICATION HISTORY: ; DMS, RSI, Oct., 1983. ; ; For Sun, DMS, RSI, April, 1989. ; ; Added TITLE, Oct, 1990. ; ; Added POSITION, NOERASE, COLOR, Feb 91, RES. ;- ; on_error,2 ;Return to caller if an error occurs s = size(u) t = size(v) if s(0) ne 2 then begin baduv: message, 'U and V parameters must be 2D and same size.' endif if total(abs(s(0:2)-t(0:2))) ne 0 then goto,baduv ; if n_params(0) lt 3 then x = findgen(s(1)) else $ if n_elements(x) ne s(1) then begin badxy: message, 'X and Y arrays have incorrect size.' endif if n_params(1) lt 4 then y = findgen(s(2)) else $ if n_elements(y) ne s(2) then goto,badxy ; if n_elements(missing) le 0 then missing = 1.0e30 if n_elements(length) le 0 then length = 1.0 mag = sqrt(u^2+v^2) ;magnitude. ;Subscripts of good elements nbad = 0 ;# of missing points if n_elements(missing) gt 0 then begin good = where(mag lt missing) if keyword_set(dots) then bad = where(mag ge missing, nbad) endif else begin good = lindgen(n_elements(mag)) endelse mag = mag(good) ;Discard missing values maxmag = max(mag) ugood = u(good) vgood = v(good) x0 = min(x) ;get scaling x1 = max(x) y0 = min(y) y1 = max(y) sina = length * (x1-x0)/s(1)/maxmag*ugood ;sin & cosine components. cosa = length * (y1-y0)/s(2)/maxmag*vgood ; if n_elements(title) le 0 then title = '' ;-------------- plot to get axes --------------- if n_elements(color) eq 0 then color = !p.color IF (n_elements(xaxis) le 0) $ or (n_elements(xaxis) le 0) THEN BEGIN if n_elements(position) eq 0 then begin plot,[x0-1.,x1+1.],[y1+1.,y0-1.],/nodata,/xst,/yst,title=title, $ noerase=noerase, color=color endif else begin plot,[x0-1.,x1+1.],[y1+1.,y0-1.],/nodata,/xst,/yst,title=title, $ noerase=noerase, color=color, position=position endelse ENDIF ELSE BEGIN if n_elements(position) eq 0 then begin plot,[x0-1.,x1+1.],[y1+1.,y0-1.],/nodata,xst=5,yst=5,title=title, $ noerase=noerase, color=color endif else begin plot,[x0-1.,x1+1.],[y1+1.,y0-1.],/nodata,xst=5,yst=5,title=title, $ noerase=noerase, color=color, position=position endelse for j=0,1 do axis,xaxis=j,xran=[min(xaxis),max(xaxis)],/xst for j=0,1 do axis,yaxis=j,yran=[min(yaxis),max(yaxis)],/yst ENDELSE ; r = .3 ;len of arrow head angle = 22.5 * !dtor ;Angle of arrowhead st = r * sin(angle) ;sin 22.5 degs * length of head ct = r * cos(angle) ; for i=0,n_elements(good)-1 do begin ;Each point x0 = x(good(i) mod s(1)) ;get coords of start & end dx = sina(i) x1 = x0 + dx y0 = y(good(i) / s(1)) dy = cosa(i) y1 = y0 + dy plots,[x0,x1,x1-(ct*dx-st*dy),x1,x1-(ct*dx+st*dy)], $ [y0,y1,y1-(ct*dy+st*dx),y1,y1-(ct*dy-st*dx)], $ color=color endfor if nbad gt 0 then $ ;Dots for missing? oplot, x(bad mod s(1)), y(bad / s(1)), psym=3, color=color end ####################################################### pro wbc_ex_event,ev widget_control,ev.top,get_uval=a wset,a.Win IF ev.id eq a.View THEN BEGIN tmp=a.a w_box_cursor,ev,xy,init=a.init,cur=tmp a.a=tmp a.init=0 a.xy=xy widget_control,ev.top,set_uval=a return ENDIF WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "DONE": begin print,a.xy WIDGET_CONTROL,ev.top,/DESTROY end "Nest": wbc_ex "Invert": begin a.image(a.xy(0,0):a.xy(1,0),a.xy(0,1):a.xy(1,1))= $ not a.image(a.xy(0,0):a.xy(1,0),a.xy(0,1):a.xy(1,1)) tmp=a.a w_box_cursor,cur=tmp a.a=tmp widget_control,ev.top,set_uval=a tv,a.image end ENDCASE end pro wbc_ex,xx init_structure={w_b_state, $ x:0, y:0, press:0, first:1, Xc:[0.,0.], Yc:[0.,0.], $ Output:intarr(2,2), stretch:0., move:0.} a={init:1, $ View:0L, $ Win:0L, $ xy:intarr(2,2), $ image: bytscl(dist(200),top=!d.n_colors-1), $ a:init_structure} base=widget_base(/column,uval=a) button=widget_button(base,val='DONE',uval='DONE') button=widget_button(base,val='Invert',uval='Invert') button=widget_button(base,val='Nest',uval='Nest') a.View=WIDGET_DRAW(base, xsize=200,ysize=200,$ /motion_events, /button_events, retain=2) WIDGET_CONTROL,base,/REALIZE,/HOURGLASS WIDGET_CONTROL,a.View,get_val=tmp a.Win=tmp wset,a.Win tv,a.image & empty widget_control,base,set_uval=a xmanager,'wbc_ex',base end ####################################################### ; Copyright (c) 1991, Research Systems, Inc. All rights reserved. ; Unauthorized reproduction prohibited. ;+ ; NAME: ; WCALC ; ; PURPOSE: ; This routine emulates a scientific calculator. ; ; CATEGORY: ; Widgets, math. ; ; CALLING SEQUENCE: ; WCALC ; ; INPUTS: ; None. ; ; KEYWORD PARAMETERS: ; GROUP: The widget ID of the widget that calls WCALC. When this ; ID is specified, a death of the caller results in a death of ; WCALC. ; ; FONT: A string containing the name of the X-Windows font to be ; used for the calculator buttons and display. If no font is ; specified, the first available 20-point font is used. ; On many systems, you can see the names of available fonts ; by entering the command "xlsfonts" from the Unix command line. ; ; OUTPUTS: ; None. ; ; OPTIONAL OUTPUT PARAMETERS: ; None. ; ; COMMON BLOCKS: ; WCALCBLOCK, WTRANSBLOCK ; ; SIDE EFFECTS: ; Initiates the XManager if it is not already running. ; ; RESTRICTIONS: ; Math error trapping varies depending upon system. ; ; PROCEDURE: ; Create and register the widget, allow computations, and then exit. ; ; MODIFICATION HISTORY: ; WIDGET CALCULATOR by Keith R Crosley, RSI, October 1991 ; Created from a template written by: Steve Richards, January, 1991 ;- ;------------------------------------------------------------------------------ ; procedure update ;------------------------------------------------------------------------------ PRO update, number COMMON wcalcblock, display, stuff, curr, prev, mem, set, lastop stuff=stuff+number WIDGET_CONTROL, display, SET_VALUE=' ' curr = FLOAT(stuff) WIDGET_CONTROL, display, SET_VALUE=stuff ;print, '' ;print, 'AFTER UPDATE:' ;print, 'CURRENT =',curr ;print, 'PRVIOUS =',prev END ;------------------------------------------------------------------------------ ; procedure set ; ; ;------------------------------------------------------------------------------ PRO set, NOPREV=noprev COMMON wcalcblock, display, stuff, curr, prev, mem, set, lastop IF KEYWORD_SET(noprev) EQ 0 THEN prev = curr stuff = '' ;print, '' ;print, 'AFTER SET:' ;print, 'CURRENT = ', curr ;print, 'PRVIOUS = ', prev set = 1 END ;------------------------------------------------------------------------------ ; procedure show ;------------------------------------------------------------------------------ PRO show, string COMMON wcalcblock, display, stuff, curr, prev, mem, set, lastop WIDGET_CONTROL, display, SET_VALUE=string END ;------------------------------------------------------------------------------ ; procedure equals ;------------------------------------------------------------------------------ PRO equals, NOSET=noset COMMON wcalcblock, display, stuff, curr, prev, mem, set, lastop CASE lastop OF '^':BEGIN curr = prev^curr prev = curr IF KEYWORD_SET(noset) EQ 0 THEN SET SHOW, STRING(prev) lastop='NOOP' END '*':BEGIN curr = curr*prev prev = curr IF KEYWORD_SET(noset) EQ 0 THEN SET SHOW, STRING(prev) lastop='NOOP' END '/':BEGIN curr = prev/curr prev = curr IF KEYWORD_SET(noset) EQ 0 THEN SET SHOW, STRING(prev) lastop='NOOP' END '-':BEGIN curr = prev-curr prev = curr IF KEYWORD_SET(noset) EQ 0 THEN SET SHOW, STRING(prev) lastop='NOOP' END '+':BEGIN curr = curr+prev prev = curr IF KEYWORD_SET(noset) EQ 0 THEN SET SHOW, STRING(prev) lastop='NOOP' END 'NOOP': BEGIN SET END ENDCASE END ;------------------------------------------------------------------------------ ; procedure wcalc_ev ;------------------------------------------------------------------------------ ; This procedure processes the events being sent by the XManager. ;*** This is the event handling routine for the wcalc widget. It is ;*** responsible for dealing with the widget events such as mouse clicks on ;*** buttons in the wcalc widget. The tool menu choice routines are ;*** already installed. This routine is required for the wcalc widget to ;*** work properly with the XManager. ;------------------------------------------------------------------------------ PRO wcalc_ev, event COMMON wcalcblock, display, stuff, curr, prev, mem, set, lastop COMMON wtransblock, conv1, conv2 WIDGET_CONTROL, event.id, GET_UVALUE = eventval ;find the user value ;of the widget where ;the event occured CASE eventval OF ;*** here is where you would add the actions for your events. Each widget ;*** you add should have a unique string for its user value. Here you add ;*** a case for each of your widgets that return events and take the ;*** appropriate action. '1': BEGIN UPDATE, '1' END '2': BEGIN UPDATE, '2' END '3': BEGIN UPDATE, '3' END '4': BEGIN UPDATE, '4' END '5': BEGIN UPDATE, '5' END '6': BEGIN UPDATE, '6' END '7': BEGIN UPDATE, '7' END '8': BEGIN UPDATE, '8' END '9': BEGIN UPDATE, '9' END '0': BEGIN UPDATE, '0' END '.': BEGIN UPDATE, '.' END '=': EQUALS '^': BEGIN CASE lastop OF 'NOOP': BEGIN lastop = '^' SET END '^': BEGIN lastop='^' curr = prev^curr prev = curr SET SHOW, STRING(prev) END ELSE: BEGIN EQUALS, /NOSET lastop = '^' SET END ENDCASE END '*': BEGIN CASE lastop OF 'NOOP': BEGIN lastop = '*' SET END '*': BEGIN lastop='*' curr = curr*prev prev = curr SET SHOW, STRING(prev) END ELSE: BEGIN EQUALS, /NOSET lastop = '*' SET END ENDCASE END '/': BEGIN CASE lastop OF 'NOOP': BEGIN lastop = '/' SET END '/': BEGIN lastop='/' curr = prev/curr prev = curr SET SHOW, STRING(prev) END ELSE: BEGIN EQUALS, /NOSET lastop = '/' SET END ENDCASE END '-': BEGIN CASE lastop OF 'NOOP': BEGIN lastop = '-' SET END '-': BEGIN lastop='-' curr = prev-curr prev = curr SET SHOW, STRING(prev) END ELSE: BEGIN EQUALS, /NOSET lastop = '-' SET END ENDCASE END '+': BEGIN CASE lastop OF 'NOOP': BEGIN lastop = '+' SET END '+': BEGIN lastop='+' curr = curr+prev prev = curr SET SHOW, STRING(prev) END ELSE: BEGIN EQUALS, /NOSET lastop = '+' SET END ENDCASE END 'C': BEGIN curr=0 prev=0 stuff='' lastop = 'NOOP' SET SHOW, STRING(curr) END 'CE': BEGIN curr = 0 stuff='' SHOW, STRING(curr) END '+/-': BEGIN curr = -(curr) SHOW, STRING(curr) END 'M': BEGIN mem = curr SHOW, STRING(curr) SET, /NOPREV END 'M+': BEGIN mem = mem+curr SHOW, STRING(curr) SET, /NOPREV END 'MR': BEGIN curr = mem SHOW, STRING(curr) SET, /NOPREV END 'MC': BEGIN mem = 0 END 'DEGREES': BEGIN conv1=!dtor conv2=!radeg END 'RADIANS': BEGIN conv1 = 1 conv2 = 1 END 'SQRT': BEGIN curr = SQRT(curr) SHOW, STRING(curr) SET, /NOPREV END 'X^2': BEGIN curr = curr^2 SHOW, STRING(curr) SET, /NOPREV END 'X^3': BEGIN curr = curr^3 SHOW, STRING(curr) SET, /NOPREV END '1/X': BEGIN curr = 1/curr SHOW, STRING(curr) SET, /NOPREV END 'ALOG': BEGIN curr = ALOG(curr) SHOW, STRING(curr) SET, /NOPREV END 'ALOG10':BEGIN curr = ALOG10(curr) SHOW, STRING(curr) SET, /NOPREV END 'EXP': BEGIN curr = EXP(curr) SHOW, STRING(curr) SET, /NOPREV END 'SIN': BEGIN curr = SIN(curr*conv1) SHOW, STRING(curr) SET, /NOPREV END 'COS': BEGIN curr = COS(curr*conv1) SHOW, STRING(curr) SET, /NOPREV END 'TAN': BEGIN curr = TAN(curr*conv1) SHOW, STRING(curr) SET, /NOPREV END 'PI': BEGIN curr = !pi SHOW, STRING(curr) SET, /NOPREV END 'ASIN': BEGIN curr = ASIN(curr)*conv2 SHOW, STRING(curr) SET, /NOPREV END 'ACOS': BEGIN curr = ACOS(curr)*conv2 SHOW, STRING(curr) SET, /NOPREV END 'ATAN': BEGIN curr = ATAN(curr)*conv2 SHOW, STRING(curr) SET, /NOPREV END 'SINH': BEGIN curr = SINH(curr*conv1) SHOW, STRING(curr) SET, /NOPREV END 'COSH': BEGIN curr = COSH(curr*conv1) SHOW, STRING(curr) SET, /NOPREV END 'TANH': BEGIN curr = TANH(curr*conv1) SHOW, STRING(curr) SET, /NOPREV END '!': BEGIN IF curr LT 0 THEN RETURN IF curr EQ 0 THEN curr=1 ELSE BEGIN curr = FIX(curr) temp = 1. FOR i=1,curr DO temp=temp*i curr = FLOAT(temp) ENDELSE SHOW, STRING(curr) SET, /NOPREV END "XLOADCT": XLoadct, GROUP = event.top ;XLoadct is the library ;routine that lets you ;select and adjust the ;color palette being ;used. "XPALETTE": XPalette, GROUP = event.top ;XPalette is the ;library routine that ;lets you adjust ;individual color ;values in the palette. "XMANTOOL": XMTool, GROUP = event.top ;XManTool is a library ;routine that shows ;which widget ;applications are ;currently registered ;with the XManager as ;well as which ;background tasks. "EXIT": WIDGET_CONTROL, event.top, /DESTROY ;There is no need to ;"unregister" a widget ;application. The ;XManager will clean ;the dead widget from ;its list. ELSE: MESSAGE, "Event User Value Not Found" ;When an event occurs ;in a widget that has ;no user value in this ;case statement, an ;error message is shown ENDCASE END ;============= end of wcalc event handling routine task ============= ;------------------------------------------------------------------------------ ; procedure wcalc ;------------------------------------------------------------------------------ ; This routine creates the widget and registers it with the XManager. ;*** This is the main routine for the wcalc widget. It creates the ;*** widget and then registers it with the XManager which keeps track of the ;*** currently active widgets. This routine builds the widget and includes a ;*** menu built using the function "mkmenu.pro". The routine "mkmenu.pro" ;*** build the menu defined by the file "wcalc.mnu" and this file must ;*** be in the same directory as "wcalc.pro" to work. ;------------------------------------------------------------------------------ PRO wcalc, GROUP = GROUP, FONT = font COMMON wcalcblock, display, stuff, curr, prev, mem, set, lastop COMMON wtransblock, conv1, conv2 ;*** If wcalc can have multiple copies running, then delete the following ;*** line and the comment for it. Often a common block is used that prohibits ;*** multiple copies of the widget application from running. In this case, ;*** leave the following line intact. IF(XRegistered("wcalc") NE 0) THEN RETURN ;only one instance of ;the wcalc widget ;is allowed. If it is ;already managed, do ;nothing and return ;*** Next the main base is created. You will probably want to specify either ;*** a ROW or COLUMN base with keywords to arrange the widget visually. wcalcbase = WIDGET_BASE(TITLE = "IDL Calculator", /COLUMN) ;create the main base ;*** Here some default controls are built in a menu. The descriptions of these ;*** procedures can be found in the wcalc_ev routine above. If you would ;*** like to add other routines or remove any of these, remove them both below ;*** and in the wcalc_ev routine. XPdMenu, [ '"Done" EXIT', $ '"Tools" {', $ '"XLoadct" XLOADCT', $ '"XPalette" XPALETTE', $ '"XManagerTool" XMANTOOL', $ '}'], $ wcalcbase IF KEYWORD_SET(font) EQ 0 THEN font='*20' row1 = WIDGET_BASE(wcalcbase, /ROW) display = WIDGET_TEXT(row1, VALUE='0 ', $ FONT=font,/FRAME) special = WIDGET_BASE(wcalcbase, /ROW, /FRAME) slcol = WIDGET_BASE(special, /COLUMN) sl2col = WIDGET_BASE(special, /COLUMN) smcol = WIDGET_BASE(special, /COLUMN) srcol = WIDGET_BASE(special, /COLUMN) s4col = WIDGET_BASE(special, /COLUMN) s5col = WIDGET_BASE(special, /COLUMN) s6col = WIDGET_BASE(special, /COLUMN) ; COMMONLY USED FN'S: sqrt = WIDGET_BUTTON(slcol, VALUE='SQRT', UVALUE='SQRT') x2 = WIDGET_BUTTON(slcol, VALUE='X^2', UVALUE='X^2') x3 = WIDGET_BUTTON(slcol, VALUE='X^3', UVALUE='X^3') x1 = WIDGET_BUTTON(slcol, VALUE='1/X', UVALUE='1/X') ;LOGS: alog = WIDGET_BUTTON(sl2col, VALUE='LN', UVALUE='ALOG') alog10 = WIDGET_BUTTON(sl2col, VALUE='LOG', UVALUE='ALOG10') exp = WIDGET_BUTTON(sl2col, VALUE='EXP', UVALUE='EXP') ; TRANSCENDENTALS: sin = WIDGET_BUTTON(smcol, VALUE='SIN', UVALUE='SIN') cos = WIDGET_BUTTON(smcol, VALUE='COS', UVALUE='COS') tan = WIDGET_BUTTON(smcol, VALUE='TAN', UVALUE='TAN') pi = WIDGET_BUTTON(smcol, VALUE='PI', UVALUE='PI') asin = WIDGET_BUTTON(srcol, VALUE='ASIN', UVALUE='ASIN') acos = WIDGET_BUTTON(srcol, VALUE='ACOS', UVALUE='ACOS') atan = WIDGET_BUTTON(srcol, VALUE='ATAN', UVALUE='ATAN') sinh = WIDGET_BUTTON(s4col, VALUE='SINH', UVALUE='SINH') cosh = WIDGET_BUTTON(s4col, VALUE='COSH', UVALUE='COSH') tanh = WIDGET_BUTTON(s4col, VALUE='TANH', UVALUE='TANH') ;OTHER FN'S: fact = WIDGET_BUTTON(sl2col, VALUE='!', UVALUE='!') ;THE DEGREE/RADIAN TOGGLE: togglebase = WIDGET_BASE(s5col, /COLUMN, /FRAME, /EXCLUSIVE) degree = WIDGET_BUTTON(togglebase, VALUE='Degrees', $ UVALUE = 'DEGREES', /NO_RELEASE) radian = WIDGET_BUTTON(togglebase, VALUE='Radians', $ UVALUE = 'RADIANS', /NO_RELEASE) keypad = WIDGET_BASE(wcalcbase, /ROW, /FRAME) lcol = WIDGET_BASE(keypad, /COLUMN) rcol = WIDGET_BASE(keypad, /COLUMN) r2col = WIDGET_BASE(keypad, /COLUMN) r3col = WIDGET_BASE(keypad, /COLUMN) row2 = WIDGET_BASE(lcol, /ROW) seven = WIDGET_BUTTON(row2, VALUE='7', FONT=font, UVALUE='7') eight = WIDGET_BUTTON(row2, VALUE='8', FONT=font, UVALUE='8') nine = WIDGET_BUTTON(row2, VALUE='9', FONT=font, UVALUE='9') row3 = WIDGET_BASE(lcol, /ROW) four = WIDGET_BUTTON(row3, VALUE='4', FONT=font, UVALUE='4') five = WIDGET_BUTTON(row3, VALUE='5', FONT=font, UVALUE='5') six = WIDGET_BUTTON(row3, VALUE='6', FONT=font, UVALUE='6') row4 = WIDGET_BASE(lcol, /ROW) one = WIDGET_BUTTON(row4, VALUE='1', FONT=font, UVALUE='1') two = WIDGET_BUTTON(row4, VALUE='2', FONT=font, UVALUE='2') three = WIDGET_BUTTON(row4, VALUE='3', FONT=font, UVALUE='3') row5 = WIDGET_BASE(lcol, /ROW) zero = WIDGET_BUTTON(row5, VALUE='0', FONT=font, UVALUE='0') point = WIDGET_BUTTON(row5, VALUE=' .', FONT=font, UVALUE='.') equals = WIDGET_BUTTON(row5, VALUE=' = ', FONT=font, UVALUE='=') clear= WIDGET_BUTTON(rcol, VALUE='C', FONT=font, UVALUE='C') mult = WIDGET_BUTTON(rcol, VALUE='*', FONT=font, UVALUE='*') div = WIDGET_BUTTON(rcol, VALUE='/', FONT=font, UVALUE='/') minus= WIDGET_BUTTON(rcol, VALUE='-', FONT=font, UVALUE='-') plus = WIDGET_BUTTON(rcol, VALUE='+', FONT=font, UVALUE='+') ce = WIDGET_BUTTON(r2col, VALUE='CE', FONT=font, UVALUE='CE') power= WIDGET_BUTTON(r2col, VALUE='^', FONT=font, UVALUE='^') plusmin=WIDGET_BUTTON(r2col, VALUE='+/-', FONT=font, UVALUE='+/-') mem = WIDGET_BUTTON(r3col, VALUE='M', FONT=font, UVALUE='M') mempl= WIDGET_BUTTON(r3col, VALUE='M+', FONT=font, UVALUE='M+') memr = WIDGET_BUTTON(r3col, VALUE='MR', FONT=font, UVALUE='MR') memc = WIDGET_BUTTON(r3col, VALUE='MC', FONT=font, UVALUE='MC') ; INITIALIZE: curr = 0. prev = 0. mem = 0. set = 0 stuff='' lastop='NOOP' conv1 = !dtor conv2 = !radeg WIDGET_CONTROL, wcalcbase, /REALIZE ;create the widgets ;that are defined WIDGET_CONTROL, degree, /SET_BUTTON XManager, "wcalc", wcalcbase, $ ;register the widgets EVENT_HANDLER = "wcalc_ev", $ ;with the XManager GROUP_LEADER = GROUP ;and pass through the ;group leader if this ;routine is to be ;called from some group ;leader. END ;==================== end of wcalc main routine ======================= ####################################################### pro wdel ; Deletes ALL the graphics windows. device,win=win index=where(win) if index(0) ge 0 then begin for j=0, n_elements(index)-1 do wdelete,index(j) print,'Windows deleted: ', byte(index) endif else print, 'No windows' end ####################################################### function wgtmax, yy, ipeak, width=width, threshold=thres, full=full ;+ Function returns coordinate (subscript) of weighted maximum ; in the given 1-dimensional or 2-dimensional array. ;- if n_params() lt 1 then message, 'Incorrect call' Sz=size(yy) if (Sz(0) lt 1) or (Sz(1) le 1) then message, 'Incorrect argument' if n_elements(width) le 0 then auto=1 else auto=0 if n_elements(thres) le 0 then thres=0.2 N=Sz(1) if Sz(0) eq 2 then Ny=Sz(2) else Ny=1 ipeak=(x=fltarr(Ny)) arg=findgen(N) for j=0, Ny-1 do begin amax=max(yy(*,j),imax) if auto then begin fw=fwhm(yy(*,j),i_peak=imax, full=keyword_set(full)) width=fix(2*fw) endif k0=imax-width/2 > 0 k1=imax+width/2 < (N-1) > k0 ind=where(yy(k0:k1,j) ge thres*amax) > 0 kmin=ind(0) kmax=ind(n_elements(ind)-1) x(j)=total(arg*yy(k0:k1,j))/total(yy(k0:k1,j))+k0 ipeak(j)=imax endfor if n_elements(x) eq 1 then x=x(0) return, x end ####################################################### pro WINDOW_SET, WIN, Scale=Scale, Map=Map, $ multi=multi, cursor=cursor, position=position, $ button=button, cancel_mouse=cancel_mouse, $ data=data,device=device,normal=normal, $ show=show ; This is WSET+Restore_scaling [+WSHOW] if (not keyword_set(device)) and (not keyword_set(normal)) $ then data=1 if keyword_set(show) then wshow,WIN,1 wset,WIN if n_elements(Scale) gt 0 then scale,Scale,/rec if n_elements(multi) gt 0 then !p.multi=multi IF n_elements(cursor) gt 0 THEN BEGIN if n_elements(cursor) gt 1 then tvcrs,cursor(0),cursor(1), $ data=data,device=device,normal=normal if n_elements(cancel_mouse) gt 0 then $ position=cursor_out(cursor,button=button, $ data=data,device=device,normal=normal) else $ position=cursor_out(button=button, $ data=data,device=device,normal=normal) ENDIF end ####################################################### function winpos, x0, y0 if n_elements(x0) le 0 then x0 = 0.5 if n_elements(y0) le 0 then y0 = 0.05 xwinsize = (!x.window(1)-!x.window(0)) ywinsize = (!y.window(1)-!y.window(0)) return, [!x.window(0) + x0*xwinsize, !y.window(0) + y0*ywinsize] end ####################################################### pro w_box_cursor_draw,a,b,base=base,index=index,move=move,put=put CASE !version.OS OF 'windows': color=255b 'Win32': color=255b ELSE: color=127b ENDCASE CASE 1 OF move or keyword_set(put): BEGIN if not a.first and not keyword_set(put) then $ plots, [a.Xc(0),a.Xc(1),a.Xc(1),a.Xc(0),a.Xc(0)], $ [a.Yc(0),a.Yc(0),a.Yc(1),a.Yc(1),a.Yc(0)],/dev,col=color a.Xc=a.Xc+b(0)-a.x a.Yc=a.Yc+b(1)-a.y a.Xc=a.Xc(sort(a.Xc)) a.Yc=a.Yc(sort(a.Yc)) plots, [a.Xc(0),a.Xc(1),a.Xc(1),a.Xc(0),a.Xc(0)], $ [a.Yc(0),a.Yc(0),a.Yc(1),a.Yc(1),a.Yc(0)],/dev,col=color a.x=b(0) a.y=b(1) END ELSE: BEGIN device,/cursor_cross if not a.first then $ plots, [a.Xc(0),a.Xc(1),a.Xc(1),a.Xc(0),a.Xc(0)], $ [a.Yc(0),a.Yc(0),a.Yc(1),a.Yc(1),a.Yc(0)],/dev,col=color a.Xc(index mod 2)=b(0) a.Yc(index/2)=b(1) a.Xc=a.Xc(sort(a.Xc)) a.Yc=a.Yc(sort(a.Yc)) plots, [a.Xc(0),a.Xc(1),a.Xc(1),a.Xc(0),a.Xc(0)], $ [a.Yc(0),a.Yc(0),a.Yc(1),a.Yc(1),a.Yc(0)],/dev,col=color END ENDCASE a.Output=fix([[a.Xc],[a.Yc]]) end pro w_box_cursor,ev,output,initial=initial, $ current_state=current_state,put=put common w_b_cursor,w_b_state CASE !version.OS OF 'windows': color=255b 'Win32': color=255b ELSE: color=127b ENDCASE init_structure={w_b_state, $ x:0, y:0, press:0, first:1, Xc:[0.,0.], Yc:[0.,0.], $ Output:intarr(2,2), stretch:0., move:0.} CASE 1 OF n_elements(current_state) gt 0: begin if n_tags(current_state) eq 9 then begin if strupcase(tag_names(current_state,/structure_name)) eq 'W_B_STATE' then $ a=current_state else begin current_state=init_structure a=init_structure endelse endif else begin current_state=init_structure a=init_structure endelse end n_elements(w_b_state) gt 0: begin if n_tags(w_b_state) eq 9 then begin if strupcase(tag_names(w_b_state,/structure_name)) eq 'W_B_STATE' then $ a=w_b_state else begin w_b_state=init_structure a=init_structure endelse endif else begin w_b_state=init_structure a=init_structure endelse end ELSE: a=init_structure ENDCASE if keyword_set(initial) or n_params() eq 0 then a.first=1 if n_params() eq 0 then return if keyword_set(put) then begin device,set_gr=6 a.first=0 a.Output=Output a.Xc=Output(*,0) a.Yc=Output(*,1) a.x=a.Xc(0) a.y=a.Yc(0) current_state=(w_b_state=a) w_box_cursor_draw,a,[a.x,a.y],/put,/move device,set_gr=3 return endif b=[ev.x,ev.y] distance=sqrt([ (b(0)-a.Xc(0))^2+(b(1)-a.Yc(0))^2, $ (b(0)-a.Xc(1))^2+(b(1)-a.Yc(0))^2, $ (b(0)-a.Xc(0))^2+(b(1)-a.Yc(1))^2, $ (b(0)-a.Xc(1))^2+(b(1)-a.Yc(1))^2]) width=10 if (a.Xc(1)-a.Xc(0)) lt width and (a.Yc(1)-a.Yc(0)) lt width then $ width=width/2 inside= float( b(0) gt (a.Xc(0)-width) and b(0) lt (a.Xc(1)+width) $ and b(1) gt (a.Yc(0)-width) and b(1) lt (a.Yc(1)+width)) Flag=float(min(distance,imin) lt width) CASE 1 OF Flag: device,/cursor_cross Inside: device,cursor_standard=32513 ELSE: device,/cursor_orig ENDCASE if ev.press then a.press=1 if ev.release then begin a.press=0 a.stretch=0 a.move=0 endif if not a.press then begin a.x=b(0) & a.y=b(1) endif IF a.press THEN BEGIN base=( [[a.Xc(0),a.Yc(0)],[a.Xc(1),a.Yc(0)], $ [a.Xc(0),a.Yc(1)],[a.Xc(1),a.Yc(1)]] )(*,3-imin) device,set_gr=6 CASE 1 OF a.stretch: w_box_cursor_draw,a,b,base=b,index=imin,move=0 a.move: w_box_cursor_draw,a,b,/move a.first: begin a.x=b(0) & a.y=b(1) a.Xc=b(0) & a.Yc=b(1) a.stretch=1 w_box_cursor_draw,a,b,base=b,index=imin,move=0 a.first=0 end not(a.first) and Flag: begin w_box_cursor_draw,a,b,base=b,index=imin,move=0 a.stretch=1 end not(Flag) and inside: begin w_box_cursor_draw,a,b,/move a.move=1 end not(Flag) and not(inside): begin a.first=1 plots, [a.Xc(0),a.Xc(1),a.Xc(1),a.Xc(0),a.Xc(0)], $ [a.Yc(0),a.Yc(0),a.Yc(1),a.Yc(1),a.Yc(0)],/dev,col=color end ELSE: device,/cursor_orig ENDCASE device,set_gr=3 ENDIF empty Output=a.Output current_state=(w_b_state=a) end ####################################################### pro w_curs, value, arrow=arrow, i_beam=i_beam, hourglass=hourglass, $ black_crosshair=black_crosshair, crosshair=crosshair, up_arrow=up_arrow, $ size=size, icon=icon, nw_se=nw_se, ne_sw=ne_sw, ew=ew, sn=sn ; Converts cursor into another shape. Only for MS Windows if !version.OS ne 'windows' and !version.OS ne 'Win32' then begin print,"Not supported on this platform. Use routine 'CURS'" return endif CASE 1 OF n_elements(value) gt 0: begin CASE value OF 0: set=32512 1: set=32513 2: set=32514 3: set=32515 4: set=32516 5: set=32640 6: set=32641 7: set=32642 8: set=32643 9: set=32644 10: set=32645 ELSE: set=value ENDCASE end keyword_set(crosshair): begin device,cursor_crosshair=1 return end keyword_set(arrow): set=32512 keyword_set(i_beam): set=32513 keyword_set(hourglass): set=32514 keyword_set(black_crosshair): set=32515 keyword_set(up_arrow): set=32516 keyword_set(size): set=32640 keyword_set(icon): set=32641 keyword_set(nw_se): set=32642 keyword_set(ne_sw): set=32643 keyword_set(ew): set=32644 keyword_set(sn): set=32645 ELSE: set=32512 ENDCASE device,cursor_standard=set end ####################################################### pro w_eof,lun if n_params(lun) le 0 then begin print,'You must define LUN!' return endif writeu,lun,'1A'xb end ####################################################### pro xdeg_pol_event, ev common xdeg_pol, I, V, P, sI, sV, ID, data if ev.ID eq ID.Draw then begin wset, ID.Win widget_control, ID.Label, set_val= $ string(data.xykf*ev.x, data.xykf*ev.y, I(ev.x, ev.y), V(ev.x, ev.y), P(ev.x, ev.y), $ format="(i3, ', ', i3, ', ', 'I: ', g9.3, ' V: ', g10.3, ' V/I: ', g10.3)") return endif widget_control, ev.id, get_uval=uv, /hour CASE uv OF 'Done': begin widget_control, ev.top, /destr end 'Colors': xloadct, /modal 'Stokes I': begin wset, ID.Win tvscl, (I > 0)^0.5 end 'Stokes V': begin wset, ID.Win tvscl, (V > 0)^0.5 - (-V > 0)^0.5 end 'Degree of polarization': begin if (size(P))(0) ne 2 then return wset, ID.Win tvscl, (P > 0)^0.5 - (-P > 0)^0.5 end 'db': begin widget_control, ID.db, get_val=tmp data.db=-abs(float(tmp(0))) widget_control, ID.db, set_val=string(-data.db, format='(f4.1)') end 'threshold': begin widget_control, ID.threshold, get_val=tmp data.threshold=float(tmp(0)) widget_control, ID.threshold, set_val=string(data.threshold, format='(g9.3)') end 'Level': begin widget_control, ID.Level, get_val=tmp data.Level=float(tmp(0)) widget_control, ID.Level, set_val=string(data.Level, format='(g9.3)') end 'Index': begin widget_control, ID.Index, get_val=tmp data.ind=fix(tmp(0))>03 widget_control, ID.Width, set_val=string(data.Width, format='(i1)') end 'EXECUTE': begin widget_control, ID.Filter, get_val=tmp data.Filter=fix(tmp(0)) ne 0 widget_control, ID.Filter, set_val=string(data.Filter, format='(i1)') widget_control, ID.Level, get_val=tmp data.Level=float(tmp(0))>0 widget_control, ID.Level, set_val=string(data.Level, format='(g9.3)') widget_control, ID.threshold, get_val=tmp data.threshold=float(tmp(0)) widget_control, ID.threshold, set_val=string(data.threshold, format='(g9.3)') widget_control, ID.db, get_val=tmp data.db=-abs(float(tmp(0))) widget_control, ID.db, set_val=string(-data.db, format='(f4.1)') widget_control, ID.Width, get_val=tmp data.Width=fix(tmp(0))>3 widget_control, ID.Width, set_val=string(data.Width, format='(i1)') tmp=0 if ID.Index eq 0 then goto,skp widget_control, ID.Index, get_val=tmp data.ind=fix(tmp(0))>0 0)^0.5 - (-P > 0)^0.5 end ELSE: ENDCASE empty end function xdeg_pol, Stokes_I, Stokes_V, xysize=xysize common xdeg_pol, I, V, P, sI, sV, ID, data ID={draw:0L, Win:0L, Label:0L, db:0L, Level:0L, width:0L, Threshold:0L, Filter:0L, Index:0L} data={threshold:400, db:(-23.), level:0.005, filter:0, width:3, xykf:1., y1s:10, x1s:10, nn:0, ind:0} Sz=size(Stokes_I) if Sz(0) lt 2 then begin message, 'Arrays must have 2 dimensions' return,0 end if Sz(0) eq 3 then data.nn=Sz(3)-1 else data.nn=0 if not equiv(Sz, size(Stokes_V)) then begin message, 'Incompatible arrays' return,0 end if n_elements(xysize) eq 0 then xys=400 else xys=xysize(0) if xys lt 10 then xys=400 if Sz(1) ge Sz(2) then begin data.x1s=xys data.xykf=Sz(1)/float(xys) data.y1s=fix(float(data.x1s)/Sz(1)*Sz(2)) endif else begin data.y1s=xys data.xykf=Sz(2)/float(xys) data.x1s=fix(float(data.y1s)/Sz(2)*Sz(1)) end sI=Stokes_I sV=Stokes_V I=congrid(SI(*,*,0),data.x1s,data.y1s,/interp) V=congrid(SV(*,*,0),data.x1s,data.y1s,/interp) mainbase=widget_base(tit='Degree of polarization', /colu) menubase=widget_base(mainbase, /row) rl_base=widget_base(mainbase, /row) leftbase=widget_base(rl_base, /colu) inputbase=widget_base(rl_base, /colu) button=widget_button(menubase, val='Done', uval='Done') button=widget_button(menubase, val='Colors', uval='Colors') button=widget_button(menubase, val='Array', /menu) button1=widget_button(button, val='Stokes I', uval='Stokes I') button1=widget_button(button, val='Stokes V', uval='Stokes V') button1=widget_button(button, val='Degree of polarization', uval='Degree of polarization') ID.Draw=widget_draw(leftbase, xs=data.x1s, ys=data.y1s, /motion) ID.label=widget_label(leftbase, /fra, val=' ', /dynam) button=widget_button(inputbase, val='EXECUTE', uval='EXECUTE') label=widget_label(inputbase, val='dB:') ID.db=widget_text(inputbase, val=string(-data.db, format='(f4.1)'), uval='db', /edit, /fra) label=widget_label(inputbase, val='Thres.:') ID.threshold=widget_text(inputbase, val=string(data.threshold, format='(g9.3)'), $ uval='threshold', /edit, /fra) label=widget_label(inputbase, val='Level:') ID.Level=widget_text(inputbase, val=string(data.Level, format='(g9.3)'), $ uval='Level', /edit, /fra) label=widget_label(inputbase, val='Filter:') ID.Filter=widget_text(inputbase, val=string(data.Filter, format='(i1)'), $ uval='Filter', /edit, /fra) label=widget_label(inputbase, val='Width:') ID.Width=widget_text(inputbase, val=string(data.Width, format='(i1)'), $ uval='Width', /edit, /fra) if Sz(0) eq 3 then begin label=widget_label(inputbase, val=string(data.nn,format='("Array [0:",i3,"]")')) ID.Index=widget_text(inputbase, val=string(data.ind, format='(i1)'), $ uval='Index', /edit, /fra) end widget_control, mainbase, /real, /hour widget_control, ID.Draw, get_val=tmp ID.Win=tmp wset, ID.Win p=deg_pol(i, v, threshold=data.threshold, range=data.db, filter=data.filter, $ width=data.width, min=data.level) tvscl, (P > 0)^0.5 - (-P > 0)^0.5 empty xmanager, 'xdeg_pol', mainbase, /modal if Sz(0) eq 3 then begin p=Stokes_I for i=0,Sz(3)-1 do $ p(*,*,i)=deg_pol(Stokes_I(*,*,i), Stokes_V(*,*,i), threshold=data.threshold,$ range=data.db, filter=data.filter, width=data.width, min=data.level) end else $ p=deg_pol(Stokes_I, Stokes_V, threshold=data.threshold, range=data.db, filter=data.filter, $ width=data.width, min=data.level) return, p end ####################################################### pro xdelfile_event,ev Common Exch_xdelfile,base,Value WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "Yes": Value=1 "No": Value=0 ENDCASE WIDGET_CONTROL,ev.top,/DESTROY end ;************************************* pro xdelfile, Filename, group_leader=group_leader, $ silent=silent, path=path ; Interactively deletes a file. Common Exch_xdelfile,base,Value if xregistered('xdelfile') then return if n_elements(group_leader) le 0 then group_leader=0 if n_elements(path) gt 0 then pushd,path Sz=Size(Filename) IF not ((Sz(0) eq 0L) and Sz(n_elements(Sz)-2) eq 7L) THEN BEGIN if n_params() lt 1 then goto, L1 print,'Invalid file name' goto,exit1 ;if Filename is not a scalar string ENDIF ;then return L1: if n_elements(Filename) le 0 then Filename='' if Filename eq '' then Filename=pickfile(title= $ 'Please select a file for DELETING') if Filename eq '' then goto, exit1 if keyword_set(silent) then begin value=1 & goto, exit endif device,get_scr=scr prompt='Delete' xpos=scr(0)/3 ypos=scr(1)/3 margin=" " base=widget_base(/colu,xoff=xpos,yoff=ypos, $ tit=prompt,group=group_leader, $ space=scr(1)/40,ypad=scr(1)/40) text=[' You are deleting the file',Filename] length=2*strlen(margin)+max(strlen(text(*))) Ques=widget_text(base,ysiz=2,val=margin+text,xsiz=length) base1=widget_base(base,/row, xpad=scr(0)/12, $ space=scr(0)/40,ypad=scr(1)/40) But0 = WIDGET_BUTTON(base1,Uval='Yes',val='OK') But1 = WIDGET_BUTTON(base1,Uval='No',val='Cancel') WIDGET_CONTROL,base,/realize,/hourglass xmanager,'xdelfile',base,/modal exit: if value eq 1 then begin openr,lun,Filename,/get_lun,/del free_lun,lun print,'File '+Filename+' is deleted' endif exit1: if n_elements(path) gt 0 then popd end ####################################################### pro xhxt_event, ev common xhxt, ID, INDEX, DATA, mytime, ave1, intervals ymar = [2,0.2] if strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then Delim = '\' else Delim = '/' Sz = size(ave1) IF ev.id eq ID.Draw THEN BEGIN Wset, ID.Win xy = (convert_coord(ev.x, ev.y, /dev, /to_data))([0,1]) range = (convert_coord([0,0], [0,!d.y_size], /dev, /to_data))(1, [0,1]) range = transpose(range) if ev.press eq 1 then ID.pressleft =1 if ev.release eq 1 then ID.pressleft =0 if ev.press eq 4 then ID.pressright =1 if ev.release eq 4 then ID.pressright =0 if ev.release eq 1 then if ID.Mode eq 'Select' then begin ID.firstleft = 1 ID.firstright = 1 if ID.nint eq 0 then intervals(0,ID.nint) = smh(ID.left*3600d0) else begin intervals(0,ID.nint) = (intervals(1,ID.nint-1) = smh(ID.left*3600d0)) endelse ID.nint=ID.nint+1 endif if ev.release eq 4 then if ID.Mode eq 'Select' then begin ID.firstleft = 1 ID.firstright = 1 if ID.nint eq 0 then intervals(0,ID.nint) = smh(ID.right*3600d0) else begin intervals(0,ID.nint+1) = (intervals(1,ID.nint) = smh(ID.right*3600d0)) endelse ID.nint=ID.nint+1 endif if ID.pressleft eq 1 and ID.Mode ne 'Mark' then begin device, set_graph = 6 if ID.firstleft ne 1 then begin plots, ID.left, range, col = 127 endif else ID.firstleft = 0 plots, xy(0), range, col = 127 ID.left = xy(0) device, set_graph = 3 endif if ID.pressright eq 1 and ID.Mode ne 'Mark' then begin device, set_graph = 6 if ID.firstright ne 1 then begin plots, ID.right, range, col = 127 endif else ID.firstright = 0 plots, xy(0), range, col = 127 ID.right = xy(0) device, set_graph = 3 endif if ID.mode eq 'Mark' then begin if ev.press eq 1 then begin intv = transpose(intervals(*,0:ID.nint-1)) number = (where(xy(0) ge hmsd(intv(*,0)) and xy(0) le hmsd(intv(*,1))))(0) if number lt 0 then return intervals(2, number) = '1' x0=hmsd(intv(number, 0)) x1=hmsd(intv(number, 1)) polyfill, [x0, x1, x1, x0, x0], range([0,0,1,1,0]), /line_fill, col = 150, $ orient = 45 endif if ev.press eq 4 then begin endif endif if ID.pressleft eq 1 or ID.pressright eq 1 then begin if Sz(0) gt 1 then begin N = (where(mytime ge xy(0)*3600.))(0) > 0 widget_control, ID.Label, set_val = smh((xy(0)+24*(xy(0) lt 0))*3600d0) + ', ' + $ strcompress(string(ave1(N,0), ave1(N, 1), ave1(N,2), ave1(N,3), format = $ "('L: ', i5, ', M1:', i5, ', M2:', i5, ', H:', i5)")) endif else $ widget_control, ID.Label, set_val = smh((xy(0)+24*(xy(0) lt 0))*3600d0) endif empty return ENDIF widget_control, ev.id, get_uval = uv CASE uv OF 'Done': begin widget_control, ev.top, /destroy end 'Wcalc': wcalc 'Load': begin file = pickfile(filt = 'hda*', /read, path = ID.path, file = ID.file) if file eq '' then return ID.firstleft = 1 ID.firstright = 1 widget_control, /hour rd_xda, file, -1,index,data ave = ave_cts(index, data, time=time1) daycnv, index.gen.day - 1 + 2443874.5d0, year, month, day dates = string(day, form='(i2.2)')+'/'+string(month, form='(i2.2)')+ '/'+$ string(year mod 100, form='(i2.2)') times = index.gen.time/1d3 mytime = time1+times(0) ave1 = transpose(reform(ave, 4, n_elements(ave)/4)) mytime = reform(mytime, n_elements(mytime)) Wset, ID.Win !p.multi=[0,1,4] for j=0,3 do $ plot, mytime/3600d0, ave1(*, j), xtickf = 'ut_tick0', $ ytit = (['L','M1', 'M2', 'H'])(j), $ color = 0, background = !d.n_colors-1, /yno, $ chars = ID.chars, ymar = ymar !p.multi=0 ID.left = !x.crange(0) ID.right = !x.crange(1) intervals = strarr(3,100) intervals(2, *) = '0' ID.firstleft = (ID.firstright = 1) ID.file = file ID.path = subdir(file) ID.left = (ID.right=0.) ID.Mode = 'Expand' ID.nint = 0 ID.pressleft= (ID.pressright = 0) path = ID.path chars = ID.chars save, path, chars, file = getenv('gr_root')+ Delim + 'xhxt.ini' end 'Expand': begin ID.Mode = 'Expand' Wset, ID.Win !p.multi=[0,1,4] xrange = [ID.left, ID.right] xrange = xrange(sort(xrange)) for j=0,3 do $ plot, mytime/3600d0, ave1(*, j), xtickf = 'ut_tick0', $ ytit = (['L','M1', 'M2', 'H'])(j), $ color = 0, background = !d.n_colors-1, $ xran = xrange, /yno, chars = ID.chars, ymar = ymar !p.multi=0 ID.firstleft = 1 ID.firstright = 1 end 'Whole': begin ID.Mode = 'Expand' Wset, ID.Win !p.multi=[0,1,4] for j=0,3 do $ plot, mytime/3600d0, ave1(*, j), xtickf = 'ut_tick0', $ ytit = (['L','M1', 'M2', 'H'])(j), $ color = 0, background = !d.n_colors-1, /yno, $ chars = ID.chars, ymar = ymar !p.multi=0 ID.firstleft = 1 ID.firstright = 1 end 'Select': begin ID.Mode = 'Select' ID.firstleft = 1 ID.firstright = 1 end 'Mark': begin ID.Mode = 'Mark' ID.firstleft = 1 ID.firstright = 1 end 'Save Data': begin file = pickfile(filt = '*.sav', /write) if file eq '' then return save, INDEX, DATA, mytime, ave1, file = file end 'Save All': begin file = pickfile(filt = '*.sav', /write) if file eq '' then return intervals1 = intervals(*, 0:ID.nint-1) save, INDEX, DATA, mytime, ave1, intervals1, file = file file = pickfile(filt = '*.txt', /write) if file eq '' then return openw, lun, file, /get for j=0, ID.nint-2 do printf, lun, intervals1(*,j) free_lun, lun end 'Save Intervals': begin file = pickfile(filt = '*.txt', /write) if file eq '' then return intervals1 = intervals(*, 0:ID.nint-1) openw, lun, file, /get for j=0, ID.nint-2 do printf, lun, intervals1(*,j) free_lun, lun end ELSE: ENDCASE empty end pro xhxt, output common xhxt, ID, INDEX, DATA, mytime, ave1, intervals intervals = strarr(3,100) intervals(2, *) = '0' ID = {Draw:0L, Win:0L, Label:0L, firstleft:1, firstright:1, $ file:'', path :'/parithi2/Grechnev/data/hxt', $ left:0., right:0., mode:'Expand', pressleft:0, pressright:0, $ nint:0, chars:2.} if strlowcase(strmid(!version.OS, 0, 3)) eq 'win' then Delim = '\' else Delim = '/' sav_file = (findfile(getenv('gr_root')+ Delim + 'xhxt.ini'))(0) if sav_file ne '' then begin restore, sav_file ID.path = path ID.chars = chars endif mainbase = widget_base(tit = 'HXT viewer', /colu) menubase = widget_base(mainbase, /row) button = widget_button(menubase, val = 'Done', uval = 'Done') button = widget_button(menubase, val = 'File', /menu) button1 = widget_button(button, val = 'Load', uval = 'Load') button1 = widget_button(button, val = 'Save', /menu) button2 = widget_button(button1, val = 'Data', uval = 'Save Data') button2 = widget_button(button1, val = 'Intervals', uval = 'Save Intervals') button2 = widget_button(button1, val = 'All', uval = 'Save All') button = widget_button(menubase, val = 'Tools', /menu) button1 = widget_button(button, val = 'Expand', uval = 'Expand') button1 = widget_button(button, val = 'Whole range', uval = 'Whole') button1 = widget_button(button, val = 'Select intervals', uval = 'Select') button1 = widget_button(button, val = 'Mark intervals', uval = 'Mark') button1 = widget_button(button, val = 'Calculator', uval = 'Wcalc') device, get_screen = screen ID.Draw = widget_draw(mainbase, xsiz = screen(0)*0.97, ys = screen(1)*0.85, $ /motion, /button) ID.Label = widget_label(mainbase, val ='', /dynam) widget_control, mainbase, /real widget_control, ID.Draw, get_val = tmp ID.Win = tmp wset, tmp plot, findgen(100), back = !d.n_colors-1, xst = 5, yst = 5, /nodata empty xmanager, 'xhxt', mainbase end ####################################################### ; Copyright (c) 1991, Research Systems, Inc. All rights reserved. ; Unauthorized reproduction prohibited. ;+ ; NAME: ; XPDMENU ; ; PURPOSE: ; This procedure implifies setting up widget pulldown menus. XPDMENU ; reads a description of the menu to be generated, and calls ; the appropriate widget creation functions to generate it. ; ; CALLING SEQUENCE: ; XPDMENU, Desc, Parent ; ; INPUTS: ; DESC: Either the name of a file that contains the description of the ; pulldown menu to be generated, or a string array that ; contains the description. The rules for a pull-down menu ; description are as follows: ; ; Leading and trailing whitespace is ignored. Lines starting ; with the '#' character or blank lines are ignored. All other ; lines contain 2 fields, a button label and a value. The label ; should be quoted with any desired delimiter, usually single ; or double quotes. The value can be omitted, in which case the ; label is used as the value. To make a menu choice reveal ; another pull-down menu, place a '{' character in its value ; field. Such a pulldown is terminated by a line containing ; a '}' in the label field. ; ; Example: ; "Colors" { ; "Red" ; "Green" ; "Blue" { ; "Light" ; "Medium" ; "Dark" ; "Navy" ; "Royal" ; } ; "Cyan" ; "Magenta" ; } ; "Quit" DONE ; ; This example builds a menu bar with 2 buttons, ; named "Colors" and "Quit". "Colors" is a pulldown ; containing "Red", "Green", "Blue", "Cyan", and "Magenta". ; "Blue" is a sub-pulldown containing shades of blue. ; Such sub-menus can be nested to any desired level. ; Most of the lines don't specify an explicit value. The ; exception is "Quit", which has the value "DONE". It can ; be instructive to run the following small program: ; ; a = WIDGET_BASE() ; XPDMENU, a, 'test' ; Test contains the above ; widget_control, /REALIZE, a ; uvalue='' ; repeat begin ; event = widget_event(a) ; WIDGET_CONTROL, get_uvalue=uvalue, event.id ; print, uvalue ; end until uvalue eq "EXIT" ; WIDGET_CONTROL, /destroy, a ; end ; ; Note that if you choose to make DESC be a string array, ; the arrays contents must be exactly the same as the file ; would be (including the quotes around the fields). Each ; element of the array corresponds to one line of a file. ; ; PARENT: Widget ID of the parent base widget for the pulldown menu. ; If this argument is omitted, the menu base is a top-level base. ; ; KEYWORDS: ; BASE: A named variable to recieve the widget ID of the created base. ; ; COLUMN: If set, the buttons will be arranged in a column. If unset, ; the buttons will be arranged in a row. ; ; FRAME: The width, in pixels of the frame drawn around the base. The ; default is no frame. ; ; TITLE: If PARENT is not supplied, TITLE can be set a string to be ; used as the title for the widget base. ; ; FONT: A string that contains the name of the font to use for the ; menu buttons. ; ; OUTPUTS: ; None. ; ; COMMON BLOCKS: ; None. ; ; SIDE EFFECTS: ; A pulldown menu widget heirarchy is created, but not realized. ; Each button has the label specified by the first field of the ; corresponding pulldown menu description line. Each button has a ; user value (uvalue) specified by the second field. ; ; RESTRICTIONS: ; Very little syntax checking is done on the description file. ; Incorrectly formated input can lead to unexpected results. ; ; EXAMPLE: ; For an example of using XPDMENU, see the "Pull-Down Menu" example ; in the "Simple Widget Examples". To create the simple widget examples ; main menu, enter WEXMASTER from the IDL prompt. ; ; MODIFICATION HISTORY: ; 4 October 1990, AB, RSI. ; 16 January 1991, AB Added the option of DESC being a string ; array containing the description. ;- function mkpull_getline, unit, data, idx, n, label, value ; Reads the next non-comment line from the description. If Unit is ; non-zero, it represents an open file from which the description ; is read. Otherwise, the description comes from data(idx) and idx is ; incremented. In this case, EOF is defined as idx being equal to n. ; ; LABEL is set to the label part and VALUE to the value part. ; On EOF, the file unit, if any, is closed. The return value of ; the function is: ; -1 - End of file was seen ; 0 - Line was single button ; 1 - Line is a pulldown button ; ret = -1 value = '' if (unit eq 0) then not_eof = (idx lt n) else not_eof = (not eof(unit)) while ((not_eof) and (ret eq -1)) do begin if (unit eq 0) then begin value = data(idx) idx = idx + 1 endif else begin readf, unit, value endelse value = strtrim(value, 2) ; Leading/trailing whitespace delim = strmid(value, 0, 1) case delim of "" : "#" : "}" : ret = 2 else: begin value = strmid(value, 1, 100000) pos = strpos(value, delim) if (pos eq -1) then begin message, "Bad delimiter in line: " + delim + value, /INFORM endif else begin label = strmid(value, 0, pos) value = strtrim(strmid(value, pos+1, 100000), 2) if (value eq "{") then begin value = "" ret = 1 endif else begin if (strlen(value) eq 0) then value = label ret = 0 endelse endelse end endcase if (unit eq 0) then not_eof = (idx lt n) else not_eof = (not eof(unit)) endwhile if ((unit ne 0) and (ret eq -1)) then begin free_lun, unit & unit = 0 & end return, ret end pro mkpull_pulldown, parent, unit, data, idx, n, font ; ; unit - A file LUN or 0. ; data - If Unit is 0, data is a string array containing the menu ; description. ; idx - If Unit is 0, idx is an integer giving the current index into data. ; n - If Unit is 0, n is an integer giving the # of elements in data. while 1 do begin ret = mkpull_getline(unit, data, idx, n, label, value) case ret of -1 : return 0 : begin if font ne '' then begin but = WIDGET_BUTTON(parent,value=label,uvalue=value,font=font) endif else begin but = WIDGET_BUTTON(parent, value=label, uvalue=value) endelse end 1 : begin if font ne '' then begin but = WIDGET_BUTTON(parent, value=label, MENU = 2, font=font) endif else begin but = WIDGET_BUTTON(parent, value=label, MENU = 2) endelse mkpull_pulldown, but, unit, data, idx, n, font end 2 : return endcase endwhile end pro XPDMENU, DESC, PARENT, BASE=BASE, FRAME=FRAME, TITLE=TITLE, $ COLUMN=COLUMN, FONT=FONT s = size(parent) if (s(s(0) + 1) eq 0) then begin ; No parent is specified. parent = 0 if (not keyword_set(TITLE)) then TITLE='Menu' endif else begin if (s(0) ne 0) then message, 'PARENT must be a scalar value." if (s(1) ne 3) then message, 'PARENT must be a long integer." endelse s = size(desc) if (s(s(0)+1) ne 7) then $ message,'Description argument must be of type string." if (s(0) eq 0) then begin openr, unit, desc, /GET_LUN n = 0 endif else begin if (s(0) ne 1) then message, 'String array must be 1-D." unit = 0 n = s(1) endelse if (not keyword_set(frame)) then frame = 0 if (not keyword_set(font)) then font = '' if (parent eq 0) then $ IF(KEYWORD_SET(COLUMN)) THEN $ base = WIDGET_BASE(/COLUMN, TITLE=TITLE, FRAME=FRAME) $ ELSE $ base = WIDGET_BASE(/ROW, TITLE=TITLE, FRAME=FRAME) $ else $ IF(KEYWORD_SET(COLUMN)) THEN $ base = WIDGET_BASE(parent, /COLUMN, FRAME=FRAME) $ ELSE $ base = WIDGET_BASE(parent, /ROW, FRAME=FRAME) mkpull_pulldown, base, unit, desc, 0, n, font end ####################################################### pro xquestion_c_u,a Common Exch_xquestion,group,Value if group ne 0 then if widget_info(group,/valid) then $ widget_control,group,/show end pro xquestion_event,ev,a Common Exch_xquestion,group,Value WIDGET_CONTROL,ev.id,GET_UVALUE = uv CASE uv OF "Yes": Value=0 "No": Value=1 ENDCASE WIDGET_CONTROL,ev.top,/DESTROY end ;************************************* pro xquestion,a, group_leader=group_leader, prompt=prompt, $ xsize=xsize,ysize=ysize,xpos=xpos, ypos=ypos, $ selection=selection, text=text, exclusive=exclusive, $ nonexclusive=nonexclusive ; Interactive selection of two possibilities. Common Exch_xquestion,group,Value device,get_scr=scr if n_elements(group_leader) le 0 then group_leader=0L group=group_leader if n_elements(xpos) le 0 then xpos=scr(0)/3 if n_elements(ypos) le 0 then ypos=scr(1)/3 if n_elements(xsize) le 0 then xsize=scr(0)/2.5 if n_elements(text) le 0 then text=' ' if n_elements(prompt) le 0 then prompt=' ' if n_elements(selection) le 0 then selection=['Yes','No'] if n_elements(exclusive) le 0 then exclusive=0 if n_elements(nonexclusive) le 0 then nonexclusive=0 margin=string(' ',format="(a1,5(' '))") base=widget_base(/colu,xoff=xpos,yoff=ypos, $ tit=prompt,group=group_leader, $ space=scr(1)/40,ypad=scr(1)/40) ;,xsiz=scr(0)/2.5,ysiz=scr(1)/3) length=2*strlen(margin)+max(strlen(text(*))) Ques=widget_text(base,ysiz=n_elements(text) > 1, $ val=margin+text,xsiz=length) base1=widget_base(base,/row, xpad=scr(0)/12, $ space=scr(0)/40,ypad=scr(1)/40,tit=prompt, $ group=group_leader, nonexclusive=nonexclusive, $ exclusive=exclusive) But0 = WIDGET_BUTTON(base1,Uval='Yes',val=selection(0)) But1 = WIDGET_BUTTON(base1,Uval='No',val=selection(1)) WIDGET_CONTROL,base,/realize,/hourglass WIDGET_CONTROL,But0,/input_focus xmanager,'xquestion',base,modal=1,cleanup='xquestion_c_u' a=selection(Value) end ####################################################### pro xselect_event,ev common xselect_exc,a,group widget_control,ev.id,get_uval=uv CASE uv OF 'DONE': begin widget_control,ev.top,/destroy if group ne 0L then if widget_info(group,/valid) then $ widget_control,group,/show end ELSE: begin a=ev.index end ENDCASE end function xselect,x,info=info,title=title,group_leader=group_leader ; Interactive selection of an element in array. ; XSELECT is similar to XLIST but returns number of element ; rather its value. common xselect_exc,a,group a=-1 if n_elements(info) le 0 then info=' ' if n_elements(title) le 0 then title='Xselect' if n_elements(group_leader) le 0 then group_leader=0L group=group_leader Len=max(strlen(x)) if Len le 80 then base=widget_base(/colu, tit=title) else $ base=widget_base(/colu,tit=title, /scroll) button=widget_button(base,val='DONE',uval='DONE') info=widget_text(base,val=Info,uval='Info',ysize=n_elements(Info)) list=widget_list(base,val= $ strcompress(sindgen(n_elements(x)),/rem)+': '+x, $ ysiz=n_elements(x) > 4 < 20, uval='List') WIDGET_control,base,/realize,/hour xmanager,'xselect',base,/modal return,a end ####################################################### pro xtext_event,ev common Exch_xtext,scbase,Txt,Out_Text,lun,Filename goto, obh_print CASE !version.OS OF 'windows': prn_funct='copy '+Filename+' prn:' 'Win32': prn_funct='copy '+Filename+' prn:' ELSE: prn_funct='lpr '+Filename ENDCASE obh_print: WIDGET_CONTROL,ev.id,GET_UVALUE = wuv, /hour CASE wuv OF "QUIT" : WIDGET_CONTROL,ev.top,/DESTROY "File" : begin file=pickfile(/read) if file eq '' then return WIDGET_CONTROL,ev.top,/DESTROY xtext, File=File end "PRINT" : IF Filename ne '' THEN begin flush,lun if strmid(!version.release,0,1) lt 5 then spawn, prn_funct else begin ; set_plot,'printer' ;device,filename=filename,/close_document a = execute('f=dialog_printersetup()') if a eq 0 then return else begin file = 'idl.' + STRLOWCASE(!D.NAME) ;stop ;file = 'idl.' + string(filename) ;cmd = 'lpr ' + file ;cmd = cmd + '; ;SPAWN, cmd spawn, prn_funct endelse endelse ;if strmid(!version.release,0,1) lt 5 then spawn, prn_funct else f=dialog_printersetup() wait,1 endif 'INPUT': begin widget_control, ev.id, get_val = n_line pos = long(n_line(0)) widget_control, ev.id, set_text_top_line = pos, $ set_text_select = [pos,40] end ELSE: ENDCASE end pro xtext,Text=Text,File=File,group_leader=group_leader, $ identifier=identifier, numbers = numbers, one_argument ; Displays interactively a text. xtext is similar to XDISPLAYFILE. common Exch_xtext,scbase,Txt,Out_Text,lun,Filename IF(XRegistered("xtext") NE 0) THEN return device,get_scr=scr if n_elements(group_leader) le 0 then group_leader=0L CASE 1 OF n_params() eq 1: Out_text = one_argument n_params() eq 0 and n_elements(Text) gt 0: Out_text = Text n_params() eq 0 and n_elements(File) gt 0: Out_text = readform(file) ELSE: ENDCASE goto, obh_new if n_elements(File) le 0 then begin if n_elements(Text) le 0 then Out_text=' ' else Out_text=Text Filename='prn_file.tmp' openw,lun,Filename,/get for j=0, n_elements(Out_text)-1 do printf, lun, Out_text(j) flush, lun ;free_lun,lun close, lun endif else begin widget_control,/hour Filename=File ;Out_text = readform(file) if file eq '' then Out_text ='' widget_control, /hour openr, lun, file, /get st = fstat(lun) data = bytarr(st.size) readu, lun, data point_lun, lun, 0 iii = where(data eq '0A'xB) N = n_elements(iii) data = strarr(N) readf, lun, data st = fstat(lun) if (st.cur_ptr + 1) lt st.size then begin tmp = '' readf, lun, tmp data = [data, tmp] endif close, lun Out_text=data ;---- obh: endelse obh_new: N = n_elements(Out_text) if keyword_set(numbers) then begin n_signs = ceil(alog10(N)) Out_text = strmid(sindgen(N), 12-n_signs, n_signs)+' '+Out_text endif scbase= widget_base(title='xtext', group_leader=group_leader, /column) menubase=widget_base(scbase, /row) button=widget_button(menubase, val="QUIT", uval="QUIT") button=widget_button(menubase, val="Load", uval="File") ;button=widget_button(menubase, val="Print", uval="PRINT") ;input=widget_text(menubase, val=string(N), uval="INPUT", /edit) Txt = WIDGET_TEXT(SCBASE,/frame, Ysize = N < scr(1)/24 < 30 > 4, $ value=Out_text,/scroll,uvalue='', xsize=max(strlen(Out_text)) +2 > 10) WIDGET_CONTROL, scbase, /realize, /hourglass identifier=scbase xmanager,'xtext', SCBASE, GROUP_LEADER = GROUP_LEADER, /no_block end ####################################################### pro xwarning_event,ev WIDGET_CONTROL,ev.top,/DESTROY end pro xwarning, text, group_leader=group_leader, prompt=prompt, $ xoffset=xoffset, yoffset=yoffset, modal=modal,delay=delay ; Issues a warning message. device,get_scr=scr if n_elements(group_leader) le 0 then group_leader=0 if n_elements(modal) le 0 then modal=0 if n_elements(xoffset) le 0 then xoffset=scr(0)/3 if n_elements(yoffset) le 0 then yoffset=scr(1)/3 if n_elements(text) le 0 then text=' ' if n_elements(prompt) le 0 then prompt=' ' Sz=size(text) if (Sz(0) eq 0) or ((Sz(0) eq 1) and (Sz(1) eq 1)) $ then N_lines=1 else N_lines=Sz(1) base=widget_base(/colu,tit=prompt,group=group_leader, $ xoffset=xoffset,yoffset=yoffset) margin=string(' ',format="(A1,5(' '))") length=2*strlen(margin)+max(strlen(text(*))) Ques=widget_text(base,ysiz=N_lines,val=margin+text,xsiz=length) But = WIDGET_BUTTON(base,Uval='OK',val='OK') WIDGET_CONTROL,base,/realize,/hourglass WIDGET_CONTROL,but,/input_focus if n_elements(delay) gt 0 then begin wait,delay WIDGET_CONTROL,base,/DESTROY return endif xmanager,'xwarning',base,modal=modal end ####################################################### function yoh_chan, j return, (['L','M1','M2','H'])(j mod 4) end ####################################################### pro yp_save_results ;****************************************************** ; SAVE COORDINATES OF THE SOLAR DISK ;****************************************************** Common Exch_yp,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output WIDGET_CONTROL,/hour CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE a=Moment.Date Subdirectory=strmid(a,6,2)+strmid(a,3,2)+strmid(a,0,2) Name=strmid(a,0,2)+strmid(a,3,2)+strmid(a,6,2) Filename=getenv('optics_dir')+Delim+Subdirectory+Delim+ $ ;strcompress(a,/rem)+'.crd' Name+'.crd' a='' xquestion,a,sel=['OK','Cancel'],text= $ ['The center and radius are to be saved into the file',' '+Filename] IF strlowcase(a) ne 'ok' THEN BEGIN kb_in_text,Filename,prompt='Input file name' xquestion,a,sel=['OK','Cancel'],text= $ ['The center and radius are to be saved into the file',' '+Filename] if strlowcase(a) ne 'ok' then return ENDIF if (findfile(Filename))(0) eq '' then $ openw,lun,Filename,/get_lun else $ openu,lun,Filename,/get_lun a=fstat(lun) point_lun,lun,a.size aa=(name_extract(Data.Optics))(1) if strmid(aa,6,1) eq 'y' then Number=', '+Data.Number else Number='' printf,lun,(name_extract(Data.Optics))(0)+Number printf,lun,strtrim(Moment.Date,2) printf,lun,strtrim(Moment.Time,2) printf,lun,Output free_lun,lun end pro yp_input_image,cancel ; This routine loads image into the window ID.Win(4) ; and sets clipping rectangle in system variable !P corresponding ; to disable clipping Common Exch_yp,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output cancel=0 Data.Map=(Num=0) if Data.Optics eq '' then path=getenv('optics_dir') $ else path=subdir(Data.Optics) filename=pickfile(path=path,/read,file=Data.Optics) if filename eq '' then return WIDGET_CONTROL,/hour Data.Optics=filename aa=strlowcase((name_extract(Filename))(1)) IF strmid(aa,6,1) eq 'y' THEN BEGIN Inf1=(Inf2=(Number=(N_size=''))) openr,lun,Filename,/get_lun Descr=fstat(lun) readf,lun,Inf1 readf,lun,Number readf,lun,Inf2 readf,lun,N_size Inf1=Inf1+string(Number) Inf2=Inf2+string(N_size)+'x'+strtrim(N_size,2) Info_strings=strarr(Number) readf,lun,Info_strings Num=xselect(Info_strings,info=[Inf1,Inf2],tit='Please select a record') WIDGET_CONTROL,/hour Offset=Descr.size-1L*N_size*N_size*Number temp=assoc(lun,bytarr(N_size,N_size),Offset) Y_data=temp(Num) free_lun,lun Sz=(Size(Y_data))([1,2]) N_sc=((Sz(0) lt 400) and (Sz(1) lt 400))+1 X_shift=(!d.x_size-512)/2 if N_sc gt 1 then tvscl,rebin(Y_data,512,512),X_shift,X_shift $ else tvscl,Y_data,X_shift,X_shift Moment.Date=strmid(aa,4,2)+' '+strmid(aa,2,2)+' '+strmid(aa,0,2) aa=strtrim(strcompress(Info_strings(Num)),2) i1=strpos(aa,' ',0) i2=strpos(aa,' ',i1+1) i3=strpos(aa,' ',i2+1) Moment.Time=strmid(aa,i2+1,i3-i2-1) N_version=strtrim(Info_strings(Num),2) N_version=strmid(N_version,0,2) Rec_Number=', '+strtrim(N_version,2) ENDIF ELSE BEGIN N_version='' Y_data=rd_image(filename, type=type, header=header) if type eq 'UNRECOGNIZED' then begin cancel=1 return endif wset,ID.Win(4) & erase,0 Sz=(Size(Y_data))([1,2]) N_sc=((Sz(0) lt 400) and (Sz(1) lt 400))+1 X_shift=(!d.x_size-512)/2 if N_sc gt 1 then tvscl,rebin(Y_data,512,512),X_shift,X_shift $ else tvscl,Y_data,X_shift,X_shift time=fh_r_time(header, error=err) date=fh_r_key(header,'date-obs',/ch, error=err) if err then date=fh_r_key(header,'date',/ch, error=err) xtext,text=header, iden=iden kb_in_time, date, time, prompt=(name_extract(filename))(0) Moment.Date=date Moment.time=time if widget_info(iden, /valid) then widget_control, iden, /destroy Rec_Number='' ENDELSE WIDGET_CONTROL,/hour Data={PosEW:[-90.,0.], PosSN:[-90.,0.], PosSUN:[0.,0.], $ BeamEW:0D, B_EW:Data.B_EW, BeamSN:0D, B_SN:Data.B_SN, $ DxEW:[0D,0D,0D], DyEW:[0D,0D,0D], $ DxSN:[0D,0D,0D], DySN:[0D,0D,0D], $ Zoom:0, Press:0, Release:0, Mode:'Follow', Mouse:0, Optics:filename, $ ClearEW:1, ClearSN:1, ClearSUN:1, $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', $ Optics_data:temporary(Y_data), $ Point1:[0.,0.], Point2:[0.,0.], Point3:[0.,0.], Map:0, $ Number:strtrim(N_version,2)} WIDGET_CONTROL,ID.Label,set_val=(name_extract(Data.Optics))(0)+Rec_Number+': '+ $ Date_string(Moment.Date)+', '+Moment.Time+' UT', /hour xyouts,0.01,0.94,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+' UT', $ chars=1.5,col=255-!P.background wset,ID.Win(0) plot,(Data.Optics_data)(*,Sz(1)/2),xst=1,yst=16 Scale,temp,/mem & SC.IEWmain=(SC.ZEWmain=temp) wset,ID.Win(1) plot,(Data.Optics_data)(Sz(0)/2,*),indgen(Sz(0)),xst=16,yst=1 Scale,temp,/mem & SC.ISNmain=(SC.ZSNmain=temp) suneph,Moment.Date,Moment.Time,SUN empty !P.clip=[0,0,1000,1000] end pro yp_draw_win ; This routine draws models of the quiet Sun scans ; as well as the scans themselves if they are available ; in two windows. ; Accordingly, in the third window map grid is drawn. Common Exch_yp,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output Sum_chan=[180,192] ; ****** DRAW MAIN WINDOW E - W ****** device,set_graphics_function=3 wset,Id.win(0) & erase plot,indgen(10),/nod,xst=4,yst=4 Scale,temp,/mem & SC.IEWmain=(SC.ZEWmain=temp) ; ****** DRAW MAIN WINDOW S - N ****** wset,Id.win(1) & erase plot,indgen(10),/nod,xst=4,yst=4 Scale,temp,/mem & SC.ISNmain=(SC.ZSNmain=temp) ; ****** DRAW SUN MAP WINDOW ****** IF Data.Optics ne '' THEN BEGIN yp_input_image,cancel if cancel then return ENDIF ELSE BEGIN Data.GridType = 'Heliographical' !p.multi=0 wset,Id.win(4) & Erase plot,indgen(10),/nod,xst=4,yst=4 scale,MapAxes0,/mem & SC.MapAxes0=MapAxes0 ENDELSE !P.clip=[0,0,1000,1000] empty end pro Zoomed_sun ; Draws map grid, axes and diurnal parallel in ; the large window for zoomed Sun image. ; Accordingly, both FWHM beam positions for ; both SSRT interferometers are drawn if they are ; defined. Common Exch_yp,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output ; *** ZOOM WINDOW (SUN MAP) *** window_set,ID.win(5),mul=0 IF Data.Zoom eq 0 THEN BEGIN MarginY=[1.,1.]*0.8 MarginX=MarginY*!D.Y_CH_SIZE/!D.X_CH_SIZE map_set,SUN.B0*180/!Pi,0,0,/ort,/nobor,/grid,/lab,tit=' ', glinestyle=Ini.lines(1), $ Xmar=MarginX,Ymar=MarginY,col=Data.GridColor,latd=10,lond=10, $ latal=1.,lonal=1. scale,MapAxesZ,/mem & SC.MapAxesZ=MapAxesZ XW=!x.window & YW=!y.window SC.CentreZ=(convert_coord([XW(0)+XW(1),YW(0)+YW(1)]/2.,/nor,/to_dev))([0,1]) SC.RZ=(convert_coord([XW(1)-XW(0),YW(1)-YW(0)]/2.,/nor,/to_dev))([0,1]) plotline,1e6,SC.CentreZ,/dev,col=Data.GridColor,linestyle=Ini.lines(3) plotline,0,SC.CentreZ,/dev,col=Data.GridColor,linestyle=Ini.lines(3) plotline,-tan(SUN.Dp),SC.CentreZ,col=Ini.colors(6),/dev,linestyle=Ini.lines(1) xyouts,0.1,0.95,Date_string(Moment.Date),/nor,col=Ini.colors(2) xyouts,0.8,0.95,Moment.Time+' UT',/nor,col=Ini.colors(2) Data.Zoom=1 ENDIF ELSE BEGIN scale,SC.MapAxesZ,/rec ENDELSE if SpotCoord(2) le -1 then goto,LZoom sz=size(SpotCoord) if sz(0) eq 1 then in=1 else in=sz(2) for i=0,in-1 do plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 LZoom: B_EW=SC.CentreZ#[1,1,1]+transpose([[Data.DxEW*SC.RZ(0)],[Data.DyEW*SC.RZ(1)]]) for i=0,2,2 do plotline,tan(!Dpi/2-Par.G_EW)*SC.RZ(1)/SC.RZ(0), $ B_EW(*,i),col=255-Ini.colors(3),line=Ini.lines(4),/dev B_SN=SC.CentreZ#[1,1,1]+transpose([[Data.DxSN*SC.RZ(0)],[Data.DySN*SC.RZ(1)]]) for i=0,2,2 do plotline,tan(!Dpi/2-Par.G_SN)*SC.RZ(1)/SC.RZ(0), $ B_SN(*,i),col=255-Ini.colors(5),line=Ini.lines(2),/dev plots,[0.91,0.99],[0.115,0.115],lin=ini.lines(4),/nor plots,[0.91,0.99],[0.075,0.075],lin=ini.lines(2),/nor xyouts,0.85,0.1,'W-E',/nor,charsiz=1.2,col=255-Ini.colors(3) xyouts,0.85,0.06,'S-N',/nor,charsiz=1.2,col=255-Ini.colors(5) end pro yp_event,ev ; Event loop for routine Yp Common Exch_yp,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output ;** PROCESS DRAWABLE EVENTS ** X_shift=(!d.x_size-512)/2 Sz=(Size(Data.Optics_data))([1,2]) N_sc=((Sz(0) lt 400) and (Sz(1) lt 400))+1 GF_COPY=3 ; initial grafics function COPY GF_RESTORE=6 ; grafics function XOR Dgf0=GF_COPY if Data.Mode eq 'Follow' then Dgf=GF_RESTORE else Dgf=GF_COPY FOR j=0,5 do $ IF ev.id eq ID.View(j) THEN BEGIN if ev.press ne 0 then Data.press=1 ;Pressed button? if ev.release ne 0 then Data.press=0 ;Released button? ENDIF IF ev.id eq ID.View(0) THEN BEGIN window_set,Id.win(0),sca=SC.IEWmain temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(0), $ set_val=string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if Data.press then begin CASE Data.Mode OF 'Follow': begin device,set_graphics_function=Dgf if not Data.ClearEW then $ plots,[(convert_coord(Data.PosEW([0,0]),/to_norm))([0,0])],[0,1], $ /norm,col=255 else Data.ClearEW=0 ; Restore precedent lines Old=Data.PosEW Data.PosEW=[temp(0),temp(0)*N_sc+X_shift] plots,[(convert_coord(Data.PosEW([0,0]),/to_norm))([0,0])],[0,1], $ /norm,col=255 window_set,Id.win(4), sca=SC.MapAxes0 ;SUN MAP WINDOW if not Data.ClearSUN then $ plots, [1,1]*Old(1),[0,!d.y_vsize],/dev,col=255 else Data.ClearSUN=0 plots, [1,1]*Data.PosEW(1),[0,!d.y_vsize],/dev,col=255 device,set_graphics_function=Dgf0 empty end 'Scope': begin return end ELSE: ENDCASE endif ENDIF IF ev.id eq ID.View(2) THEN BEGIN window_set,Id.win(2),sca=SC.IEWaux temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(2),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin Data.PosEW=temp & wait,0.2 for j=0,1 do WIDGET_CONTROL,ID.Leftbase(j),map=1-j WIDGET_CONTROL,ID.LabelEWSN(0),set_val= $ string(Data.PosEW(0),Data.PosEW(1),format='(F6.1,",",2X,F6.1)') endif ENDIF IF ((ev.id eq ID.View(0)) or (ev.id eq ID.View(2))) THEN return IF ev.id eq ID.View(1) THEN BEGIN window_set,Id.win(1),sca=SC.ISNmain temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.LabelEWSN(1),set_val= $ string(temp(0),temp(1),format='(F6.1,",",2X,F6.1)') if (Data.press gt 0) then begin CASE Data.Mode OF 'Follow': begin device,set_graphics_function=Dgf if not Data.ClearSN then $ plots,[0,1],[(convert_coord(Data.PosSN([0,0]),/to_norm))([1,1])], $ /norm,col=255 else Data.clearSN=0 Old=Data.PosSN Data.PosSN=[temp(1),temp(1)*N_sc+X_shift] plots,[0,1],[(convert_coord(Data.PosSN([0,0]),/to_norm))([1,1])], $ /norm,col=255 window_set,Id.win(4), sca=SC.MapAxes0 if not Data.ClearSUN then $ plots, [0,!d.y_vsize], [1,1]*Old(1),/dev,col=255 $ else Data.ClearSUN=0 plots, [0,!d.y_vsize], [1,1]*Data.PosSN(1),/dev,col=255 device,set_graphics_function=Dgf0 empty end 'Scope': begin end ELSE: ENDCASE endif ENDIF IF ((ev.id eq ID.View(1)) or (ev.id eq ID.View(3))) THEN return IF ev.id eq ID.View(4) THEN BEGIN window_set,Id.win(4),sca=SC.MapAxes0 ;Map Window temp=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) if temp(0) lt 0 then DirEW='E' else DirEW='W' if temp(1) lt 0 then DirSN='S' else DirSN='N' EW=strcompress(DirEW+string(abs(temp(0)),Format='(F6.1)'),/rem) SN=strcompress(DirSN+string(abs(temp(1)),Format='(F5.1)'),/rem) if not(Data.Map) then Map_coord=' ' else Map_coord='; '+EW+', '+SN WIDGET_CONTROL,ID.MapLabel,set_val= $ string(ev.X,ev.Y,format='(I4,",",2X,I4)')+Map_Coord if (ev.press ne 0) and (Data.Mouse eq 1) then begin ; Mark spot plots,temp,/data,psym=8,syms=0.7 & Data.Mouse=0 empty & return endif if (Data.press gt 0) then begin wset,ID.Win(0) plot,(Data.Optics_data)(*,(ev.Y-X_shift)/N_sc > 0 < (Sz(1)-1)),xst=1,yst=16 Scale,temp,/mem & SC.IEWmain=(SC.ZEWmain=temp) wset,ID.Win(1) plot,(Data.Optics_data)((ev.X-X_shift)/N_sc > 0 < (Sz(0)-1),*),indgen(Sz(0)),xst=16,yst=1 Scale,temp,/mem & SC.ISNmain=(SC.ZSNmain=temp) wait,0.1 Data.ClearEW=(Data.ClearSN=1) Data.ClearSUN=0 endif empty return ENDIF IF ev.id eq ID.View(5) THEN BEGIN window_set,Id.win(5),sca=SC.MapAxesZ ;Zoom Window Data.PosSUN=(convert_coord(ev.x, ev.y, /DEVICE, /TO_DATA))([0,1]) WIDGET_CONTROL,ID.ZoomLabel,set_val= $ string(Data.PosSUN(0),Data.PosSUN(1),format='(F6.1,",",2X,F6.1)') if ev.press ne 0 then plots,Data.PosSUN,/data,psym=8,syms=0.7 ; Mark spot empty & return ENDIF ;**************** OTHER EVENTS ********************** WIDGET_CONTROL,ev.id,GET_UVALUE = wuv,/hour CASE wuv OF "DONE" : begin WIDGET_CONTROL,/hour if ID.group_leader ne 0L then begin if WIDGET_INFO(ID.group_leader,/valid) then $ WIDGET_CONTROL,ID.group_leader,/show endif !P=P_save ID=(SC=(Moment=(Data=(Ini=(Rec=(Stokes=(SSRT=0))))))) P_save=(SpotCoord=(SUN=(Par=(EW_line_save=(SN_line_save=0))))) xyouts,0,0,'!3 ',/nor !x.style=(!y.style=(!x.range=(!y.range=0))) WIDGET_CONTROL,ev.top,/DEST end "QuitZoom": for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=1-j "XMTool": XMTool,group=ev.top "XLoadct": Xloadct,group=ev.top "Scope": Data.Mode='Scope' "Follow": Data.Mode='Follow' "Save": begin yp_save_results widget_control,ev.top,/show end "Point_1": Data.Point1=[Data.PosEW(1), Data.PosSN(1)] "Point_2": Data.Point2=[Data.PosEW(1), Data.PosSN(1)] "Point_3": begin Data.Point3=[Data.PosEW(1), Data.PosSN(1)] A=def_circle(Data.Point1,Data.Point2,Data.Point3) Centre=A([0,1]) & Radius=A(2) Output=A wset,ID.Win(4) temp=!p.color & !p.color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-Centre(0),!d.x_size-Centre(0)]/Radius !y.range=[-Centre(1),!d.y_size-Centre(1)]/Radius map_set,SUN.B0*!Radeg,0,0, /grid, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,col=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, col=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp !x.style=(!y.style=(!x.range=(!y.range=0))) Data.Map=1 scale,temp,/mem if wuv eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp yp_save_results widget_control,ev.top,/show end "Coordinates": begin kb_in_helio,H_coord Norm_coord=(convert_coord(H_coord,/data,/to_norm))([0,1]) plots,[1,1]*Norm_coord(0),[0,1],/nor plots,[0,1],[1,1]*Norm_coord(1),/nor empty end "Save_Image": begin widget_control,/hour New_File=pickfile(path=subdir(Data.Optics), filt='*.fit', $ file=(name_extract(Data.Optics))(1)+'.fit') if New_File eq '' then return if (findfile(New_File))(0) ne '' then begin widget_control,/hour xquestion,a,sel=['OK','Cancel'],text= ['This file already exists. Overwrite?'] if strlowcase(a) ne 'ok' then return endif widget_control,/hour struc=fh_st_ssrt(/soho) struc.object='SUN' struc.type_obs='FULL DISK' struc.time_obs=Moment.Time struc.date_obs=Moment.Date struc.telescop='SOHO' name=(name_extract(Data.Optics))(1) struc.wave=strmid(name,strlen(name)-3,3) struc.origin='SOHO' struc.radius=SUN.R*!radeg*60 struc.p0=SUN.dp*!radeg struc.lat0=SUN.B0*!radeg struc.lon0=SUN.Karr*!radeg struc.bscale=1. struc.bzero=0. Centre=Output([0,1])-64 Radius=Output(2) Sz=size(Data.Optics_data) struc.x_origin=-(struc.radius)/Radius*Sz(1)/2 struc.y_origin=-(struc.radius)/Radius*Sz(2)/2 struc.x_obs=struc.radius/Radius*Sz(1) struc.y_obs=struc.radius/Radius*Sz(2) struc.center_x=Centre(0)/Sz(1)*struc.x_obs+struc.x_origin struc.center_y=Centre(1)/Sz(2)*struc.y_obs+struc.y_origin header=fh_mk_ssrt(Sz, struc) openw, lun, New_File,/get_lun writeu, lun, byte(header) writeu, lun, Data.Optics_data free_lun, lun end "Input": begin kb_in_text,a,prompt='Solar center:', text='Print: Center(0), Center(1), Radius ' if a eq '' then return else begin a=strcompress(a,/rem) i1=strpos(a,',') i2=strpos(a,',',i1+1) Centre=[strmid(a,0,i1),strmid(a,i1+1,i2-i1-1)] Radius=strmid(a,i2+1,10) wset,ID.Win(4) temp=!p.color & !p.color=Data.Gridcolor if strmid(!version.release,0,1) lt 5 then begin !x.style=(!y.style=1) !x.range=[-Centre(0),!d.x_size-Centre(0)]/Radius !y.range=[-Centre(1),!d.y_size-Centre(1)]/Radius map_set,SUN.B0*!Radeg,0,0, /grid, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,col=Data.Gridcolor !x.style=(!y.style=(!x.range=(!y.range=0))) endif else begin map_set,SUN.B0*!Radeg,0,0, /ortho,/noerase,pos=[0,0,1,1],/nobor !x.s=[0.5*!d.x_size, Radius] / float(!d.x_size) !y.s=[0.5*!d.y_size, Radius] / float(!d.y_size) P_clip_save=!P.clip !p.clip = [0, 0, !d.x_size, !d.y_size] MAP_GRID, latdel=10, londel=10, col=Data.Gridcolor, glinestyle=Ini.lines(1) !P.clip=P_clip_save endelse !p.color=temp Data.Map=1 scale,temp,/mem if wuv eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp empty endelse Output=float([Centre,Radius]) end "Calculator": wcalc "Suncalc": begin WIDGET_CONTROL,/hourglass suncalc,group_leader=ev.top, Moment.Date,Moment.Time,/modal end "Help" : xtext,file='yp.hlp',group=ev.top "VC": spawn,'vc' "NC": spawn,'nc' "DOS" : spawn "Parameters": param_ssrt,time=Moment.time, Date=Moment.Date,Rec=Rec,group=ev.top "Clear": begin Data.ClearEW=(Data.ClearSN=(Data.ClearSUN=1)) Data.PosEW=(Data.PosSN=[-90.,0.]) & Data.PosSUN=[5.,5.] yp_draw_win !P.clip=[0,0,1000,1000] end "E-W FWHM": begin ; WINDOW E-W window_set,Id.win(0),sca=SC.IEWmain SpacingEW=abs(tan(!Dpi/2-P(1))*Df/F0) Pos=transpose((convert_coord([[Data.PosEW-Data.BeamEW/SpacingEW/2], $ [Data.PosEW+Data.BeamEW/SpacingEW/2]],/to_norm))(0,*)) for i=0,1 do plots,[Pos(i),Pos(i)],[0,1], /norm,col=255B-Ini.colors(3) empty end "S-N FWHM": begin ; WINDOW S-N window_set,Id.win(1),sca=SC.ISNmain SpacingSN=abs(tan(!Dpi/2-Q(1))*Df/F0) Pos=transpose((convert_coord([[Data.PosSN-Data.BeamSN/SpacingSN/2], $ [Data.PosSN+Data.BeamSN/SpacingSN/2]],/to_norm))(0,*)) for i=0,1 do plots,[Pos(i),Pos(i)],[0,1], /norm,col=255B-Ini.colors(5) empty end "SUN FWHM": begin ; SUN MAP WINDOW window_set,Id.win(4), sca=SC.MapAxes0 for i=0,2,2 do plotline,tan(!Dpi/2-G_EW)*SC.R0(1)/SC.R0(0), $ Data.B_EW(*,i),col=255B-Ini.colors(3),/dev for i=0,2,2 do plotline,tan(!Dpi/2-G_SN)*SC.R0(1)/SC.R0(0), $ Data.B_SN(*,i),col=255B-Ini.colors(5),/dev empty end "Zoom": begin for j=0,1 do WIDGET_CONTROL,ID.Togglebase(j),map=j Zoomed_sun end "Kbrd": BEGIN kb_in_helio,SpotCoord,prompt='Input spots coordinates', group=ev.top window_set,Id.win(4), sca=SC.MapAxes0 if SpotCoord(2) le -1 then goto,Lkbrd sz=size(SpotCoord) if sz(0) eq 1 then in=1 else in=sz(2) FOR i=0,in-1 DO BEGIN IF SpotCoord(2,i) EQ 1. THEN SpotCoord(*,i)=[(convert_coord(SpotCoord(*,i)*SC.R0+ $ SC.Centre0,/dev,/to_data))([0,1]),0] plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 ENDFOR Lkbrd: WIDGET_CONTROL,ev.top,/show END "File": begin rspotcoord,Moment,Coord,num=in if in eq 1 then b0=0. else b0=fltarr(1,in) Coord=[Coord,b0] if SpotCoord(2) le -1. then SpotCoord=Coord else SpotCoord=[[Coord],[SpotCoord]] window_set,Id.win(4), sca=SC.MapAxes0 for i=0,in-1 do plots,SpotCoord([0,1],i),/data,psym=8,syms=0.7 WIDGET_CONTROL,ev.top,/show end "Mouse": Data.Mouse=1 "Open": begin widget_control, /hour yp_input_image, cancel if cancel then return WIDGET_CONTROL,ev.top,/show end "Mild": Data.Gridcolor=Ini.colors(7) "Medium": Data.Gridcolor=Ini.colors(8) "Sharp": Data.Gridcolor=Ini.colors(9) "Remove": begin if Data.Optics eq '' then erase,255 else begin yp_input_image, cancel if cancel then return endelse CASE Data.GridType OF 'Carrington': window_set,ID.Win(4),scal=SC.MapAxesK 'Heliographical': window_set,ID.Win(4),scal=SC.MapAxes0 ELSE: ENDCASE end "Carrington": begin Data.GridType='Carrington' & Lon=SUN.Karr*!Radeg end "Heliographical":begin Data.GridType = 'Heliographical' & Lon=0. end "Axes": begin temp=!p.color & !p.color=Data.Gridcolor window_set,ID.Win(4);,scal=SC.MapAxes0 plotline,1e6,SC.Centre0,/dev & plotline,0,SC.Centre0,/dev !p.color=temp end "Diurnal parallel": begin temp=!p.color & !p.color=Data.Gridcolor window_set,ID.Win(4);,scal=SC.MapAxes0 plotline,-tan(SUN.Dp),SC.Centre0,/dev,linestyle=Ini.lines(1) !p.color=temp end "PS": begin goto,ObhPot set_plot,'PS' Sum_chan=[180,192] !x.thick=(!y.thick=(!P.thick=(!P.charthick=2))) CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE PS_Filename=getenv('gr_prg')+Delim+ $ newfilename(model=strcompress(Moment.Date,/rem),filt='*.PS') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 Data.GridType = 'Heliographical' !p.multi=0 xyouts,0,0,'!3 ',/nor map_set,SUN.B0*180/!Pi,0,0,/ortho,/nobor,/grid,/lab, glinestyle=Ini.lines(1), $ pos=[0,0,1,1],latdel=10,londel=10 xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time Centre0=[!x.window(0)+!x.window(1), !y.window(0)+!y.window(1)]/2. R0=[!x.window(1)-!x.window(0), !y.window(1)-!y.window(0)]/2. Centre0=(convert_coord(Centre0,/norm,/to_dev))([0,1]) R0=(convert_coord(R0,/norm,/to_dev))([0,1]) plotline,1e6,Centre0,/dev & plotline,0,Centre0,/dev plotline,-tan(SUN.Dp),Centre0,/dev,linestyle=Ini.lines(1) plotline,tan(!Dpi/2-G_EW)*R0(1)/R0(0), $ (Centre0#[1,1,1]+transpose([[Data.DxEW*R0(0)],[Data.DyEW*R0(1)]]))(*,1),/dev,linest=0 goto, First_only ChanEWobs=Data.PosEW(0)+2 OEWobs=ORD_RECOGNIZE(ChanEWobs,NoEW,OEW,CEW) CoordEW=acos(OEWobs*C/chanfreq(ChanEWobs,Rec)/D) BeamEW=0.886*C/(N*F0*D*abs(sin(P(1))))*par.BeamEW(1)/par.BeamEW(0) CoordEW=[CoordEW-BeamEW/2,CoordEW,CoordEW+BeamEW/2] DyEW=[0D,0D,0D] DxEW=(P(1)-coordEW)/cos(G_EW)/Rsol KEW=tan(!Dpi/2-G_EW) BEW=DyEW-KEW*DxEW B_EW=Centre0#[1,1,1]+ $ transpose([[DxEW*SC.R0(0)],[DyEW*SC.R0(1)]]) ;plotline,tan(!Dpi/2-G_EW)*R0(1)/R0(0), $ ;(Centre0#[1,1,1]+transpose([[DxEW*R0(0)],[DyEW*R0(1)]]))(*,1),/dev,linest=5 First_only: device,/close PS_Filename=newfilename(model=strcompress(Moment.Date,/rem),filt='*.PS') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 plot_scans, model=CHECKVIS(Rec,SSRT.NoEW,SSRT.CEW), $ int=Stokes.IEW, pol=Stokes.VEW, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Char=Ini.Char xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+'!CE-W' plots,[(convert_coord(Data.PosEW,/to_norm))([0,0])],[0,1], /norm,linest=0 device,/close PS_Filename=newfilename(model=strcompress(Moment.Date,/rem),filt='*.ps') device,file=PS_Filename,xsize=17.78,ysize=17.78,yoff=6.3 plot_scans, model=CHECKVIS(Rec,SSRT.NoSN,SSRT.CSN), $ int=Stokes.ISN, pol=Stokes.VSN, Xmar=Ini.PmargX, $ Xran=[1,Sum_chan(Rec)],Char=Ini.Char xyouts,0.02,0.95,/nor,Date_string(Moment.Date)+'!C'+Moment.Time+'!CS-N' plots,[(convert_coord(Data.PosSN,/to_norm))([0,0])],[0,1], /norm,linest=0 device,/close CASE !version.OS OF 'windows': Initial_device='WIN' 'Win32': Initial_device='WIN' ELSE: Initial_device='X' ENDCASE set_plot,Initial_device !x.thick=(!y.thick=(!P.thick=(!P.charthick=1))) ObhPot: wset,ID.Win(4) x=tvrd() filename=newfilename(filter='*.gif', $ path=getenv('optics_dir'),model='map') a='' xquestion,a,sel=['OK','Cancel'],text= $ ['Image is to be saved into the file',' '+Filename] if strlowcase(a) ne 'ok' then begin kb_in_text,Filename,prompt='Input file name' xquestion,a,sel=['OK','Cancel'],text= $ ['Image is to be saved into the file',' '+Filename] if strlowcase(a) ne 'ok' then return endif CASE !version.OS OF 'windows': Delim='\' 'Win32': Delim='\' ELSE: Delim='/' ENDCASE write_gif, strcompress(getenv('optics_dir')+Delim+Filename,/rem),x end ELSE: ENDCASE IF (wuv eq 'Mild') or (wuv eq 'Medium') or (wuv eq 'Sharp') THEN BEGIN ;WIDGET_CONTROL,ID.GridTypelabel,set_val=Data.GridType,/hour if Data.GridType eq 'Carrington' then temp=SC.MapAxesK else temp=SC.MapAxes0 window_set,ID.Win(4),scal=temp temp=!p.color & !p.color=Data.Gridcolor !P.clip=[0,0,1000,1000] map_grid,/label,latdel=10,londel=10,col=Data.Gridcolor, glinestyle=Ini.lines(1) !p.color=temp ENDIF IF (wuv eq 'Heliographical') or (wuv eq 'Carrington') THEN BEGIN ;WIDGET_CONTROL,ID.GridTypelabel,set_val=Data.GridType,/hour wset,ID.Win(4) if Data.Optics eq '' then erase,255 else begin yp_input_image, cancel if cancel then return endelse temp=!p.color & !p.color=Data.Gridcolor map_set,SUN.B0*!Radeg,Lon,0, /grid,/label, glinestyle=Ini.lines(1), $ /ortho,/noerase,pos=[0,0,1,1],/nobor,latdel=10,londel=10,color=Data.Gridcolor !p.color=temp & scale,temp,/mem if wuv eq 'Carrington' then SC.MapAxesK=temp else SC.MapAxes0=temp ENDIF empty end pro yp,Centre,Radius, group_leader=group_leader,Date=Date,time=time Common Exch_yp,ID,SC,Moment,Data,Ini,Rec,Stokes,SSRT, $ SpotCoord,SUN,Par,EW_line_save,SN_line_save,P_save,Factor,Output if xregistered('yp') then return CASE !version.OS OF 'windows': Factor=1. 'Win32': Factor=1. ELSE: Factor=1.04 ENDCASE Output=[0.,0.,0.] SpotCoord=[0.,0.,-1.] if n_elements(group_leader) le 0 then group_leader = 0L ID={View:Lonarr(6), Win:Lonarr(6), Label:0L, ToggleBase:[0L,0L], $ Leftbase:[0L,0L], LabelEW:0L, LabelEWSN:lonarr(4), MapLabel:0L, ZoomLabel:0L, $ group_leader:group_leader} Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} SC={ZEWmain:Ax, IEWmain:Ax, VEWmain:Ax, $ ZSNmain:Ax, ISNmain:Ax, VSNmain:Ax, $ ZEWaux:Ax, IEWaux:Ax, VEWaux:Ax, $ ZSNaux:Ax, ISNaux:Ax, VSNaux:Ax, $ MapAxes0:Ax, R0:fltarr(2), Centre0:fltarr(2), $ MapAxesK:Ax, RK:fltarr(2), CentreK:fltarr(2), $ MapAxesZ:Ax, RZ:fltarr(2), CentreZ:fltarr(2)} Ax=0 WIDGET_CONTROL,/hourglass M=strlowcase(findfile('vga_drv.rcg')) if equiv(M,'') then M=1 else begin openr,lun,'vga_drv.rcg',/get_lun readf,lun,M free_lun,lun endelse ;M=0 for L-310 else M=1 (to plot lines with various styles) Ini={Lines:indgen(5)*M(0),$ colors:[0B, $ ; Color Table 255B, $ ; Background 0B, $ ; Main color for inscriptions 255B, $ ; E-W 160B, $ ; Reserved 160B, $ ; S-N 60B, $ ; Diurnal parallel 200B, $ ; Mild grid 100B, $ ; Medium grid 0B], $ ; Sharp grid PmargX:[3.5,3.5], Char:1.5} temp=make_array(2,3,val=2000D) Data={PosEW:[-90.,0.], PosSN:[-90.,0.], PosSUN:[0.,0.], $ BeamEW:0D, B_EW:temp, BeamSN:0D, B_SN:temp, $ DxEW:[0D,0D,0D], DyEW:[0D,0D,0D], $ DxSN:[0D,0D,0D], DySN:[0D,0D,0D], $ Zoom:0, Press:0, Release:0, Mode:'Follow', Mouse:0, Optics:'', $ ClearEW:1, ClearSN:1, ClearSUN:0, $ GridColor:255B-Ini.colors(8), GridType:'Heliographical', $ Optics_data:bytarr(640,640), $ Point1:[0.,0.], Point2:[0.,0.], Point3:[0.,0.], Map:0, Number:''} if n_elements(Date) le 0 then Date='01 01 00' if n_elements(Time) le 0 then Time='00 00 00' Moment={Date:Date, Time:Time} Rec=0 P_save=!P Sum_chan=[180,192] Fmin=chanfreq(1,Rec) Fmax=chanfreq(Sum_chan(Rec),Rec) F0=(Fmax+Fmin)/2 Df=(Fmax-Fmin)/(Sum_chan(Rec)-1) device,get_scr=scr if scr(1) lt 500 then ZoomWin=scr*0.8 else ZoomWin=scr*0.92 if scr(1) lt 1000 then TV_size=512 else TV_size=640 TV_size=[1,1]*TV_size*Factor Scan_size0=[(scr(0)-TV_size(0))*0.9,scr(1)/2.3] Scan_size1=[TV_size(0),scr(1)/2.3] Xs= [[[Scan_size0]#replicate(1,2)], $ [[Scan_size1]#replicate(1,2)], $ [TV_size], [ZoomWin]] ;***** Drawing widget Mainbase= widget_base(/fra, group=group_leader, $ tit='Image preprocessing') for j=0,1 do ID.ToggleBase(j)=widget_base(Mainbase) ;***** Left Base if scr(1) lt 500 then Wholebase=widget_base(ID.ToggleBase(0),/row,/scroll, $ x_scroll_size=scr(0)*0.96, y_scroll_size=scr(1)*0.91) else $ Wholebase=widget_base(ID.ToggleBase(0),/row) LeftTogglebase=widget_base(Wholebase) for j=0,1 do ID.Leftbase(j)=widget_base(LeftTogglebase,/colu) XPdMenu, ['"DONE" DONE', $ '"File" {', $ '"Open" Open', $ '"Save" {', $ '"Results" Save', $ '"Image" Save_Image', $ '"Screen" PS','}',$ '}', $ '"Tools" {', $ '"Screen"{', $ '"Zoom" Zoom', $ '"Clear" Clear','}',$ '"Grid" {', $ '"Diurnal parallel" Diurnal parallel', $ '"Axes" Axes', $ '"Contrast" {', $ '"Mild" Mild', $ '"Medium" Medium', $ '"Sharp" Sharp','}',$ '"Longitude" {', $ '"Heliographical" Heliographical', $ '"Carrington" Carrington','}', $ '"Remove" Remove', $ '}', $ '"Calculator" Calculator', $ '"Coord. converter" Suncalc', $ '"Parameters" Parameters', $ '"Palette" XLoadct', $ '"XManager Tool" XMTool', $ '"Shell" DOS', $ '"Norton Commander" {','"NC" NC', $ '"VC" VC','}', $ '}', $ '"Help" Help', $ '"Circle" {', $ '"Point 1" Point_1', $ '"Point 2" Point_2', $ '"Point 3" Point_3', $ '"Input" Input','}'], ID.Leftbase(0) Emptystring=' ' ID.label=WIDGET_LABEL(ID.Leftbase(0), val= $ Emptystring+Date_string(Moment.Date)+', '+Moment.Time+' UT') Scroll_size=480 if scr(1) gt 1000 then ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=640, $ YS=640, /motion, /button, retain=2) else $ ID.view(4)=WIDGET_DRAW(ID.Leftbase(0), XS=640, $ YS=640, /motion, /button, retain=2,/scroll, $ x_scroll=Scroll_size,y_scroll=Scroll_size) ID.Maplabel=WIDGET_LABEL(ID.Leftbase(0), val= $ ' ') for j=2,3 do begin ID.view(j)=WIDGET_DRAW(ID.Leftbase(1), XS=Xs(0,j), YS=Xs(1,j), /motion, /button_events, retain=2) ID.LabelEWSN(J)=WIDGET_LABEL(ID.Leftbase(1),val=Emptystring) endfor ZoomBase=WIDGET_BASE(ID.ToggleBase(1),/row) junk=WIDGET_BASE(ZoomBase,/colu) junk1=WIDGET_BUTTON(junk,VAL='DONE',uval='QuitZoom') junk=WIDGET_BASE(ZoomBase,/colu) ID.view(5)=WIDGET_DRAW(junk, XS=Xs(0,5), YS=Xs(1,5), /motion, /button_events, retain=2) ID.ZoomLabel=WIDGET_LABEL(junk,val=Emptystring) ;***** Right Base Rightbase=widget_base(Wholebase,/colu) for J=0,1 do begin ID.view(J)=WIDGET_DRAW(Rightbase, XS=Xs(0,J),YS=Xs(1,J), /motion, /button_events, retain=2) ID.LabelEWSN(J)=WIDGET_LABEL(Rightbase,val=Emptystring) endfor ;***** WIDGET_CONTROL,ID.Leftbase(1),map=0 WIDGET_CONTROL,ID.Togglebase(1),map=0 WIDGET_CONTROL,Mainbase,/real,/hour for J=0,5 do begin WIDGET_CONTROL,ID.view(J),GET_VALUE=temp & ID.Win(J)=temp wset,ID.Win(J) endfor if scr(1) lt 1000 then WIDGET_CONTROL,ID.view(4),set_draw_view=[1,1]*(640-Scroll_size)/2 WIDGET_CONTROL,/hour circ yp_draw_win xmanager,'yp',Mainbase,group=group_leader Centre=Output([0,1]) & Radius=Output(2) end ####################################################### function ys_time, index, ms = ms if n_elements(ms) le 0 then ms = 0 return, smh(index.gen.time/1d3, ms = ms) end ####################################################### pro _s_m_imp_event,ev common _s_m_imp, ID, image, header, index, a, data, disk_index, trace Sz=size(Image) if ev.id eq ID.Draw(0) then begin window_set, ID.Win(0), sc=ID.Sc(0) widget_control, ID.Label(0), set_val= $ string(ev.x/ID.factor, ev.y/ID.factor, $ image(ev.x/ID.factor>0<(Sz(1)-1), ev.y/ID.factor>0<(Sz(1)-1)), $ format='(i3, ", ", i3, "; ", g10.3)') if id.Mode eq 'Mark' then begin CASE ID.Select_Mode OF 'Box': begin tmp=a.a w_box_cursor,ev,xy,init=a.init,cur=tmp a.a=tmp a.init=0 a.xy=xy end 'Trace': begin if ev.press then ID.press=1 if ev.release then ID.press=0 if ID.press eq 0 then return if n_elements(trace) eq 1 then trace=[ev.x, ev.y] else begin trace=[[trace], [ev.x, ev.y]] Sz_tr=size(trace) plots,trace(0,Sz_tr(2)-[1,2]), trace(1,Sz_tr(2)-[1,2]), /dev empty endelse end 'Triangle': begin if ev.press eq 0 then return Data.Triangle(*, Data.Attempt)=[ev.x, ev.y] if Data.Attempt then begin x0=Data.Triangle(0,0) x1=Data.Triangle(0,1) y0=Data.Triangle(1,0) y1=Data.Triangle(1,1) k=(y1-y0)/(x1-x0) b=y0-k*x0 wset,ID.Win(0) plotline, k, [x0, y0], /dev, /noc, col=0;!d.n_colors-1 CASE 1 OF (b lt 0) and (k*!d.x_size+b le !d.y_size): $ Data.Triangle=[[-b/k,0], [!d.x_size, 0], [!d.x_size, !d.x_size*k+b], [-b/k,0]] (b lt 0) and (k*!d.x_size+b gt !d.y_size) and ((-b/k) gt !d.x_size/2): $ Data.Triangle=[[-b/k,0], [!d.x_size, 0], [!d.x_size, !d.y_size], [!d.y_size/k-b/k, !d.y_size]] (b lt 0) and (k*!d.x_size+b gt !d.y_size) and ((-b/k) le !d.x_size/2): $ Data.Triangle=[[0,0], [-b/k,0], [(!d.y_size-b)/k, !d.y_size], [0, !d.y_size]] (b ge 0) and (k*!d.x_size+b le !d.y_size/2) and (k*!d.x_size+b ge 0): $ Data.Triangle=[[0,0], [!d.x_size, 0], [!d.x_size, !d.x_size*k+b], [0,b]] (b ge 0) and (k*!d.x_size+b gt !d.y_size/2) and (k*!d.x_size+b le !d.y_size): $ Data.Triangle=[[0,b], [!d.x_size, !d.x_size*k+b], [!d.x_size, !d.y_size], [0, !d.y_size]] (b ge 0) and (k*!d.x_size+b gt !d.y_size/2) and (k*!d.x_size+b gt !d.y_size): $ Data.Triangle=[[0,b], [(!d.y_size-b)/k, !d.y_size], [0, !d.y_size], [0, b]] (b ge 0) and (b le !d.y_size) and (k*!d.x_size+b le 0): $ Data.Triangle=[[0,0], [-b/k,0], [0,b], [0,0]] (b gt !d.y_size) and (k*!d.x_size+b le 0) and ((-b/k) le !d.x_size/2): $ Data.Triangle=[[0,0], [-b/k,0], [(!d.y_size-b)/k,!d.y_size], [0,!d.y_size]] (b gt !d.y_size) and (k*!d.x_size+b le 0) and ((-b/k) gt !d.x_size/2): $ Data.Triangle=[[-b/k,0], [!d.x_size,0], [!d.x_size, !d.y_size], [(!d.y_size-b)/k,!d.y_size]] (b gt !d.y_size) and (k*!d.x_size+b gt 0): $ Data.Triangle=[[(!d.y_size-b)/k,!d.y_size], [!d.x_size, k*!d.x_size+b], [!d.x_size, !d.y_size], [(!d.y_size-b)/k,!d.y_size]] ;(b gt !d.y_size) and (k*!d.x_size+b gt 0) and ((-b/k) gt !d.x_size/2): $ ;Data.Triangle=[[-b/k,0], [!d.x_size,0], [!d.x_size, !d.y_size], [(!d.y_size-b)/k,!d.y_size]] ELSE: ENDCASE C=Data.Triangle polyfill,C(0,*), C(1,*), /dev, col=0 empty endif Data.Attempt=(Data.Attempt+1) mod 2 end ELSE: ENDCASE endif else begin device, /cursor_cross a.init=1 endelse if ev.press then begin if ID.Mode eq 'Profiles' then begin wset,ID.Win(1) plot,image(*,ev.y/ID.factor > 0 < (Sz(2)-1)), /yno, col=0, back=!d.n_colors-1, $ xmar=[6,2], ymar=[2,1], /xst Scale, tmp, /mem ID.Sc(1)=tmp wset,ID.Win(2) plot,image(ev.x/ID.factor > 0 < (Sz(1)-1),*), indgen(Sz(2)), col=0, back=!d.n_colors-1, $ xmar=[6,2], ymar=[2,1], /yst Scale, tmp, /mem ID.Sc(2)=tmp endif endif return endif if ev.id eq ID.Draw(1) then begin window_set, ID.Win(1), sc=ID.Sc(1) widget_control, ID.Label(1), set_val= $ string(ev.x/ID.factor, ev.y/ID.factor, format='(i3, ", ", i3)') return endif if ev.id eq ID.Draw(2) then begin window_set, ID.Win(2), sc=ID.Sc(2) widget_control, ID.Label(2), set_val= $ string(ev.x/ID.factor, ev.y/ID.factor, format='(i3, ", ", i3)') return endif widget_control, ev.id, get_uval=uv, /hourglass CASE uv OF "DONE": begin widget_control, ev.top, /destroy if ID.group_leader ne 0L then if widget_info(ID.group_leader,/valid) then $ widget_control, ID.group_leader, /show ID=(image=(header=(index=(a=(data=0))))) trace=(disk_index=0) end "Xloadct": begin widget_control, /hour Xloadct end "Calculator": begin widget_control, /hour Wcalc end "Profiles": ID.Mode='Profiles' "Header": begin widget_control,/hour xtext,text=header end "QS_S": Data.Scaling=1 "Whole_S": Data.Scaling=0 "Save": begin file=ID.File path=subdir(ID.File) widget_control, /hour New_File=pickfile(/write, path=path, file=file) if New_File eq '' then return widget_control, /hour minval=min(image, max=maxval) bscale=(maxval-minval)*1e-4 bzero=float(minval) image_to_write=fix((image-bzero)/bscale) Sz=size(image) suneph, Data.Date, Data.Time, SUN solr=SUN.R*!Radeg*3600 ind=(where(strmid(header,0,2) eq 'Ro'))(0) if ind ge 0 then header=[header(0:ind-1), header(ind+1:*)] Ref_Culm=strtrim(fh_r_key(header,'CULMIN', error=error),2) ref_decl=hms(strtrim(fh_r_key(header,'DELTA', error=error),2)) Ref_Freq=fh_r_key(header,'FREQ', error=error) sxdelpar,header,'CULMIN' sxdelpar,header,'DELTA' sxdelpar,header,'FREQ' sxaddpar,header,'BITPIX',16 sxaddpar,header,'NAXIS1',Sz(1) sxaddpar,header,'NAXIS2',Sz(2) sxaddpar,header,'BSCALE',bscale, ' REAL = DATA*BSCALE + BZERO',after='NAXIS2' sxaddpar,header,'BZERO',bzero, after='BSCALE' sxaddpar,header,'DATAMIN',Data.Min, after='BZERO' sxaddpar,header,'DATAMAX',Data.Max, after='DATAMIN' date=strmid(Data.date,0,2)+'/'+strmid(Data.date,3,2)+'/'+strmid(Data.date,6,2) time_obs=fh_r_key(header, 'time-obs') sxdelpar,header,'DATE-OBS' sxdelpar,header,'TIME-OBS' sxaddpar,header,'DATE-OBS', date, after='NAXIS2' sxaddpar,header,'TIME-OBS', time_obs, ' reference time', after='DATE-OBS' sxaddpar,header,'TSTART', fh_r_key(header, 'BEG-OBS'), after='TIME-OBS' sxaddpar,header,'TSTOP', fh_r_key(header, 'END-OBS'), after='TSTART' sxdelpar,header,'BEG-OBS' sxdelpar,header,'END-OBS' sxdelpar,header,'MIN' sxdelpar,header,'MAX' sxdelpar,header,'DELTA' sxdelpar,header,'CENTER-X' sxdelpar,header,'CENTER-Y' sxdelpar,header,'CREATORS' sxaddpar,header,'CRVAL1',0., after='DATAMAX',format='f4.2',' disk center X' sxaddpar,header,'CRVAL2',0., after='CRVAL1',format='f4.2',' disk center Y' sxaddpar,header,'CTYPE1', 'SOLAR-WEST ',after='CRVAL2', ' oriented heliocentrically' sxaddpar,header,'CTYPE2', 'SOLAR-NORTH',after='CTYPE1' sxaddpar,header,'CRPIX1', float(Sz(1)/2)+1,after='CTYPE2', format='f6.2' sxaddpar,header,'CRPIX2', float(Sz(2)/2)+1,after='CRPIX1', format='f6.2' sxaddpar,header,'CDELT1', solr/ID.R*ID.Factor, after='CRPIX2', ' arcsec' sxaddpar,header,'CDELT2', solr/ID.R*ID.Factor, after='CDELT1', ' arcsec' sxdelpar,header,'TELESCOP' sxdelpar,header,'OBJECT' sxaddpar,header,'OBS-FREQ', '5.7 GHz ', after='CDELT2' sxaddpar,header,'OBJECT', 'SUN ', after='OBS-FREQ' sxaddpar,header,'TELESCOP', 'SSRT ', ' Siberian Solar Radio Telescope', after='OBJECT' sxaddpar,header,'INSTRUME', 'MFB ', ' multi-frequency filterbank', after='TELESCOP' sxaddpar,header,'ORIGIN', 'BADARY ', ' Radio Astrophysical Observatory', after='INSTRUME' sxaddpar,header,'DATA-TYP', 'DIRTY_MAP', ' calibrated', after='ORIGIN' sxaddpar,header,'POLARIZ', 'R+L ', after='DATA-TYP' sxdelpar,header,'XSIZE' sxdelpar,header,'YSIZE' sxaddpar,header,'DEC', SUN.Decl*!Radeg, ' declination (degree)' sxaddpar,header,'CULM', smh(SUN.tcul*3600,ms=1), ' culmination at Badary' sxaddpar,header,'SOLR', solr, ' optical solar radius (arcsec)' sxaddpar,header,'SOLP', SUN.Dp*!radeg, ' solar polar angle (degree)' sxaddpar,header,'SOLB', SUN.B0*!radeg, ' solar b0 (degree)' sxaddpar,header,'CARR-LNG', SUN.Karr*!radeg, ' Carringt. long of the sol. cent. (degree)' sxaddpar,header,'REF-DEC', Ref_decl, ' reference declination (degree)' sxaddpar,header,'REF-CULM', Ref_culm, ' reference culmination ' sxaddpar,header,'REF-FREQ', Ref_freq, ' reference frequency (MHz)' writefits,New_File,image_to_write,header end "Box": begin ID.Mode='Mark' ID.Select_Mode='Box' end "Trace": begin ID.Mode='Mark' ID.Select_Mode='Trace' trace=0 end "Triangle": begin ID.Mode='Mark' ID.Select_Mode='Triangle' Data.Triangle(*,*)=0 end "Accept": begin wset,ID.Win(0) CASE ID.Select_Mode OF 'Box': begin V_x=[a.xy(0,0),a.xy(1,0),a.xy(1,0),a.xy(0,0),a.xy(0,0)] V_y=[a.xy(0,1),a.xy(0,1),a.xy(1,1),a.xy(1,1),a.xy(0,1)] end 'Trace': begin V_x=[transpose(trace(0,*)), trace(0,0)] V_y=[transpose(trace(1,*)), trace(1,0)] trace=0 end ELSE: return ENDCASE polyfill, V_x, V_y, /dev,col=(Data.Plot_mean-Data.Plot_min)*Data.Plot_factor ind_cur=polyfillv(V_x/ID.factor, V_y/ID.factor, !d.x_size/ID.factor, !d.y_size/ID.factor) if n_elements(index) eq 1 then index=ind_cur else begin index=[index, ind_cur] index=index(uniq(index, sort(index))) endelse wset,ID.Win(1) erase,!d.n_colors-1 temp=bytscl(image) temp(index)=(Data.Plot_mean-Data.Plot_min)*Data.Plot_factor Data.Plot_Max=max(temp)/Data.Plot_factor+Data.Plot_min Sz=size(image) V_size=!d.y_size < !d.x_size tvscl,congridg(temp, V_size, V_size) ;tv,Data.factor*(temp-Data.min) if Data.Scaling then begin wset, ID.Win(0) if ID.factor ne 1 then $ tvscl, bytscl(congrid(image, !d.x_size, !d.y_size, /int),max=Data.Plot_Max) else $ tvscl, bytscl(image, max=Data.Plot_Max) endif empty end "Flatten": begin if n_elements(disk_index) le 1 then begin N=2048 t=findgen(N)/(N-1)*2*!pi xx=cos(t)*ID.R/ID.factor+ID.Centre(0)/ID.factor yy=sin(t)*ID.R/ID.factor+ID.Centre(1)/ID.factor disk_index=polyfillv(xx, yy, Sz(1), Sz(2)) t=(xx=(yy=0)) endif Mark=make_array(size=size(image), /byte, val=1b) Mark(disk_index)=0 Mark(index)=1b Quiet_Sun=image(where(Mark eq 0)) Data.Mean=total(Quiet_Sun)/n_elements(Quiet_Sun) Data.Max=max(Quiet_Sun) Quiet_Sun=0 x=image x(index)=Data.Mean Mark=make_array(size=size(x), /byte, val=1b) Mark(disk_index)=0 Outside_index=where(Mark) Mark=0 Outside=x(Outside_index) Mean_Outside=total(Outside)/n_elements(Outside) x(Outside_index)=x(Outside_index)-Mean_Outside+Data.Mean ;Outside_index=(Outside=0) Outside=0 Sz=size(x) if Sz(0) eq 3 then x=total(x,1) else x=float(x) Sz=size(x) smooth_width=30 aux_w=smooth_width/2 width=20 x1=replicate(1,aux_w)#total(x(0:width,*),1)/(width+1) x2=replicate(1,aux_w)#total(x(Sz(2)-width-1:*,*),1)/(width+1) x=[x1,x,x2] x1=(x2=0) x0=total(x(*,0:width),2)/(width+1)#replicate(1,aux_w) x3=total(x(*,Sz(2)-width-1:*),2)/(width+1)#replicate(1,aux_w) x=[[x0],[x],[x3]] x0=(x3=0) Sz=size(x) x=(smooth(x,smooth_width))(aux_w:Sz(1)-aux_w-1,aux_w:Sz(1)-aux_w-1) inside=x(disk_index) Mean_inside=total(inside)/n_elements(inside) factor=x/Mean_inside factor(Outside_index)=1;(x(Outside_index)+Mean_Outside-Data.Mean)/Mean_Outside factor=smooth(factor,5) image=image/factor wset, ID.Win(0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image empty end "Filter": begin x=image x(index)=Data.Mean x=median(x,3) x(index)=image(index) image=temporary(x) wset,ID.Win(0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image empty end '1D scan': begin ID.Mode='1D scan' wset,ID.Win(1) plot,total(image,2)/Sz(2), /yno, col=0, back=!d.n_colors-1, $ xmar=[6,2], ymar=[2,1], /xst Scale, tmp, /mem ID.Sc(1)=tmp wset,ID.Win(2) plot,total(image,1)/Sz(1),indgen(Sz(2)), col=0, back=!d.n_colors-1, $ xmar=[6,2], ymar=[2,1], /yst Scale, tmp, /mem ID.Sc(2)=tmp empty end "Load": begin widget_control, /hour filt='*.fit *.fts' if ID.file eq '' then begin path=getenv('optics_dir') if path ne '' then file=pickfile(/read, filt=filt, path=path) else $ file=pickfile(/read, filt=filt) endif else begin path=subdir(ID.File) file=pickfile(/read, filt=filt, path=path, file=ID.File) endelse if file eq '' then return else ID.File=file ID.Mode ='Init' Data.Scaling=0 index=0 widget_control, /hour ; image=rfitsg(file,index=fnum,key_struct=hstruc,header=header,error=err, $ ; user_struct=ustruc,date_obs=date,time_obs=time ,/sc) image=readfits(file, header) ;image=image-min(image) wset, ID.Win(0) Szx=size(image) ID.factor=float(!d.x_size)/Szx(1) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image max_val=max(image, min=min_val) Data.Plot_min=(Data.min=min_val) Data.Plot_max=(Data.max=max_val) Data.Plot_factor=float(!d.n_colors)/(max_val-min_val) Data.Plot_mean=(Data.mean=total(image)/n_elements(image)) empty Date=fh_r_key(header,'date-obs', error=error) Dima=fh_r_key(header,'creators', error=error1) Dima1=fh_r_key(header,'author', error=error1) Les=fh_r_key(header,'CTYPE1', error=error2) if (dima1 eq 'S&D') then goto, Label_Dima1 if (dima ne 'S&D') and (error2 eq 1) then begin day=strmid(date,3,2) if strmid(day,0,1) eq ' ' then strput,day,'0',0 month=strmid(date,0,2) if strmid(month,0,1) eq ' ' then strput,month,'0',0 Data.date=day+' '+month+' '+strmid(date,6,2) endif else Data.date=date Data.Time=fh_r_key(header,'time-obs', error=error, /char) suneph, Data.Date, Data.Time, Sun Radius=fh_r_key(header,'radius', error=error) if error then Radius=SUN.R*!radeg*60 X_origin=fh_r_key(header,'x-origin', error=error) Y_origin=fh_r_key(header,'y-origin', error=error) X_obs=fh_r_key(header,'X-obs', error=error) if error then X_obs=fh_r_key(header,'X-extent', error=error) if error then begin X_obs=fh_r_key(header,'Xsize', error=error) X_obs=hms(strtrim(X_obs,2))*60 endif Y_obs=fh_r_key(header,'Y-obs', error=error) if error then Y_obs=fh_r_key(header,'Y-extent', error=error) if error then begin Y_obs=fh_r_key(header,'Ysize', error=error) Y_obs=hms(strtrim(Y_obs,2))*60 endif X_cent=fh_r_key(header,'center-X', error=error) if error then X_cent=0.d0 Y_cent=fh_r_key(header,'center-Y', error=error) if error then Y_cent=0.d0 if dima eq 'S&D' then begin X_cent=0 X_origin=-X_obs/2 Y_cent=0 Y_origin=-Y_obs/2 endif P0=fh_r_key(header,'P0', error=error) if error then P0=SUN.dp*!radeg ID.R=Radius*Szx(1)/X_obs*ID.factor ID.Centre= [(X_cent-X_origin)/X_obs*!d.x_size, $ (Y_cent-Y_origin)/Y_obs*!d.y_size] if error2 eq 0 then begin Radius=sxpar(header, 'solr')/60. X_obs=sxpar(header, 'cdelt1')*512./60 ID.R=Radius*Szx(1)/X_obs*ID.factor crpix1=sxpar(header, 'CRPIX1')-1 crpix2=sxpar(header, 'CRPIX2')-1 if crpix1 lt Szx(1)/3. then crpix1=Szx(1)/2. if crpix2 lt Szx(2)/3. then crpix2=Szx(2)/2. ID.Centre=[CRPIX1/(Szx(1))*!d.x_size, CRPIX2/(Szx(2))*!d.y_size] endif Label_dima1: if dima1 eq 'S&D' then begin Data.Date=sxpar(header,'date-obs') Data.Time=sxpar(header,'time-obs') suneph, Data.Date, Data.Time, Sun Radius=SUN.R*!radeg*60 X_cent=0.d0 Y_cent=0.d0 crpix1=sxpar(header, 'CRPIX1')-1 crpix2=sxpar(header, 'CRPIX2')-1 X_obs=sxpar(header, 'cdelt1')*Szx(1)/60. ID.R=Radius*Szx(1)/X_obs*ID.factor Y_obs=sxpar(header, 'cdelt2')*Szx(2)/60. ID.Centre=[CRPIX1/(Szx(1))*!d.x_size, CRPIX2/(Szx(2))*!d.y_size] endif draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 widget_control, ID.Label(3), set_val= $ 'File: '+(name_extract(ID.File))(0)+', '+ $ Date_string(Data.Date)+ $ ', '+Data.Time+' UT' empty end 'Moire': begin widget_control,/hour ID.Mode ='Moire' x=image N=2048 t=findgen(N)/(N-1)*2*!pi xx=cos(t)*ID.R/ID.factor+ID.Centre(0)/ID.factor yy=sin(t)*ID.R/ID.factor+ID.Centre(1)/ID.factor disk_index=polyfillv(xx, yy, Sz(1), Sz(2)) t=(xx=(yy=0)) Mark=make_array(size=size(image), /byte, val=1b) Mark(disk_index)=0 Mark(index)=1b Quiet_Sun=image ind=(where(Mark eq 0)) Quiet_Sun(where(Mark eq 1))=0 Data.Mean=total(Quiet_Sun(ind))/n_elements(ind) Data.Plot_Max=max(Quiet_Sun) Quiet_Sun(where(Mark eq 1))=Data.Mean Quiet_Sun=(Mark=0) x(index)=Data.mean Sz=size(x) if Sz(0) eq 3 then x=total(x,1) else x=float(x) Sz=size(x) smooth_width=100 aux_w=smooth_width/2 width=10 ;level_x=(total(x(0:width,*),1)/(width+1)+ $ ; total(x(Sz(2)-width-1:*,*),1)/(width+1))*0.5 ;level_x=level_x-smooth(level_x,width) ;x=x-replicate(1,Sz(1))#level_x ;level_y=(total(x(*,0:width),2)/(width+1)+ $ ; total(x(*,Sz(2)-width-1:*),2)/(width+1))*0.5 ;x=x-level_y#replicate(1,Sz(2)) ;Data.min=min(x) x=x-Data.min x1=replicate(1.,aux_w)#total(x(0:width,*),1)/(width+1) x2=replicate(1.,aux_w)#total(x(Sz(2)-width-1:*,*),1)/(width+1) x=[x1,x,x2] x1=(x2=0) x0=total(x(*,0:width),2)/(width+1)#replicate(1.,aux_w) x3=total(x(*,Sz(2)-width-1:*),2)/(width+1)#replicate(1.,aux_w) x=[[x0],[x],[x3]] x0=(x3=0) Sz=size(x) b_hor=total(x,1) a_hor=b_hor/smooth(b_hor,smooth_width) a_h=replicate(1.,Sz(2))#a_hor a_h=min(a_h)/a_h x=x*a_h a_hor=(b_hor=0) b_ver=total(x,2) x=0 a_ver=b_ver/smooth(b_ver,smooth_width) a_v=a_ver#replicate(1.,Sz(2)) a_v=min(a_v)/a_v a_ver=(b_ver=0) image=image *a_h(aux_w:Sz(1)-aux_w-1,aux_w:Sz(1)-aux_w-1) $ *a_v(aux_w:Sz(1)-aux_w-1,aux_w:Sz(1)-aux_w-1) wset, ID.Win(0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image empty end 'Rotate': begin wset,ID.Win(0) image=rotate(image,7) suneph,Data.Date,Data.Time,sun image=rot(image, sun.dp*!Radeg, /int, miss=0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image end 'X+': begin wset,ID.Win(0) image=shift(image,1,0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'X+2': begin wset,ID.Win(0) image=shift(image,2,0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'X+5': begin wset,ID.Win(0) image=shift(image,5,0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'X-': begin wset,ID.Win(0) image=shift(image,-1,0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'X-2': begin wset,ID.Win(0) image=shift(image,-2,0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'X-5': begin wset,ID.Win(0) image=shift(image,-5,0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Y+': begin wset,ID.Win(0) image=shift(image,0,1) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Y+2': begin wset,ID.Win(0) image=shift(image,0,2) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Y+5': begin wset,ID.Win(0) image=shift(image,0,5) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Y-': begin wset,ID.Win(0) image=shift(image,0,-1) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Y-2': begin wset,ID.Win(0) image=shift(image,0,-2) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Y-5': begin wset,ID.Win(0) image=shift(image,0,-5) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end 'Calibrate': begin widget_control,/hour ID.Mode ='Calibrate' x=image N=2048 t=findgen(N)/(N-1)*2*!pi Radio=1.07 xx=cos(t)*ID.R/ID.factor*Radio +ID.Centre(0)/ID.factor yy=sin(t)*ID.R/ID.factor*Radio +ID.Centre(1)/ID.factor disk_index0=polyfillv(xx, yy, Sz(1), Sz(2)) xx=(yy=0) Mark=make_array(size=size(image), /byte, val=1b) Mark(disk_index0)=0 ind=(where(Mark eq 1)) Sky=total(image(ind))/n_elements(ind) image=image-Sky Radio=0.9 xx=cos(t)*ID.R/ID.factor*Radio +ID.Centre(0)/ID.factor yy=sin(t)*ID.R/ID.factor*Radio +ID.Centre(1)/ID.factor disk_index=polyfillv(xx, yy, Sz(1), Sz(2)) xx=(yy=0) Mark=make_array(size=size(image), /byte, val=1b) Mark(disk_index)=0 Outside_index=where(Mark) Mark(index)=1b ind=(where(Mark eq 0)) Data.Mean=total(image(ind))/n_elements(ind) image=image/Data.Mean*1.6e4 x = image Radio=1.02 xx=cos(t)*ID.R/ID.factor*Radio +ID.Centre(0)/ID.factor yy=sin(t)*ID.R/ID.factor*Radio +ID.Centre(1)/ID.factor disk_index0=polyfillv(xx, yy, Sz(1), Sz(2)) xx=(yy=0) Mark=make_array(size=size(image), /byte, val=1b) Mark(disk_index0)=0 Outside_index=where(Mark) Mark(index)=1b Mark(Outside_index)=0 ind = (where(Mark eq 1)) if ind(0) ge 0 then x(ind) = 1.6e4 Mark=make_array(size=size(x), /byte, val=0b) Mark(index)=1b Mark(disk_index0)=0 ind = (where(Mark eq 1)) if ind(0) ge 0 then x(ind) = 0 slope = rebin(float(sfit(rebin(x, Sz(1)/4, Sz(2)/4), 1)), Sz(1), Sz(2)) slope = slope-mean(slope) image = image-slope Data.Min=min(image, max=amax) Data.Max=amax end 'Resize': begin suneph, Data.Date, Data.Time, SUN solr=SUN.R*!Radeg*3600 pix1=solr/ID.R pix=4.91104 Sz=size(image) factor=Sz(1)/512.*pix1/pix ID.factor=float(!d.x_size)/512. ID.Centre=200 ID.R=ID.R*factor image=congridg(image, 512, 512) image=rot(image, 0, factor, /int, miss=0) if ID.factor ne 1 then tvscl, congrid(image, !d.x_size, !d.y_size, /int) else $ tvscl, image draw_circle,ID.Centre, ID.R, /noer, /axes, linest=1, a_lines=3 end ELSE: ENDCASE empty end pro _s_m_imp, group_leader=group_leader common _s_m_imp, ID, image, header, index, a, data, disk_index, trace if xregistered('_s_m_imp') then return image=bytarr(512,512) if n_elements(group_leader) le 0 then group_leader=0L Ax={Axes, x:{!Axis}, y:{!Axis}, z:{!Axis}, map:!Map} ID={group_leader:group_leader, draw:lonarr(3), Win:lonarr(3), Label:lonarr(4), $ Sc:replicate(Ax,3), Mode:'Init', press:0, $ file:'', R:0., Centre: [0.,0.], factor:1., Mark:0L, $ Moire:0L, Flatten:0L, Filter:0L, Select_Mode:'Box'} Data={Date:' ', Time:' ', Mean:0., Min:0., factor:1., Triangle:fltarr(2,4), $ Attempt:0, Max:0., Scaling:0, $ Plot_Mean:0., Plot_Min:0., Plot_Max:0., Plot_factor:1.} Ax=0 init_structure={w_b_state, $ x:0, y:0, press:0, first:1, Xc:[0.,0.], Yc:[0.,0.], $ Output:intarr(2,2), stretch:0., move:0.} a={init:1, xy:intarr(2,2), a:init_structure} bm_box= [ $ [000B, 000B], $ [000B, 000B], $ [000B, 000B], $ [248B, 031B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [008B, 016B], $ [248B, 031B], $ [000B, 000B], $ [000B, 000B], $ [000B, 000B] $ ] bm_triangle= [ $ [000B, 000B], $ [000B, 000B], $ [000B, 000B], $ [248B, 031B], $ [016B, 016B], $ [032B, 016B], $ [064B, 016B], $ [128B, 016B], $ [000B, 017B], $ [000B, 018B], $ [000B, 020B], $ [000B, 024B], $ [000B, 016B], $ [000B, 000B], $ [000B, 000B], $ [000B, 000B] $ ] bm_trace= [ $ [000B, 000B], $ [192B, 001B], $ [032B, 002B], $ [016B, 004B], $ [008B, 008B], $ [008B, 016B], $ [008B, 032B], $ [004B, 032B], $ [004B, 032B], $ [004B, 032B], $ [004B, 016B], $ [004B, 008B], $ [008B, 008B], $ [112B, 008B], $ [128B, 007B], $ [000B, 000B] $ ] bm_OK= [ $ [000B, 000B], $ [000B, 000B], $ [000B, 000B], $ [056B, 132B], $ [068B, 068B], $ [130B, 036B], $ [130B, 020B], $ [130B, 012B], $ [130B, 020B], $ [130B, 036B], $ [068B, 068B], $ [056B, 132B], $ [000B, 000B], $ [000B, 000B], $ [000B, 000B], $ [000B, 000B] $ ] mainbase=widget_base(tit='SSRT map enhancer',/colu) menubase=widget_base(mainbase,/row) button=widget_button(menubase, val='DONE', uval='DONE') button=widget_button(menubase, val='File', /menu) junk=widget_button(button, val='Load', uval='Load') junk=widget_button(button, val='Header', uval='Header') shift_but=widget_button(button, val='Centering', /menu) X_shift_but=widget_button(shift_but, val='X', /menu) X_shift_but_plus=widget_button(X_shift_but, val='+', /menu) button0=widget_button(X_shift_but_plus, val='+1', uval='X+') button0=widget_button(X_shift_but_plus, val='+2', uval='X+2') button0=widget_button(X_shift_but_plus, val='+5', uval='X+5') X_shift_but_minus=widget_button(X_shift_but, val='-', /menu) button0=widget_button(X_shift_but_minus, val='-1', uval='X-') button0=widget_button(X_shift_but_minus, val='-2', uval='X-2') button0=widget_button(X_shift_but_minus, val='-5', uval='X-5') Y_shift_but=widget_button(shift_but, val='Y', /menu) Y_shift_but_plus=widget_button(Y_shift_but, val='+', /menu) button0=widget_button(Y_shift_but_plus, val='+1', uval='Y+') button0=widget_button(Y_shift_but_plus, val='+2', uval='Y+2') button0=widget_button(Y_shift_but_plus, val='+5', uval='Y+5') Y_shift_but_minus=widget_button(Y_shift_but, val='-', /menu) button0=widget_button(Y_shift_but_minus, val='-1', uval='Y-') button0=widget_button(Y_shift_but_minus, val='-2', uval='Y-2') button0=widget_button(Y_shift_but_minus, val='-5', uval='Y-5') ; button0=widget_button(shift_but, val='X-', uval='X-' ; Y_shift_but=widget_button(shift_but, val='Y', /menu) ; button0=widget_button(shift_but, val='X+', uval='X+') ; button0=widget_button(shift_but, val='X-', uval='X-' ; button0=widget_button(shift_but, val='X+', uval='X+') ; button0=widget_button(shift_but, val='X-', uval='X-') ; button0=widget_button(shift_but, val='Y+', uval='Y+') ; button0=widget_button(shift_but, val='Y-', uval='Y-') ; ID.Mark=widget_button(button, val='Mark sources', /menu) ; junk=widget_button(ID.Mark, val='Enter mode', uval='Box') ; junk=widget_button(ID.Mark, val='Accept', uval='Accept') ID.Moire=widget_button(button, val='Remove moire', uval='Moire') calib_button=widget_button(button, val='Calibrate', uval='Calibrate') rot_button=widget_button(button, val='Rotate', uval='Rotate') Resize_button=widget_button(button, val='Resize to NRH', uval='Resize') ; ID.Flatten=widget_button(button, val='Flatten', uval='Flatten') ; ID.Filter=widget_button(button, val='Filter', uval='Filter') junk=widget_button(button, val='Save', uval='Save') button=widget_button(menubase, val='Tools', /menu) junk=widget_button(button, val='Palette', uval='Xloadct') junk=widget_button(button, val='Scaling', /menu) junk1=widget_button(junk, val='Whole range', uval='Whole_S') junk1=widget_button(junk, val='Quiet Sun', uval='QS_S') junk=widget_button(button, val='Profiles', uval='Profiles') junk=widget_button(button, val='1D scan', uval='1D scan') junk=widget_button(button, val='Calculator', uval='Calculator') rowbase=widget_base(mainbase,/row) leftbase=widget_base(rowbase,/colu) rightbase=widget_base(rowbase,/colu) DrawSize=400 edit_base=widget_base(leftbase,/row) button=widget_button(edit_base, val=bm_box, uval='Box') ;button=widget_button(edit_base, val=bm_triangle, uval='Triangle') button=widget_button(edit_base, val=bm_trace, uval='Trace') button=widget_button(edit_base, val=bm_OK, uval='Accept') if !version.release ge 4 then begin ID.Label(3)=widget_label(leftbase, val=' ', /dyn) ID.Draw(0)=widget_draw(leftbase, xs=DrawSize, ys=DrawSize, $ /button, /motion, /fra) ID.Label(0)=widget_label(leftbase, val=' ', /fra, /dyn) for j=1,2 do begin ID.Draw(j)=widget_draw(rightbase, xs=DrawSize*0.8, ys=DrawSize*0.55, $ /button, /motion, /fra) ID.Label(j)=widget_label(rightbase, val=' ', /fra, /dyn) endfor endif else begin ID.Label(3)=widget_label(leftbase, val=' ') ID.Draw(0)=widget_draw(leftbase, xs=DrawSize, ys=DrawSize, /button, $ /motion, /fra) ID.Label(0)=widget_label(leftbase, val=' ', /fra) for j=1,2 do begin ID.Draw(j)=widget_draw(rightbase, xs=DrawSize*0.8, ys=DrawSize*0.55, $ /button, /motion, /fra) ID.Label(j)=widget_label(rightbase, val=' ', /fra) endfor endelse widget_control, mainbase, /real, /hour for j=0,2 do begin widget_control, ID.Draw(j), get_val=tmp ID.Win(j)=tmp wset, ID.Win(j) plot,indgen(10),xst=4,yst=4,/nod,back=!d.n_colors-1 Scale, tmp, /mem ID.Sc(j)=tmp endfor xmanager,'_s_m_imp',mainbase end ####################################################### function _trend, x, width if n_elements(width) le 0 then width=10 return, x-trend(x, width) end #######################################################