diff --git a/fiasco/tests/idl/ssw_gen_functions/datatype.pro b/fiasco/tests/idl/ssw_gen_functions/datatype.pro new file mode 100644 index 00000000..f2e7170b --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/datatype.pro @@ -0,0 +1,156 @@ +function datatype,var, flag0, descriptor=desc, help=hlp, Tname = tname + ;+ +; NAME: +; DATATYPE() +; +; PURPOSE: +; Returns the data type of a variable. +; +; EXPLANATION: +; This routine returns the data type of a variable in a format specified +; by the optional flag parameter. Can also be used to emulate, in +; earlier versions of IDL, the SIZE(/TNAME) option introduced in V5.1. +; +; This routine was originally derived from the JHUAPL library ***but has +; diverged from the JHUAPL library for the newer data types.*** For this +; reason DATATYPE is no longer used in any other procedure in the IDL +; Astronomy Library. +; CALLING SEQUENCE : +; Result = DATATYPE( VAR [, FLAG , /TNAME, /DESC ] ) +; +; INPUTS: +; VAR = Variable to examine, no restrictions +; +; OPTIONAL INPUT PARAMETERS: +; FLAG = Integer between 0 and 3 giving the output format flag as +; explained below. The default is 0. +; /DESC = If set, then return a descriptor for the given variable. If the +; variable is a scalar the value is returned as a string. If it is +; an array a description is returned just like the HELP command +; gives. Ex:' +; IDL> print, datatype(fltarr(2,3,5),/desc) gives the string +; 'FLTARR(2,3,5)' +; /TNAME - If set, then returns a identical result to the use of the /TNAME +; keyword to the SIZE() function in IDL V5.2 and later. +; Overrides the value of FLAG. +; /HELP = If set, then a short explanation is printed out. +; +; OUTPUT PARAMETERS: +; The result of the function is the either a string or integer giving the +; data type of VAR. Depending on the value of FLAG or /TNAME, the result +; will be one of the values from the following table: +; +; FLAG = 0 FLAG = 1 FLAG = 2 FLAG = 3 /TNAME +; +; UND Undefined 0 UND UNDEFINED +; BYT Byte 1 BYT BYTE +; INT Integer 2 INT INT +; LON Long 3 LON LONG +; FLO Float 4 FLT FLOAT +; DOU Double 5 DBL DOUBLE +; COM Complex 6 COMPLEX COMPLEX +; STR String 7 STR STRING +; STC Structure 8 STC STRUCT +; DCO DComplex 9 DCOMPLEX DCOMPLEX +; PTR Pointer 10 PTR POINTER +; OBJ Object 11 OBJ OBJREF +; UIN UInt 12 UINT UINT +; ULN ULong 13 ULON ULONG +; L64 Long64 14 LON64 LONG64 +; U64 ULong64 15 ULON64 ULONG64 +; +; +; REVISION HISTORY: +; Original Version: R. Sterner, JHU/APL, 24 October 1985. +; Major rewrite, add /TNAME keyword, unsigned and 64 bit datatypes +; W. Landsman August 1999 +; Zarro (SM&A/GSFC) - November 2001, replace error stops by continues +;- +;------------------------------------------------------------- + + + if (N_params() lt 1) or keyword_set(hlp) then begin + print,' Datatype of variable as a string (3 char or spelled out).' + print,' typ = datatype(var, [flag])' + print,' var = variable to examine. in' + print,' flag = output format flag (def=0). in' + print,' typ = datatype string or number. out' + print,' flag=0 flag=1 flag=2 flag=3 /TNAME' + print,' UND Undefined 0 UND UNDEFINE' + print,' BYT Byte 1 BYT BYTE' + print,' INT Integer 2 INT INT' + print,' LON Long 3 LON LONG' + print,' FLO Float 4 FLT FLOAT' + print,' DOU Double 5 DBL DOUBLE' + print,' COM Complex 6 COMPLEX COMPLEX' + print,' STR String 7 STR STRING' + print,' STC Structure 8 STC STRUCT' + print,' DCO DComplex 9 DCOMPLEX DCOMPLEX' + print,' PTR Pointer 10 PTR POINTER' + print,' OBJ Object 11 OBJ OBJREF' + print,' UIN UInt 12 UINT UINT' + print,' ULO ULong 13 ULON ULONG' + print,' L64 Long64 14 LON64 LONG64' + print,' U64 ULong64 15 ULON64 ULONG64' + print,' Keywords:' + print,' /TNAME - Identical output to SIZE(/TNAME) ' + print,' /DESCRIPTOR returns a descriptor for the given variable.' + print,' If the variable is a scalar the value is returned as' + print,' a string. If it is an array a description is return' + print,' just like the HELP command gives. Ex:' + print,' datatype(fltarr(2,3,5),/desc) gives' + print,' FLTARR(2,3,5) (flag always defaults to 3 for /DESC).' + return, -1 + endif + + s_tname = ['UNDEFINE', 'BYTE','INT','LONG','FLOAT','DOUBLE','COMPLEX',$ + 'STRING','STRUCT','DCOMPLEX','POINTER','OBJREF','UINT','ULONG', $ + 'LONG64','ULONG64'] + + s_flag0 = ['UND','BYT','INT','LON','FLO','DOU','COM','STR','STC','DCO','PTR',$ + 'OBJ','UIN','ULO','L64','U64'] + + s_flag1 = ['Undefined','Byte','Integer','Long','Float','Double','Complex', $ + 'String','Structure','DComplex','Pointer','Object','UInt','ULong',$ + 'Long64','ULong64'] + + s_flag3 = [ 'UND','BYT','INT','LON','FLT','DBL','COMPLEX','STR','STC', $ + 'DCOMPLEX','PTR','OBJ','UINT','ULON','LON64','ULON64'] + + s = size(var) + stype = s[s[0]+1] + if stype GT N_elements(s_tname) then begin + message,'ERROR - Unrecognized IDL datatype',/cont + stype=0 + endif + + if keyword_set(TNAME) then return, s_tname[stype] + + if N_params() lt 2 then flag0 = 0 ; Default flag. + if keyword_set(desc) then flag0 = 3 + + case flag0 of + + 0: return, s_flag0[stype] + 1: return, s_flag1[stype] + 2: return, stype + 3: typ = s_flag3[stype] + else: message,'ERROR - Flag parameter must be between 0 and 3' + endcase + + if keyword_set(desc) then begin + if stype EQ 0 then begin + message,'ERROR - Input variable is undefined',/cont + return,'Undefined' + endif + if s[0] eq 0 then return,strtrim(var,2) ; Return scalar desc. + aa = typ+'ARR(' + for i = 1, s[0] do begin + aa = aa + strtrim(s[i],2) + if i lt s[0] then aa = aa + ',' + endfor + aa = aa+')' + return, aa + endif else return,typ + + end diff --git a/fiasco/tests/idl/ssw_gen_functions/default.pro b/fiasco/tests/idl/ssw_gen_functions/default.pro new file mode 100755 index 00000000..8f397ad3 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/default.pro @@ -0,0 +1,50 @@ +;+ +; Project : SOHO - CDS +; +; Name : DEFAULT +; +; Purpose : Supply default values for variables +; +; Explanation : If the first parameter is not defined, it is +; set to the value of the second parameter. +; +; Use : DEFAULT,VARIABLE,DEFAULT_VALUE +; +; Inputs : VARIABLE : The variable that could take on the default value +; +; DEFAULT_VALUE : The default value. +; +; Opt. Inputs : None. +; +; Outputs : None. +; +; Opt. Outputs: None. +; +; Keywords : None. +; +; Calls : None. +; +; Common : None. +; +; Restrictions: None. +; +; Side effects: None. +; +; Category : Utility, Misc. +; +; Prev. Hist. : Taken from my private library. +; +; Written : Stein Vidar Hagfors Haugan +; +; Modified : Never +; +; Version : 1, 4-Sept-1995 +;- + +PRO DEFAULT,VAR,VAL + +If N_params() lt 2 then message,"Use: DEFAULT,VARIABLE,DEFAULT_VALUE" + +IF N_ELEMENTS(VAR) EQ 0 THEN VAR=VAL + +END diff --git a/fiasco/tests/idl/ssw_gen_functions/delvarx.pro b/fiasco/tests/idl/ssw_gen_functions/delvarx.pro new file mode 100644 index 00000000..64611b93 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/delvarx.pro @@ -0,0 +1,52 @@ +;+ +; NAME: +; DELVARX +; PURPOSE: +; Undefine up to 10 variables for memory management (can call from routines) +; EXPLANATION: +; Similar to the intrinsic DELVAR function, but can be used from any calling level. +; (DELVAR can only be used at the main level.) Note, however, that unlike DELVAR, +; DELVARX does not delete the variables (they will be listed as UNDEFINED when +; viewed with HELP), but only makes them undefined and frees their memory +; +; Also look at the similar Coyote routine UNDEFINE +; http://www.idlcoyote.com/programs/undefine.pro +; +; CALLING SEQUENCE: +; DELVARX, p0, [p1, p2......p9] +; +; INPUTS: +; p0, p1...p9 - variables to delete +; +; OBSOLETE KEYWORD: +; /FREE_MEM - free memory associated with pointers and objects. Since this is now the +; DELVARX default (since 2012) this keyword now does nothing. +; +; METHOD: +; Uses HEAP_FREE and PTR_NEW(/NO_COPY) to undefine variables and free memory +; +; REVISION HISTORY: +; Copied from the Solar library, written by slf, 25-Feb-1993 +; Added to Astronomy Library, September 1995 +; Modified, 26-Mar-2003, Zarro (EER/GSFC) 26-Mar-2003 +; - added FREE_MEM to free pointer/objects +; Modified, 28-Jan-2012, E. Rykoff (SLAC), W. Landsman - +; replace EXECUTE calls with SCOPE_VARFETCH. +; Clarified documentation W. Landsman Sep 2018 +;- + +PRO delvarx, p0,p1,p2,p3,p4,p5,p6,p7,p8,p9,free_mem = free_mem + + npar = N_params() ; Number of parameters + pp = 'p'+strtrim(indgen(npar),1) + + for i=0,npar-1 do begin + defined = N_elements( SCOPE_VARFETCH(pp[i],LEVEL=0)) + if LOGICAL_TRUE(defined) then $ + heap_free, ptr_new( SCOPE_VARFETCH(pp[i],LEVEL=0),/no_copy) + + endfor + + return + end + diff --git a/fiasco/tests/idl/ssw_gen_functions/get_uniq.pro b/fiasco/tests/idl/ssw_gen_functions/get_uniq.pro new file mode 100644 index 00000000..982bb2b7 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/get_uniq.pro @@ -0,0 +1,58 @@ +;+ +; Project : HESSI +; +; Name : get_uniq +; +; Purpose : return unique elements of an array +; +; Category : utility +;; +; Syntax : IDL> out=get_uniq(in) +; +; Inputs : IN = array to search +; +; Outputs : OUT = unique elements +; +; Optional Out: SORDER = sorting index +; +; Keywords : NO_CASE: case insensitive ordering on strings +; COUNT: # of uniq values +; EPSILON: positive number ge 0, for gt 0 the difference between +; two consecutive numbers must be gt epsilon for them to be unique. +; +; History : Written 20 Sept 1999, D. Zarro, SM&A/GSFC +; 25-Aug-2006, richard.schwartz@gsfc.nasa.gov; added an epsilon tolerance +; for determining floats to be the same value +; : 16-Sep-2014 - S.Freeland - uniq -> ssw_uniq.pro (avoid +; 8.3/exelis uniq collision) +; : 18-Jul-2018 - return null for non-existent input +; +; Contact : dzarro@solar.stanford.edu +;- + +function get_uniq,array,sorder,no_case=no_case,count=count, epsilon=epsilon + +count=0 +sorder=-1 +if ~exist(array) then return,null() +sorder=0 +if n_elements(array) eq 1 then begin + count=1 + return,array[0] +endif + +sorted=0b +if keyword_set(no_case) then begin + if is_string(array) then begin + sorder=ssw_uniq([strlowcase(array)],sort([strlowcase(array)])) + sorted=1b + endif +endif + +if ~sorted then sorder=ssw_uniq([array],sort([array]), epsilon=epsilon) + +count=n_elements(sorder) +if count eq 1 then sorder=sorder[0] + +return,array[sorder] +end diff --git a/fiasco/tests/idl/ssw_gen_functions/null.pro b/fiasco/tests/idl/ssw_gen_functions/null.pro new file mode 100644 index 00000000..f3ed8f17 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/null.pro @@ -0,0 +1,27 @@ +;+ +; Project : VSO +; +; Name : NULL +; +; Purpose : Return !NULL +; +; Category : Utility +; +; Inputs : None +; +; Outputs : !NULL = '' if !NULL not defined +; +; Keywords : None +; +; History : 9-Dec-2015, Zarro (ADNET) - written +; +; Contact : DZARRO@SOLAR.STANFORD.EDU +;- + +function null + +null='' +defsysv,'!null',exists=i +if i eq 0 then defsysv,'!null','' +return,!null +end diff --git a/fiasco/tests/idl/ssw_gen_functions/repstr.pro b/fiasco/tests/idl/ssw_gen_functions/repstr.pro new file mode 100644 index 00000000..3e1ff9b4 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/repstr.pro @@ -0,0 +1,92 @@ +function repstr,obj,in,out +;+ +; NAME: +; REPSTR +; PURPOSE: +; Replace all occurences of one substring by another. +; EXPLANATION: +; Meant to emulate the string substitution capabilities of text editors +; +; Obsolete since introduction of the REPLACE method for string variables +; introduced in IDL 8.4 +; +; For a more sophisticated routine that allows regular expressions look +; at MG_STRREPLACE() http://docs.idldev.com/idllib/strings/mg_streplace.html +; CALLING SEQUENCE: +; result = repstr( obj, in, out ) +; +; INPUT PARAMETERS: +; obj = object string for editing, scalar or array +; in = substring of 'obj' to be replaced, scalar +; +; OPTIONAL INPUT PARMETER: +; out = what 'in' is replaced with, scalar. If not supplied +; then out = '', i.e. 'in' is not replaced by anything. +; +; OUTPUT PARAMETERS: +; Result returned as function value. Input object string +; not changed unless assignment done in calling program. +; +; PROCEDURE: +; Searches for 'in', splits 'obj' into 3 pieces, reassembles +; with 'out' in place of 'in'. Repeats until all cases done. +; +; EXAMPLE: +; If a = 'I am what I am' then print,repstr(a,'am','was') +; will give 'I was what I was'. +; +; MODIFICATION HISTORY: +; Written by Robert S. Hill, ST Systems Corp., 12 April 1989. +; Accept vector object strings, W. Landsman HSTX, April, 1996 +; Convert loop to LONG, vectorize STRLEN call W. Landsman June 2002 +; Correct bug in optimization, case where STRLEN(OBJ) EQ +; STRLEN(IN), C. Markwardt, Jan 2003 +; Fixed problem when multiple replacements extend the string length +; D. Finkbeiner, W. Landsman April 2003 +; Allow third parameter to be optional again W. Landsman August 2003 +; Remove limitation of 9999 characters, C. Markwardt Dec 2003 +; Test for empty "in" string (causing infinite loop) W. Landsman Jan 2010 +; Streamline code W Landsman Dec 2011 +; Use string .replace method in IDL 8.4 or later W. Landsman Feb 2015 +; Use CALL_METHOD so that it still compiles in IDL 7.1 W.Landsman Aug 2015 +; Keep 3rd parameter optional in V8.4 or later W. Landsman Sep 2016 +; Test for valid parameter values even when using .replace method W.L. Jan 2017 +;- + On_error,2 + compile_opt idl2 + + if N_params() LT 2 then begin + print,'Syntax - result = REPSTR( obj, in, out )' + return, obj + endif + + if N_elements(out) EQ 0 then out = '' + l1 = strlen(in) + if l1 EQ 0 then message,'ERROR - empty input string not allowed' + Nstring = N_elements(obj) + if Nstring EQ 0 then message,'ERROR - undefined object string (first parameter)' + if !VERSION.RELEASE GE '8.4' then return,call_method('replace',obj,in,out) + l2 = strlen(out) + + diflen = l2- l1 + + object = obj + lo = strlen(object) - l1 ;Last character needed to look at + for i= 0L ,Nstring-1 do begin + last_pos = 0 + pos = 0 + while ( pos LE lo[i]) do begin + pos = strpos(object[i],in,last_pos) + if (pos GE 0) then begin + first_part = strmid(object[i],0,pos) + last_part = strmid(object[i],pos+l1) + object[i] = first_part + out + last_part + last_pos = pos + l2 + lo[i] += diflen ;Length of string may have changed + endif else break + endwhile + endfor + + return,object + + end diff --git a/fiasco/tests/idl/ssw_gen_functions/ssw_uniq.pro b/fiasco/tests/idl/ssw_gen_functions/ssw_uniq.pro new file mode 100644 index 00000000..f8830edc --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/ssw_uniq.pro @@ -0,0 +1,118 @@ +;+ +; NAME: +; SSW_UNIQ +; +; PURPOSE: +; Return the subscripts of the unique elements in an array. +; +; Note that repeated elements must be adjacent in order to be +; found. This routine is intended to be used with the SORT +; function. See the discussion of the IDX argument below. +; +; This command is inspired by the Unix uniq(1) command. +; +; CATEGORY: +; Array manipulation. +; +; CALLING SEQUENCE: +; SSW_UNIQ(Array [, Idx] [/first] [EPSILON=epsilon) +; +; INPUTS: +; Array: The array to be scanned. The type and number of dimensions +; of the array are not important. The array must be sorted +; into monotonic order unless the optional parameter Idx is +; supplied. +; +; OPTIONAL INPUT PARAMETERS: +; IDX: This optional parameter is an array of indices into Array +; that order the elements into monotonic order. +; That is, the expression: +; +; Array(Idx) +; +; yields an array in which the elements of Array are +; rearranged into monotonic order. If the array is not +; already in monotonic order, use the command: +; +; SSW_UNIQ(Array, SORT(Array)) +; +; The expression below finds the unique elements of an unsorted +; array: +; +; Array(SSW_UNIQ(Array, SORT(Array))) +; EPSILON: positive number ge 0, for gt 0 the relative difference between +; two consecutive numbers must be gt epsilon for them to be unique. +; +; OUTPUTS: +; An array of indicies into ARRAY is returned. The expression: +; +; ARRAY(SSW_UNIQ(ARRAY)) +; +; will be a copy of the sorted Array with duplicate adjacent +; elements removed. +; +; Optional Keyword Parameter: +; first - if set, return index of FIRST occurence for duplicates +; (default is LAST occurence) +; +; COMMON BLOCKS: +; None. +; +; MODIFICATION HISTORY: +; 29 July 1992, ACY - Corrected for case of all elements the same. +; 30 Aug 1994, SLF - added /first keyword +; 1 Sep 1994, MDM - Modified to return a vector for the case of +; a single element being returned (so it matches +; the pre IDL Ver 3.0 version of UNIQ) +; - Modified to return [0] for a scalar +; 10 Sep 1996, Zarro +; - modified to return 0 for a scalar and a scalar +; for single element being returned. +; 10 Oct 1996, Zarro +; - added OLDWAY keyword to return,[value] for scalar +; value +; 25-Aug-2006, richard.schwartz@gsfc.nasa.gov; added an epsilon tolerance +; for determining floats as the same value +; 15-sep-2014, Freeland - verbatim namepace copy UNIQ -> SSW_UNIQ to avoid 8.3 'uniq' collision +;- + +function SSW_UNIQ, ARRAY, IDX, $ + FIRST=FIRST, OLDWAY=OLDWAY, EPSILON=EPSILON + +; Check the arguments. + default, epsilon, 0.0 + epsilon = abs(epsilon) + isstring = datatype(array,/tname) eq 'STRING' + oldway=keyword_set(oldway) + s = size(ARRAY) + first=keyword_set(first) + + if (s(0) eq 0) then begin + val=0 + if oldway then val=[val] + return,val + endif + + shifts=([-1,1])(first) ;slf - shift direction -> first/last + if n_params() ge 2 then begin ;IDX supplied? + q = array(idx) + if epsilon eq 0 or isstring then $ + indices = where(q ne shift(q,shifts), count) else $ + indices = where(abs(q - shift(q,shifts)) gt abs(q)*epsilon, count) + if (count GT 0) then return, idx(indices) else begin + val=(n_elements(q)-1) * (1-first) + if oldway then val=[val] + return,val + endelse + endif else begin + if epsilon eq 0 or isstring then $ + indices = where(array ne shift(array, shifts), count) else $ + indices = where(abs(array - shift(array,shifts)) gt abs(array)*epsilon, count) + if (count GT 0) then return, indices else begin + val=(n_elements(ARRAY)-1) * (1-first) + if oldway then val=[val] + return,val + endelse + endelse + + end diff --git a/fiasco/tests/idl/ssw_gen_functions/str_index.pro b/fiasco/tests/idl/ssw_gen_functions/str_index.pro new file mode 100644 index 00000000..d3c9b132 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/str_index.pro @@ -0,0 +1,68 @@ +FUNCTION STR_INDEX, str, substr, offset +;+ +; NAME: +; STR_INDEX() +; +; PURPOSE: +; Get indices of a substring (SUBSTR) in string. +; +; EXPLANATION: +; The IDL intrinsic function STRPOS returns only the index of the first +; occurrence of a substring. This routine calls itself recursively to get +; indices of the remaining occurrences. +; +; CALLING SEQUENCE: +; result= STR_INDEX(str, substr [, offset]) +; +; INPUTS: +; STR -- The string in which the substring is searched for +; SUBSTR -- The substring to be searched for within STR +; +; OPTIONAL INPUTS: +; OFFSET -- The character position at which the search is begun. If +; omitted or being negative, the search begins at the first +; character (character position 0). +; +; OUTPUTS: +; RESULT -- Integer scalar or vector containing the indices of SUBSTR +; within STR. If no substring is found, it is -1. +; +; CALLS: +; DELVARX +; +; COMMON BLOCKS: +; STR_INDEX -- internal common block. The variable save in the block is +; deleted upon final exit of this routine. +; +; CATEGORY: +; Utility, string +; +; MODIFICATION HISTORY: +; Written January 3, 1995, Liyun Wang, GSFC/ARC +; Converted to IDL V5.0 W. Landsman September 1997 +; Use size(/TNAME) instead of DATATYPE() W. Landsman October 2001 +; +;- +; + ON_ERROR, 2 + COMMON str_index, idx + + IF N_PARAMS() LT 2 THEN MESSAGE,'Syntax: str_index, str, substr [,offset]' + + IF size(str,/TNAME) NE 'STRING' OR size(substr,/TNAME) NE 'STRING' THEN $ + MESSAGE, 'The first two input parameters must be of string type.' + + IF N_ELEMENTS(offset) EQ 0 THEN pos = 0 ELSE pos = offset + aa = STRPOS(str,substr,pos) + IF aa NE -1 THEN BEGIN + IF N_ELEMENTS(idx) EQ 0 THEN idx = aa ELSE idx = [idx,aa] + bb = str_index(str,substr,aa+1) + RETURN, bb + ENDIF ELSE BEGIN + IF N_ELEMENTS(idx) NE 0 THEN BEGIN + result = idx + delvarx, idx + ENDIF ELSE result = -1 + RETURN, result + ENDELSE +END diff --git a/fiasco/tests/idl/ssw_gen_functions/strpad.pro b/fiasco/tests/idl/ssw_gen_functions/strpad.pro new file mode 100644 index 00000000..f326a879 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/strpad.pro @@ -0,0 +1,102 @@ +;+ +; Project : SOHO - CDS +; +; Name : STRPAD +; +; Purpose : Pads a string with blanks (or whatever) to specified width +; +; +; Explanation : Spaces are added in front of the input string to +; make the returned string have LENGTH characters. +; Use /AFTER to add spaces at the end. +; +; Use : str = strpad(value, length, /after, fill=fill]) +; +; Inputs : VALUE: A string.. +; LENGTH: The desired length of the result in characters +; +; Opt. Inputs : None. +; +; Outputs : Returns the padded string. +; +; Opt. Outputs: None. +; +; Keywords : AFTER : Set to add spaces at the end. +; FILL : The character with which to pad out the string. +; Default is the space character +; +; Restrictions: Value must be a scalar string +; +; Side effects: If the input string is longer than the desired +; width, it is returned without truncation +; +; Category : Utilities, Strings +; +; Written : Stein Vidar Hagfors Haugan, 27 September 1993 +; +; Modified : Corrected typo which stopped /after working. CDP, 28-Sep-94 +; Increased possible length used. CDP, 22-Dec-94 +; Handle arrays of strings. CDP, 16-Mar-95 +; Add FILL keyword and stop overwriting input. CDP, 30-Apr-95 +; Vectorized, richard.schwartz@gsfc.nasa.gov, 23-jan-2003 +; Vectorized even better, Zarro (EER/GSFC), 24-Jan-2003 +; Fixed degenerate dimension bug, Zarro (EER/GSFC), 29-Mar-2003 +;- + + +function strpad, in_txt, length, after=after, fill=fill, no_copy=no_copy + +; +; check basic input +; + +sz=size(in_txt) +if sz[n_elements(sz)-2] ne 7 then return,'' +if exist(fill) then fill=fill else fill = ' ' +if not exist(length) then return,in_txt + +;-- only process strings with length less than new length + +tlen=strlen(in_txt) +mlen=max(tlen) +process=where(tlen lt length,lcount) +if lcount eq 0 then return,in_txt else begin + chk=where(tlen ge length,pcount) + if pcount gt 0 then keep=in_txt[chk] + mlen=max(tlen[process]) +endelse +mlen=mlen > 1 + +;-- convert to byte array + +if keyword_set(no_copy) then byte_in=temporary(in_txt) else byte_in=in_txt + +;-- remove degenerate dimensions + +if sz[0] gt 0 then byte_in=reform(byte_in) + +byte_in = transpose(byte(strmid(temporary(byte_in),0,mlen))) + +;-- pad with 32b blanks + +blank=where(byte_in eq 0b,count) +if count gt 0 then byte_in[blank]=(byte(' '))[0] + +;-- create output byte array + +byte_out = bytarr(n_elements(byte_in[*,0]),length) + (byte(fill))[0] + +if keyword_set(after) then byte_out[0,0]=temporary(byte_in) else $ + byte_out[0,length-mlen]=temporary(byte_in) + +;-- convert back to string + +byte_out=string(transpose(temporary(byte_out))) + +;-- insert back unprocessed strings + +if pcount gt 0 then byte_out[chk]=temporary(keep) + +return,byte_out + +end diff --git a/fiasco/tests/idl/ssw_gen_functions/tag_exist.pro b/fiasco/tests/idl/ssw_gen_functions/tag_exist.pro new file mode 100644 index 00000000..8006edcc --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/tag_exist.pro @@ -0,0 +1,99 @@ +;+ +; NAME: +; TAG_EXIST() +; PURPOSE: +; To test whether a tag name exists in a structure. +; EXPLANATION: +; Routine obtains a list of tagnames and tests whether the requested one +; exists or not. The search is recursive so if any tag names in the +; structure are themselves structures the search drops down to that level. +; (However, see the keyword TOP_LEVEL). +; +; CALLING SEQUENCE: +; status = TAG_EXIST(str, tag, [ INDEX =, /TOP_LEVEL, /QUIET ] ) +; +; INPUT PARAMETERS: +; str - structure variable to search +; tag - tag name to search for, scalar string +; +; OUTPUTS: +; Function returns 1b if tag name exists or 0b if it does not. +; +; OPTIONAL INPUT KEYWORD: +; /TOP_LEVEL = If set, then only the top level of the structure is +; searched. +; /QUIET - if set, then do not print messages if invalid parameters given +; /RECURSE - does nothing but kept for compatibility with the +; Solarsoft version for which recursion is not the default +; http://sohowww.nascom.nasa.gov/solarsoft/gen/idl/struct/tag_exist.pro +; OPTIONAL OUTPUT KEYWORD: +; INDEX = index of matching tag, scalar longward, -1 if tag name does +; not exist +; +; EXAMPLE: +; Determine if the tag 'THICK' is in the !P system variable +; +; IDL> print,tag_exist(!P,'THICK') +; +; PROCEDURE CALLS: +; None. +; +; MODIFICATION HISTORY: : +; Written, C D Pike, RAL, 18-May-94 +; Passed out index of matching tag, D Zarro, ARC/GSFC, 27-Jan-95 +; William Thompson, GSFC, 6 March 1996 Added keyword TOP_LEVEL +; Zarro, GSFC, 1 August 1996 Added call to help +; Use SIZE(/TNAME) rather than DATATYPE() W. Landsman October 2001 +; Added /RECURSE and /QUIET for compatibility with Solarsoft version +; W. Landsman March 2009 +; Slightly faster algorithm W. Landsman July 2009 +; July 2009 update was not setting Index keyword W. L Sep 2009. +; Use V6.0 notation W.L. Jan 2012 +; Not setting index again, sigh W.L./ K. Allers Jan 2012 +;- + +function tag_exist, str, tag,index=index, top_level=top_level,recurse=recurse, $ + quiet=quiet + +; +; check quantity of input +; +compile_opt idl2 +if N_params() lt 2 then begin + print,'Use: status = tag_exist(structure, tag_name)' + return,0b +endif + +; +; check quality of input +; + +if size(str,/TNAME) ne 'STRUCT' or size(tag,/TNAME) ne 'STRING' then begin + if ~keyword_set(quiet) then begin + if size(str,/TNAME) ne 'STRUCT' then help,str + if size(tag,/TNAME) ne 'STRING' then help,tag + print,'Use: status = tag_exist(str, tag)' + print,'str = structure variable' + print,'tag = string variable' + endif + return,0b +endif + + tn = tag_names(str) + + index = where(tn eq strupcase(tag), nmatch) + + if ~nmatch && ~keyword_set(top_level) then begin + status= 0b + for i=0,n_elements(tn)-1 do begin + if size(str.(i),/TNAME) eq 'STRUCT' then $ + status=tag_exist(str.(i),tag,index=index) + if status then return,1b + endfor + return,0b + +endif else begin + index = index[0] + return,logical_true(nmatch) + endelse +end diff --git a/fiasco/tests/idl/ssw_gen_functions/valid_num.pro b/fiasco/tests/idl/ssw_gen_functions/valid_num.pro new file mode 100644 index 00000000..05b2a205 --- /dev/null +++ b/fiasco/tests/idl/ssw_gen_functions/valid_num.pro @@ -0,0 +1,80 @@ +;+ +; NAME: +; VALID_NUM() +; PURPOSE: +; Check if a string is a valid number representation. +; EXPLANATION: +; The input string is parsed for characters that may possibly +; form a valid number. It is more robust than simply checking +; for an IDL conversion error because that allows strings such +; as '22.3qwert' to be returned as the valid number 22.3 +; +; This function had a major rewrite in August 2008 to use STREGEX +; and allow vector input. It should be backwards compatible. +; CALLING SEQUENCE: +; IDL> status = valid_num(string [,value] [,/integer]) +; +; INPUTS: +; string - the string to be tested, scalar or array +; +; RETURNS +; status - byte scalar or array, same size as the input string +; set to 1 where the string is a valid number, 0 for invalid +; OPTIONAL OUTPUT: +; value - The value the string decodes to, same size as input string. +; This will be returned as a double precision number unless +; /INTEGER is present, in which case a long integer is returned. +; +; OPTIONAL INPUT KEYWORD: +; /INTEGER - if present code checks specifically for an integer. +; EXAMPLES: +; (1) IDL> print,valid_num(3.2,/integer) +; --> 0 ;Since 3.2 is not an integer +; (2) IDL> str =['-0.03','2.3g', '3.2e12'] +; IDL> test = valid_num(str,val) +; test = [1,0,1] & val = [-0.030000000 ,NaN ,3.2000000e+12] +; REVISION HISTORY: +; Version 1, C D Pike, RAL, 24-May-93 +; Version 2, William Thompson, GSFC, 14 October 1994 +; Added optional output parameter VALUE to allow +; VALID_NUM to replace STRNUMBER in FITS routines. +; Version 3 Wayne Landsman rewrite to use STREGEX, vectorize +; Version 4 W.L. (fix from C. Markwardt) Better Stregex expression, +; was missing numbers like '134.' before Jan 1 2010 +;- + +FUNCTION valid_num, string, value, INTEGER=integer + On_error,2 + compile_opt idl2 + +; A derivation of the regular expressions below can be found on +; http://wiki.tcl.tk/989 + + if keyword_set(INTEGER) then $ + st = '^[-+]?[0-9][0-9]*$' else $ ;Integer + st = '^[-+]?([0-9]+\.?[0-9]*|\.[0-9]+)([eEdD][-+]?[0-9]+)?$' ;F.P. + +;Simple return if we just need a boolean test. + if N_params() EQ 1 then return, stregex(strtrim(string,2),st,/boolean) + + + vv = stregex(strtrim(string,2),st,/boolean) + if size(string,/N_dimen) EQ 0 then begin ;Scalar + if vv then $ + value= keyword_set(integer) ? long(string) : double(string) + endif else begin ;Array + + g = where(vv,Ng) + if Ng GT 0 then begin ;Need to create output vector + if keyword_set(integer) then begin + value = vv*0L + value[g] = long(string[g]) + endif else begin + value = replicate(!VALUES.D_NAN,N_elements(vv)) + value[g] = double(string[g]) + endelse + endif + endelse + + return,vv + end