local hops; /* DOCUMENT hops.i --- Hyperslab operator suite List of routines * hadd_attr: add hyperslab attribute * happend: append hyperslabs to netCDF file * hatmepv: compute atmospheric potential vorticity * hatmepflux: compute atmospheric E-P flux * hattr: get hyperslab attribute * hbin: carry out bin-averaging on dimension * hcat: concatenate hyperslabs * hclose: close netCDF file * hcombine: combine hysperslabs from several files into a single file * hconform: check conformance of two or more hyperslabs * hcont: superimpose continental outlines * hcoord: return coordinate values * hcopy: copy hyperslab * hdata: read actual data into hyperslab * hdiff: difference two netCDF files/hyperslab arrays * hdimsof: return dimension counts for hyperslab components * hfold: fold time dimension to create index dimension * hfft: fourier transform selected dimension * hgather: combine several hyperslabs into a single array * hget: read variable form history file as hyperslab * hgrow: grow hyperslab array * hinterp: interpolate to new grid * hlegend: return descriptive legend string about hyperslab * hmask: apply region masking on hyperslab * hocnmask: superimpose land/depth mask (for ocean data) * hocndrho: compute gradients of sea water density * hocnrho: compute density of sea water * hop: carry out arithmetic/logical operations on hyperslabs * hopen: open netCDF file for reading hyperslabs * hplot: display hyperslab data graphically * hregrid: regrid data along dimension * hsave: save hyperslabs in netCDF file * hset_attr: set hyperslab attribute * hshift: shift data along dimension * hshop: carry out spherical harmonic operations * hshtran: carry out spherical harmonic transforms * hsplit: split all slices along a dimension as separate hyperslabs * hsprout: re-introduce eliminated dimensions * hsub: reduce hyperslab domain through slicing, averaging etc. * htbin: carry out bin-averaging on time-series * htwrite: write time-series to file * hunfold: unfold index dimension into time dimension * hvecplot: overlay vectors on plot * hver_wt: compute vertical weights for 3-D hyperslab * * Version: 1.5 * Modified: 26 Jan 1999, R. Saravanan * Web page: http://www.cgd.ucar.edu/gds/svn/hops * * SEE ALSO: tops, flexplot, ncops, yodel, lowops */ local lowops; /* DOCUMENT lowops --- Low-level functions for hyperslab operator suite List of routines * natmfile: open CSM format atmospheric netCDF file * nattr: return coordinate attributes of hyperslab * nattlist: return structure containing all attributes of a variable * nattmatch: check if attributes of two variables match * nbinop: carry out binary operation between two data arrays * ncat: concatenate hyperslabs along a dimension * ncheck_grid: check consistency of staggered grid * ncopyatt: copy variable attributes from one slab to another * ndataprec: return data precision, given data type * ndim_bounds: return subdomain bounds * ndimlist: read variable dimensions from netCDF file * ngetatt: get variable attributes from netCDF file * ngetcoord: get coordinate values from hyperslab * nget_handle: extract file handle from file structure * nhyperfile: open hyperslab netCDF file * ninit: initialize HOPS * ninterp: auxiliary routine for HINTERP * nlocate: return locator structure for variable in netCDF file * nmask: carry out masking operation on an array * nmiss_value: generate/convert missing value * nocnfile: open CSM format atmospheric netCDF file * nocnrho: initialize sea water density polynomial coefficients * nplotcontours: determine contour levels/labels for ocean fields * nplotrange: determine axis coordinate ranges for ocean fields * npsum: compute partial sums along dimension * nputatt: write variable attributes to netCDF file * nrange: select subrange of hyperslab dimension * nrecord: write record variables to netCDF file * nreduce: carry out rank-reduction operation on hyperslab dimension * nrotate: rotate periodic X dimension of hyperslab * nsave: write non-record variables to netCDF file * nset_attr: set coordinate attribute of hyperslab * nshiftmask: shift 2D bitmask from regular to interfacial grid * nsize_vec: return hyperslab size vector * nslabarr: access an effective hyperslab array * nsublegend: return string describing hyperslab subdomain * nunop: carry out unary operation on hyperslab * nvarattdef: define variable and its attributes in a netCDF file * * SEE ALSO: hops, ncops, yodel, flexplot */ require, "ncops.i"; require, "yodel.i"; require, "flexplot.i"; struct hfmt_struc{ // Hyperslab format descriptor structure string hopsroot, dimnames(5), dimintnames(5), dimaltnames(5); string coordnames(5), reduceops(6); long data, area_wt, z_bot; pointer dimlist, varlist, attdata, attglob, attfixed; pointer ignorelist, attdesc; pointer ocn_dimlist, ocn_varlist, ocn_attdesc; pointer atm_dimlist, atm_varlist, atm_attdesc; pointer ssh_dimlist, ssh_varlist, ssh_attdesc; long nattstd(3); double epsdate, epscoord, default_missing_value; long nchar, nsigma_coefs; pointer shtab; long ishtab; } struct hyperfile_struc{ // Yorick notation for hyperslab netCDF file descriptor string structure; // Structure name ("HYPERFILE") NC_file fmeta; // File structure descriptor long fnumber; // File number string fname; // File name string vars; // File variable list string std_dims(5); // Names of the standard dimensions string int_dims(5); // Names of the interfacial dimensions pointer other_dims; // pointer to a 1-D string array pointer other_labels; // pointer to a 1-D string array // (labels are stored concatenated together in one string, separated by ";") long phys_offset(5,2); // Physical offset for regular/int grid long reverse(5); // Coordinate reversal flag long recordvars; // No. of record variables (-1,0,1,...) long scratch; // Scratch file flag pointer x0, y0, z0; // pointers to 1-D double arrays pointer xint0, yint0, zint0; // pointers to 1-D double arrays pointer time0, date0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array pointer template; // Hyperslab template } struct ocnfile_struc{ // Yorick notation for ocean history file descriptor string structure; // Structure name ("ATMFILE") NC_file fmeta; // File structure descriptor long fnumber; // File number string fname; // File name string vars; // File variable list string ftype; // "PROGNOSTIC" / "DIAGNOSTIC" string fconventions; // "CSM" / "HYPERSLAB" string std_dims(5); // Names of the standard dimensions string int_dims(5); // Names of the interfacial dimensions pointer other_dims; // pointer to a 1-D string array pointer other_labels; // pointer to a 1-D string array // (labels are stored concatenated together in one string, separated by ";") long phys_offset(5,2); // Physical offset for regular/int grid long reverse(5); // Coordinate reversal flag long recordvars; // No. of record variables (-1,0,1,...) long scratch; // Scratch file flag string area_wt_units; // Initial area weight units string area_wt_var, z_bot_var; // Area weight/Z_BOT variable names string area_wtint_var, z_botint_var; // Interfacial area weight/Z_BOT variable names pointer x0, y0, z0; // pointers to 1-D double arrays pointer xint0, yint0, zint0; // pointers to 1-D double arrays pointer time0, date0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array pointer sigma0, sigmaint0; // pointers to 2-D double arrays pointer area_wt0, area_wtint0; // pointers to 2-D double arrays pointer z_bot0, z_botint0; // pointers to 2-D double arrays double f0, g0; // polar coriolis parameter, // surface gravity double rhoocn0, cpocn0, socn0; // density, specific heat, mean salinity // By convention, the first "extra" dimension corresponds to the // list of pre-defined horizontal regions, if any long nrmask; // No. of pre-defined horizontal regions pointer rmask; // Horizontal region mask // (2-D byte array) pointer template; // Hyperslab template } struct atmfile_struc{// Yorick notation for atmospheric history file descriptor string structure; // Structure name ("ATMFILE") NC_file fmeta; // File structure descriptor long fnumber; // File number string fname; // File name string vars; // File variable list string ftype; // "" string fconventions; // "CSM" / "HYPERSLAB" string std_dims(5); // Names of the standard dimensions string int_dims(5); // Names of the interfacial dimensions pointer other_dims; // pointer to a 1-D string array pointer other_labels; // pointer to a 1-D string array // (labels are stored concatenated together in one string, seperated by ";") long phys_offset(5,2); // Physical offset for regular/int grid long reverse(5); // Coordinate reversal flag long recordvars; // No. of record variables (-1,0,1,...) long scratch; // Scratch file flag string area_wt_units; // Initial area weight units string area_wt_var, z_bot_var; // Area weight/Z_BOT variable names pointer x0, y0, z0; // pointers to 1-D double arrays pointer zint0; // pointers to 1-D double arrays pointer time0, date0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array pointer sigma0, sigmaint0; // pointers to 2-D double arrays pointer area_wt0; // pointer to 1-D double array pointer z_bot0; // pointers to 2-D double arrays double f0, g0; // polar coriolis parameter, // surface gravity double rdry0, cpdry0; // dry air constant, specific heat // By convention, the first "extra" dimension corresponds to the // list of pre-defined horizontal regions, if any long nrmask; // No. of pre-defined horizontal regions pointer rmask; // Horizontal region mask // (2-D byte array) pointer template; // Hyperslab template } struct locator_struc { // Yorick notation for slab data locator structure string structure; // structure name ("slabdata") pointer fstruc; // pointer to file structure string fname; // file name NC_file fmeta; // File structure descriptor float add_offset, scale_factor; // data offset, scale factor string area_wt_var, z_bot_var; // Area weight/Z_BOT variable names string type(3); // DATA/AREA_WT/Z_BOT type string string dimenstr; // dimension string long dim_data(5); // data dimension index number in file long dim_area_wt(5); // area_wt dimension index number long dim_z_bot(5); // z_bot index number long was_present(5); // Initial dimension presence code long slab_wrapcount; // hyperslab X wrap-around count pointer slab_fold; // hyperslab T fold descriptor pointer slab_offset, slab_count; // hyperslab offset/count } struct hyperslab { // Yorick notation for a hyperslab // Mandatory variables describing the hyperslab // (A coordinate variable may be null, if the corresponding dimension // was not present even in the original history file, i.e., prior to slicing, // rank-reduction operations.) // SDIM=5: no. of standard dimensions // NATT=56: total number of attributes // NIATT=7, NFATT=8, NSATT=41: numberof integer, float, string attributes string structure; // Structure name ("HYPERSLAB...") pointer x, y, z, time; // pointer to a 1-D double arrays pointer ilabel; // pointer to a 1-D string array pointer data; // pointer to a 5-D float/double array pointer missing_value; // pointer to a scalar of same type as // the data string name, long_name, units; pointer attlist; // Attribute list("var","nam","var:nam") pointer attcode; // Attribute codes (type(1-3),index) pointer iatt; // Integer attributes: pointer fatt; // Float attributes: pointer satt; // String attributes: string type(3); // DATA/AREA_WT/Z_BOT type string long dimension(5,3); // DATA/AREA_WT/Z_BOT dimensions long reduced(5); // DATA rank-reduction codes // Optional variables describing the hyperslab (may be null) pointer area_wt, z_bot; // pointers to a 5-D float/double arrays pointer date; // pointer to a 1-D double array pointer iparam; // pointer to a 1-D double array // Optional variables describing the full spatial domain grid pointer x0, y0, z0; // pointers to 1-D double arrays pointer xint0, yint0, zint0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array } struct hyperslab_atm { // Yorick notation for a ATM-type hyperslab // Mandatory variables describing the hyperslab // (A coordinate variable may be null, if the corresponding dimension // was not present even in the original history file, i.e., prior to slicing, // rank-reduction operations.) // SDIM=5: no. of standard dimensions // NATT=56: total number of attributes // NIATT=7, NFATT=8, NSATT=41: numberof integer, float, string attributes string structure; // Structure name ("HYPERSLAB...") pointer x, y, z, time; // pointer to a 1-D double arrays pointer ilabel; // pointer to a 1-D string array pointer data; // pointer to a 5-D float/double array pointer missing_value; // pointer to a scalar of same type as // the data string name, long_name, units; pointer attlist; // Attribute list("var","nam","var:nam") pointer attcode; // Attribute codes (type(1-3),index) pointer iatt; // Integer attributes: pointer fatt; // Float attributes: pointer satt; // String attributes: string type(3); // DATA/AREA_WT/Z_BOT type string long dimension(5,3); // DATA/AREA_WT/Z_BOT dimensions long reduced(5); // DATA rank-reduction codes // Optional variables describing the hyperslab (may be null) pointer area_wt, z_bot; // pointers to a 5-D float/double arrays pointer date; // pointer to a 1-D double array pointer iparam; // pointer to a 1-D double array // Optional variables describing the full spatial domain grid pointer x0, y0, z0; // pointers to 1-D double arrays pointer xint0, yint0, zint0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array // SPH extension fields double a0; // planetary radius pointer eqdx0, cosdy0; // pointer to 1-D double arrays pointer eqdxint0, cosdyint0; // pointer to 1-D double arrays // SIG extension fields pointer sigma0, sigmaint0; // pointers to 2-D double arrays // ATM extension fields pointer hgrid0; // pointer to 2-D byte array } struct hyperslab_ocn { // Yorick notation for a OCN-type hyperslab // Mandatory variables describing the hyperslab // (A coordinate variable may be null, if the corresponding dimension // was not present even in the original history file, i.e., prior to slicing, // rank-reduction operations.) // SDIM=5: no. of standard dimensions // NATT=56: total number of attributes // NIATT=7, NFATT=8, NSATT=41: numberof integer, float, string attributes string structure; // Structure name ("HYPERSLAB...") pointer x, y, z, time; // pointer to a 1-D double arrays pointer ilabel; // pointer to a 1-D string array pointer data; // pointer to a 5-D float/double array pointer missing_value; // pointer to a scalar of same type as // the data string name, long_name, units; pointer attlist; // Attribute list("var","nam","var:nam") pointer attcode; // Attribute codes (type(1-3),index) pointer iatt; // Integer attributes: pointer fatt; // Float attributes: pointer satt; // String attributes: string type(3); // DATA/AREA_WT/Z_BOT type string long dimension(5,3); // DATA/AREA_WT/Z_BOT dimensions long reduced(5); // DATA rank-reduction codes // Optional variables describing the hyperslab (may be null) pointer area_wt, z_bot; // pointers to a 5-D float/double arrays pointer date; // pointer to a 1-D double array pointer iparam; // pointer to a 1-D double array // Optional variables describing the full spatial domain grid pointer x0, y0, z0; // pointers to 1-D double arrays pointer xint0, yint0, zint0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array // SPH extension fields double a0; // planetary radius pointer eqdx0, cosdy0; // pointer to 1-D double arrays pointer eqdxint0, cosdyint0; // pointer to 1-D double arrays // SIG extension fields pointer sigma0, sigmaint0; // pointers to 2-D double arrays // OCN extension fields pointer kmax0; // pointer to 2-D byte array } struct hyperslab_ssh { // Yorick notation for a SSH-type hyperslab // Mandatory variables describing the hyperslab // (A coordinate variable may be null, if the corresponding dimension // was not present even in the original history file, i.e., prior to slicing, // rank-reduction operations.) // SDIM=5: no. of standard dimensions // NATT=56: total number of attributes // NIATT=7, NFATT=8, NSATT=41: numberof integer, float, string attributes string structure; // Structure name ("HYPERSLAB...") pointer x, y, z, time; // pointer to a 1-D double arrays pointer ilabel; // pointer to a 1-D string array pointer data; // pointer to a 5-D float/double array pointer missing_value; // pointer to a scalar of same type as // the data string name, long_name, units; pointer attlist; // Attribute list("var","nam","var:nam") pointer attcode; // Attribute codes (type(1-3),index) pointer iatt; // Integer attributes: pointer fatt; // Float attributes: pointer satt; // String attributes: string type(3); // DATA/AREA_WT/Z_BOT type string long dimension(5,3); // DATA/AREA_WT/Z_BOT dimensions long reduced(5); // DATA rank-reduction codes // Optional variables describing the hyperslab (may be null) pointer area_wt, z_bot; // pointers to a 5-D float/double arrays pointer date; // pointer to a 1-D double array pointer iparam; // pointer to a 1-D double array // Optional variables describing the full spatial domain grid pointer x0, y0, z0; // pointers to 1-D double arrays pointer xint0, yint0, zint0; // pointers to 1-D double arrays pointer ilabel0; // pointer to a 1-D string array pointer iparam0; // pointer to a 1-D double array // SSH extension fields double a0; // planetary radius // SIG extension fields pointer sigma0, sigmaint0; // pointers to 2-D double arrays } struct attlist_struc { // Attribute list for a variable pointer inames, ivals; // Integer-valued attributes pointer fnames, fvals; // Float-valued attributes pointer snames, svals; // String-valued attributes } struct shtran_struc { // Grid info for spherical harmonic transforms long nlon, nlat, m, n, k; // Truncation parameters pointer x0, y0; // pointer to 1-D double arrays pointer eqdx0, cosdy0; // pointer to 1-D double arrays pointer area_wt0; // pointer to 2-D double array pointer hgrid0; // pointer to 2-D byte array pointer init; // pointer to Shtran_Init structure } func hadd_attr(slab,attribute,value,help=) /* DOCUMENT hadd_attr(slab,attribute,value,help=help) * Adds specified ATTRIBUTE to SLAB, sets it to VALUE, and returns new slab, * where ATTRIBUTE="varname:attribute_name", or ATTRIBUTE=":attribute_name" * for global attributes. * SEE ALSO: hset_attr, hattr, hcopy */ { func_name= "hadd_attr"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write, "Function HADD_ATTR adds specified ATTRIBUTE to SLAB, && sets it"; write, "to VALUE, where ATTRIBUTE='varname:attribute_name', || "; write, " ATTRIBUTE=':attribute_name' for global attributes. "; write," E.g.,"; write," new_slab= hadd_attr(slab, 'data:new_attr', 'ATT_VALUE')"; write," adds the attribute 'data:new_attr', sets it to 'ATT_VALUE', &&"; write," returns the modified slab."; write," See also: hset_attr, hattr, hcopy"; write,""; write," Usage: hadd_attr(slab, 'varname:attribute', value)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) error, "Can only add attributes to scalar slabs"; // Copy attribute list/codes attlist= *(slab.attlist); attcode= *(slab.attcode); // Locate attribute attwhere= where(attlist(I0+2,) == attribute); // Split attribute into variable name and attribute name str2= strsplit(attribute, ":"); if (numberof(str2) != 2) error, "Invalid attribute specification - " + attribute; attvar= str2(I0); attname= str2(I0+1); new_slab= NULL; if ( ((attvar == "data") && \ is_where(where(*(HFMT.attdata) == attname))) || \ (attname == "dimension") || \ (attribute == ":structure") || \ is_where(attwhere) ) { // Attribute already exists; simply copy slab hcopy, slab, new_slab; if (is_where(attwhere)) { attno= attwhere(I0); if (attcode(I0+1,attno) < 0) { // "Undelete" attribute attcode(I0+1,attno)= -attcode(I0+1,attno); new_slab.attcode= ref(attcode); } } } else { // Copy slab, adding attribute attype= typeof(value); if (attype == "int") attype= "long"; if (attype == "float") attype= "double"; if ((attype != "long") && (attype != "double") && \ (attype != "string")) error, "Invalid attribute type - " + attype; hcopy, slab, new_slab, extra_atts=[attvar, attname, attype]; } // Set attribute value hset_attr, new_slab, attribute, value; return timer_return(func_name, new_slab); } func happend( &fstruc, //YORICKoutput: slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9, help=, overwrite=, partial=, nocheck=, create=) /* DOCUMENT happend, fstruc, * slab0, slab1, slab2, slab3, slab4, * slab5, slab6, slab7, slab8, slab9, * help=0/1, overwrite=0/1, partial=0/1, nocheck=0/1, * create= * * Append upto 9 hyperslabs (or hyperslab arrays) in the t-dimension * to the netCDF file described by file data structure FSTRUC, * updating FSTRUC to reflect the extended t-dimension. * The appended hyperslabs must have strong full conformance in all * dimensions, including reduced ones, and also variable, case, and domain * conformance, with the hyperslabs already present in the file * (except for the t-dimension, where only dimension-unit conformance * and monotonically increasing t-coordinate values are required). * If OVERWRITE==1, overwrite existing data. * If PARTIAL==1, allow partial records to be written. * If NOCHECK==1, no slab conformance checking is done, and area weights/Z_BOT * values are always written out (use this option with care). * If CREATE="filename" is specified and FSTRUC has a null value, * a new netCDF file is created and its file structure is returned as * FSTRUC. Subsequent calls to HAPPEND can append to this file. * SEE ALSO: hsave, hopen, hconform */ { func_name= "happend"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HAPPEND appends a set of hyperslabs to a netCDF file"; write," created using HSAVE, && subsequently opened using HOPEN. E.g.,"; write," happend, fstruc, slab1, slab2"; write," appends to the file pointed to by file structure FSTRUC"; write," On returning, the FSTRUC is modified to reflect the appended data."; write," (The hyperslabs SLAB1 && SLAB2, which may themselves be arrays.)"; write," Tips:"; write," 1. overwrite=1 allows overwriting of existing records."; write," 2. partial=1 allows writing of partial records."; write," 3. nocheck=1 suppresses conformance checking."; write," 4. create='filename' creates a new netCDF if FSTRUC is null."; write,""; write," See also: hsave, hopen, hconform"; write,""; write," Usage: happend,fstruc,slab1,slab2,...,overwrite=0/1,partial=0/1,nocheck=0/1,create='filename'"; return timer_return(func_name); } if (is_null(fstruc)) { if (is_null(create)) error, "Null value for FSTRUC; specify create='filename'" // Create new save file, open it for appending, and return hsave, create, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9, nocheck=nocheck; hopen, create, fstruc, alt=1, append=1, silent=1; return timer_return(func_name); } if (typeof(fstruc) != "struct_instance") error, "Argument FSTRUC should be a structure"; if (fstruc.structure != "HYPERFILE") error, "Cannot append to file of type " + fstruc.structure; if (fstruc.recordvars == 0) error, "Cannot append to file without unlimited (record) dimension"; // Get file handle fhandle= nget_handle( fstruc ); // List of variables in file filevars= strsplit(fstruc.vars, ","); // Prior time and date values time1= *(fstruc.time0); date1= deref(fstruc.date0); nt1= numberof(time1); // Number of slabs nslab= numberof(slab0) + numberof(slab1) + numberof(slab2) + numberof(slab3) + numberof(slab4) + numberof(slab5) + numberof(slab6) + numberof(slab7) + numberof(slab8) + numberof(slab9); if (nslab == 0) error, "No slabs specified to append"; // T/I dimension transpose flag ti_transp= 0; // Flags/dimensions for area weights, and Z_BOT values area_wt_flag= 0; area_wt_var= NULL; apresent0= NULL; along_name= NULL; aunits= NULL; aelements= NULL; area_wt1= NULL; z_bot_flag= 0; z_bot_var= NULL; zpresent0= NULL; zlong_name= NULL; zunits= NULL; zref= NULL; z_bot1= NULL; // Variable list newvars= array("",nslab); for (jslab=I0; jslab <= nslab-I1; jslab++) { // Get copy of each new slab (with data) tem_slab= nslabarr( jslab+I1, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); // Variable name varname= tem_slab.name; // Check for uniqueness of variable name if (strloc(newvars, varname) > 0) error, "Duplicate variable name in hyperslab list - " + varname; is_present= tem_slab.dimension(,HFMT.data); if (is_present(TDIM) <= 0) error, "T dimension not present in variable " + varname; if (is_present(IDIM) > 0) { // Set T/I dimension transpose flag ti_transp= 1; } // Add variable name to list newvars(jslab)= varname; if (tem_slab.type(HFMT.data) == "struct_instance") error, "Slab "+tem_slab.name+" does not contain actual data"; if (!param_set(nocheck)) { // Get corresponding old hyperslab from file (without data) old_slab= hget(varname, fstruc=fstruc, nodata=1); old_loc= *(old_slab.data); // Check conformance of old and new slabs (including reduced dimensions) isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, old_slab, tem_slab, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf, reduced=1; if (!allof(dim_conf(XDIM:ZDIM) == 2)) error, "XYZ-dimensions not conforming for variable " + varname; if (dim_conf(IDIM) != 2) error, "I-dimension not conforming for variable " + varname; if (!udim_conf(TDIM)) error, "T-dimension not unit conforming for variable " + varname; if ( (!var_conf) || (!case_conf) || (!domain_conf) ) error, "Variable/case/domain non-conformance for variable " + varname; if (is_null(old_slab.missing_value)) { if (!is_null(tem_slab.missing_value)) error, "Missing value attribute mismatch for variable " + varname; } else { if (!is_null(tem_slab.missing_value)) { if (*(old_slab.missing_value) != *(tem_slab.missing_value)) error, "Missing value attribute mismatch for variable " + varname; } } } if (jslab == I0) { // First slab time2= *(tem_slab.time); date2= deref(tem_slab.date); nt2= numberof(time2); if (is_null(date1) != is_null(date2)) error, "Date value presence mismatch"; if (time2(I0) > time1(nt1-I1)) { // Append time values overwrite_flag= 0; ioffset= nt1; time0= time1; date0= date1; grow, time0, time2; grow, date0, date2; // Create new slab file data structure with extended time coordinate fstruc2= hyperfile_struc( fmeta= fstruc.fmeta, other_dims= fstruc.other_dims, other_labels= fstruc.other_labels, x0= fstruc.x0, y0= fstruc.y0, z0= fstruc.z0, xint0= fstruc.xint0, yint0= fstruc.yint0, zint0= fstruc.zint0, time0= ref(time0), date0= ref(date0), ilabel0= fstruc.ilabel0, iparam0= fstruc.iparam0, template= fstruc.template ); fstruc2.structure= "HYPERFILE"; // Initialize fixed size fields fstruc2.fnumber= fstruc.fnumber; fstruc2.fname= fstruc.fname; fstruc2.vars= fstruc.vars; fstruc2.std_dims= fstruc.std_dims; fstruc2.int_dims= fstruc.int_dims; fstruc2.phys_offset= fstruc.phys_offset; fstruc2.recordvars= fstruc.recordvars; fstruc2.reverse= fstruc.reverse; } else { // Overwrite values if (!param_set(overwrite)) error, "Overlapping time values; specify overwrite=1 to overwrite records" overwrite_flag= 1; // Locate new time coordinate offset among old values ioffset= rangeloc( time1, time2(I0) ) - 1; if ( (ioffset+nt2) > nt1 ) error, "Time values to be overwritten are not fully overlapping"; if (!array_eq(time1(I0+ioffset:I0+ioffset+nt2-1), time2, epsilon=HFMT.epscoord)) error, "Time values to be overwritten are not contiguous"; if (!is_null(date1)) { if (!array_eq(date1(I0+ioffset:I0+ioffset+nt2-1), date2, epsilon=HFMT.epsdate/max([max(date2),1.0]) )) error, "Date values to be overwritten do not match"; } } } else { // Not the first slab; check time/date coordinate values if (!array_eq(time2,*(tem_slab.time),epsilon=HFMT.epscoord)) error, "Time values not the same for all slabs"; if (!is_null(date2)) { if (!array_eq(date2, deref(tem_slab.date), epsilon=HFMT.epsdate/max([max(date2),1.0]) )) error, "Date values not the same for all slabs"; } } if (tem_slab.type(HFMT.area_wt) != "") { // Area weights present if ((!area_wt_flag) && (!param_set(nocheck))) { // First set of area weights; check for variable name area_wt_flag= 1; area_wt_var= old_loc.area_wt_var; if (strloc(filevars, area_wt_var) == 0) area_wt_var= NULL; } if (!is_null(area_wt_var)) { // Area weights variable attributes if (is_null(apresent0)) { apresent0= tem_slab.dimension(,HFMT.area_wt); along_name= hattr( tem_slab, "area_wt:long_name" ); aunits= hattr( tem_slab, "area_wt:units" ); aelements= hattr( tem_slab, "area_wt:elements" ); area_wt1= *(tem_slab.area_wt); } else { if ( (!array_eq( apresent0, tem_slab.dimension(,HFMT.area_wt)) ) || \ (along_name != hattr(tem_slab, "area_wt:long_name")) || \ (aunits != hattr(tem_slab, "area_wt:units")) || \ (aelements != hattr(tem_slab, "area_wt:elements")) ) error, "Area weights dimensions/attributes are not the same"; if (!array_eq(area_wt1, *(tem_slab.area_wt), epsilon=HFMT.epscoord)) error, "Area weights array values do not match among all slabs"; } } } if (tem_slab.type(HFMT.z_bot) != "") { // Z_BOT values present if ((!z_bot_flag) && (!param_set(nocheck))) { // First set of Z_BOT values; check for variable name z_bot_flag= 1; z_bot_var= old_loc.z_bot_var; if (strloc(filevars, z_bot_var) == 0) z_bot_var= NULL; } if (!is_null(z_bot_var)) { // Z_BOT variable attributes if (is_null(zpresent0)) { zpresent0= tem_slab.dimension(,HFMT.z_bot); zlong_name= hattr( tem_slab, "z_bot:long_name" ); zunits= hattr( tem_slab, "z_bot:units" ); zref= hattr( tem_slab, "z_bot:ref" ); z_bot1= *(tem_slab.z_bot); } else { if ( (!array_eq( zpresent0, tem_slab.dimension(,HFMT.z_bot)) ) || \ (zlong_name != hattr(tem_slab, "z_bot:long_name")) || \ (zunits != hattr(tem_slab, "z_bot:units")) || \ (zref != hattr(tem_slab, "z_bot:ref")) ) error, "Z_BOT dimensions/attributes are not the same"; if (!array_eq(z_bot1, *(tem_slab.z_bot), epsilon=HFMT.epscoord)) error, "Z_BOT values do not match among all slabs"; } } } } // Area weights/Z_BOT array write flags awrite= 1; zwrite= 1; if (!is_null(area_wt_var)) { // Area weights variable iloc= strloc(newvars, area_wt_var); if (iloc == 0) error, "Area weights variable not found among slabs"; tem_slab= nslabarr( iloc, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); awrite= 0; aelements1= hattr(tem_slab, "area_wt:elements"); if ( (!array_eq( apresent0, tem_slab.dimension(,HFMT.data)) ) || \ (along_name != hattr(tem_slab, "area_wt:long_name")) || \ (aunits != hattr(tem_slab, "area_wt:units")) || \ (aelements != aelements1) ) error, "Area weights variable dimensions/attributes do not match"; if (!array_eq(area_wt1, *(tem_slab.data), epsilon=HFMT.epscoord)) error, "Area weights array values do not match variable values"; } if (!is_null(z_bot_var)) { // Z_BOT variable iloc= strloc(newvars, area_wt_var); if (iloc == 0) error, "Z_BOT variable not found among slabs"; tem_slab= nslabarr( iloc, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); zwrite= 0; zref1= hattr(tem_slab, "z_bot:ref"); if ( (!array_eq( zpresent0, tem_slab.dimension(,HFMT.data)) ) || \ (zlong_name != hattr(tem_slab, "data:long_name")) || \ (zunits != hattr(tem_slab, "data:units")) || \ (zref != zref1) ) error, "Z_BOT variable dimensions/attributes do not match"; if (!array_eq(z_bot1, *(tem_slab.data), epsilon=HFMT.epscoord)) error, "Z_BOT values do not match variable values"; } if (!param_set(partial)) { // Check to make sure that a full record is being written dimnames= HFMT.dimnames; for (ivar=I0; ivar <= numberof(filevars)-I1; ivar++) { if (strloc(newvars, filevars(ivar)) == 0) { vardims= nc_getdims( fstruc.fmeta, filevars(ivar) ); if (strloc(vardims, dimnames(TDIM)) > 0) error, "Set partial=1 to write partial record"; } } } // Write record variables for (k=1; k <= nt2; k++) { if (!overwrite_flag) { //YORICKbegin: // Add records for time dimension nc_addrec, fhandle, time2(k-I1) //YORICKend: // Write time values nc_putvar, fhandle, "time", [time2(k-I1)], offset=[ioffset+k-1], record=1; // Write date values if (!is_null(date2)) nc_putvar, fhandle, "date", [date2(k-I1)], offset=[ioffset+k-1], record=1; } // Write record variables nrecord, fhandle, ioffset+k, slab0, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab1, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab2, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab3, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab4, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab5, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab6, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab7, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab8, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, ioffset+k, slab9, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; } if (!overwrite_flag) { // Copy updated file structure fstruc= fstruc2; } return timer_return(func_name); } func hattr( slab, attribute, help=, index=) /* DOCUMENT hattr(slab, attribute, help=, index=) * Returns the specified ATTRIBUTE of SLAB, * where ATTRIBUTE="varname:attribute_name", or ATTRIBUTE=":attribute_name" * for global attributes. If the attribute is not defined, a null value is * returned. * If ATTRIBUTE="varname:" is specified, all attributes of" * of the variable are printed out, and a null string is returned. * (The "units" and "long_name" attributes for the five standard dimensions * may be accessed through the array components nattr("units",slab), * and nattr("long_name",slab). The "name", "long_name", "units", * and "missing_value" attributes for the data may accessed directly as * structure members slab.*) * If INDEX is non-null, return attributes for SLAB(INDEX) * If SLAB may be an array of hyperslabs, an array of attribute values * is returned. * SEE ALSO: hset_attr, hadd_attr, hcopy, hget */ { func_name= "hattr"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write,"Function HATTR returns the specified ATTRIBUTE of SLAB,"; write," where ATTRIBUTE='varname:attribute_name', || "; write," ATTRIBUTE=':attribute_name' for global attributes. "; write," E.g.,"; write," case_name = hattr(slab, ':case_name')"; write," returns the global string attribute 'case_name'."; write," If SLAB is actually an array of hyperslabs, case_name would"; write," be an array of strings."; write," If ATTRIBUTE='varname:' is specified, all attributes of"; write," of variable 'varname' are printed out."; write," E.g.,"; write," write,hattr(slab, 'time:')"; write," prints out all attributes of variable 'time'."; write," See also: hset_attr, hadd_attr, hcopy, hget"; write,""; write," Usage: hattr(slab,'varname:attribute',index=...)"; return timer_return(func_name, ""); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (is_null(index) && (!is_scalar(slab))) { // Array of hyperslabs; handle recursively att_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_att= NULL; tem_att= hattr( slab(j), attribute ); grow, att_array, tem_att; } return timer_return(func_name, att_array); } k1= I0; if (!is_null(index)) k1= index; // Copy attribute list/codes attlist= *(slab(k1).attlist); attcode= *(slab(k1).attcode); // Locate attribute attwhere= where(attlist(I0+2,) == attribute); if (is_where(attwhere)) { attno= attwhere(I0); // If "deleted" attribute, return null if (attcode(I0+1,attno) <= 0) return timer_return(func_name, NULL); // Attribute type/index attype= attcode(I0,attno); attinx= attcode(I0+1,attno) - I1; if (attype == 1) { return timer_return(func_name, (*(slab(k1).iatt))(attinx)); } else if (attype == 2) { return timer_return(func_name, (*(slab(k1).fatt))(attinx)); } else if (attype == 3) { return timer_return(func_name, (*(slab(k1).satt))(attinx)); } } // Special handling for attributes accessible as structure members if (attribute == ":structure") { return timer_return(func_name, slab(k1).structure); } nlen= strlen(attribute); if (nlen > 5 ) { if ( (strmid(attribute,0,5) == "data:") && \ anyof(*(HFMT.attdata) == strmid(attribute,5,nlen-5)) ) { // Data attribute accessible as structure member attname= strmid(attribute,5,nlen-5); if (attname == "missing_value") { return timer_return(func_name, deref(slab(k1).missing_value)); } else if (attname == "name") { return timer_return(func_name, slab(k1).name); } else if (attname == "long_name") { return timer_return(func_name, slab(k1).long_name); } else if (attname == "units") { return timer_return(func_name, slab(k1).units); } else { error, "Internal error 1"; } } } if (strmid(attribute,nlen-1,1) == ":") { // Recursively display all attributes of variable and return null string attvar= strmid(attribute,0,nlen-1); attwhere= where(attlist(I0,) == attvar); if (is_where(attwhere)) { attsel= attlist(I0+2,attwhere) ; for (j=I0; j <= numberof(attsel)-I1; j++) { write, attsel(j)+" = ", hattr(slab, attsel(j), index=index); } } return timer_return(func_name, ""); } // Attribute not found; return NULL value return timer_return(func_name, NULL); } func hatmepflux( t_slab, u_slab, v_slab, omega_slab, &epfy_slab, &epfz_slab, &epfdc_slab, //YORICKoutput: help=,fpolar=,pref=,gravit=,kappa=, nohistory=) /* DOCUMENT hatmepflux, t_slab, u_slab, v_slab, omega_slab, * epfy_slab, epfz_slab, epfdc_slab, * fpolar=,pref=,gravit=,kappa=, * nohistory=0/1 * Returns Eliassen-Palm flux components in pressure coordinates- * EPFY_SLAB: meridional component of E-P flux (in m2 s-2) * EPFZ_SLAB: vertical component of E-P flux (in m Pa s-2) * EPFDC_SLAB: cosine-latitude times E-P flux divergence (in m s-2) * given the temperatures (T_SLAB, in K), horizontal velocity components * (U_SLAB, V_SLAB, in m/s), and pressure tendency (OMEGA_SLAB, in Pa/s) * * FPOLAR is the polar value of the Coriolis parameter (in s-1) * (defaults to 1.4584E-04) * * PREF is the reference pressure (in Pa) used to compute potential * temperature (defaults to 1000.0e2) * * GRAVIT is the surface gravitational acceleration (in m/s2) * (defaults to 9.80616) * * KAPPA is tha dimensionless ratio R/C_p (defaults to 287.04/1004.64) * * SEE ALSO: hatmepv */ { func_name= "hatmepflux"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; //IDLbegin: //:error, "Spectral transforms module SHTRAN not yet implemented in IDL"; //IDLend: //YORICKbegin: require, "shtran.i" //YORICKend: if (param_set(help)) { write,""; write," Procedure HATMEPFLUX returns the Eliassen-Palm flux components,"; write," given T, U, V, && OMEGA."; write," E.g.,"; write," hatmepflux, t_slab, u_slab, v_slab, omega_slab,"; write," epfy_slab, epfz_slab, epfdc_slab"; write," See also: hatmepv"; write,""; write," Usage: hatmepflux, t_slab, u_slab, v_slab, omega_slab, epfy_slab, epfz_slab, epfdc_slab"; return timer_return(func_name); } if (is_null(t_slab) || is_null(u_slab) || \ is_null(v_slab) || is_null(omega_slab)) error, "Null operand(s)"; if ( (typeof(t_slab) != "struct_instance") || \ (typeof(u_slab) != "struct_instance") || \ (typeof(v_slab) != "struct_instance") || \ (typeof(omega_slab) != "struct_instance") ) error, "Operands not hyperslabs"; if ((!is_scalar(t_slab)) || \ (!is_scalar(u_slab)) || \ (!is_scalar(v_slab)) || \ (!is_scalar(omega_slab)) ) error, "Operands should be scalar slabs"; if ( (t_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") || \ (u_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") || \ (v_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") || \ (omega_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") ) error, "Incorrect slab structure for operands"; if ((t_slab.units != "K") && (t_slab.units != "Kelvin")) error, "Unrecognized units for T_SLAB - " + t_slab.units; if ((u_slab.units != "m/s") && (u_slab.units != "m s-1")) error, "Unrecognized units for U_SLAB - " + u_slab.units; if ((v_slab.units != "m/s") && (v_slab.units != "m s-1")) error, "Unrecognized units for V_SLAB - " + v_slab.units; if ((omega_slab.units != "Pa/s") && (omega_slab.units != "Pa s-1")) error, "Unrecognized units for OMEGA_SLAB - " + omega_slab.units; his_str= "<"+ t_slab.name+ ">,<" + u_slab.name + ">" + ">,<" + v_slab.name+ ">,<" + omega_slab.name +">"; f0= double(1.4584E-04); if (!is_null(fpolar)) { his_str= his_str + ",fpolar=" + strnum(fpolar); f0= fpolar; } pref1= 1000.0e2; if (!is_null(pref)) { his_str= his_str + ",pref=" + strnum(pref); pref1= pref; } gravit1= 9.80616; if (!is_null(gravit1)) { his_str= his_str + ",gravit=" + strnum(gravit); gravit1= gravit; } kappa1= 287.04/1004.64; if (!is_null(kappa1)) { his_str= his_str + ",kappa=" + strnum(kappa); kappa1= kappa; } // Compute sine/cosine of latitude SINLAT= hop("sin", hcoord(t_slab,"y"), name="SINLAT"); COSLAT= hop("cos", hcoord(t_slab,"y"), name="COSLAT"); // Compute planetary vorticity PLVOR= hop(SINLAT, "*", f0, name="PLVOR", units="s-1"); // Compute zonal-mean absolute vorticity RELVOR= hshtran(hgather(u_slab,v_slab),vec=1,curl=1,phys=1,preserve=1); ABSVORXAV= hop(PLVOR, "+", hsub(RELVOR,x="avg"), units="s-1"); RELVOR= NULL; // Get pressure values on pressure levels (Pa) PLEV= hcoord(t_slab,"z"); if (PLEV.units == "hPa") PLEV= hop(PLEV, "*", 100., units="Pa"); if (PLEV.units != "Pa") error, "Incorrect pressure units"; // Compute delta pressure DELTAP2= hop( hshift(PLEV,"z",count=1), "-", hshift(PLEV,"z",count=-1), name="DELTAP2"); // Compute potential temperature THETA= hop( t_slab, "*", hop( hop(pref1,"/",PLEV,units=""), "^", kappa1) , name="THETA"); // E-P flux components (in pressure coordinates) // // ( [...] denotes zonal-averaging, (") denotes deviation from zonal-mean) // // PSIind = cos(phi) [v"theta"] / (d[theta]/dp) // // EPFY = PSIind d[u]/dp - [v"u"] cos(phi) // // EPFZ = (f + [xi]) PSIind - [omega"u"] cos(phi) // Compute vertical derivative of zonal-mean THETA THETAXAV= hsub(THETA,x="avg"); DTHDPXAV= hop( hop( hshift(THETAXAV,"z",count=1), "-", hshift(THETAXAV,"z",count=-1)), "/", DELTAP2, name="DTHDPXAV"); THETAXAV= NULL; // Compute vertical derivative of zonal-mean U UXAV= hsub(U,x="avg"); DUDPXAV= hop( hop( hshift(UXAV,"z",count=1), "-", hshift(UXAV,"z",count=-1)), "/", DELTAP2, name="DUDPXAV"); UXAV= NULL; // Compute [v"theta"], [u"v"], [u"omega"] VP= hop(v_slab, "-", hsub(v_slab,x="avg",nohistory=1),nohistory=1); THP= hop(THETA, "-", hsub(THETA,x="avg")); VTHPXAV= hsub( hop(VP,"*",THP,name="VTHP", units="m K s-1"), x="avg", nohistory=1 ); THP= NULL; THETA= NULL; UP= hop(u_slab, "-", hsub(u_slab,x="avg")); UVPXAV= hsub( hop(UP,"*",VP, name="UVP", units="m2 s-2"), x="avg" ); VP= NULL; OMP= hop(omega_slab, "-", hsub(omega_slab,x="avg")); UOMPXAV= hsub( hop(UP,"*",OMP,name="UOMP", units="m Pa s-2"), x="avg" ); UP= NULL; OMP= NULL; // Compute induced streamfunction PSIIND= hop( hop(VTHPXAV,"*",COSLAT,nohistory=1), "/", DTHDPXAV, name="PSIIND", units="m Pa s-1", nohistory=1); // Compute E-P flux components epfy_slab= hop( hop(PSIIND,"*",DUDPXAV, units="m2 s-2", nohistory=1), "-", hop(COSLAT,"*",UVPXAV), name="EPFY", nohistory=1 ); epfz_slab= hop( hop(PSIIND,"*",ABSVORXAV, units="m Pa s-2", nohistory=1), "-", hop(COSLAT,"*",UOMPXAV), name="EPFZ", nohistory=1 ); epfy_slab.long_name= "E-P_flux_y_component"; epfz_slab.long_name= "E-P_flux_p_component"; UVPXAV= NULL; UOMPXAV= NULL; VTHPXAV= NULL; DUDPXAV= NULL; ABSVORXAV= NULL; // Broadcast cos(phi)*EPFY to have original X dimension EPFYC= hop(COSLAT,"*",epfy_slab); EPFYCB= NULL; hcopy, t_slab, EPFYCB, data=broadcast(*(EPFYC.data),hdimsof(t_slab)); EPFYCB.name= "EPFYC"; // Compute gradient of cos(phi)*EPFY EPFYCGRAD= hshtran(EPFYCB,grad=1,phys=1,preserve=1); EPFYCY= hsub(EPFYCGRAD(I0+1),x="avg",name="EPFYCY"); EPFYCY.units= "m s-2"; EPFYC= NULL; EPFYCB= NULL; EPFYCGRAD= NULL; // Compute vertical derivative of EPFZ DEPFZDP= hop( hop( hshift(epfz_slab,"z",count=1,nohistory=1), "-",hshift(epfz_slab,"z",count=-1,nohistory=1)), "/", DELTAP2, name="DEPFZDP", units="m s-2", nohistory=1); // Compute E-P flux divergence epfdc_slab= hop( hop(DEPFZDP,"*",COSLAT,nohistory=1), "+", EPFYCY, name="EPFDC", nohistory=1 ); epfdc_slab.long_name= "E-P_flux_divergence_cosine"; EPFYCY= NULL; DEPFZDP= NULL; if (!param_set(nohistory)) { // Append history info to output slabs hset_attr, epfy_slab, "data:history", hattr(epfy_slab,"data:history") + " hatmepflux, " + his_str + ", ...;" hset_attr, epfz_slab, "data:history", hattr(epfz_slab,"data:history") + " hatmepflux, " + his_str + ", ...;" hset_attr, epfdc_slab, "data:history", hattr(epfdc_slab,"data:history") + " hatmepflux, " + his_str + ", ...;" } return timer_return(func_name); } func hatmepv( t_slab, u_slab, v_slab, help=, fpolar=, pref=, gravit=, kappa=, tref=, nohistory=) /* DOCUMENT hatmepv(t_slab, u_slab, v_slab, fpolar=, * pref=, gravit=, kappa=, * tref=, nohistory=0/1) * Computes Ertel Potential Vorticity (EPV, in m2 K s-1 kg-1), * given the temperatures (T_SLAB, in K) and velocity components * (U_SLAB, V_SLAB, in m/s). * * FPOLAR is the polar value of the Coriolis parameter (in s-1) * (defaults to 1.4584E-04) * * PREF is the reference pressure (in Pa) used to compute potential * temperature (defaults to 1000.0e2) * * GRAVIT is the surface gravitational acceleration (in m/s2) * (defaults to 9.80616) * * KAPPA is tha dimensionless ratio R/C_p (defaults to 287.04/1004.64) * * If reference temperature TREF (in K) is specified, the PV is * scaled to remove the static potential temperature dependence, * and the resulting nondimensional PV is returned. For isothermal * barotropic flow, the scaled PV should show no height variation. * * SEE ALSO: hatmepflux */ { func_name= "hatmepv"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; //IDLbegin: //:error, "Spectral transforms module SHTRAN not yet implemented in IDL"; //IDLend: //YORICKbegin: require, "shtran.i" //YORICKend: if (param_set(help)) { write,""; write," Function HATMEPV computes the Ertel Potential Vorticity,"; write," given T, U, && V."; write," E.g.,"; write," pv_slab = hatmepv(t_slab, u_slab, v_slab)"; write," See also: hatmepflux"; write,""; write," Usage: hatmepv(t_slab, u_slab, v_slab, ...)"; return timer_return(func_name, NULL); } if (is_null(t_slab) || is_null(u_slab) || is_null(v_slab)) error, "Null operand(s)"; if ( (typeof(t_slab) != "struct_instance") || \ (typeof(u_slab) != "struct_instance") || \ (typeof(v_slab) != "struct_instance") ) error, "Operands not hyperslabs"; if ((!is_scalar(t_slab)) || \ (!is_scalar(u_slab)) || \ (!is_scalar(v_slab)) ) error, "Operands should be scalar slabs"; if ( (t_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") || \ (u_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") || \ (v_slab.structure != "HYPERSLAB1.0_SPH_SIG_ATM") ) error, "Incorrect slab structure for operands"; if ((t_slab.units != "K") && (t_slab.units != "Kelvin")) error, "Unrecognized units for T_SLAB - " + t_slab.units; if ((u_slab.units != "m/s") && (u_slab.units != "m s-1")) error, "Unrecognized units for U_SLAB - " + u_slab.units; if ((v_slab.units != "m/s") && (v_slab.units != "m s-1")) error, "Unrecognized units for V_SLAB - " + v_slab.units; his_str= "<"+ t_slab.name+ ">,<" + u_slab.name + ">" + ">,<" + v_slab.name +">"; f0= double(1.4584E-04); if (!is_null(fpolar)) { his_str= his_str + ",fpolar=" + strnum(fpolar); f0= fpolar; } pref1= 1000.0e2; if (!is_null(pref)) { his_str= his_str + ",pref=" + strnum(pref); pref1= pref; } gravit1= 9.80616; if (!is_null(gravit)) { his_str= his_str + ",gravit=" + strnum(gravit); gravit1= gravit; } kappa1= 287.04/1004.64; if (!is_null(kappa)) { his_str= his_str + ",kappa=" + strnum(kappa); kappa1= kappa; } if (param_set(tref)) { // Prepare to scale PV his_str= his_str + ",tref=" + strnum(tref); // Reference PV pvref= gravit1 * f0 * kappa1 * tref / pref1; } // Compute sine/cosine of latitude SINLAT= hop("sin", hcoord(t_slab,"y"), name="SINLAT"); COSLAT= hop("cos", hcoord(t_slab,"y"), name="COSLAT"); // Compute planetary vorticity PLVOR= hop(SINLAT, "*", f0, name="PLVOR", units="s-1"); // Get pressure values on model levels (Pa) PMOD= hcoord(t_slab,"z"); if (PMOD.units == "hPa") PMOD= hop(PMOD, "*", 100., units="Pa"); if (PMOD.units != "Pa") error, "Incorrect pressure units"; // Compute delta pressure DPMOD2= hop( hshift(PMOD,"z",count=1), "-", hshift(PMOD,"z",count=-1), name="DPMOD2"); // Compute potential temperature THETA= hop( t_slab, "*", hop( hop(pref1,"/",PMOD,units=""), "^", kappa1) , name="THETA", nohistory=1); PMOD= NULL; // Compute Ertel"s PV using potential temperature as the invariant quantity. // If the result is interpolated to theta ("isentropic") surfaces, then // the field is what is commonly known is isentropic potential vorticity (IPV) // // PV = -g Zeta d(theta)/dp, where Zeta is the absolute vorticity on theta // surfaces. // Zeta is approximated by a standard coordinate transformation from the // input surfaces to theta surfaces. // // PV = -g{(vor+f) d(theta)/dp - [d(theta)/dx dv/dp - d(theta)/dy du/dp]} // // where vor, d(theta)/dx, and d(theta)/dy are on the input surfaces and // are obtained through spectral transforms. // "vor" is the relative vorticity, a code defined derived field. // // The -g factor is included to obtain the result in commonly used units // m2 K s-1 kg-1. // Compute vertical derivative of THETA DTHDP= hop( hop( hshift(THETA,"z",count=1, nohistory=1), "-", hshift(THETA,"z",count=-1, nohistory=1)), "/", DPMOD2,name="DTHDP", nohistory=1); // Compute relative vorticity RELVOR= hshtran(hgather(u_slab,v_slab),vec=1,curl=1,phys=1,preserve=1); // Add planetary vorticity ABSVOR= hop(PLVOR, "+", RELVOR, units="s-1"); // Compute PV term1 PVTERM1= hop(DTHDP, "*", ABSVOR, name="PVTERM1", nohistory=1); DTHDP= NULL; RELVOR= NULL; ABSVOR= NULL; // Compute horizontal gradient of Theta THGRAD= hshtran(THETA,grad=1,phys=1,preserve=1); if (param_set(tref)) { // Compute scale factor for nondimensionalizing PV PVSCALE= hop( pvref, "*", hop( hop(THETA,"/",tref,units=""), "^", 1.+1./kappa1), name="PVSCALE", units="m2 K s-1 kg-1"); } THETA= NULL; // Compute vertical derivative of U, V DUDP= hop( hop( hshift(u_slab,"z",count=1), "-", hshift(u_slab,"z",count=-1)), "/", DPMOD2, name="DUDP"); DVDP= hop( hop( hshift(v_slab,"z",count=1), "-", hshift(v_slab,"z",count=-1)), "/", DPMOD2, name="DVDP"); // Compute PV term2 PVTERM2= hop( hop(THGRAD(I0+0),"*",DVDP), "-", hop(THGRAD(I0+1),"*",DUDP),name="PVTERM2",units="K/Pa s-1"); THGRAD= NULL; DUDP= NULL; DVDP= NULL; DPMOD2= NULL; // Compute PV pv_slab= hop( -gravit1, "*", hop(PVTERM1,"-",PVTERM2), name="PV", units="m2 K s-1 kg-1", nohistory=1); pv_slab.long_name= "Ertel potential vorticity"; PVTERM1= NULL; PVTERM2= NULL; if (param_set(tref)) { // Scale PV pv_slab= hop( pv_slab, "/", PVSCALE, name="ScaledPV", nohistory=1 ); PVSCALE= NULL; } if (!param_set(nohistory)) { // Append history info to slab hset_attr, pv_slab, "data:history", hattr(pv_slab,"data:history") + " hatmepv( " + his_str + ");" } // Return output slab return timer_return(func_name, pv_slab); } func hbin( slab, dim, bin_size, help=, nohistory=) /* DOCUMENT hbin, slab, dim, bin_size, nohistory=0/1 * "Bins" data along dimension DIM (="x"/"y"/"z"/"t"/"i") by averaging the * weighted data values and the corresponding coordinate values. * BIN_SIZE may be a single value, or a list of values, which are used * cyclically. Negative values in a list would correspond to skipped bins. * SEE ALSO: htbin, hsub, hcat */ { func_name= "hbin"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HBIN bins data along a selected dimension."; write," E.g.,"; write," binned_slab = hbin(slab,'x',2)"; write," bins data in groups of 2 along the X dimension."; write," See also: htbin, hsub, hcat"; write,""; write," Usage: hbin(slab,'x/y/z/t/i',bin_size)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= hbin( slab(j), dim, bin_size, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab); } return timer_return(func_name, slab_array); } // Determine dimension to be re-introduced mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; if (!is_number(bin_size)) error, "Invalid bin size specification"; // Dimension presence codes is_present= slab.dimension(,HFMT.data); if (is_present(mdim-I1) <= 0) error, "Dimension to be binned not present"; ncoord= (hdimsof(slab))(1+mdim-I1); // History string his_str= "<" + slab.name + ">,<" + dim + ">,[" + strcombine(strnum(bin_size),",") + "]"; // Copy slab, ensuring that it contains data slab_copy= hdata(slab); if ( (is_present(ZDIM) > 0) && \ (!is_null(slab_copy.z0)) && (!is_null(slab_copy.zint0)) && \ (hattr(slab_copy,"area_wt:elements") != "dxdydz") ) { // Ensure that Z weights are included slab_copy= hver_wt(slab_copy); } // Count number of bins istart= 1; jsize= 0; nsize= numberof(bin_size); bin_range= NULL; while (istart <= ncoord) { if (bin_size(I0+jsize) > 0) { // Bin to be averaged over iend= istart+bin_size(I0+jsize)-1; if (iend > ncoord) error, "Incomplete bin not permitted"; grow, bin_range, [istart, iend]; } // Move to next bin istart= istart + abs(bin_size(I0+jsize)); jsize= (jsize + 1) % nsize; } nbin= numberof(bin_range)/2; if (nbin == 0) error, "No bins to be averaged over"; reshape_array, bin_range, [2, 2, nbin]; out_slab= NULL; for (j=I0; j <= nbin-I1; j++) { // Extract bin from slab and average irange= bin_range(,j); if (mdim == XDIM+I1) { tem_slab= hsub( slab_copy, limx=irange, x="avg", subscript=1 ); } else if (mdim == YDIM+I1) { tem_slab= hsub( slab_copy, limy=irange, y="avg", subscript=1 ); } else if (mdim == ZDIM+I1) { tem_slab= hsub( slab_copy, limz=irange, z="avg", subscript=1 ); } else if (mdim == TDIM+I1) { tem_slab= hsub( slab_copy, limt=irange, t="avg", subscript=1 ); } else if (mdim == IDIM+I1) { tem_slab= hsub( slab_copy, limi=irange, i="avg", subscript=1 ); } // Re-introduce averaged dimension, with averaged coordinate value tem_slab= hsprout(tem_slab, dim, area_wt=1, z_bot=1, crange="avg"); // Append to slab array hgrow, out_slab, tem_slab, j, nbin, destroy=1; } // Concatenate bin-averages out_slab= hcat(out_slab); if (!param_set(nohistory)) { // Append history info to output slab hset_attr, out_slab, "data:history", hattr(slab_copy,"data:history") + " hbin(" + his_str + ");" } return timer_return(func_name, out_slab); } func hcat(slab1,slab2,help=,ilabel=,iparam=,name=) /* DOCUMENT hcat(slab1,slab2,help=,ilabel=,iparam=,name=) * Concatenates SLAB1 and SLAB2 along a non-conformant dimension, provided * all other dimensions have full strong conformance, and the slabs also * have variable and grid conformance. * (Monotonicity of the concatenated coordinates is required.) * SLAB2 may be omitted, in which case SLAB1 should be an array of hyperslabs, * all of which are concatenated together. * * For the special case where all slabs have four identical dimensions "xyzt", * but do not have the i-dimension, the i-dimension is created, and the slabs * concatenated along that dimension. In this case, an array of new ILABEL * strings may be specified. If not, default labels are generated using * the variables names, if the variable names are different, and/or * the CASE_NAME, if the slabs are not case-conformant, and/or also the * HOR_DOMAIN, VER_DOMAIN attributes, if the slabs are not domain-conformant. * (i.e., attributes values that are not the same for all slabs are appended * to the label string for the slab, and set to null). * IPARAM contains the (optional) parameter values associated with the * i-dimension. * NAME contains the new variable name for the concatenated slab. * (NAME must be specified if the variable names are not the same.) * SEE ALSO: hsub, hsprout, hsplit, hcopy, happend */ { func_name= "hcat"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HCAT concatenates hyperslabs along a dimension."; write," E.g.,"; write," cat_slab = hcat(slab1,slab2)"; write," concatenates slab1 && slab2 along the non-conformant dimension."; write," cat_slab = hcat(slab_arr)"; write," concatenates the hyperslab array slab_arr along the non-conformant dimension."; write," Tips:"; write," 1. If the hyperslabs have four identical dimensions 'xyzt',"; write," a new i-dimension is automatically created. In this case"; write," ilabel=['label1',label2',...] may be specified to generate"; write," label strings for the i-dimension."; write," 2. iparam=[value1,value2,...] specifies i-parameter values."; write," See also: hsub, hsprout, hsplit, hcopy, happend"; write,""; write," Usage: hcat(slab1,slab2,ilabel=['label1','label2',...],iparam=...)"; return timer_return(func_name, NULL); } // Check conformance of hyperslabs isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, slab1, slab2, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; // Check unit and grid conformance if ( (!unit_conf) || (!grid_conf) ) error, "Unit/grid conformance required for concatenation"; if ((!var_conf) && is_null(name)) error, "NAME parameter must be specified for differing variables"; // Locate non-conformant dimension dwhere= where(dim_conf != 2); if (is_where(dwhere)) { // At least one non-conformant dimension if (numberof(dwhere) > 1) error, "More than one non-conformant dimension; cannot concatenate" // Dimension to be concatenated mcatdim= dwhere(I0) + I1; // Concatenate dimension cat_slab= ncat(mcatdim, slab1, slab2, extend=(case_conf && domain_conf) ); } else { // No non-conformant dimension is_present= slab1(I0).dimension(,HFMT.data); if (is_present(IDIM) > 0) error, "No non-conformant dimension for concatenation"; // Create i-dimension and concatenate is_present(IDIM)= 1; if (is_null(slab2)) { // Array of slabs nslab= numberof(slab1); if (is_null(ilabel)) { // Create label strings ilabel0= array("",nslab); if (!alleq(slab1.name)) ilabel0= ilabel0 + slab1.name; for (islab=I0; islab <= nslab-I1; islab++) { if (!case_conf) ilabel0(islab)= ilabel0(islab)+hattr(slab1(islab), ":case_name"); if (!domain_conf) { hstr= hattr(slab1(islab), ":hor_subdomain"); vstr= hattr(slab1(islab), ":ver_subdomain"); if (hstr != "") ilabel0(islab)= ilabel0(islab) + ":" + hstr; if (vstr != "") ilabel0(islab)= ilabel0(islab) + ":" + vstr; } } } else { // Specified label strings if (numberof(ilabel) != nslab) error, "No. of label strings does not match number of slabs"; ilabel0= ilabel; } // Copy slabs, creating i-dimension slab1c= NULL; iparam1= NULL; for (islab=I0; islab <= nslab-I1; islab++) { tem_slab= NULL; if (!is_null(iparam)) iparam1= iparam(islab); hcopy, slab1, tem_slab, index1=islab, is_present=is_present, ilabel1=[ilabel0(islab)], iparam1=iparam1, ilabel0=ilabel0, iparam0=iparam; nset_attr, "subdomain", tem_slab, IDIM+I1, islab+I1; hgrow, slab1c, tem_slab, islab, [1, nslab], destroy=1; } slab2c= NULL; } else { // Two slab concatenation if (is_null(ilabel)) { // Create label strings ilabel0= array("",2); if (slab1.name != slab2.name) ilabel0= ilabel0 + [slab1.name, slab2.name]; if (!case_conf) { ilabel0= ilabel0 + [ hattr(slab1, ":case_name"), hattr(slab2, ":case_name") ]; } if (!domain_conf) { hstr1= hattr(slab1, ":hor_subdomain"); vstr1= hattr(slab1, ":ver_subdomain"); hstr2= hattr(slab2, ":hor_subdomain"); vstr2= hattr(slab2, ":ver_subdomain"); if (hstr1 != "") ilabel0(I0)= ilabel0(I0) + ":" + hstr1; if (vstr1 != "") ilabel0(I0)= ilabel0(I0) + ":" + vstr1; if (hstr2 != "") ilabel0(I0+1)= ilabel0(I0+1) + ":" + hstr2; if (vstr2 != "") ilabel0(I0+1)= ilabel0(I0+1) + ":" + vstr2; } } else { // Specified label strings if (numberof(ilabel) != 2) error, "No. of label strings does not match number of slabs"; ilabel0= ilabel; } // Copy slabs, creating i-dimension iparam1= NULL; slab1c= NULL; if (!is_null(iparam)) iparam1= iparam(I0); hcopy, slab1, slab1c, is_present=is_present, ilabel1=[ilabel0(I0)], iparam1=iparam1, ilabel0=ilabel0, iparam0=iparam; slab2c= NULL; if (!is_null(iparam)) iparam1= iparam(I0+1); hcopy, slab2, slab2c, is_present=is_present, ilabel1=[ilabel0(I0+1)], iparam1=iparam1, ilabel0=ilabel0, iparam0=iparam; // Initialize i-dimension nset_attr, "subdomain", slab1c, IDIM+I1, 1; nset_attr, "subdomain", slab2c, IDIM+I1, 2; } // Concatenate i-dimension mcatdim= IDIM + I1; cat_slab= ncat(mcatdim, slab1c, slab2c, extend=1 ); } if (!is_null(name)) cat_slab.name= name; if (!case_conf) { // No case conformance hset_attr, cat_slab, ":case_name", ""; hset_attr, cat_slab, ":case_title", ""; } if (!domain_conf) { // No domain conformance hset_attr, cat_slab, ":hor_subdomain", ""; hset_attr, cat_slab, ":ver_subdomain", ""; } return timer_return(func_name, cat_slab); } func hclose( &fstruc, //YORICKoutput: help=,keep=,command=,silent=) /* DOCUMENT hclose,fstruc,help=0/1,keep=0/1,command=,silent=0/1 * Close netCDF history file described structure FSTRUC and associated with * file handle FHANDLE * * Optional parameter: * fstruc -- history file data structure (set to NULL on output) * (if omitted, default history file is closed) * (KEYWORD PARAMETERS) * help -- help option * keep -- if true, do not delete scratch file on closing * command -- execute specified string as operating system command * after closing the file(s), with any % characters * substituted with the file name header (i.e., excluding any * suffix, and leading pathnames). * silent -- silent mode * SEE ALSO: hopen */ { func_name= "hclose"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Procedure HCLOSE closes a previously opened netCDF history file."; write," E.g.,"; write," hclose "; write," closes the default history file."; write," hclose,fstruc2 "; write," closes the additional history file referred to by FSTRUC2, FHANDLE2."; write," Tips:"; write," 1. keep=1 prevents scratch files from being deleted"; write," 2. command='filter /tmp/%.his %.nc' applies operating system command,"; write," with occurrences of % substituted by file name header."; write,""; write," See also: hopen"; write,""; write," Usage: hclose[,fstruc][,keep=1][,command='..']"; return timer_return(func_name); } if (is_null(fstruc)) { // Close the default history file if (is_null(DEFAULT_FILE_STRUC)) return timer_return(func_name); fname= DEFAULT_FILE_STRUC.fname; fmeta= DEFAULT_FILE_STRUC.fmeta; fnumber= DEFAULT_FILE_STRUC.fnumber; fscratch= DEFAULT_FILE_STRUC.scratch; fhandle= nget_handle( DEFAULT_FILE_STRUC, erase=1 ); DEFAULT_FILE_STRUC= NULL; } else { // Close additional history file fname= fstruc.fname; fmeta= fstruc.fmeta; fnumber= fstruc.fnumber; fscratch= fstruc.scratch; fhandle= nget_handle( fstruc, erase=1 ); fstruc= NULL; } if (!param_set(silent)) { write, "hclose: closing file "+fname; } // Close netCDF file nc_close, fhandle; // Execute operating system command, if specified if (!is_null(command)) oscommand, command, filename=filename; if ((!param_set(keep)) && fscratch) { // Delete file(s) files= strsplit(fname,","); rm_command= "/bin/rm " + strcombine(files," "); oscommand, rm_command; } return timer_return(func_name); } func hcombine( &fstruc, //YORICKoutput: infiles, help=, varlist=, chunk_size=, create=, new_case=) /* DOCUMENT hcombine, fstruc, infiles, * help=help, varlist=varlist, chunk_size=chunk_size, * create=create, new_case=new_case * * Combine data from input files INFILES and append them out to output file * described by file data structure FSTRUC, * The appended hyperslabs must have strong full conformance in all * dimensions, including reduced ones, and also variable, case, and domain * conformance, with the hyperslabs already present in the output file. * * If VARLIST is specified, it should contain an array of strings, one for * each input file. Each string should contain a comma-separated list of * variables to be read from the file. Null string implies all variables * are to be read from the file. * * If VARLIST is specified as a single string (which may be a null string), * the same variables are read from all the input files, and concatenated * using the HCAT operator. * * If CHUNK_SIZE is specified, process data in chunks of CHUNK_SIZE * records each. This allows a smaller memory footprint for the operation. * * If CREATE="filename" is specified and FSTRUC has a null value, * a new netCDF file is created and its file structure is returned as * FSTRUC. Subsequent calls to HCOMBINE can append to this file. * * NEW_CASE is the (optional) new case name * * SEE ALSO: hsave, happend */ { func_name= "hcombine"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HCOMBINE combines data from several input files &&"; write," writes/appends them to a single netCDF file. E.g.,"; write," created using HSAVE, && subsequently opened using HOPEN. E.g.,"; write," hcombine, fstruc, ['infile1', 'infile2', ...]"; write," appends all hyperslabs from the specified input files to the file"; write," pointed to by file structure FSTRUC"; write," On returning, the FSTRUC is modified to reflect the appended data."; write," (The hyperslabs SLAB1 && SLAB2, which may themselves be arrays.)"; write," Tips:"; write," 1. varlist=['file1var1,file1var2','file2var1',...] selects variables for input."; write," 2. chunk_size= specified processing in chunks of records."; write," 3. create='filename' creates a new netCDF if FSTRUC is null."; write,""; write," See also: hsave, happend"; write,""; write," Usage: hcombine,fstruc,infiles,varlist=['file1var1,file1var2','file2var1',...],chunk_size=,create='filename'"; return timer_return(func_name); } //IDL2YORICK: error, "Not yet implemented in IDL" ; if (is_null(fstruc) && is_null(create)) error, "Null value for FSTRUC; specify create='filename'" if (is_null(infiles)) error, "No input files specified"; nfiles= numberof(infiles); varlist1= array("",nfiles); if (!is_null(varlist)) { if (numberof(varlist) == 1) { varlist1(*)= varlist; } else { if (numberof(varlist) != nfiles) error, "Incorrect number of strings specified for VARLIST"; varlist1= varlist; } } // Open all input files instruc= NULL; for (j=I0; j <= nfiles-I1; j++) { hopen, infiles(j), fs, fh, time0, date0, filevars, alt=1; grow, instruc, fs; if (j == I0) { // First input file; count records nt= numberof(time0); } else { if (nt != numberof(time0)) error, "No. of records does not match for file "+infiles(j); } // Determine variables to be read if (varlist1(j) == "") varlist1(j)= strcombine(filevars,","); } // Concatenation flag cat_flag= allof(varlist1(*) == varlist1(I0)); // Chunk size nsize= nt; if (param_set(chunk_size)) nsize= chunk_size; // No. of chunks nchunk= 1 + (nt-1)/nsize//; for (ichunk=I0; ichunk <= nchunk-I1; ichunk++) { // Starting, ending time subscripts itime1= 1 + (ichunk-1)*nsize//; if (ichunk != nchunk-I1) { // Not the last chunk itime2= itime1+nsize-1//; } else { // Last chunk itime2= nt//; } write, format="Chunk %4d: [%5d, %5d]\n", ichunk, itime1, itime2; ALLVARS= NULL; if (cat_flag) { // Concatenate variables vars= strsplit(varlist1(1),","); for (ivar=I0; ivar <= numberof(vars)-I1; ivar++) { VARCAT= NULL; for (j=I0; j <= nfiles-I1; j++) { VAR= hget(vars(ivar), fstruc=instruc(j), limt=[itime1,itime2], subscript=1, strip="i"); grow, VARCAT, VAR; } VARCAT= hcat(VARCAT); if (param_set(new_case)) hset_attr, VARCAT, ":case_name", new_case//; grow, ALLVARS, VARCAT; } } else { // Combine variables for (j=I0; j <= nfiles-I1; j++) { // Read input chunks VARS= hget(strsplit(varlist1(j),","), fstruc=instruc(j), limt=[itime1,itime2], subscript=1); if (param_set(new_case)) hset_attr, VARS, ":case_name", new_case//; grow, ALLVARS, VARS; } } // Append variables to file happend, fstruc, ALLVARS, create=create; } // Close input files for (j=I0; j <= nfiles-I1; j++) { hclose, instruc(j); } return timer_return(func_name); } func hconform( slab1, slab2, &isuperset, &dim_conf, &udim_conf, &unit_conf, //YORICKoutput: &var_conf, &case_conf, &grid_conf, &domain_conf, //YORICKoutput: help=, reduced=, verbose=) /* DOCUMENT hconform, slab1, slab2, * isuperset, dim_conf, udim_conf, unit_conf, * var_conf, case_conf, grid_conf, domain_conf, * help=, reduced=, verbose= * Checks conformance characteristics of two or more hyperslabs * * Input parameters: * slab1, slab2 -- hyperslab data structures * (slab1 may also be an array of hyperslabs, * in which case slab2 should be set to NULL) * Output parameters: * isuperset -- = 0 => no slab has superset of all dimensions present * > 0 => all dimensions are at least weakly conformant, * and slab ISUPERSET contains superset of all * dimensions present * dim_conf(SDIM) -- dimension conformance value (for each standard dimension) * 0 => corresponding dimensions are non-conformable * >0 => corresponding dimensions are strongly conformable * <0 => corresponding dimensions are weakly conformable * [ 2 => present in all and identical, or missing in all slabs * ("strong full conformance") * 1 => identical where present, missing in one or more slabs * ("strong broadcast conformance") * -1 => same length, where present * ("weak broadcast conformance") * -2 => same length in all ] * ("weak full conformance") * udim_conf(SDIM)-- dimension units and other attributes conformance value * (for each standard dimension) * 1 => dimension units/long name/grid/reduction-ops are same * 0 => dimension units/long name/... are different * unit_conf -- true if all slabs have the same data units * var_conf -- true if all slabs have unit conformance, and the same * variable names, long names, and time representation * case_conf -- true if all slabs have the same case name attribute * grid_conf -- true if all slabs have the same full domain grid * domain_conf -- true if all slabs have grid conformance, and * have the same horizontal and vertical subdomain name * attributes * (KEYWORD PARAMETERS) * help -- help option * reduced -- if true, check conformance of reduced dimensions as well * verbose -- verbose option (prints out additional info) * SEE ALSO: hop, hcat, happend */ { func_name= "hconform"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Procedure HCONFORM checks conformance of two || more hyperslabs."; write," E.g.,"; write," hconform, slab_a, slab_b, isuperset, dim_conf, udim_conf,"; write," unit_conf, var_conf, case_conf, grid_conf, domain_conf"; write," check conformance of slab_a && slab_a, returning the various"; write," conformance flags."; write," hconform, slab_arr, NULL, ..."; write," checks conformance of an array of hyperslabs slab_arr."; write," Tips:"; write," 1. verbose=1 option prints out conformance details."; write," 2. See source code && hyperslab structure definition for the"; write," meaning of all the output parameters."; write," See also: hop, hcat, happend"; write,""; write," Usage: hconform, slab_a, slab_b, isuperset, dim_conf, udim_conf,"; write," unit_conf, var_conf, case_conf, grid_conf, domain_conf,"; write," verbose=1"; return timer_return(func_name); } if ( (typeof(slab1) != "struct_instance") && \ (typeof(slab2) != "struct_instance") ) error, "Argument SLAB1, SLAB2 should be structures"; if (is_null(slab2)) { // Only one argument present; check no. of elements nslab= numberof(slab1); // Ensure that there are at least two slabs if (nslab <= 1) error, "At least two slab arguments required for conformance testing"; slab_array= 1; } else { // Two arguments present if ((!is_scalar(slab1)) || (!is_scalar(slab2))) error, "SLAB1 && SLAB2 should both be scalars"; nslab= 2; slab_array= 0; } // Conformance strings conf_str= ["WF", "WB", "NC", "SB", "SF"]; flag_str= ["F", "T"]; // Initialize dimension conformance array (set to strong full conformance) dim_conf= array(2,SDIM); // Initialize dimension unit conformance array (set to true) udim_conf= array(1,SDIM); // Initialize all dimensions present array (set to true) all_present= array(1,nslab); for (mdim=I0; mdim <= SDIM-I1; mdim++) { dim_presence= array(1,nslab); coord= NULL; if (!slab_array) { // SLAB1 is not an array if ( (slab1.dimension(mdim,HFMT.data) > 0) || \ ( (slab1.dimension(mdim,HFMT.data) < 0) && \ param_set(reduced) ) ) { // Dimension is/was present in slab coord= ngetcoord(slab1,mdim+I1); credop= slab1.reduced(mdim); cgrid= nattr("grid",slab1,mdim+I1); cunits= nattr("units",slab1,mdim+I1); clong_name= nattr("long_name",slab1,mdim+I1); } else { coord= NULL; // Dimension not present in slab; reset slab dimension presence flag dim_presence(1-I1)= 0; } if ( (slab2.dimension(mdim,HFMT.data) > 0) || \ ( (slab2.dimension(mdim,HFMT.data) < 0) && \ param_set(reduced) ) ) { // Dimension is/was present in slab coord2= ngetcoord(slab2,mdim+I1); if (!is_null(coord)) { // Check conformance of dimension grid, units, and long name udim_conf(mdim)= udim_conf(mdim) && \ (nattr("grid",slab2,mdim+I1) == cgrid) && \ (nattr("units",slab2,mdim+I1) == cunits) && \ (nattr("long_name",slab2,mdim+I1) == clong_name); if (param_set(reduced)) { // Check reduction operation on dimension udim_conf(mdim)= udim_conf(mdim) && \ (slab2.reduced(mdim) == credop); } if (numberof(coord2) == numberof(coord)) { // Same dimension length; check coordinate values if ( (!array_eq(coord2,coord,epsilon=HFMT.epscoord)) && \ (dim_conf(mdim) > 0) ) { // Weak full conformance dim_conf(mdim)= -2; } } else { // Different dimension lengths; non-conformance dim_conf(mdim)= 0; } } } else { // Dimension not present in slab; reset slab dimension presence flag dim_presence(2-I1)= 0; } } else { // SLAB1 is an array for (islab=I0; islab <= nslab-I1; islab++) { if ( (slab1(islab).dimension(mdim,HFMT.data) > 0) || \ ( (slab1(islab).dimension(mdim,HFMT.data) < 0) && \ param_set(reduced) ) ) { // Dimension is/was present in slab if (is_null(coord)) { coord= ngetcoord(slab1(islab),mdim+I1); credop= slab1(islab).reduced(mdim); cgrid= nattr("grid",slab1(islab),mdim+I1); cunits= nattr("units",slab1(islab),mdim+I1); clong_name= nattr("long_name",slab1(islab),mdim+I1); } else { coord2= ngetcoord(slab1(islab),mdim+I1); // Check conformance of dimension grid, units, and long name udim_conf(mdim)= udim_conf(mdim) && \ (nattr("grid",slab1(islab),mdim+I1) == cgrid) && \ (nattr("units",slab1(islab),mdim+I1) == cunits) && \ (nattr("long_name",slab1(islab),mdim+I1) == clong_name); if (param_set(reduced)) { // Check reduction operation on dimension udim_conf(mdim)= udim_conf(mdim) && \ (slab1(islab).reduced(mdim) == credop); } if (numberof(coord2) == numberof(coord)) { // Same dimension lengths; check coordinate values if ( (!array_eq(coord2,coord,epsilon=HFMT.epscoord)) && \ (dim_conf(mdim) > 0) ) { // Weak full conformance dim_conf(mdim)= -2; } } else { // Differing dimension lengths; non-conformance dim_conf(mdim)= 0; } } } else { // Dimension not present in slab; reset slab dimension presence flag dim_presence(islab)= 0; } } } if (!(allof(dim_presence) || noneof(dim_presence)) ) { // Some slabs with missing dimension; downgrade to broadcast conformance dim_conf(mdim)= dim_conf(mdim) / 2; } if (!udim_conf(mdim)) { // Dimension attributes not identical; downgrade to weak conformance dim_conf(mdim)= -abs(dim_conf(mdim)); } if (anyof(dim_presence(*))) { // Apply AND operation on combined slabs dimension presence flag all_present(*)= all_present(*) * dim_presence(*); } } // Superset slab number isuperset= 0; if ( (noneof(abs(dim_conf) == 0)) && anyof(all_present) ) { // All dimensions are at least weakly conformant, and // at least one slab has superset of all dimensions present; locate it isuperset= (where(all_present))(I0) + I1; } if (!slab_array) { // Units conformance unit_conf= (slab1.units == slab2.units); // Variable conformance var_conf= unit_conf && (slab1.name == slab2.name ) && \ (slab1.long_name == slab2.long_name) && \ (hattr(slab1,"data:time_rep") == hattr(slab2,"data:time_rep")); // Case conformance case_conf= (hattr( slab1,":case_name") == hattr( slab2,":case_name")); // Grid conformance grid_conf= (slab1.structure == slab2.structure) && \ (hattr(slab1,"x:period") == hattr(slab2,"x:period")) && \ (hattr(slab1,"x:rotated") == hattr(slab2,"x:rotated")) && \ array_eq(deref(slab1.x0), deref(slab2.x0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.y0), deref(slab2.y0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.z0), deref(slab2.z0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.ilabel0), deref(slab2.ilabel0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.iparam0), deref(slab2.iparam0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.xint0), deref(slab2.xint0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.yint0), deref(slab2.yint0), epsilon=HFMT.epscoord) && \ array_eq(deref(slab1.zint0), deref(slab2.zint0), epsilon=HFMT.epscoord); // Domain conformance domain_conf= grid_conf && \ (hattr(slab1,":hor_subdomain") == hattr(slab2,":hor_subdomain")) && \ (hattr(slab1,":ver_subdomain") == hattr(slab2,":ver_subdomain")); } else { // Units conformance unit_conf= alleq( slab1.units ); // Variable conformance var_conf= unit_conf && alleq(slab1.name ) && \ alleq(slab1.long_name) && \ alleq( hattr(slab1,"data:time_rep") ); // Case conformance case_conf= alleq( hattr( slab1,":case_name") ); // Grid conformance grid_conf= 0; if ( alleq(slab1.structure) ) { grid_conf= 1; x0= deref(slab1(I0).x0); y0= deref(slab1(I0).y0); z0= deref(slab1(I0).z0); ilabel0= deref(slab1(I0).ilabel0); iparam0= deref(slab1(I0).iparam0); xint0= deref(slab1(I0).xint0); yint0= deref(slab1(I0).yint0); zint0= deref(slab1(I0).zint0); for (islab=I0+1; islab <= nslab-I1; islab++) { grid_conf= grid_conf && \ alleq(hattr(slab1,"x:period")) && \ alleq(hattr(slab1,"x:rotated")) && \ array_eq( deref(slab1(islab).x0), x0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).y0), y0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).z0), z0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).ilabel0), ilabel0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).iparam0), iparam0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).xint0), xint0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).yint0), yint0, epsilon=HFMT.epscoord ) && \ array_eq( deref(slab1(islab).zint0), zint0, epsilon=HFMT.epscoord ); } } // Domain conformance domain_conf= grid_conf && alleq(hattr(slab1,":hor_subdomain")) && \ alleq(hattr(slab1,":ver_subdomain")); } if (param_set(verbose)) { // Print out conformance information write, "Superset-slab-no: ", strnum(isuperset); write, "Dimension-conformance: ", strcombine( conf_str(dim_conf(*)+2+I0), "," ); write, "Dimension-unit-conformance: ", strcombine( flag_str(udim_conf(*)+I0), "," ); write, "Unit-conformance: ", flag_str(unit_conf+I0); write, "Variable-conformance: ", flag_str(var_conf+I0); write, "Case-conformance: ", flag_str(case_conf+I0); write, "Grid-conformance: ", flag_str(grid_conf+I0); write, "Domain-conformance: ", flag_str(domain_conf+I0); } return timer_return(func_name); } func hcont(slab,help=,mval=,fill=,width=,scolor=, lcolor=,ltype=,proj=,ppars=,rotx=, terrain=,transp=) /* DOCUMENT hcont,slab,help=,mval=,fill=,width=,scolor=, * lcolor=,proj=,ppars=,rotx=,terrain=,transp= * Superimposes continental outlines on previous plot for * atmospheric/oceanic hyperslab data, and optionally solid-fills land area * * slab -- hyperslab containing atmospheric/oceanic data * (KEYWORD PARAMETERS) * help -- help option * mval -- for atmospheric data, ORO mask value to be contoured * for oceanic data, depth index values < MVAL are contoured * (default value is 1) * fill -- if set, solid-fill land area * width -- line thickness (default 0.5) * scolor -- color for solid fills (default: light gray) * lcolor -- color for continental outlines (default: black) * ltype -- linetype for continental outlines (default: solid) * proj -- projection ("","NHPOLAR","SHPOLAR","MOLLWEIDE",...) * (NOTE: projection names may be abbreviated) * ppars -- projection parameters ([start_lon, extreme_lat]/...) * rotx -- if defined, rotate X-coordinate by angle ROTX * terrain -- slab containing terrain elevation (in m) above * sea level to be used to draw continental outlines * (special case: if terrain==1, use 30-minute topographic * elevation values from TerrainBase dataset) * transp -- if set, interchanges X/Y axes * SEE ALSO: hplot */ { func_name= "hcont"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HCONT superimposes continental outlines on previous plot"; write," for atmospheric/oceanic hyperslab data."; write," E.g.,"; write," hcont, slab"; write," superimposes continental outlines over previous plot."; write," Tips:"; write," 1. fill=1 produces solid-fills for continents."; write," 2. width=line_width, scolor=fill_color, lcolor=line_color, "; write," ltype=line_type control line/fill details."; write," 3. proj='projection', ppars=[] "; write," controls the projection."; write," 4. rotx=x_rotation_angle rotates the X domain."; write," 5. terrain=1 uses 30-minute topographic elevation database"; write," 6. mval=mask_value determines value to be contoured."; write," See also: hplot"; write,""; write," Usage: hcont,slab,mval=mask_value,width=line_width,scolor=fill_color,"; write," lcolor=line_color,proj=...,ppars=[...],rotx=rot_angle,terrain=1,fill=1"; return timer_return(func_name); } if (is_null(mval)) mval= 1; if (is_null(width)) width= 0.5; if (is_null(scolor)) scolor= 10; if (is_null(lcolor)) lcolor= 2; if (is_null(ltype)) ltype= 0; if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) error, "Argument SLAB should be a scalar"; is_present= slab.dimension(,HFMT.data); // Determine X/Y dimensions if ( (is_present(XDIM) <= 0) || (is_present(YDIM) <= 0) ) error, "X/Y dimensions not present in slab"; ddims= hdimsof(slab); nx= ddims(1+XDIM); ny= ddims(1+YDIM); // Return if too few grid points if ( (nx < 2) || (ny < 2) ) return timer_return(func_name); if (param_set(terrain)) { if (typeof(terrain) == "struct_instance") { elev_slab= terrain; } else { if (strlen(HFMT.hopsroot) == 0) error, "Set environment variable HOPS_ROOT to root directory of HOPS installation"; // Read topographic elevation data elev_slab= hget("TOPO30", file=HFMT.hopsroot+"/data/topo30.nc"); } // Reduce to subdomain like slab elev_slab= hsub(elev_slab, like=slab); //HARD-EXTENSIONS-BEGIN: // Determine continental mask if (slab.structure == "HYPERSLAB1.0_SPH_SIG_ATM") { // SPH_SIG_ATM extension elev_slab= hop(elev_slab, ">", 0.); } else if (slab.structure == "HYPERSLAB1.0_SPH_SIG_OCN") { // SPH_SIG_OCN extension elev_slab= hop(elev_slab, ">", 0.); } else { error, "Unrecognized slab type"; } //HARD-EXTENSIONS-END: if (param_set(fill)) { // Solid fill all land areas hplot, elev_slab, proj=proj, ppars=ppars, rotx=rotx, transp=transp, overplot=1, levs=[0.5, 1.5], nomask=1, mix=[scolor,scolor], fill=1; } else { // Plot continental outline hplot, elev_slab, proj=proj, ppars=ppars, rotx=rotx, transp=transp, overplot=1, levs=[0.5, 1.5], nomask=1, width=width, line_color=lcolor, type=ltype, c_labels=0; } } else { // Current horizontal subdomain offsets ix= nattr("subdomain",slab,XDIM+I1); iy= nattr("subdomain",slab,YDIM+I1); if ( (ix < 0) || (iy < 0)) error, "X && Y subdomains should be contiguous to plot continental outlines"; if (ix == 0) ix= 1; if (iy == 0) iy= 1; // Get regular grid coordinates for subdomain xc= ngetcoord(slab, XDIM+I1, grid=1); yc= ngetcoord(slab, YDIM+I1, grid=1); if (numberof(xc) < (nx+ix-1)) nx= numberof(xc) - (ix-1); if (numberof(yc) < (ny+iy-1)) ny= numberof(yc) - (iy-1); xc= xc(ix-I1:ix+nx-1-I1); yc= yc(iy-I1:iy+ny-1-I1); // Current rotation state x_rotated= hattr(slab, "x:rotated"); //HARD-EXTENSIONS-BEGIN: // Slab type, full domain land mask if (slab.structure == "HYPERSLAB1.0_SPH_SIG_ATM") { // SPH_SIG_ATM extension lmask= (*(slab.hgrid0) == mval); } else if (slab.structure == "HYPERSLAB1.0_SPH_SIG_OCN") { // SPH_SIG_OCN extension lmask= (*(slab.kmax0) < mval); } else { error, "Unrecognized slab type"; } //HARD-EXTENSIONS-END: if (x_rotated != 0) { // Apply rotation on full domain masks lmask= rangeop(lmask,"rot",1,count=-x_rotated); } // Reduce land mask to subdomain lmask= lmask(ix-I1:ix+nx-1-I1, iy-I1:iy+ny-1-I1); if (param_set(rotx) && (nattr("subdomain",slab,XDIM+I1) == 0)) { // Rotate X-coordinate xrotate,360.0,rotx,xc,irot; lmask= rangeop(lmask,"rot",1,count=irot); } // Compute grid-box boundaries xb= xc(I0) - 0.5*(xc(I0+1)-xc(I0)); grow, xb, 0.5*(xc(I0:nx-I1-1) + xc(I0+1:nx-I1)); grow, xb, xc(nx-I1) + 0.5*(xc(nx-I1) - xc(nx-I1-1)); yb= yc(I0) - 0.5*(yc(I0+1)-yc(I0)); grow, yb, 0.5*(yc(I0:ny-I1-1) + yc(I0+1:ny-I1)); grow, yb, yc(ny-I1) + 0.5*(yc(ny-I1) - yc(ny-I1-1)); nxb= numberof(xb); nyb= numberof(yb); // Generate grid-box boundary mesh xm= xb(,-:1:nyb)// //IDL2YORICK: xm= xb # replicate(1, nyb) ym= yb(-:1:nxb,)// //IDL2YORICK: ym= replicate(1, nxb) # yb if (!is_null(proj)) { // Projection specified pmesh= array(double, 2, numberof(xm) ); pmesh(I0,)= xm(*); pmesh(I0+1,)= ym(*); pmesh= fproject( pmesh, proj=proj, ppars=ppars); xm(*)= pmesh(I0,); ym(*)= pmesh(I0+1,); } if (param_set(transp)) { // Transpose X/Y coordinates lmask= transpose(lmask); temp= xm; xm= ym; ym= temp; temp= nx; nx= ny; ny= temp; } if (param_set(fill)) { // Solid fill all land areas for (j=I0; j <= ny-I1; j++) { for (i=I0; i <= nx-I1; i++) { if (lmask(i,j) != 0) { plfp,[char(scolor)],[ym(i,j), ym(i,j+1), ym(i+1,j+1), ym(i+1,j)], [xm(i,j), xm(i,j+1), xm(i+1,j+1), xm(i+1,j)], [4]; } } } } else { // Draw continental outlines for (j=I0; j <= ny-I1; j++) { for (i=I0; i <= nx-I1; i++) { if (lmask(i,j) != 0) { if (i < nx-1) { if (lmask(i+1,j) == 0) plg, [ym(i+1,j), ym(i+1,j+1)], [xm(i+1,j), xm(i+1,j+1)], width=width, type=ltype, color=char(lcolor), marks=0; } if (i > 0) { if (lmask(i-1,j) == 0) plg, [ym(i,j), ym(i,j+1)], [xm(i,j), xm(i,j+1)], width=width, type=ltype, color=char(lcolor), marks=0; } if (j < ny-1) { if (lmask(i,j+1) == 0) plg, [ym(i,j+1), ym(i+1,j+1)], [xm(i,j+1), xm(i+1,j+1)], width=width, type=ltype, color=char(lcolor), marks=0; } if (j > 0) { if (lmask(i,j-1) == 0) plg, [ym(i,j), ym(i+1,j)], [xm(i,j), xm(i+1,j)], width=width, type=ltype, color=char(lcolor), marks=0; } } } } } } return timer_return(func_name); } func hcoord(slab,dim,help=,all=,data_prec=) /* DOCUMENT hcoord(slab,dim,help=,all=0/1,data_prec=) * returns a version of hyperslab SLAB with the variable values replaced * by the coordinate values corresponding to dimension DIM * ("x"/"y"/"z"/"t"/"i"), and the variable name/units changed to that of * the coordinate. * (The coordinate values will be defined everywhere; i.e., there will be * no missing values.) * If DIM=="area_wt", the area weights are returned as a hyperslab. * If DIM=="z_bot", the bottom Z values are returned as a hyperslab. * If ALL==1, coordinate values are broadcast to have all data dimensions. * DATA_PREC, if set, specifies the data precision ("float"/"double") * for the coordinate values. (The default is to have the same precision * as the data.) * SEE ALSO: hinterp, hver_wt */ { func_name= "hcoord"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HCOORD returns slab with data values substituted by the"; write," coordinate values for the specified dimension. E.g.,"; write," z_slab = hcoord(slab, 'z')"; write," returns a slab containing Z coordinate values."; write," Tips:"; write," 1. all=1 ensures that coordinates are broadcast to data dimensions."; write," See also: hinterp, hver_wt"; write,""; write," Usage: hcoord(slab, 'x/y/z/t/i', data_prec='float/double')"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (i=I0; i <= I0+numberof(slab)-1; i++) { tem_slab= NULL; tem_slab= hcoord( slab(i), dim ); hgrow, slab_array, tem_slab, i, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (slab.type(HFMT.data) == "") error, "Error - null data values"; // Determine coordinate precision if (param_set(data_prec)) { coord_prec= data_prec; } else { // Data type info data_type= slab.type(HFMT.data); if (data_type == "struct_instance") { loc= *(slab.data); data_type= loc.type(HFMT.data); } coord_prec= ndataprec(data_type); } if (strtolower(dim) == "area_wt") { // Return area weights slab if (is_null(slab.area_wt)) error, "Area weights not available in slab"; area_wt1= typeconv( coord_prec, *(slab.area_wt) ); apresent= slab.dimension(,HFMT.area_wt); // Create area weights slab new_slab= NULL; hcopy, slab, new_slab, is_present=apresent, data=area_wt1, missing_value="", area_wt1="", area_wt_dims=array(long,SDIM), z_bot1="", z_bot_dims=array(long,SDIM); // Change variable name/units new_slab.name= slab.name + "_area_wt"; new_slab.units= hattr(slab,"area_wt:units"); new_slab.long_name= "Area weights"; return timer_return(func_name, new_slab); } if (strtolower(dim) == "z_bot") { // Return Z_BOT values slab if (is_null(slab.z_bot)) error, "Bottom Z values not available in slab"; z_bot1= typeconv( coord_prec, *(slab.z_bot) ); zpresent= slab.dimension(,HFMT.z_bot); // Create Z_BOT values slab new_slab= NULL; hcopy, slab, new_slab, is_present=zpresent, data=z_bot1, area_wt1="", area_wt_dims=array(long,SDIM), z_bot1="", z_bot_dims=array(long,SDIM); // Change variable name/units new_slab.name= slab.name + "_z_bot"; new_slab.units= hattr(slab,"z_bot:units"); new_slab.long_name= "Bottom Z values"; return timer_return(func_name, new_slab); } // Determine selected dimension mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; // Dimension presence/reduction codes is_present= slab.dimension(,HFMT.data); is_reduced= slab.reduced(*); if (is_present(mdim-I1) <= 0) error, "Dimension needs to be present in the data to generate coordinates"; // Reduce all dimensions new_reduced= is_reduced; new_reduced(where(is_present > 0))= -strloc(HFMT.reduceops, "avg"); new_present= -abs(is_present); // Sigma coordinate flag sigma_coord= (nattr("units",slab,ZDIM+I1) == "hybrid_sigma_pressure") || \ (nattr("units",slab,ZDIM+I1) == "sigma_level"); if ((mdim != ZDIM+I1) || (!sigma_coord)) { // Not sigma Z coordinate // Coordinate variable name and units if (mdim == IDIM+I1) { new_name= "iparam"; new_long_name= "parameter"; } else { new_name= HFMT.dimnames(mdim-I1); new_long_name= nattr("long_name", slab, mdim); } new_units= nattr("units", slab, mdim); // Get coordinate values coord= ngetcoord(slab, mdim, iparam=1); ncoord= numberof(coord); if (ncoord == 0) error, "Coordinate values not available for dimension"; // Reintroduce selected dimension new_present(mdim-I1)= is_present(mdim-I1); // Copy coordinate values as data values data1= typeconv( coord_prec, coord ); // Reshape data array to have right dimensionality ddims= array(1,SDIM+1); ddims(I0)= SDIM; ddims(1+mdim-I1)= ncoord; reshape_array, data1, ddims; } else { // Sigma Z coordinate if (slab.type(HFMT.z_bot) == "") error, "Bottom Z values not available to compute vertical coordinate"; // Copy Z_BOT values z_bot1= *(slab.z_bot); z_bot_ref1= typeconv( coord_prec, hattr(slab, "z_bot:ref") ); // Coordinate variable name and units zb_long_name= hattr(slab, "z_bot:long_name"); new_name= "z"; new_units= hattr(slab, "z_bot:units"); new_long_name= ""; if (zb_long_name == "surface_pressure") { // Pressure coordinate new_name= "p"; new_long_name= "pressure"; } else if (zb_long_name == "bottom_depth") { // Depth coordinate new_long_name= "depth"; } // Copy Z coordinate z= *(slab.z); nz= numberof(z); // Locate Z offset iz= nattr("subdomain",slab,ZDIM+I1); if (iz < 0) error, "Cannot compute vertical weights for non-contiguous Z subdomain"; if (iz == 0) iz= 1; // Copy missing value missing_value= deref(slab.missing_value); // Get full domain sigma values if (is_present(ZDIM) == 1) { // Data on regular Z grid if (is_null(slab.sigma0)) error, "Full domain regular sigma values not available"; sigmafull= *(slab.sigma0); } else { // Data on interfacial Z grid if (is_null(slab.sigmaint0)) error, "Full domain interfacial sigma values not available"; sigmafull= *(slab.sigmaint0); } // Set precision of sigma values sigmafull= typeconv( coord_prec, sigmafull ); // List of current data dimensions ddims= hdimsof(slab); // Z_BOT dimensions new_ddims= hdimsof(slab, z_bot=1); // Re-introduce all dimensions present in Z_BOT zwhere= where(slab.dimension(,HFMT.z_bot) > 0); if (is_where(zwhere)) { new_present(zwhere)= is_present(zwhere); new_reduced(zwhere)= 0; } // Add Z dimension new_ddims(1+ZDIM)= ddims(1+ZDIM); new_present(ZDIM)= is_present(ZDIM); timer_call,"hcoord-crit"; //CRITICAL-SECTION-BEGIN: if (!is_null(missing_value)) { // Set missing bottom Z values to reference bottom value (temporarily) // (This is just for computational convenience to avoid overflows.) z_missing= where(z_bot1 == missing_value); if (is_where(z_missing)) z_bot1(z_missing)= z_bot_ref1; } // Set precision of Z_BOT values if (typeof(z_bot1) != coord_prec) z_bot1= typeconv( coord_prec, z_bot1 ); // Focus on Z dimension new_zfocus= dim_reshape( new_ddims, focus=ZDIM+I1 ); nxy= new_zfocus(I0+1); nti= new_zfocus(I0+3); // Reshape/create arrays reshape_array, z_bot1, [2, nxy, nti]; data1= array( typeconv(coord_prec,0), [3, nxy, nz, nti] ); // Compute vertical coordinate for (k=I0; k <= I0+nz-1; k++) { data1(,k,)= sigmafull(I0, k+iz-1)*z_bot_ref1 + sigmafull(I0+1, k+iz-1)*z_bot1(,); } // Reshape data array to final dimensions reshape_array, data1, new_ddims; timer_return,"hcoord-crit"; //CRITICAL-SECTION-END: } if (param_set(all)) { // Broadcast coordinate values to all dimensions present in original data dwhere= where(slab.dimension(,HFMT.data) > 0); new_present(dwhere)= is_present(dwhere); new_reduced(dwhere)= 0; data1= broadcast(data1, hdimsof(slab)); // Copy slab, replacing data values with coordinate values (no missing values) new_slab= NULL; hcopy, slab, new_slab, is_present=new_present, is_reduced=new_reduced, missing_value="", data=data1; } else { // Create slab containing coordinate values (no missing values, area weights) new_slab= NULL; hcopy, slab, new_slab, is_present=new_present, is_reduced=new_reduced, missing_value="", data=data1, area_wt1="", area_wt_dims=array(long,SDIM), z_bot1="", z_bot_dims=array(long,SDIM); } // Change variable name/units new_slab.name= new_name; new_slab.units= new_units; new_slab.long_name= new_long_name; return timer_return(func_name, new_slab); } func hcopy( slab1, &slab2, //YORICKoutput: help=, index1=, index2=, overwrite=, x1=, y1=, z1=, time1=, date1=, ilabel1=, iparam1=, data=, area_wt1=, z_bot1=, missing_value=, x0=, y0=, z0=, xint0=, yint0=, zint0=, ilabel0=, iparam0=, structure0=, reset_vars=, extra_atts=, area_wt_dims=, z_bot_dims=, is_present=, is_reduced=) /* DOCUMENT hcopy, slab1, slab2, help=help, index1=index1, index2=index2, * x1=x1, y1=y1, z1=z1, time1=time1, date1=date1, ilabel1=ilabel1, * iparam1=iparam1, data=data, area_wt1=area_wt1, z_bot1=z_bot1, * missing_value=missing_value, * x0=x0, y0=y0, z0=z0, xint0=xint0, yint0=yint0, zint0=zint0, * ilabel0=ilabel0, iparam0=iparam0, structure0=structure0, * reset_vars=reset_vars, extra_atts=extra_atts, * area_wt_dims=area_wt_dims, z_bot_dims=z_bot_dims, * is_present=is_present, is_reduced=is_reduced * Copy SLAB1 to SLAB2, with specified keyword parameter fields modified. * If SLAB2 is an array of hyperslabs, copy SLAB1 into element * SLAB2(INDEX2) of the array. * If SLAB2 is null, return in SLAB2 a new modified copy of SLAB1, * with default field values determined by the STRUCTURE keyword parameter. * If OVERWRITE == 1, overwrite values in SLAB2. * Either SLAB1 or SLAB2 may be arrays. If they are both arrays, they * should have the same number of elements. Otherwise, if SLAB1 is an array, * SLAB2 should be null. If SLAB2 is an array, * INDEX1/INDEX2 should be specified to choose the element of the array to * copy from or to copy to. * If SLAB2 is undefined, a new hyperslab is created. * * RESET_VARS is a list of variables whose attribute lists need to be reset * (i.e., standard attributes are set to "zero" values and the non-standard * attributes are "deleted"). * (*NOTE* Attributes of coordinate variables for undefined dimensions are * automatically reset.) * EXTRA_ATTS is a 3xn array of string triplets of the form * [ ["variable_name", "attribute", "data_type"], ...] * of extra attributes to be added to the hyperslab. * IS_PRESENT specifies what dimensions are present, and what their grid types * are. * IS_REDUCED specifies what reduction operations have been carried out on the * dimensions. * AREA_WT_DIMS specifies the current dimensions present for the area weights. * Z_BOT_DIMS specifies the current dimensions present for the Z_BOT array. * (See the hyperslab format definition document for more details.) * If keyword parameter IS_PRESENT is specified, the data array, area weights * array, and the z_bot array are reshaped to conform to the standard * coordinate dimensions. * **Important note** * Specifying NULL values to parameters is equivalent to omitting them, * which would result in their values being copied from the source SLAB1. * To prevent that and to actually assign a NULL value for a parameter, * set numeric parameters to a string value (e.g., x1="", missing_value="", * data=""), and string parameters to a numeric value (e.g., ilabel1=0). * * Output parameter: * slab2 -- new slab * SEE ALSO: hget, hsub, hcat, hsave, hattr, hdata, ncopyatt */ { func_name= "hcopy"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HCOPY creates/copies/modifies hyperslabs."; write," E.g., "; write," hcopy, slab1, slab2 "; write," copies slab1 to slab2, with no modifications."; write," In the above, slab1 && slab2 may be arrays with the same dimensions."; write," hcopy, slab1, slab2, index2=2"; write," copies 'scalar' slab1 to array element slab2(2)."; write," hcopy, slab1, slab2, data=new_data"; write," copies slab1 to slab2, with modified data array new_data."; write," hcopy, NULL, new_slab, structure0='HYPERSLAB1.0_SPH_SIG_OCN'"; write," creates a new ocean data hyperslab new_slab."; write," Tips:"; write," 1. structure0='HYPERSLAB1.0_...' may be used to define the hyperslab structure attribute (for new slabs)."; write," 2. overwrite=1 allows destination slab to be overwritten."; write," 3. x1=..., y1=..., z1=..., time1=..., date1=..., ilabel1=..., iparam1=..."; write," may be used to modify the coordinate arrays."; write," 4. is_present=... may be used to add/delete dimensions."; write," 5. is_reduced=... may be used to specify reduction operations."; write," 6. data=...,area_wt1=...,z_bot1=... may be used to modify the data, area-weight, bottom Z arrays"; write," 7. x0=...,y0=...,z0=...,xint0=...,yint0=...,zint0=...,ilabel0=...,iparam0=...,"; write," may be used to modify the full domain grid details"; write," 8. extra_atts=['attribute','data_type',...] adds extra attributes to the slab."; write," See also: hget, hsub, hcat, hsave, hattr, hdata, ncopyatt"; write,""; write," Usage: hcopy, slab1, slab2, overwrite=1, index1=index1, index2=index2, structure0='HYPERSLAB1.0_...', data=..., ..."; return timer_return(func_name); } if (param_set(overwrite)) { // Overwrite slab recursively if (!is_null(index2)) error, "index2=... incompatible with overwrite"; tem_slab= NULL; hcopy, slab1, tem_slab, index1=index1, x1=x1, y1=y1, z1=z1, time1=time1, date1=date1, ilabel1=ilabel1, iparam1=iparam1, data=data, area_wt1=area_wt1, z_bot1=z_bot1, missing_value=missing_value, x0=x0, y0=y0, z0=z0, xint0=xint0, yint0=yint0, zint0=zint0, ilabel0=ilabel0, iparam0=iparam0, structure0=structure0, reset_vars=reset_vars, extra_atts=extra_atts, area_wt_dims=area_wt_dims, z_bot_dims=z_bot_dims, is_present=is_present, is_reduced=is_reduced; slab2= tem_slab; return timer_return(func_name); } if (is_null(index1) && (!is_null(slab1)) && \ (!is_scalar(slab1)) ) { // Array of source hyperslabs; handle recursively if (!is_null(index2)) error, "Index incompatible with array copy"; if (is_null(index2) && (!is_null(slab2)) && \ (!is_scalar(slab2)) ) { // Array-to-array copy if (!dim_conform(dimsof(slab1), dimsof(slab2), trim=1)) error, "Non-conforming dimensions for array-to-array copy"; for (i=I0; i <= I0+numberof(slab1)-1; i++) { hcopy, slab1, slab2, index1=i, index2=i, x1=x1, y1=y1, z1=z1, time1=time1, date1=date1, ilabel1=ilabel1, iparam1=iparam1, data=data, area_wt1=area_wt1, z_bot1=z_bot1, missing_value=missing_value, x0=x0, y0=y0, z0=z0, xint0=xint0, yint0=yint0, zint0=zint0, ilabel0=ilabel0, iparam0=iparam0, structure0=structure0, reset_vars=reset_vars, extra_atts=extra_atts, area_wt_dims=area_wt_dims, z_bot_dims=z_bot_dims, is_present=is_present, is_reduced=is_reduced; } } else { // Create new array if (!is_null(slab2)) error, "Cannot copy multiple source slabs to single destination slab"; slab2= NULL; for (i=I0; i <= I0+numberof(slab1)-1; i++) { tem_slab= NULL; hcopy, slab1, tem_slab, index1=i, x1=x1, y1=y1, z1=z1, time1=time1, date1=date1, ilabel1=ilabel1, iparam1=iparam1, data=data, area_wt1=area_wt1, z_bot1=z_bot1, missing_value=missing_value, x0=x0, y0=y0, z0=z0, xint0=xint0, yint0=yint0, zint0=zint0, ilabel0=ilabel0, iparam0=iparam0, structure0=structure0, reset_vars=reset_vars, extra_atts=extra_atts, area_wt_dims=area_wt_dims, z_bot_dims=z_bot_dims, is_present=is_present, is_reduced=is_reduced; } } } // Slab array indices if (numberof(slab1) > 1) { if (!is_scalar(index1)) error, "Scalar index required for array of source hyperslabs"; k1= index1; } else { k1= I0; } if (numberof(slab2) > 1) { if (!is_scalar(index2)) error, "Scalar index required for array of destination hyperslabs"; k2= index2; } else { k2= I0; } // Determine slab structure type if (is_null(slab1)) structure1= "HYPERSLAB1.0" ; else structure1= slab1(k1).structure; if (is_null(structure0)) { structure2= structure1; } else { structure2= structure0; } // Check structure compatibility if (!is_null(slab2)) { if (slab2(k2).structure != structure2) error, "Incompatible structure for destination slab"; } // Determine number of structure extensions struc_list1= strsplit(structure1, "_"); struc_list2= strsplit(structure2, "_"); nextens= numberof(struc_list2) - 1; // Initialize attribute list if (!is_null(slab1)) { // Copy attribute list/type from source slab attlist2= *(slab1(k1).attlist); attcode2= *(slab1(k1).attcode); // Determine no. of source attributes of each type: // 1 => long; 2 => double; 3 => string. natt1= array(long,3); natt1(I0)= long(sum( attcode2(I0,) == 1)); natt1(I0+1)= long(sum( attcode2(I0,) == 2)); natt1(I0+2)= long(sum( attcode2(I0,) == 3)); natt2= natt1; } else { // Copy default attribute list //HARD-EXTENSIONS-BEGIN: if (structure2 == "HYPERSLAB1.0") { // Standard hyperslab new_atts= *(HFMT.attdesc); } else if (structure2 == "HYPERSLAB1.0_SPH_SIG_OCN") { // SPH_SIG_OCN-extension hyperslab new_atts= *(HFMT.ocn_attdesc); } else if (structure2 == "HYPERSLAB1.0_SPH_SIG_ATM") { // SPH_SIG_ATM-extension hyperslab new_atts= *(HFMT.atm_attdesc); } else if (structure2 == "HYPERSLAB1.0_SSH_SIG") { // SSH_SIG-extension hyperslab new_atts= *(HFMT.ssh_attdesc); } //HARD-EXTENSIONS-END: // Copy new attribute names to attribute list attlist2= array("",3, numberof(new_atts(I0,)) ); attlist2(I0:I0+1,)= new_atts(I0:I0+1,); attlist2(I0+2,)= new_atts(I0,) + ":" + new_atts(I0+1,); // Initialize attribute codes (type, index) natt2= array(long,3); nnew= numberof(new_atts(I0,)); attcode2= array(long,2,nnew); for (j=I0; j <= nnew-I1; j++) { iwhere= where(["long", "double", "string"] == new_atts(I0+2,j)); if (!is_where(iwhere)) error, "Invalid attribute type - " + typestr; // Type code (1 => long; 2 => double; 3 => string) attcode2(I0,j)= iwhere(I0)+I1; // Increment and copy index value for that type natt2(iwhere)= natt2(iwhere) + 1; attcode2(I0+1,j)= natt2(iwhere); } } if (!is_null(extra_atts)) { // Append unique extra attributes as new attributes add_atts= NULL; nexatt= numberof(extra_atts(I0,)); for (j=I0; j <= nexatt-I1; j++) { // Locate attribute in list varnamstr= extra_atts(I0,j) + ":" + extra_atts(I0+1,j); iwhere= where(attlist2(I0+2,) == varnamstr); if (is_where(iwhere)) { // Attribute already present in list; "undelete" it, if necessary if (numberof(iwhere) > 1) error, "Internal error; duplicate attribute" k= iwhere(I0); attcode2(I0+1,k)= abs(attcode2(I0+1,k)); } else { // Attribute not present in list; add to list of attributes grow, attlist2, [extra_atts(I0,j), extra_atts(I0+1,j), extra_atts(I0,j)+":"+extra_atts(I0+1,j) ]; // Determine attribute codes iwhere= where(["long", "double", "string"] == extra_atts(I0+2,j)); if (!is_where(iwhere)) error, "Invalid attribute type - " + typestr; codelist= array(long,2); // Type code (1 => long; 2 => double; 3 => string) codelist(I0)= iwhere(I0)+I1; // Increment and copy index value for that type natt2(iwhere)= natt2(iwhere) + 1; codelist(I0+1)= natt2(iwhere); // Append new attribute codes grow, attcode2, codelist; } } } // Create destination attribute arrays iatt2= array(long,natt2(I0)); fatt2= array(double,natt2(I0+1)); satt2= array("",natt2(I0+2)); // Initialize variables x2= NULL ; y2= NULL ; z2= NULL; time2= NULL ; date2= NULL; x02= NULL ; y02= NULL ; z02= NULL; xint02= NULL ; yint02= NULL ; zint02= NULL; ilabel2= NULL ; iparam2= NULL; ilabel02= NULL ; iparam02= NULL; data2= NULL ; area_wt2= NULL ; z_bot2= NULL; missing_value2= NULL; is_present2= array(long,SDIM); is_reduced2= array(long,SDIM); area_wt_dims2= array(long,SDIM); z_bot_dims2= array(long,SDIM); // Copy keyword parameters if ((!is_null(x1)) && (typeof(x1) != "string")) x2= x1; if ((!is_null(y1)) && (typeof(y1) != "string")) y2= y1; if ((!is_null(z1)) && (typeof(z1) != "string")) z2= z1; if ((!is_null(time1)) && (typeof(time1) != "string")) time2= time1; if ((!is_null(date1)) && (typeof(date1) != "string")) date2= date1; if ((!is_null(x0)) && (typeof(x0) != "string")) x02= x0; if ((!is_null(y0)) && (typeof(y0) != "string")) y02= y0; if ((!is_null(z0)) && (typeof(z0) != "string")) z02= z0; if ((!is_null(xint0)) && (typeof(xint0) != "string")) xint02= xint0; if ((!is_null(yint0)) && (typeof(yint0) != "string")) yint02= yint0; if ((!is_null(zint0)) && (typeof(zint0) != "string")) zint02= zint0; if ( (!is_null(ilabel1)) && \ (!is_number(ilabel1)) ) ilabel2= ilabel1; if ( (!is_null(ilabel0)) && \ (!is_number(ilabel0)) ) ilabel02= ilabel0; if ( (!is_null(iparam1)) && \ (typeof(iparam1) != "string") ) iparam2= iparam1; if ( (!is_null(iparam0)) && \ (typeof(iparam0) != "string") ) iparam02= iparam0; if ( (!is_null(data)) && \ (typeof(data) != "string") ) data2= data; if ( (!is_null(area_wt1)) && \ (typeof(area_wt1) != "string") ) area_wt2= area_wt1; if ( (!is_null(z_bot1)) && \ (typeof(z_bot1) != "string") ) z_bot2= z_bot1; if ( (!is_null(missing_value)) && \ (typeof(missing_value) != "string") ) missing_value2= missing_value; if (!is_null(is_present)) is_present2= is_present; if (!is_null(is_reduced)) is_reduced2= is_reduced; if (!is_null(area_wt_dims)) area_wt_dims2= area_wt_dims; if (!is_null(z_bot_dims)) z_bot_dims2= z_bot_dims; // Previous dimension presence flag was_present1= array(long,SDIM); if (!is_null(slab1)) { // Copy keyword parameters from source slab if (is_null(x1) && (!is_null(slab1(k1).x))) x2= *(slab1(k1).x); if (is_null(y1) && (!is_null(slab1(k1).y))) y2= *(slab1(k1).y); if (is_null(z1) && (!is_null(slab1(k1).z))) z2= *(slab1(k1).z); if (is_null(time1) && (!is_null(slab1(k1).time))) time2= *(slab1(k1).time); if (is_null(date1) && (!is_null(slab1(k1).date))) date2= *(slab1(k1).date); if (is_null(ilabel1) && (!is_null(slab1(k1).ilabel))) ilabel2= *(slab1(k1).ilabel); if (is_null(iparam1) && (!is_null(slab1(k1).iparam))) iparam2= *(slab1(k1).iparam); if (is_null(x0) && (!is_null(slab1(k1).x0))) x02= *(slab1(k1).x0); if (is_null(y0) && (!is_null(slab1(k1).y0))) y02= *(slab1(k1).y0); if (is_null(z0) && (!is_null(slab1(k1).z0))) z02= *(slab1(k1).z0); if (is_null(ilabel0) && (!is_null(slab1(k1).ilabel0))) ilabel02= *(slab1(k1).ilabel0); if (is_null(iparam0) && (!is_null(slab1(k1).iparam0))) iparam02= *(slab1(k1).iparam0); if (is_null(xint0) && (!is_null(slab1(k1).xint0))) xint02= *(slab1(k1).xint0); if (is_null(yint0) && (!is_null(slab1(k1).yint0))) yint02= *(slab1(k1).yint0); if (is_null(zint0) && (!is_null(slab1(k1).zint0))) zint02= *(slab1(k1).zint0); if (is_null(missing_value) && (!is_null(slab1(k1).missing_value))) missing_value2= *(slab1(k1).missing_value); was_present1= slab1(k1).dimension(,HFMT.data); if (is_null(is_present)) is_present2= slab1(k1).dimension(,HFMT.data); if (is_null(area_wt_dims)) area_wt_dims2= slab1(k1).dimension(,HFMT.area_wt); if (is_null(z_bot_dims)) z_bot_dims2= slab1(k1).dimension(,HFMT.z_bot); if (is_null(is_reduced)) is_reduced2= slab1(k1).reduced(*); // Copy attributes iatt2(I0:natt1(I0)-I1)= *(slab1(k1).iatt); fatt2(I0:natt1(I0+1)-I1)= *(slab1(k1).fatt); satt2(I0:natt1(I0+2)-I1)= *(slab1(k1).satt); // Treat large arrays differently if (is_null(data) && (slab1(k1).type(HFMT.data) != "")) data2= *(slab1(k1).data); if (is_null(area_wt1) && (slab1(k1).type(HFMT.area_wt) != "")) area_wt2= *(slab1(k1).area_wt); if (is_null(z_bot1) && (slab1(k1).type(HFMT.z_bot) != "")) z_bot2= *(slab1(k1).z_bot); } // Eliminate dimension and grid variables, if necessary clean_vars= NULL; if (is_present2(XDIM) == 0) { x2= NULL; x02= (xint02= NULL); if (was_present1(XDIM) != 0) grow, clean_vars, ["x", "x0", "xint0"]; } if (is_present2(YDIM) == 0) { y2= NULL; y02= (yint02= NULL); if (was_present1(YDIM) != 0) grow, clean_vars, ["y", "y0", "yint0"]; } if (is_present2(ZDIM) == 0) { z2= NULL; z02= (zint02= NULL); if (was_present1(ZDIM) != 0) grow, clean_vars, ["z", "z0", "zint0"]; } if (is_present2(TDIM) == 0) { time2= (date2= NULL); if (was_present1(TDIM) != 0) grow, clean_vars, ["time", "date"]; } if (is_present2(IDIM) == 0) { ilabel2= (ilabel02= NULL); iparam2= (iparam02= NULL); if (was_present1(IDIM) != 0) grow, clean_vars, ["ilabel", "iparam", "ilabel0", "iparam0"]; } // Check consistency of alternate coordinates if (!is_null(date2)) { if (numberof(time2) != numberof(date2)) error, "Incorrect number of DATE values"; } if (!is_null(iparam2)) { if (numberof(ilabel2) != numberof(iparam2)) error, "Incorrect number of IPARAM values"; } //HARD-EXTENSIONS-BEGIN: // Handle array fields for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list2(iext+1) == "SPH") { // Initialize SPH extension variables eqdx02= (cosdy02= NULL); eqdxint02= (cosdyint02= NULL); if (!is_null(x02)) eqdx02= array(double,numberof(x02)); if (!is_null(xint02)) eqdxint02= array(double,numberof(xint02)); if (!is_null(y02)) cosdy02= array(double,numberof(y02)); if (!is_null(yint02)) cosdyint02= array(double,numberof(yint02)); if (anyof(struc_list1 == "SPH")) { // Copy SPH-extension variables from slab A if ( dim_conform(dimsof(eqdx02), dimsof(deref(slab1(k1).eqdx0))) ) eqdx02= deref(slab1(k1).eqdx0); if ( dim_conform(dimsof(eqdxint02), dimsof(deref(slab1(k1).eqdxint0))) ) eqdxint02= deref(slab1(k1).eqdxint0); if ( dim_conform(dimsof(cosdy02), dimsof(deref(slab1(k1).cosdy0))) ) cosdy02= deref(slab1(k1).cosdy0); if ( dim_conform(dimsof(cosdyint02), dimsof(deref(slab1(k1).cosdyint0))) ) cosdyint02= deref(slab1(k1).cosdyint0); } } else if (struc_list2(iext+1) == "SSH") { // Initialize SSH extension variables } else if (struc_list2(iext+1) == "SIG") { // Initialize SIG extension variables sigma02= (sigmaint02= NULL); if (!is_null(z02)) sigma02= array(double,HFMT.nsigma_coefs,numberof(z02)); if (!is_null(zint02)) sigmaint02= array(double,HFMT.nsigma_coefs,numberof(zint02)); if (anyof(struc_list1 == "SIG")) { // Copy SIG-extension variables from slab A if ( dim_conform(dimsof(sigma02), dimsof(deref(slab1(k1).sigma0))) ) sigma02= deref(slab1(k1).sigma0); if ( dim_conform(dimsof(sigmaint02), dimsof(deref(slab1(k1).sigmaint0))) ) sigmaint02= deref(slab1(k1).sigmaint0); } } else if (struc_list2(iext+1) == "OCN") { // Initialize OCN extension variables kmax02= NULL; if ((!is_null(x02)) && (!is_null(y02))) { kmax02= array(char,numberof(x02),numberof(y02)); if (anyof(struc_list1 == "OCN")) { // Copy OCN-extension variables from slab A if ( dim_conform(dimsof(kmax02), dimsof(deref(slab1(k1).kmax0))) ) kmax02= deref(slab1(k1).kmax0); } } } else if (struc_list2(iext+1) == "ATM") { // Initialize ATM extension variables hgrid02= NULL; if ((!is_null(x02)) && (!is_null(y02))) { hgrid02= array(char,numberof(x02),numberof(y02)); if (anyof(struc_list1 == "ATM")) { // Copy ATM-extension variables from slab A if ( dim_conform(dimsof(hgrid02), dimsof(deref(slab1(k1).hgrid0))) ) hgrid02= deref(slab1(k1).hgrid0); } } } } //HARD-EXTENSIONS-END: // Compute standard dimension counts dim_std= [ SDIM, numberof(x2), numberof(y2), numberof(z2), numberof(time2), numberof(ilabel2) ]; dim_area_wt= dim_std; dim_z_bot= dim_std; // Check for presence of dimensions, and reset dimension count for (m=I0; m <= SDIM-I1; m++) { if (is_present2(m) <= 0) { // Reset dimension count for absent/reduced dimensions dim_std(1+m)= 1; dim_area_wt(1+m)= 1; dim_z_bot(1+m)= 1; } if (is_present2(m) == 0) { // Dimension absent is_reduced2(m)= 0; } else { if (is_present2(m) < 0) { // Dimension reduced/sliced if (is_reduced2(m) == 0) error, "No reduction operation specifed for reduced dimension"; } else { // Dimension present is_reduced2(m)= 0; } } // Ensure that dimensions of area weights/Z_BOT are a subset of data dimensions if (area_wt_dims2(m) == 0) { dim_area_wt(1+m)= 1; } else { if (area_wt_dims2(m) != is_present2(m)) error,"Area weights have dimension not present in data - "+strnum(m+I1); } if (z_bot_dims2(m) == 0) { dim_z_bot(1+m)= 1; } else { if (z_bot_dims2(m) != is_present2(m)) error, "Z_BOT has dimension not present in data - "+strnum(m+I1); } } if (!is_null(reset_vars)) { // Variable attributes need to be reset nvars= numberof(reset_vars); for (m=I0; m <= nvars-I1; m++) { if (is_null(clean_vars)) { clean_vars= reset_vars(m); } else { if (noneof(clean_vars == reset_vars(m))) grow, clean_vars, reset_vars(m); } } } if (!is_null(clean_vars)) { // Variable attributes need to be reset nvars= numberof(clean_vars); for (m=I0; m <= nvars-I1; m++) { // Locate all attributes of the variable iwhere2= where(attlist2(I0,) == clean_vars(m)); if (is_where(iwhere2)) { // For each attribute of the variable for (j=I0; j <= numberof(iwhere2)-I1; j++) { j2= iwhere2(j); // Attribute index/typecode inx2= abs(attcode2(I0+1,j2))-I1; type2= attcode2(I0,j2); // Reset attribute value if (type2 == 1) { iatt2(inx2)= 0; } else if (type2 == 2) { fatt2(inx2)= 0.; } else if (type2 == 3) { satt2(inx2)= ""; } // If non-standard attribute, "delete" it if (attcode2(I0+1,j2) > HFMT.nattstd(type2-I1)) attcode2(I0+1,j2)= -abs(attcode2(I0+1,j2)); } } } } // Determine slab size vector size_vec= array(long,36); size_vec(I0:I0+14)=[ numberof(x2), numberof(y2), numberof(z2), numberof(time2), numberof(date2), numberof(ilabel2), numberof(iparam2), numberof(x02), numberof(y02), numberof(z02), numberof(ilabel02), numberof(iparam02), numberof(xint02), numberof(yint02), numberof(zint02)]; // Include atribute counts size_vec(I0+15:I0+17)= natt2; // Array data types (initally set to null strings) typearr= array("",3); data_type= ""; area_wt_type= ""; z_bot_type= ""; if (is_null(data2)) { size_vec(I0+18)= 0; data_type= ""; } else { // Determine data type and check data consistency typearr(HFMT.data)= typeof(data2); if (typearr(HFMT.data) == "struct_instance") { // Data locator structure size_vec(I0+18)= -1; data_type= data2.type(HFMT.data); area_wt_type= data2.type(HFMT.area_wt); z_bot_type= data2.type(HFMT.z_bot); } else { // Actual data array size_vec(I0+18)= 1; data_type= typearr(HFMT.data); ddims= dimsof(data2); if (ddims(I0) < SDIM) { ddims= dim_reshape( ddims, mindim=SDIM ); //YORICKbegin: reshape_array, data2, ddims //YORICKend: } if (!dim_conform(ddims, dim_std)) error, "Data array has wrong size"; } size_vec(I0+19)= where(data_type == ["float","double","complex"]); // Determine data precision data_prec= ndataprec(data_type); if (!is_null(missing_value2)) { // Ensure that missing value has same type as data if (typeof(missing_value2) != data_type) missing_value2= nmiss_value( missing_value=missing_value2, data_type=data_type ); size_vec(I0+20)= 1; } size_vec(I0+21:I0+25)= dim_std(I0+1:); } if (!is_null(area_wt2)) { // Check area weights consistency typearr(HFMT.area_wt)= typeof(area_wt2); if ( (data_type != "") && \ (typearr(HFMT.area_wt) != data_prec) ) { // Convert area weights array to have same real precision as data area_wt2= typeconv( data_prec, area_wt2); typearr(HFMT.area_wt)= data_prec; } adims= dimsof(area_wt2); if (adims(I0) < SDIM) { adims= dim_reshape( adims, mindim=SDIM ); //YORICKbegin: reshape_array, area_wt2, adims //YORICKend: } if (!dim_conform(adims, dim_area_wt)) error, "Area weights array has wrong size"; // Include size of area weights array in size vector size_vec(I0+26:I0+30)= adims(I0+1:); } if (!is_null(z_bot2)) { // Check bottom Z values consistency typearr(HFMT.z_bot)= typeof(z_bot2); if ( (data_type != "") && \ (typearr(HFMT.z_bot) != data_prec) ) { // Convert area weights array to have same real precision as data z_bot2= typeconv( data_prec, z_bot2); typearr(HFMT.z_bot)= data_prec; } zdims= dimsof(z_bot2); if (zdims(I0) < SDIM) { zdims= dim_reshape( zdims, mindim=SDIM ); //YORICKbegin: reshape_array, z_bot2, zdims //YORICKend: } if (!dim_conform(zdims, dim_z_bot)) error, "Bottom Z values array has wrong size"; // Include size of bottom Z values array in size vector size_vec(I0+31:I0+35)= zdims(I0+1:); } if (!is_null(slab2)) { // Slab B already exists; copy keyword/array parameters to slab B //IDLbegin: //: if (!array_eq(size_vec, nsize_vec(slab2,index=k2) )) //: error, "Slab arrays size mismatch with slab B - " + //: strcombine( strnum(size_vec), "x" ) ; //: if (!array_eq(attlist2, *(slab2(k2).attlist))) //: error, "Attribute mismatch with slab B - " + //: strcombine( strnum(size_vec), "x" ) ; //IDLend: slab2(k2).x= ref(x2); slab2(k2).y= ref(y2); slab2(k2).z= ref(z2); slab2(k2).time= ref(time2); slab2(k2).date= ref(date2); slab2(k2).ilabel= ref(ilabel2); slab2(k2).iparam= ref(iparam2); slab2(k2).x0= ref(x02); slab2(k2).y0= ref(y02); slab2(k2).z0= ref(z02); slab2(k2).ilabel0= ref(ilabel02); slab2(k2).iparam0= ref(iparam02); slab2(k2).xint0= ref(xint02); slab2(k2).yint0= ref(yint02); slab2(k2).zint0= ref(zint02); slab2(k2).attlist= ref(attlist2); slab2(k2).attcode= ref(attcode2); slab2(k2).iatt= ref(iatt2); slab2(k2).fatt= ref(fatt2); slab2(k2).satt= ref(satt2); slab2(k2).data= ref(data2); slab2(k2).area_wt= ref(area_wt2); slab2(k2).z_bot= ref(z_bot2); slab2(k2).missing_value= ref(missing_value2); // Handle extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list2(iext+1) == "SPH") { // Copy SPH extension fields slab2(k2).eqdx0= ref(eqdx02); slab2(k2).cosdy0= ref(cosdy02); slab2(k2).eqdxint0= ref(eqdxint02); slab2(k2).cosdyint0= ref(cosdyint02); } else if (struc_list2(iext+1) == "SSH") { // Copy SSH extension variables } else if (struc_list2(iext+1) == "OCN") { // Copy SIG extension variables slab2(k2).sigma0= ref(sigma02); slab2(k2).sigmaint0= ref(sigmaint02); } else if (struc_list2(iext+1) == "OCN") { // Copy OCN extension variables slab2(k2).kmax0= ref(kmax02); } else if (struc_list2(iext+1) == "ATM") { // Copy ATM extension variables slab2(k2).hgrid0= ref(hgrid02); } } } else { // Create slab B //HARD-EXTENSIONS-BEGIN: //IDLbegin: //: if (structure2 == "HYPERSLAB1.0") { // Create standard hyperslab //: slab2= hyperslab( x1=ref(x2), y1=ref(y2), z1=ref(z2), //: time1=ref(time2), date1=ref(date2), //: ilabel1=ref(ilabel2), iparam1=ref(iparam2), //: x0=ref(x02), y0=ref(y02), z0=ref(z02), //: xint0=ref(xint02), yint0=ref(yint02), //: zint0=ref(zint02), //: ilabel0=ref(ilabel02), iparam0=ref(iparam02), //: data=ref(data2), //: area_wt=ref(area_wt2), //: z_bot=ref(z_bot2), //: missing_value=ref(missing_value2), //: attlist=ref(attlist2), attcode=ref(attcode2), //: iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2) ); //: } else if (structure2 == "HYPERSLAB1.0_SPH_SIG_OCN") { // Create SPH_SIG_OCN-extension hyperslab //: slab2= hyperslab_ocn( x1=ref(x2), y1=ref(y2), z1=ref(z2), //: time1=ref(time2), date1=ref(date2), //: ilabel1=ref(ilabel2), iparam1=ref(iparam2), //: x0=ref(x02), y0=ref(y02), z0=ref(z02), //: xint0=ref(xint02), yint0=ref(yint02), //: zint0=ref(zint02), //: ilabel0=ref(ilabel02), iparam0=ref(iparam02), //: data=ref(data2), //: area_wt=ref(area_wt2), //: z_bot=ref(z_bot2), //: missing_value=ref(missing_value2), //: attlist=ref(attlist2), attcode=ref(attcode2), //: iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2), //: eqdx0=ref(eqdx02), eqdxint0=ref(eqdxint02), //: cosdy0=ref(cosdy02), cosdyint0=ref(cosdyint02), //: sigma0=ref(sigma02), sigmaint0=ref(sigmaint02), //: kmax0=ref(kmax02) ); //: } else if (structure2 == "HYPERSLAB1.0_SPH_SIG_ATM") { // Create SPH_SIG_ATM-extension hyperslab //: slab2= hyperslab_atm( x1=ref(x2), y1=ref(y2), z1=ref(z2), //: time1=ref(time2), date1=ref(date2), //: ilabel1=ref(ilabel2), iparam1=ref(iparam2), //: x0=ref(x02), y0=ref(y02), z0=ref(z02), //: xint0=ref(xint02), yint0=ref(yint02), //: zint0=ref(zint02), //: ilabel0=ref(ilabel02), iparam0=ref(iparam02), //: data=ref(data2), //: area_wt=ref(area_wt2), //: z_bot=ref(z_bot2), //: missing_value=ref(missing_value2), //: attlist=ref(attlist2), attcode=ref(attcode2), //: iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2), //: eqdx0=ref(eqdx02), eqdxint0=ref(eqdxint02), //: cosdy0=ref(cosdy02), cosdyint0=ref(cosdyint02), //: sigma0=ref(sigma02), sigmaint0=ref(sigmaint02), //: hgrid0=ref(hgrid02) ); //: } else if (structure2 == "HYPERSLAB1.0_SSH_SIG") { // Create SSH_SIG-extension hyperslab //: slab2= hyperslab_ssh( x1=ref(x2), y1=ref(y2), z1=ref(z2), //: time1=ref(time2), date1=ref(date2), //: ilabel1=ref(ilabel2), iparam1=ref(iparam2), //: x0=ref(x02), y0=ref(y02), z0=ref(z02), //: xint0=ref(xint02), yint0=ref(yint02), //: zint0=ref(zint02), //: ilabel0=ref(ilabel02), iparam0=ref(iparam02), //: data=ref(data2), //: area_wt=ref(area_wt2), //: z_bot=ref(z_bot2), //: missing_value=ref(missing_value2), //: attlist=ref(attlist2), attcode=ref(attcode2), //: iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2), //: sigma0=ref(sigma02), sigmaint0=ref(sigmaint02) ); //: } //IDLend: //YORICKbegin: if (structure2 == "HYPERSLAB1.0") { // Create standard hyperslab slab2= hyperslab( x=ref(x2), y=ref(y2), z=ref(z2), time=ref(time2), date=ref(date2), ilabel=ref(ilabel2), iparam=ref(iparam2), x0=ref(x02), y0=ref(y02), z0=ref(z02), xint0=ref(xint02), yint0=ref(yint02), zint0=ref(zint02), ilabel0=ref(ilabel02), iparam0=ref(iparam02), data=ref(data2), area_wt=ref(area_wt2), z_bot=ref(z_bot2), missing_value=ref(missing_value2), attlist=ref(attlist2), attcode=ref(attcode2), iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2) ) } else if (structure2 == "HYPERSLAB1.0_SPH_SIG_OCN") { // Create SPH_SIG_OCN-extension hyperslab slab2= hyperslab_ocn( x=ref(x2), y=ref(y2), z=ref(z2), time=ref(time2), date=ref(date2), ilabel=ref(ilabel2), iparam=ref(iparam2), x0=ref(x02), y0=ref(y02), z0=ref(z02), xint0=ref(xint02), yint0=ref(yint02), zint0=ref(zint02), ilabel0=ref(ilabel02), iparam0=ref(iparam02), data=ref(data2), area_wt=ref(area_wt2), z_bot=ref(z_bot2), missing_value=ref(missing_value2), attlist=ref(attlist2), attcode=ref(attcode2), iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2), eqdx0=ref(eqdx02), eqdxint0=ref(eqdxint02), cosdy0=ref(cosdy02), cosdyint0=ref(cosdyint02), sigma0=ref(sigma02), sigmaint0=ref(sigmaint02), kmax0=ref(kmax02) ) } else if (structure2 == "HYPERSLAB1.0_SPH_SIG_ATM") { // Create SPH_SIG_ATM-extension hyperslab slab2= hyperslab_atm( x=ref(x2), y=ref(y2), z=ref(z2), time=ref(time2), date=ref(date2), ilabel=ref(ilabel2), iparam=ref(iparam2), x0=ref(x02), y0=ref(y02), z0=ref(z02), xint0=ref(xint02), yint0=ref(yint02), zint0=ref(zint02), ilabel0=ref(ilabel02), iparam0=ref(iparam02), data=ref(data2), area_wt=ref(area_wt2), z_bot=ref(z_bot2), missing_value=ref(missing_value2), attlist=ref(attlist2), attcode=ref(attcode2), iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2), eqdx0=ref(eqdx02), eqdxint0=ref(eqdxint02), cosdy0=ref(cosdy02), cosdyint0=ref(cosdyint02), sigma0=ref(sigma02), sigmaint0=ref(sigmaint02), hgrid0=ref(hgrid02) ) } else if (structure2 == "HYPERSLAB1.0_SSH_SIG") { // Create SSH_SIG-extension hyperslab slab2= hyperslab_ssh( x=ref(x2), y=ref(y2), z=ref(z2), time=ref(time2), date=ref(date2), ilabel=ref(ilabel2), iparam=ref(iparam2), x0=ref(x02), y0=ref(y02), z0=ref(z02), xint0=ref(xint02), yint0=ref(yint02), zint0=ref(zint02), ilabel0=ref(ilabel02), iparam0=ref(iparam02), data=ref(data2), area_wt=ref(area_wt2), z_bot=ref(z_bot2), missing_value=ref(missing_value2), attlist=ref(attlist2), attcode=ref(attcode2), iatt=ref(iatt2), fatt=ref(fatt2), satt=ref(satt2), sigma0=ref(sigma02), sigmaint0=ref(sigmaint02) ) } // Initialize string variables to null strings slab2.name= "" slab2.long_name= "" slab2.units= "" //YORICKend: //HARD-EXTENSIONS-END: } // Set structure attribute slab2(k2).structure= structure2; // Set array types slab2(k2).type(*)= typearr(*); // Set dimension attributes slab2(k2).dimension(,HFMT.data)= is_present2; slab2(k2).dimension(,HFMT.area_wt)= area_wt_dims2; slab2(k2).dimension(,HFMT.z_bot)= z_bot_dims2; slab2(k2).reduced(*)= is_reduced2; // Set grid attributes for spatial dimensions for (m=XDIM; m <= ZDIM; m++) { if (is_present2(m) != 0) { if (abs(is_present2(m)) == 1) { nset_attr, "grid", slab2, m+I1, "regular", index=k2; } else { nset_attr, "grid", slab2, m+I1, "interfacial", index=k2; } } } if (!is_null(slab1)) { // Copy non-keyword parameters from slab A to slab B slab2(k2).name= slab1(k1).name; slab2(k2).long_name= slab1(k1).long_name; slab2(k2).units= slab1(k1).units; if (structure2 == structure1) { // Copy scalar variables from slab A to slab B //HARD-EXTENSIONS-BEGIN: // Handle scalar variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list2(iext+1) == "SPH") { // Copy SPH extension scalar variables slab2(k2).a0= slab1(k1).a0; } else if (struc_list2(iext+1) == "SSH") { // Copy SSH extension scalar variables slab2(k2).a0= slab1(k1).a0; } } //HARD-EXTENSIONS-END: } } if (is_null(slab1) || (structure2 != structure1)) { // Set default values for attributes hset_attr, slab2, ":format_URL", "http://www.cgd.ucar.edu/gds/svn/hops", index=k2; hset_attr, slab2, "date:long_name", "Date (yyyymmdd.)", index=k2; hset_attr, slab2, "x0:long_name", "Full domain regular X grid", index=k2; hset_attr, slab2, "xint0:long_name", "Full domain interfacial X grid", index=k2; hset_attr, slab2, "y0:long_name", "Full domain regular Y grid", index=k2; hset_attr, slab2, "yint0:long_name", "Full domain interfacial Y grid", index=k2; hset_attr, slab2, "z0:long_name", "Full domain regular Z grid", index=k2; hset_attr, slab2, "zint0:long_name", "Full domain interfacial Z grid", index=k2; hset_attr, slab2, "ilabel0:long_name", "Full domain I-labels", index=k2; hset_attr, slab2, "iparam0:long_name", "Full domain I-parameters", index=k2; //HARD-EXTENSIONS-BEGIN: for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list2(iext+1) == "SPH") { // SPH-extension default attribute values hset_attr, slab2, "x:long_name", "longitude", index=k2; hset_attr, slab2, "y:long_name", "latitude", index=k2; hset_attr, slab2, "a0:long_name", "planetary radius", index=k2; hset_attr, slab2, "eqdx0:long_name", "Regular X grid interval at equator", index=k2; hset_attr, slab2, "eqdxint0:long_name", "Interfacial X grid interval at equator", index=k2; hset_attr, slab2, "cosdy0:long_name", "Regular Y grid interval (including cosine-latitude factor)", index=k2; hset_attr, slab2, "cosdyint0:long_name", "Interfacial Y grid interval (including cosine-latitude factor)", index=k2; hset_attr, slab2, "x:units", "degrees_east", index=k2; hset_attr, slab2, "y:units", "degrees_north", index=k2; hset_attr, slab2, "a0:units", "m", index=k2; hset_attr, slab2, "eqdx0:units", "m", index=k2; hset_attr, slab2, "eqdxint0:units", "m", index=k2; hset_attr, slab2, "cosdy0:units", "m", index=k2; hset_attr, slab2, "cosdyint0:units", "m", index=k2; } else if (struc_list2(iext+1) == "SSH") { // SSH-extension default attribute values hset_attr, slab2, "x:long_name", "m", index=k2; hset_attr, slab2, "y:long_name", "n-m", index=k2; hset_attr, slab2, "a0:long_name", "planetary radius", index=k2; hset_attr, slab2, "x:units", "", index=k2; hset_attr, slab2, "y:units", "", index=k2; hset_attr, slab2, "a0:units", "m", index=k2; } else if (struc_list2(iext+1) == "SIG") { // SIG-extension default attribute values hset_attr, slab2, "sigma0:long_name", "z (A), sigma (B) regular grid coefficients", index=k2; hset_attr, slab2, "sigmaint0:long_name", "z (A), sigma (B) interfacial grid coefficients", index=k2; } else if (struc_list2(iext+1) == "ATM") { // ATM-extension default attribute values hset_attr, slab2, "hgrid0:long_name", "Grid-point type code: 0 (ocean), 1 (land), 2 (sea ice)", index=k2; } else if (struc_list2(iext+1) == "OCN") { // OCN-extension default attribute values hset_attr, slab2, "kmax0:long_name", "Ocean depth index (>=0)", index=k2; } } //HARD-EXTENSIONS-END: } return timer_return(func_name); } func hdata( slab) /* DOCUMENT hdata(slab) * Replace data locator in SLAB with the actual data array read from file. * SEE ALSO: hget, hrestore */ { func_name= "hdata"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hdata( slab(j) ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (slab.type(HFMT.data) == "") error, "Error - null data values"; // If not data locator, return slab as is if (slab.type(HFMT.data) != "struct_instance") return timer_return(func_name, slab); // Slab locator loc= *(slab.data); if (loc.structure != "LOCATOR") error, "Invalid data locator type '" + loc.structure + "'"; // File structure, no. of dimensions fstruc= *(loc.fstruc); ndim= strlen(loc.dimenstr); // Get file handle fhandle= nget_handle( fstruc ); // History file flag hisflag= (fstruc.structure != "HYPERFILE"); // Copy logical offsets etc from hyperslab locator // (values should already be set for the "extra" dimensions) data_type= loc.type(HFMT.data); dim_data= loc.dim_data; dim_area_wt= loc.dim_area_wt; dim_z_bot= loc.dim_z_bot; was_present= loc.was_present; slab_wrapcount= loc.slab_wrapcount; dfold= deref(loc.slab_fold); count= deref(loc.slab_count); offset= deref(loc.slab_offset); // Check offset/count for all dimensions for (k=I0; k <= ndim-I1; k++) { if ((offset(k) < 0) || (count(k) <= 0)) error, "Invalid offset/count for data dimension " + strnum(k+I1); } // Dimension presence/reduction codes is_present= slab.dimension(,HFMT.data); is_reduced= slab.reduced(*); // Standard dimension count for current subdomain dim_std= hdimsof( slab ); // Check if data dimension need to be transposed after reading in dtransp= NULL; atransp= NULL; ztransp= NULL; prevdim= NULL; for (m=I0; m <= I0+SDIM-1; m++) { if (was_present(m) > 0) { // Dimension is/was present in hyperslab mdat= dim_data(m); if (mdat == 0) error, "Internal error; hyperslab dimension not present file" if (!is_null(prevdim)) { // Check for tranposition if (dim_data(prevdim) > mdat) { // Transposing required; if (dim_data(prevdim) != mdat+1) error, "Can only transpose adjacent dimensions"; grow, dtransp, mdat; if ( anyof(dim_area_wt(*) == mdat) && \ anyof(dim_area_wt(*) == mdat+1) ) grow, atransp, mdat; if ( anyof(dim_z_bot(*) == mdat) && \ anyof(dim_z_bot(*) == mdat+1) ) grow, ztransp, mdat; } } // Save "previous" standard dimension index prevdim= m; } } // Check if last dimension is folded afold= NULL; zfold= NULL; if (!is_null(dfold)) { // Check for presence of folded time dimension in area weights/Z_BOT values if (dim_area_wt(TDIM) > 0) afold= dfold; if (dim_z_bot(TDIM) > 0) zfold= dfold; } // Initialize time coordinate values drecords= 0; arecords= 0; zrecords= 0; if ( (dim_data(TDIM) > 0) && \ (dim_data(TDIM) == numberof(count)) && \ (fstruc.recordvars != 0)) { // T dimension is the last and unlimited dimension drecords= numberof( *(fstruc.time0) ); if (dim_area_wt(TDIM) > 0) arecords= drecords; if (dim_z_bot(TDIM) > 0) zrecords= drecords; } // Initialize wrap-around count and offset wrapcount= 0; wrapoffset= 0; if (dim_data(XDIM) > 0) { // X dimension present in slab if (slab_wrapcount > 0) { // X dimension has been rotated; copy wrap-around count wrapcount= slab_wrapcount; if (hisflag) { // Reading data from history file; set wrap-around offset if (was_present(XDIM) <= 0) error, "Internal error; X dimension was never present" wrapoffset= fstruc.phys_offset(XDIM,was_present(XDIM)-I1); } } } if (!hisflag) { // Read data from hyperslab file field= nc_getvar(fhandle, slab.name, offset=offset, count=count, wrapoffset=wrapoffset, wrapcount=wrapcount, records=drecords, fold=dfold, transp=dtransp); if (data_type == "complex") { // Read imaginary part of complex data and concatenate field2= nc_getvar(fhandle, slab.name+"_im", offset=offset, count=count, wrapoffset=wrapoffset, wrapcount=wrapcount, records=drecords, fold=dfold, transp=dtransp); //IDLbegin: //: field= complex(field(*), field2(*)); //IDLend: //YORICKbegin: field= complex(field) field(*).im= field2(*) //YORICKend: field2= NULL; } // Reshape data array reshape_array, field, dim_std; } else { // Read data from history file // Add physical offsets for all "xyzti" dimensions originally present in data for (m=I0; m <= I0+SDIM-1; m++) { if (was_present(m) > 0) { // Dimension physically present in file mdat= dim_data(m); if ((!is_null(dfold)) && (mdat >= ndim-2)) { // Folded dimensions if (mdat == ndim) { // Last dimension; add physical offset to fold parameters dfold(I0)= dfold(I0) + fstruc.phys_offset(m, was_present(m)-I1); } } else { // Add physical offset for non-folded dimension offset(mdat-I1)= offset(mdat-I1) + fstruc.phys_offset(m, was_present(m)-I1); } } } // Read hyperslab data, and reshape to five dimensions field= nc_getvar(fhandle, slab.name, offset=offset, count=count, wrapoffset=wrapoffset, wrapcount=wrapcount, records=drecords, fold=dfold, transp=dtransp); if (typeof(field) == "long") { // Convert long to double field= typeconv("double",field); } reshape_array, field, dim_std; if ( (loc.scale_factor != 1) || (loc.add_offset != 0) ) { // Scale/offset data if (is_null(slab.missing_value)) { // No missing values in data // Scale data, if necessary if (loc.scale_factor != 1) field(*)= loc.scale_factor*field(*); // Offset data, if necessary if (loc.add_offset != 0) field(*)= loc.add_offset + field(*); } else { // Missing values in data missing_value= *(slab.missing_value); def= where(field(*) != missing_value); // Scale data, if necessary if (is_where(def) && (loc.scale_factor != 1)) field(def)= loc.scale_factor*field(def); // Offset data, if necessary if (is_where(def) && (loc.add_offset != 0)) field(def)= loc.add_offset + field(def); } } for (m=I0; m <= I0+SDIM-1; m++) { if (fstruc.reverse(m)) { // Reverse dimension if (nattr("subdomain",slab,m+I1) != 0) error, "Cannot reverse dimension of subdomain"; if ((!is_null(dfold)) && (m >= TDIM)) error, "Cannot reverse folded dimension"; field= rangeop(field,"rev",m+I1); } } } // Auxiliary arrays z_bot= NULL; area_wt= NULL; if (loc.area_wt_var != "") { // Read AREA_WT values from file (subset of data dimensions) awdim= array(1, SDIM+1 ); awdim(I0)= SDIM; awhere= where( dim_area_wt(*) > 0 ); if (is_where(awhere)) { aindex= dim_data(awhere) - I1; apermute= sort(dim_area_wt(awhere) - I1); acount= ( count(aindex))(apermute); aoffset= (offset(aindex))(apermute); awdim( awhere+1 )= count( aindex ); } else { acount= NULL; aoffset= NULL; } area_wt= nc_getvar(fhandle, loc.area_wt_var, offset=aoffset, count=acount, wrapoffset=wrapoffset, wrapcount=wrapcount, records=arecords, fold=afold, transp=atransp); reshape_array, area_wt, awdim; } if (loc.z_bot_var != "") { // Read Z_BOT values from file (subset of data dimensions) zbdim= array(1, SDIM+1 ); zbdim(I0)= SDIM; zwhere= where( dim_z_bot(*) > 0 ); if (is_where(zwhere)) { zindex= dim_data(zwhere) - I1; zpermute= sort(dim_z_bot(zwhere) - I1); zcount= ( count(zindex))(zpermute); zoffset= (offset(zindex))(zpermute); zbdim( zwhere+1 )= count( zindex ); } else { zcount= NULL; zoffset= NULL; } z_bot= nc_getvar(fhandle, loc.z_bot_var, offset=zoffset, count=zcount, wrapoffset=wrapoffset, wrapcount=wrapcount, records=zrecords, fold=zfold, transp=ztransp); reshape_array, z_bot, zbdim; } // Insert actual data into hyperslab new_slab= NULL; hcopy, slab, new_slab, data=field, z_bot1=z_bot, area_wt1=area_wt; if (is_null(area_wt) && (new_slab.type(HFMT.area_wt) != "")) { // Area weight mask already present; apply masking on data values if (min(*(new_slab.area_wt)) == 0.) { // Copy data and mask arrays field= *(new_slab.data); bitmask= *(new_slab.area_wt) > 0.; mdims= dim_reshape(dimsof(bitmask), trim=1); nmaskdim= mdims(I0); if (!is_null(new_slab.missing_value)) { // Copy missing value attribute missing_value= *(new_slab.missing_value); } else { // No missing value attribute; generate new missing value missing_value= nmiss_value(field); } // Apply mask on data nmask, field, bitmask, nmaskdim, mark_zero=1, missing_value=missing_value; if ((new_slab.type(HFMT.z_bot) != "") && \ (new_slab.dimension(ZDIM,HFMT.area_wt) <= 0)) { // Apply mask on bottom Z values as well z_bot= *(new_slab.z_bot); nmask, z_bot, bitmask, nmaskdim, mark_zero=1, missing_value=missing_value; } else { z_bot= NULL; } // Insert masked fields in slab hcopy, new_slab, new_slab, data=field, missing_value=missing_value, z_bot1=z_bot, overwrite=1; } } return timer_return(func_name, new_slab); } func hdiff( slab_or_file1, slab_or_file2, help=, rmsdiff=, vars=, limt1=, limt2=) /* DOCUMENT hdiff, slab_or_file1, slab_or_file2, help=0/1, rmsdiff=0/1, * vars=vars, limt1=limt1, limt2=limt2 * Computes the RMS/maximum absolute differences for variables in * two hyperslab arrays or two netCDF hyperslab files. * Arguments SLAB_OR_FILE1 or SLAB_OR_FILE2 may either be hyperslab arrays * or hyperslab file names. * * VARS is a list of variable names to difference. * (If VARS is omitted, all record/hyperslab variables in SLAB_OR_FILE1 * are difference.) * * If RMSDIFF==1, the root-mean-square difference is displayed, * rather than the maximum absolute difference (the default). * * LIMT1/LIMT2 are the time-domain to read (subscripts). * SEE ALSO: hget, hop, hplot */ { func_name= "hdiff"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Procedure HDIFF displays the RMS difference || the maximum absolute difference"; write," between corresponding variables in two netCDF files || hyperslab arrays"; write," E.g.,"; write," hdiff, 'atm_hisfile_1.nc', 'atm_hisfile_2.nc' "; write," displays the maximun absolute difference between record variables"; write," in the two history files."; write," Tips:"; write," 1. Filename arguments may be substituted with hyperslab array arguments"; write," 2. rmsdiff=1 displays RMS difference, rather than max. absolute difference"; write," 3. vars=['varname1',...] may be used to select variables"; write," 4. limt1=[..], limt2=[..] may be used to select subscript time subdomains"; write,""; write," See also: hget, hop, hplot"; write,""; write," Usage: hdiff,slab_or_file1,slab_or_file2,rmsdiff=0/1,vars=['varnam1',..],limt1=[it_min,it_max],limt2=[..]"; return timer_return(func_name); } if (param_set(rmsdiff)) avstr= "rms" ; else avstr= "max"; if (typeof(slab_or_file1) == "string") { file1= 1; hopen, slab_or_file1, fs1, alt=1; } else { file1= 0; } if (typeof(slab_or_file2) == "string") { file2= 1; hopen, slab_or_file2, fs2, alt=1; } else { file2= 0; } if (is_null(vars)) { if (file1) varlist= strsplit(fs1.vars,",") ; else varlist= slab_or_file1.name; } else { varlist= vars; } for (j=I0; j <= numberof(varlist)-I1; j++) { if (file1) { var1= hget(varlist(j),limt=limt1,fstruc=fs1,subscript=1); } else { iwhere= where(slab_or_file1.name == varlist(j)); if (!is_where(iwhere)) error, "Variable "+varlist(j)+" not found in SLAB_OR_FILE1"; var1= slab_or_file1(iwhere); } if (file2) { var2= hget(varlist(j),limt=limt2,fstruc=fs2,subscript=1); } else { iwhere= where(slab_or_file2.name == varlist(j)); if (!is_where(iwhere)) error, "Variable "+varlist(j)+" not found in SLAB_OR_FILE2"; var2= slab_or_file2(iwhere); } varname= varlist(j) + "(" + hattr(var1,":case_name") + "-" + hattr(var2,":case_name") + ")"; vdif= hop(var1, "-", var2, weak=1, name=varname); hset_attr, vdif, ":case_name", ""; hplot, hsub(hop("abs",vdif), x=avstr, y=avstr, z=avstr, t=avstr, i=avstr); } if (file1) hclose, fs1; if (file2) hclose, fs2; } func hdimsof( slab, area_wt=, z_bot=, name=, strip=, ti_transp=, index=) /* DOCUMENT hdimsof(slab, area_wt=, z_bot=, name=0/1, strip=0/1, * ti_transp=0/1, index=) * returns the list of standard dimension lengths associated with the data, * i.e., dimsof(data), in hyperslab SLAB. * If AREA_WT==1, the appropriate dimensions of of area weights array * are returned. * If Z_BOT==1, the appropriate dimensions of the Z_BOT array * are returned. * If NAME==1, a string of 1-character coordinate names is returned. * If STRIP==1, only the counts for dimensions that are present are returned, * with no preceding dimension count. (NULL value is returned for scalars) * If TI_TRANSP==1, the T and I dimension counts are interchanged. * If SLAB is an array, INDEX=... may be used to pick an element of the array. * SEE ALSO: ngetcoord, nsize_vec */ { func_name= "hdimsof"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; // Slab array index if (numberof(slab) > 1) { if (numberof(index) != 1) error, "Scalar index required for array of hyperslabs"; k1= index(I0); } else { k1= I0; } aflag= param_set(area_wt); zflag= param_set(z_bot); if (aflag+zflag > 1) error, "Ambiguous area_wt=1 && z_bot=1 specification"; dim_std= [ SDIM, numberof(deref(slab(k1).x)), numberof(deref(slab(k1).y)), numberof(deref(slab(k1).z)), numberof(deref(slab(k1).time)), numberof(deref(slab(k1).ilabel)) ]; // Presence codes if (aflag) { presence= slab(k1).dimension(,HFMT.area_wt); } else { if (zflag) { presence= slab(k1).dimension(,HFMT.z_bot); } else { presence= slab(k1).dimension(,HFMT.data); } } if (param_set(name)) { // Return name string dimstr= ""; for (m=I0; m <= I0+SDIM-1; m++) { if (presence(m) > 0) { if (presence(m) == 1) { dimstr= dimstr + HFMT.coordnames(m); } else { dimstr= dimstr + strtoupper(HFMT.coordnames(m)); } } } return timer_return(func_name, dimstr); } if (param_set(strip)) { // Strip absent dimensions if (param_set(ti_transp)) { // T/I transpose; check if both dimensions are present if ( (presence(TDIM) > 0) && (presence(IDIM) > 0) ) dim_std(1+TDIM:1+IDIM)= [dim_std(1+IDIM), dim_std(1+TDIM)]; } where_present= where( presence > 0 ); if (is_where(where_present)) return timer_return(func_name, dim_std(1+where_present)); return timer_return(func_name, NULL); } else { // No stripping where_absent= where(presence <= 0); if (is_where(where_absent)) dim_std( 1+where_absent )= 1; if (param_set(ti_transp)) dim_std(1+TDIM:1+IDIM)= [dim_std(1+IDIM), dim_std(1+TDIM)]; return timer_return(func_name, dim_std); } } func hfft( slab, dim, direction, help=, power=, name=, nocheck=, nohistory=) /* DOCUMENT hfft(slab, dim, direction, help=, power=, name=, nohistory=0/1) * HFFT applies the Fast Fourier Transform along dimension DIM. * (SLAB may be an array of hyperslabs.) * DIM="x"/"y"/"z"/"t"/"i" => dimension to be transformed. * DIRECTION may be 1 for the forward transform (the default), * -1 for the backward transform, as in Yorick"s FFT. * The output array is normalized by dividing by sqrt(N), * where N is length of the transformed dimension. This means that the * backward transform is the exact inverse of the forward transform. * For the forward transform, the output array is not in the usual FFT * output order, but in a more natural ordering from the most negative to * the most positive "frequencies", with one extra negative "frequency" value. * For the backward transform, the input is expected to be in the same * "natural" order. * If POWER==1, compute the power spectrum, i.e., square of the modulus * of the FFT result, and add power for negative frequencies to corresponding * positive frequencies, returning only values for non-negative frequencies. * If NAME is specified, change the variable name in the output slab. * If NOCHECK==1, the data may be unequally spaced along the * transformed dimension. * NOHISTORY==1 disables appending of history information. * SEE ALSO: hshtran, hshift */ { func_name= "hfft"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HFFT applies the Fast Fourier Transform along a"; write," selected dimension."; write," E.g.,"; write," fft_slab = hfft(slab,'t',1)"; write," compute the forward fourier transform over the t-dimension."; write," Tips:"; write," 1. nocheck=1 allows FFTs on unequally spaced data."; write," See also: hshtran, hshift"; write,""; write," Usage: hfft(slab,'x/y/z/t/i',name=..,nocheck=1,nohistory=1)"; return timer_return(func_name, NULL); } // Transform direction ftdir= 1; if (!is_null(direction)) ftdir= direction; if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively if ((!is_null(name)) && (numberof(name) != numberof(slab))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hfft( slab(j), dim, name=name1, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (!is_scalar(dim)) error, "Argument DIM should be a scalar string"; // Determine dimension to be fourier transformed mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; // Data type data_type= slab.type(HFMT.data); if (data_type == "LOCATOR") error, "Actual data needs to be present in the slab"; data_prec= ndataprec(data_type); if ((mdim == IDIM+I1) && is_null(slab.iparam)) error, "FFT on i-dimension requires parameter values to be present"; coord= ngetcoord(slab,mdim,iparam=1); ncoord= numberof(coord); nhcoord= ncoord/2; fncoord= typeconv(data_type, ncoord); // If single coordinate value, return slab unaltered if (ncoord == 1) return timer_return(func_name, slab); delta= abs(coord(I0+1:) - coord(I0:ncoord-1-I1)); if ((!param_set(nocheck))&&(!alleq(delta,epsilon=HFMT.epscoord))) error, "Unequally spaced coordinate intervals"; // History string his_str= "<" + slab.name + ">,<" + dim + ">"; // Dimension presence/reduction codes is_present= slab.dimension(,HFMT.data); apresent= slab.dimension(,HFMT.area_wt); zpresent= slab.dimension(,HFMT.z_bot); if (is_present(mdim-I1) <= 0) error, "Dimension not present in data"; if (apresent(mdim-I1) > 0) error, "Area weights have the FFT dimension"; if (zpresent(mdim-I1) > 0) error, "Z_BOT values have the FFT dimension"; // Copy data data1= *(slab.data); missing_value= deref(slab.missing_value); where_defined= NULL; where_missing= NULL; if (!is_null(missing_value)) { // Missing value mask, summed over FFT dimension miss_mask= arrayop((data1 == missing_value), "sum", mdim); // Missing/defined index lists where_missing= where(miss_mask > 0); where_defined= where(miss_mask == 0); if (!is_where(where_defined)) error, "All data values undefined"; // Convert missing value to complex type if (typeof(missing_value) != "complex") missing_value= nmiss_value( missing_value=missing_value, data_type="complex" ); } ddims= hdimsof(slab); // Reshape data array to focus on FFT dimension fddims= dim_reshape( ddims, focus=mdim ); nleft= fddims(I0+1); nright= fddims(I0+3); reshape_array, data1, [3, nleft, ncoord, nright]; // Transpose to make FFT dimension the first, and reshape array data1= transpose(data1, [1,2]); reshape_array, data1, [2, ncoord, nleft*nright]; if (ftdir != 1) { // Backward transform; swap the two halves of the FFT dimension data1= rangeop( data1, "swap", 1); } // Apply FFT on first dimension of array data2= array( complex(0), [2, ncoord, nleft*nright] ); //IDLbegin: //:if (ftdir == 1) fac= sqrt(fncoord) ; //: else fac= sqrt(fncoord)^(-1); //:if (is_where(where_defined)) { //: for (j=I0; j <= numberof(where_defined)-I1; j++) { //: data2(,where_defined(j))= fac*fft( data1(,where_defined(j)),-ftdir); //: } //:} else { //: for (j=I0; j <= nleft*nright-I1; j++) { //: data2(,j)= fac*fft( data1(,j),-ftdir); //: } //:} //IDLend: //YORICKbegin: fac= sqrt(fncoord)^(-1) if (is_where(where_defined)) data2(,where_defined)= fac*fft( data1(,where_defined), [ftdir] ); else data2= fac*fft( data1, [ftdir] ); //YORICKend: // Delete original data data1= NULL; // Compute new coordinates in transformed space (frequency/wavenumber) new_coord= ((indgen(ncoord)-I0) - nhcoord) / (ncoord*delta(I0)); ncoordnew= ncoord; // New data dimensions and units ddimsnew= ddims; new_units= slab.units; if (param_set(power)) { // Compute spectral power data2= typeconv( data_prec, abs(data2)^2 ); if (!is_null(missing_value)) missing_value= typeconv( typeof(data2), missing_value ); if (new_units != "") new_units= "(" + new_units + ")^2"; } if (is_where(where_missing)) { // Re-introduce missing values data2(,where_missing)= missing_value; } if (param_set(power)) { // Symmetrize power spectrum by eliminating negative frequencies data0= array( typeconv(data_type,0), [2, nhcoord+1, nleft*nright] ); data0(I0,)= data2(I0,); nh1coord= (ncoord+1)/2; data0(I0+1:I0+nh1coord-1,)= data2(I0+1:I0+nh1coord-1,) + rangeop(data2(I0+nhcoord+1:,),"rev",1); if ((ncoord % 2) == 0) data0(I0+nhcoord,)= data2(I0+nhcoord,); data2= data0; data0= NULL; // Change new data dimensions new_coord= (indgen(nhcoord+1)-I0) / (ncoord*delta(I0)); ncoordnew= nhcoord+1; ddimsnew(1+mdim-I1)= nhcoord+1; } else { if (ftdir == 1) { // Forward transform; swap the two halves of the FFT dimension data2= rangeop( data2, "swap", 1); } } // Reshape output data array reshape_array, data2, [3, ncoordnew, nleft, nright]; // Reshape array to final dimensions data2= transpose(data2, [1,2]); reshape_array, data2, ddimsnew; // New structure attribute if (mdim <= ZDIM+I1) { // Spatial transform; revert to default structure new_structure= "HYPERSLAB1.0"; } else { // Temporal/index transform; preserve structure new_structure= slab.structure; } // Copy slab with new data array and coordinate values new_slab= NULL; if (mdim == XDIM+I1) { hcopy, slab, new_slab, data=data2, x1=new_coord, x0="", xint0="", structure0=new_structure; } else if (mdim == YDIM+I1) { hcopy, slab, new_slab, data=data2, y1=new_coord, y0="", yint0="", structure0=new_structure; } else if (mdim == ZDIM+I1) { hcopy, slab, new_slab, data=data2, z1=new_coord, z0="", zint0="", structure0=new_structure; } else if (mdim == TDIM+I1) { hcopy, slab, new_slab, data=data2, time1=new_coord, date1="", structure0=new_structure; } else if (mdim == IDIM+I1) { hcopy, slab, new_slab, data=data2, ilabel1=array("",ncoordnew), iparam1=new_coord, structure0=new_structure; } if (new_units != "") new_slab.units= new_units; // Modify coordinate units, long name, subdomain code, sample_count dimvar= HFMT.dimnames(mdim-I1); dim_units= nattr("units",slab,mdim); if (dim_units != "") dim_units= "1/(" + dim_units + ")"; dim_long_name= nattr("long_name",slab,mdim); new_long_name= ""; if (ftdir == 1) { // Forward transform if (mdim <= ZDIM+I1) { new_long_name= "wavenumber"; } else { if ((mdim == TDIM+I1) && (dim_long_name == "time")) new_long_name= "frequency"; } } else { // Backward transform if ((mdim == TDIM+I1) && (dim_long_name == "frequency")) new_long_name= "time"; } nset_attr, "long_name", new_slab, mdim, new_long_name; nset_attr, "subdomain", new_slab, mdim, -1; if (mdim == IDIM+I1) { // i-dimension hset_attr, new_slab, "iparam:long_name", ""; } else { // Space/time dimension nset_attr, "units", new_slab, mdim, dim_units; } if (mdim <= ZDIM+I1) { // Reset subdomain bounds for spatial dimensions hset_attr, new_slab, dimvar+":lower_bound", new_coord(I0); hset_attr, new_slab, dimvar+":upper_bound", new_coord(ncoordnew-I1); } //SOFT-EXTENSIONS-BEGIN: // Add sampling interval attribute if (mdim >= TDIM+I1) new_slab= hadd_attr( new_slab, dimvar+":sampling_interval", double(delta(I0)) ); // Add sample count attribute if (mdim >= TDIM+I1) new_slab= hadd_attr( new_slab, "data:sample_count", long(ncoord) ); //SOFT-EXTENSIONS-END: if (!is_null(name)) new_slab.name= name; if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hfft(" + his_str + ");" } // Return output slab return timer_return(func_name, new_slab); } func hfold( slab, help=, ilabel=, iparam=, like=, month1=, nohistory=) /* DOCUMENT hfold, slab, help=, ilabel=, iparam=, * like=like, month1=, nohistory=0/1 * Folds the T-dimension to create a new I-dimension with labels ILABEL * and parameters IPARAM. * E.g., for monthly data, a new I-dimension corresponding to the calendar * month can be created, retaining only the annual time-scale for the * T-dimension. * * LIKE=LIKE_SLAB allows the ILABEL/IPARAM values to be obtained from * another hyperslab slab LIKE_SLAB. * * MONTH1 is set to the name of the first month, it indicates that the * 12 calendar months from the I-dimension, allowing ILABEL and IPARAM * values to be generated automatically. * (If MONTH1="", the first month is determined from the first date value) * * NOHISTORY==1 disables appending of history information. * SEE ALSO: hsub, hcat, hsprout */ { func_name= "hfold"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HFOLD folds the T-dimension to create a new I-dimension."; write," E.g.,"; write," new_slab = hfold(slab,ilabel=['winter','spring','summer','fall'])"; write," folds a seasonally averaged time-series into the seaonal I-dimension"; write," && the annual T-dimension."; write," Tips:"; write," 1. ilabel=['label1','label2',...] specifies list of labels."; write," 2. iparam=[value1,value2,...] specifies list of parameters."; write," 3. like=like_slab uses ilabel/iparam values from like_slab."; write," 4. month1='march' folds monthly averaged data starting from March"; write," See also: hsub, hcat, hsprout"; write,""; write," Usage: hfold(slab,ilabel=[...],iparam=[...],,like=like_slab,month1='month',nohistory=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hfold( slab(j), ilabel=ilabel, iparam=iparam, like=like, month1=month1, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } // History string his_str= "<" + slab.name + ">"; // Check if slab contains actual data or just a locator structure actual_data= (slab.type(HFMT.data) != "struct_instance"); // Copy dimension presence codes is_present= slab.dimension(,HFMT.data); apresent= slab.dimension(,HFMT.area_wt); zpresent= slab.dimension(,HFMT.z_bot); // Check slab dimensionality if (is_present(TDIM) <= 0) error, "Time dimension not present in slab"; if (is_present(IDIM) > 0) error, "I-dimension already present in slab"; // Save legend information for reduced I-dimension, if necessary ilegend= ""; if (is_present(IDIM) < 0) ilegend= nsublegend(slab,IDIM+I1); // Copy labels/parameters ilabel1= NULL; iparam1= NULL; ilabel_name= ""; iparam_name= ""; if (!is_null(like)) { // Copy ILABEL/IPARAM values from "like" slab ilabel1= *(like.ilabel); ilabel_name= hattr( like, "ilabel:long_name" ); iparam1= deref(like.ilabel); if (!is_null(iparam1)) iparam_name= hattr( like, "iparam:long_name" ); } if (param_set(ilabel)) ilabel1= ilabel; if (param_set(iparam)) iparam1= iparam; // Time coordinate time1= *(slab.time); date1= deref(slab.date); ntime1= numberof(time1); t_units= hattr(slab, "time:units"); // Determine fold count if (!is_null(month1)) { // 12 calendar months if (param_set(ilabel) || param_set(like)) error, "ILABEL/LIKE parameters incompatible with MONTH1 parameter"; months= [ "January", "February", "March", "April", "May", "June", "July", "August", "September", "October", "November", "December" ]; nfold= numberof(months); // Locate first month if (month1 != "") { imonth= strloc( months, month1, case_fold=1, abbrev=1); if (imonth == 0) error, "Invalid month name - " + month1; } else { if (is_null(date1)) error, "No dates available; please specify month1=..." imonth= (long(date1(I0)) % 10000) / 100; if ((imonth < 1) || (imonth > 12)) error, "Invalid date value - "+strnum(date1(I0)); } // Rotate list of months to generate label strings ilabel1= months(I0 + (indgen(nfold)-I0 + imonth-1) % nfold); ilabel_name= "calendar month"; // History string his_str= his_str + ",month1=<" + month1 + ">"; } else { // Not monthly data if (is_null(ilabel1)) { if (is_null(iparam1)) error, "One of ILABEL/IPARAM must be specified"; nfold= numberof(iparam1); // Generate null-string labels for non-monthly data ilabel1= array("",nfold); } else { nfold= numberof(ilabel1); } } if ((!is_null(ilabel1)) && (numberof(ilabel1) != nfold)) error, "Incorrect number of ILABEL values"; if ((!is_null(iparam1)) && (numberof(iparam1) != nfold)) error, "Incorrect number of IPARAM values"; // Number of new "time" values ntime2= ntime1/nfold; if ((ntime1 % nfold) != 0) { // Incomplete folding; not allowed for actual data if ((ntime1 < nfold) || actual_data) error, "T-dimension length not a multiple of fold-length"; // File data; allow extra incomplete fold ntime2= ntime2 + 1; } // New date/time values (choose first value in each fold) if (!is_null(date1)) { date2= date1( I0 + nfold*(indgen(ntime2)-I0) ); } else { date2= NULL; } time2= time1( I0 + nfold*(indgen(ntime2)-I0) ); // Generate I-parameter values from time values iparam2_name= "Folding time"; iparam2= time1(I0:nfold-I1) - time1(I0); if (!is_null(month1)) { // Generate new time and I-parameter values from date/time values if (!is_null(date1)) { // Use date values to overwrite time values for monthly fold time2(*)= long(date2(*)+HFMT.epsdate)/10000; t_units= "year"; iparam2_name= "Folding month"; base_value= double(10000)*long(date1(I0)/10000); iparam2= date1(I0:nfold-I1) - base_value; } else { if (t_units == "day") { dayspyr= hattr(slab,"time:days_per_year"); if (dayspyr > 0) { // Convert days to years time2(*)= time2(*) / dayspyr; iparam2(*)= iparam2(*) / dayspyr; t_units= "year"; } } else if (t_units == "month") { // Convert months to years time2(*)= time2(*) / nfold; iparam2(*)= iparam2(*) / nfold; t_units= "year"; } } } if (is_null(iparam1)) { iparam1= iparam2; iparam_name= iparam2_name; } // Introduce I-dimension is_present(IDIM)= 1; if (apresent(TDIM) > 0) apresent(IDIM)= 1; if (zpresent(TDIM) > 0) zpresent(IDIM)= 1; // Fold dimension area_wt1= NULL; z_bot1= NULL; if (actual_data) { // Reshape data array, and transpose temdims= hdimsof(slab); temdims(1+TDIM)= nfold; temdims(1+IDIM)= ntime2; data1= *(slab.data); reshape_array, data1, temdims; data1= transpose( data1, [TDIM+I1, IDIM+I1] ); if ((apresent(TDIM) > 0) && (slab.type(HFMT.area_wt) != "")) { // Reshape and transpose area weights array temdims= hdimsof(slab,area_wt=1); temdims(1+TDIM)= nfold; temdims(1+IDIM)= ntime2; area_wt1= *(slab.area_wt); reshape_array, area_wt1, temdims; area_wt1= transpose( area_wt1, [TDIM+I1, IDIM+I1] ); } if ((zpresent(TDIM) > 0) && (slab.type(HFMT.z_bot) != "")) { // Reshape and transpose Z_BOT array temdims= hdimsof(slab,z_bot=1); temdims(1+TDIM)= nfold; temdims(1+IDIM)= ntime2; z_bot1= *(slab.z_bot); reshape_array, z_bot1, temdims; z_bot1= transpose( z_bot1, [TDIM+I1, IDIM+I1] ); } } else { // Data locator loc= *(slab.data); dimenstr= loc.dimenstr; dim_data= loc.dim_data; dim_area_wt= loc.dim_area_wt; dim_z_bot= loc.dim_z_bot; was_present= loc.was_present; slab_offset= *(loc.slab_offset); slab_count= *(loc.slab_count); // No. of dimensions ndim= strlen(dimenstr); if (was_present(IDIM) > 0) error, "I-dimension already present in file"; if (dim_data(TDIM) != ndim) error, "T-dimension not the last dimension in file"; // Introduce I-dimension dimenstr= strmid(dimenstr,0,ndim-1) + HFMT.coordnames(IDIM) + HFMT.coordnames(TDIM); was_present(IDIM)= 1; dim_data(TDIM)= ndim+1; dim_data(IDIM)= ndim; // Save old T-dimension offset, count etc slab_fold= array(long,3); slab_fold(I0)= slab_offset(ndim-I1); slab_fold(I0+1)= slab_count(ndim-I1); slab_fold(I0+2)= nfold; // Set offset/count for new I-dimension slab_offset(ndim-I1)= 0; slab_count(ndim-I1)= nfold; // Append offset/count for new T-dimension grow, slab_offset, 0; grow, slab_count, ntime2; if (apresent(TDIM) > 0) { // Fold T-dimension for area weights too ndima= sum( dim_area_wt > 0 ); if (dim_area_wt(TDIM) != ndima) error, "Internal error 1; last area weight dimension not time" dim_area_wt(TDIM)= ndima+1; dim_area_wt(IDIM)= ndima; } if (zpresent(TDIM) > 0) { // Fold T-dimension for Z_BOT values too ndimz= sum( dim_z_bot > 0 ); if (dim_z_bot(TDIM) != ndimz) error, "Internal error 2; last Z_BOT dimension not time" dim_z_bot(TDIM)= ndimz+1; dim_z_bot(IDIM)= ndimz; } // Create new data locator structure data1= locator_struc( fstruc= loc.fstruc, fname= loc.fname, fmeta= loc.fmeta, add_offset= loc.add_offset, scale_factor= loc.scale_factor, area_wt_var= loc.area_wt_var, z_bot_var= loc.z_bot_var, dimenstr= dimenstr, dim_data= dim_data, dim_area_wt= dim_area_wt, dim_z_bot= dim_z_bot, was_present= was_present, slab_wrapcount= loc.slab_wrapcount, slab_fold= ref(slab_fold), slab_offset= ref(slab_offset), slab_count= ref(slab_count) ); data1.structure= "LOCATOR"; data1.type(*)= loc.type(*); } // Ensure that any old IPARAM values are erased if (is_null(iparam1)) iparam1= ""; // Copy folded slab, including data, area weight/Z_BOT values/dimensions new_slab= NULL; hcopy, slab, new_slab, data=data1, is_present=is_present, date1=date2, time1=time2, ilabel1=ilabel1, iparam1=iparam1, ilabel0=ilabel1, iparam0=iparam1, area_wt1=area_wt1, area_wt_dims=apresent, z_bot1=z_bot1, z_bot_dims=zpresent, reset_vars=["ilabel","iparam"]; // Reset T-dimension subdomain and units attribute hset_attr, new_slab, "time:subdomain", 0; hset_attr, new_slab, "time:units", t_units; // Set I-dimension attributes hset_attr, new_slab, "ilabel:long_name", ilabel_name; hset_attr, new_slab, "iparam:long_name", iparam_name; hset_attr, new_slab, "ilabel:subdomain", 0; if (ilegend != "") { // Add legend information for prior reduced I-dimension hset_attr, new_slab, "data:legend", hattr(new_slab,"data:legend") + " " + ilegend; } if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hfold(" + his_str + ",...);" } // Return output slab return timer_return(func_name, new_slab); } func hgather( slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9, help=) /* DOCUMENT hgather(slab0, slab1, slab2, slab3, slab4, * slab5, slab6, slab7, slab8, slab9, help=0/1) * "Gathers" several hyperslabs/hyperslab-arrays into a single one-dimensional * hyperslab array. * Note: 1. This not quite the inverse of HSCATTER. * 2. In IDL, the contstituent hyperslabs have to be of the same size. * SEE ALSO: hgrow, hcat, hsplit */ { func_name= "hgather"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HGATHER creates an array of hyperslabs by combining"; write," all of its arguments."; write," E.g.,"; write," slab_array = hgather(slab0,slab1,...,slab9)"; write," combines SLAB0, ..., SLAB9 into a one-dimensional hyperslab array."; write," (SLAB0, ..., SLAB9 may themselves be arrays.)"; write," See also: hgrow, hcat, hsplit"; write,""; write," Usage: hgather(slab0,[,slab1],...)"; return timer_return(func_name, NULL); } // Number of slabs nslab= numberof(slab0) + numberof(slab1) + numberof(slab2) + numberof(slab3) + numberof(slab4) + numberof(slab5) + numberof(slab6) + numberof(slab7) + numberof(slab8) + numberof(slab9); slab_array= NULL; for (jslab=I0; jslab <= I0+nslab-1; jslab++) { // Get slab tem_slab= nslabarr( jslab+I1, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); // Append to slab array hgrow, slab_array, tem_slab, jslab, nslab, destroy=1; } return timer_return(func_name, slab_array); } func hget( varname, help=, verbose=, slice=, limx=, limy=, limz=, limt=, limi=, x=, y=, z=, t=, i=, subscript=, rotx=, sumz=, like=, strip=, mask=, shrink=, hregion=, vregion=, name=, fstruc=, file=, noweight=, no_area_wt=, no_z_bot=, nodata=, nohistory=) /* DOCUMENT hget( varname, help=0/1, verbose=0/1, slice=, * limx=, limy=, limz=, limt=, limi=, * x=, y=, z=, t=, i=, subscript=0/1, rotx=, sumz=0/1, * like=, strip=, mask=0/1, shrink=0/1, hregion=, * vregion=, name=, fstruc=, file=, * noweight=0/1, no_area_wt=0/1, no_z_bot=01/, * nodata=0/1, nohistory=0/1 ) * * HGET reads a specified variable from a history file as a hyperslab data * structure, and selects a spatial/temporal subdomain * * Input parameters: * varname -- variable name (string) * (VARNAME may also be an array of strings, * in which case an array of hyperslabs is returned.) * (If VARNAME omitted, all variables in a hyperslab * file are returned) * (KEYWORD PARAMETERS) * help -- help option * verbose -- verbose option * slice -- slice is a 1-dimensional array of paired strings, * with the first element of a pair representing the name of an * extra dimension in the variable (apart from the five * standard dimensions), and the second element representing * the "coordinate" value at which to slice the dimension. * NOTE: SLICE *must* be specified if any extra dimensions are present, * because they cannot be represented in the hyperslab data structure * lim(x/y/z/t/i) -- x/y/z/t/i subdomain range selection. E.g, limx=[xmin,xmax] * (x/y/z/t/i) -- x/y/z/t/i value/rank-reduction selection. * E.g, x=[xval1, xval2, ...] for selecting slices, or * x="avg" or "sum" or "rms" or "min" or "max", * for weighted averaging/summing/RMS-values/extreme values * (NOTE: subdomain range selection is done prior to selecting * specific coordinate slices or rank reduction operations) * subscript -- subscript specification flag * (if set, assume that integer coordinate values for * coordinate ranges/lists (limx, x, ...) represent array * subscript values, starting from 1, rather than actual * coordinate values; floating point values are still assumed * represent actual coordinate values.) * rotx -- if defined, rotate X-coordinate by angle ROTX * (rotation is done before all masking/subdomain selection operations) * sumz -- carry out summation in Z dimension using Z weights only * like -- another hyperslab data structure * (if this parameter is specified, the subdomain selection/ * rank-reduction parameters determined from this hyperslab) * strip -- list of reduced dimensions to be stripped (e.g. ["x","t","i"]) * mask -- if true, the default history file region masks, if any, * are used to mask out horizontal/vertical subdomains * shrink -- if true, the domain is shrunk to fit the masked region * hregion -- horizontal subdomain name * vregion -- vertical subdomain name * name -- new name for data variable * fstruc -- history file data structure * (if omitted, the default history file is read) * file -- if specified, the file is opened temporarily for reading. * noweight -- if true, do not compute vertical weights for sigma coordinate, * and allow spatial averaging without weights. * no_area_wt -- if true, do not read area weights from file * (but save area weights variable name as attribute) * no_z_bot -- if true, do not read Z_BOT values from file * (but save Z_BOT variable name as attribute) * nodata -- if true, do not actually read the data, but replace the * data array with a data locator structure for the moment * (later, the routine HDATA may be used to read the data) * nohistory -- if true, do not append history information to hyperslab * * Output: a single hyperlsab data structure of spatial/temporal subdomain * of the named variable, * or an array of hyperslab structures, if VARNAME was an array * * SEE ALSO: hopen, hsave, hsub, hmask, hop, hcat, hcopy, hplot, hlegend, hattr, hdata */ { func_name= "hget"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HGET reads a `hyperslab' of data for a named variable (|| variables)"; write," from a history file. The data is returned as a hyperslab data strucure."; write," HGET also accepts all the optionsof routine HSUB, && can thus select"; write," a spatial/temporal subdomain of the data. E.g.,"; write," slab = hget('T',z=0,fstruc=ocean_struc)"; write," returns a slab containing the (z=0) SST values from an ocean history file"; write," structure OCEAN_STRUC that was opened using HOPEN."; write," slab = hget(['T','S'],limt=[19030101,19941201])"; write," returns values of variables 'T' && 'S' between the specified dates"; write," from the default history file as a 2-element hyperslab array."; write," Tips:"; write," 1. The variable name parameter may be omitted for hyperslab files,"; write," in which case all the variables in the file are read."; write," 2. fstruc=history_file_data_structure reads the data from the"; write," specified history file. Otherwise, data is read from the"; write," default history file."; write," 3. file=`name` reads data from specified file."; write," 4. slice=['dimension_a','value_a',...] slices out any extra"; write," dimensions in the variable. E.g., slice=['basins','atlantic']"; write," 5. mask=1 applies history file masks on data"; write," 6. nodata=1 delays reading of data values"; write," 7. no_area_wt=1 suppresses reading of area weights"; write," 8. no_z_bot=1 suppresses reading of Z_BOT values"; write," 9. HGET also accepts all options accepted by HSUB (to select subdomains)"; write," See also: hopen, hsave, hsub, hmask, hop, hcat, hcopy, hplot, hlegend, hattr, hdata"; write,""; write," Usage: hget('variable_name', fstruc=.., file=..,slice=['dima','vala'],lim(x/y/z/t/i)=[min,max], (x/y/z/t/i)=[val1,...], sumz=0/1, rotx=angle, like=old_slab, ..."; return timer_return(func_name, ""); } // Determine file to be read if (!is_null(file)) { // Open file temporarily for reading hopen, file, fstruc, alt=1, silent=(param_set(verbose) == 0); } else { // Read from opened file if (is_null(fstruc)) { if (is_null(DEFAULT_FILE_STRUC)) { error, "Error - no default history file opened to read data from"; } else { fstruc= DEFAULT_FILE_STRUC; } } } if (is_null(varname)) { // Read all variables from file, recursively varlist= strsplit(fstruc.vars, ","); if (numberof(varlist) == 1) varlist= varlist(I0); } else { if (typeof(varname) != "string") error, "Argument VARNAME should be of string type"; varlist= varname; } if (!is_scalar(varlist)) { // Array of variables; handle recursively if ((!is_null(name)) && (numberof(name) != numberof(varlist))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(varlist)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hget( varlist(j), verbose=verbose, slice=slice, limx=limx, limy=limy, limz=limz, limt=limt, limi=limi, x=x, y=y, z=z, t=t, i=i, subscript=subscript, rotx=rotx, sumz=sumz, like=like, strip=strip, mask=mask, shrink=shrink, hregion=hregion, vregion=vregion, name=name1, fstruc=fstruc, file=file, noweight=noweight, no_area_wt=no_area_wt, no_z_bot=no_z_bot, nodata=nodata, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(varlist), destroy=1; } return timer_return(func_name, slab_array); } // History string his_str= "<" + varlist + ">"; if (!is_null(like)) his_str= his_str + ",like=<" + like.name + ">"; // Initialize region name hregion1= NULL; if (!is_null(hregion)) { hregion1= hregion; his_str= his_str + ",hregion=<" + hregion + ">"; } if (param_set(mask)) { // Masking requested his_str= his_str + ",mask=1"; if (is_null(fstruc.other_labels) || is_null(fstruc.rmask)) error, "No region masks available in history file"; other_labels1= *(fstruc.other_labels); hmask_label= strsplit( other_labels1(I0), ";") // Discard first region on history file (assumed to be "global") if (numberof(hmask_label) > 1) { hmask_label= hmask_label(I0+1:); } else { hmask_label= NULL; } if (is_null(hregion1) && (!is_null(like))) { // Check if "like" slab is restricted to known region iregion= strloc(hmask_label, hattr(like, ":hor_subdomain") ); if (iregion > 0) hregion1= hattr(like, ":hor_subdomain"); } } // Locate variable in file, and get hyperslab with locator instead of data slab= nlocate(varlist(I0), fstruc, no_area_wt=no_area_wt, no_z_bot=no_z_bot); loc= *(slab.data); // No. of data dimensions dimenstr= loc.dimenstr; ndim= strlen( dimenstr ); // Handle slice parameter if (is_null(slice)) { nslice= 0; } else { if ( (typeof(slice) != "string") || ( (dimsof(slice))(I0) != 1) || \ ((numberof(slice) % 2) != 0) ) error, "Parameter SLICE should be an array of paired strings"; // Split paired slice specifications for the extra dimensions nslice= numberof(slice) / 2; extra_dims= array("",nslice); extra_vals= array("",nslice); for (j=I0; j <= nslice-I1; j++) { extra_dims(j)= slice(2*j-I0); extra_vals(j)= slice(2*j+I1); } } // Slice out extra dimensions slice_flag= 0; slab_offset= *(loc.slab_offset); slab_count= *(loc.slab_count); for (mdim=I0; mdim <= ndim-I1; mdim++) { cdim= strmid(dimenstr,mdim-I0,1); if ((cdim >= "0") && (cdim <= "9")) { // Extra dimension iextra= (long( (char(*(pointer(cdim))))(I0) - char('0') ))(I0) + I0 ; // keep "'" dimname= (*(fstruc.other_dims))(iextra); dimlabels= strsplit( (*(fstruc.other_labels))(iextra), ";" ) if (nslice == 0) error, "Dimension " + dimname + " must be sliced out"; // Locate slice info for extra dimension ival= strloc(extra_dims, dimname, case_fold=1, abbrev=1); if (ival == 0) error, "Please specify dimension slice=[..., '" + dimname + "', 'VALUE']"; islice= strloc( dimlabels, extra_vals(ival-I1), case_fold=1, abbrev=1, comment=dimname); if (islice == 0) error, "Please specify value slice=[..., '" + dimname + "', 'VALUE']"; // Slice out the extra dimension slice_flag= 1; slab_offset(mdim)= islice-1; slab_count(mdim)= 1; // Append slice parameter to legend hset_attr, slab, "data:legend", hattr(slab,"data:legend") + " " + dimlabels(islice-I1); } } if (slice_flag) { // Modify slab data locator loc.slab_offset= ref(slab_offset); loc.slab_count= ref(slab_count); hcopy, slab, new_slab, data=loc; slab= new_slab; new_slab= NULL; } // Rotation parameter rotx2= NULL; if (!is_null(rotx)) { rotx2= rotx; his_str= his_str + ",rotx=" + strnum(rotx); } if ( (!is_null(like)) && (slab.dimension(XDIM,HFMT.data) > 0) ) { // Copy rotation state from "like" slab like_rotated= hattr(like, "x:rotated"); nx= numberof(*(like.x)); if (is_null(rotx2) && (like_rotated != 0) && (nx > 1)) { rotx2= like_rotated*( (*(like.x))(I0+1) - (*(like.x))(I0) ); } } if (param_set(rotx2)) { // Carry out X rotation before any masking/subdomain selection operation slab= nrotate(slab, rotx2); } if (param_set(mask)) { // Carry out region masking if (param_set(shrink)) his_str= his_str + ",shrink=1"; slab= hmask( slab, *(fstruc.rmask), hmask_label, hregion=hregion1, regular_grid=1, shrink=shrink, nohistory=1 ); hregion1= NULL; } if (!param_set(nohistory)) { // Append history info to slab hset_attr, slab, "data:history", hattr(slab,"data:history") + " hget(" + his_str + ");" } if (param_set(nodata) && (!is_null(strip))) error, "Actual data must be present in slab for stripping dimensions"; // Call HSUB for subdomain selection, slicing, or rank reduction (NOT rotation) slab= hsub(slab, limx=limx, limy=limy, limz=limz, limt=limt, limi=limi, x=x, y=y, z=z, t=t, i=i, subscript=subscript, sumz=sumz, like=like, strip=strip, hregion=hregion1, vregion=vregion, noweight=noweight, nohistory=1 ); if (!param_set(nodata)) { // Ensure that slab contains actual data (!a data locator) if (slab.type(HFMT.data) == "") error, "Error - null data values"; if (slab.type(HFMT.data) == "struct_instance") slab= hdata(slab); } if (!is_null(file)) { // Close temporary file hclose, fstruc, silent=(param_set(verbose) == 0); } if (!is_null(name)) { // Change variable name if (slab.type(HFMT.data) == "struct_instance") error, "name=... option may only be used with actual data in slab"; slab.name= name; } // Return hyperslab return timer_return(func_name, slab); } func hgrow( &var, &sfx, //YORICKoutput: index, dims, destroy=, notime=) /* DOCUMENT hgrow, var, sfx, index, dims, destroy=0/1, notime=0/1 * Dimension preserving, limited "grow" function for an array of hyperslabs * VAR with dimension array DIMS. INDEX is a 1-dimensional index. * SFX is copied to the array element VAR(INDEX). * (Successive calls with different values of INDEX should be used to fill * the destination array.) * * If DESTROY==1, SFX is set to null on output. * (*NOTE* This allows for more efficient copying in Yorick) * * If NOTIME==1, if the data array, area weights, or Z_BOT values * have the time dimension, they are stripped from SFX prior to copying. * (This could be useful in growing a "shell" hyperslab array that can be * fed to HSAVE with the notime option.) * Output parameters: * var * SEE ALSO: hgather, hcopy, grow */ { func_name= "hgrow"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (is_null(index)) error, "INDEX not specified"; if (is_null(dims)) error, "DIMS not specified"; if (param_set(notime)) { // Handle NOTIME option recursively data1= (area_wt1= (z_bot1= NULL)); if (sfx.dimension(TDIM,HFMT.data) > 0) data1= ""; if (sfx.dimension(TDIM,HFMT.area_wt) > 0) area_wt1= ""; if (sfx.dimension(TDIM,HFMT.z_bot) > 0) z_bot1= ""; new_sfx= NULL; hcopy, sfx, new_sfx, data=data1, area_wt1=area_wt1, z_bot1=z_bot1; hgrow, var, new_sfx, index, dims, destroy=1; // Preserve type information var(index).type= sfx.type; if (param_set(destroy)) sfx= NULL; return timer_return(func_name); } if (is_null(var)) { if (is_scalar(dims)) { if (dims == 1) { // Scalar structure var= sfx(I0); } else { // Structure array var= array(sfx(I0), dims); } } else { if (dims(I0) == 0) { // Scalar structure var= sfx; } else { //IDLbegin: //: if ((dims(I0) == 1) && (dims(I0+1) == 1)) { // 1-D one-element structure "array" //: var= sfx; //: } else { // Structure array //: var= array(sfx(I0), dims); //: } //IDLend: //YORICKbegin: // Structure array var= array(sfx(I0), dims) //YORICKend: } } } else { if (!param_set(destroy)) { hcopy, sfx, var, index2=index; } else { var(index)= sfx //IDL2YORICK: hcopy, sfx, var, index2=index ; sfx= NULL; } } return timer_return(func_name); } func hinterp( slab, dim, help=, grid=, alt_grid=, interface=, like=, coord=, op=, extrapolate=, x_period=, z_bot=, nohistory=) /* DOCUMENT hinterp(slab, dim, help=0/1, grid=, alt_grid=, * interface=0/1, like=, coord=, op=, * extrapolate=0/1, x_period=, * z_bot=, nohistory=0/1) * HINTERP carries out linear interpolation of data in SLAB along * dimension DIM. * Area/volume weights and bottom Z values are deleted if they contain the * interpolated dimension. Bottom Z values are deleted during Z interpolation. * SLAB may be an array of hyperslabs. * DIM="x"/"y"/"z"/"t"/"i" => dimension to be interpolated. * GRID=[val1,val2,...] => new coordinate values. * ALT_GRID=[val1,val2,...] => new staggered coordinate values. * INTERFACE=1 => new interfacial grid (default is to assume regular grid). * LIKE=like_slab determines new coordinates from like_slab. * COORD=coordinate_values_on_data_grid (hyperslab). * (If the COORD parameter is not specified, it is computed by calling HCOORD. * If SLAB is a slab array, it is more efficient to specify COORD explicitly.) * OP="log"/2/... specifies an operation to be applied on the coordinate * before the linear interpolation is carried out. A numeric value causes * the coordinate to be raised to the power OP. The value "log" results in * linear interpolation using the logarithm of the coordinate value. * EXTRAPOLATE=1 extrapolates data linearly for out-of-range coordinate values. * (Extrapolation will not work if there are missing coordinate values.) * X_PERIOD=... may be used to specify the X period attribute. * Z_BOT= specifies the new bottom Z values after interpolation. * NOHISTORY=1 disables appending of history information. * SEE ALSO: hcoord, hshift, hsub */ { func_name= "hinterp"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HINTP interpolates data from one set of coordinates to"; write," another, along the selected dimension."; write," E.g.,"; write," new_slab = hinterp(slab,'z',grid=[850.,500.,300.])"; write," interpolates data along Z dimension to specified coordinate values."; write," Tips:"; write," 1. grid=[val1,val2,...] allows new grid to be specified."; write," 2. alt_grid=[val1,val2,...] allows staggered grid to be specified."; write," 3. interface=1 implies new grid is interfacial."; write," 4. like=like_slab allows grid values to be taken from like_slab."; write," 5. coord=coord_slab allows old coordinate values to be specified"; write," on the data grid."; write," 6. op='log'/2/... applies log/squaring operation to coordinate."; write," 7. extrapolate=1 allows linear extrapolation."; write," 8. x_period=... specifies X period."; write," 9. z_bot= specifies bottom Z values information."; write," See also: hcoord, hshift, hsub"; write,""; write," Usage: hinterp(slab,'x/y/z/t/i',grid=[val1,val2,...],alt_grid=[...],like=like_slab,coord=coord_slab,op='log'/2,extrapolate=0/1,x_period=val,z_bot=...)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (is_null(coord) && (!is_scalar(slab)) ) { // No coordinates specified for array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= hinterp( slab(j), dim, grid=grid, alt_grid=alt_grid, interface=interface, like=like, coord=coord, op=op, extrapolate=extrapolate, x_period=x_period, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (!is_scalar(dim)) error, "Argument DIM should be a scalar string"; // Determine dimension to be shifted mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; // Compute coordinates if (is_null(coord)) coord= hcoord(slab, dim); // Periodicity flag periodic= (mdim == XDIM+I1) && (hattr(coord, "x:period") != 0.) && \ (hattr(coord, "x:subdomain") == 0); new_alt= NULL; if (is_null(grid)) { // Determine grid from like slab if (is_null(like)) error, "One of grid=/like= parameters should be specified"; if (like.dimension(mdim-I1,HFMT.data) == 0) error, "Dimension not present in like slab"; if ((mdim == IDIM+1) && is_null(like.iparam)) error, "IPARAM values not available for interpolation"; new_coord= ngetcoord(like, mdim, iparam=1); interfacial= (abs(like.dimension(mdim-I1,HFMT.data)) == 2); if ((mdim <= ZDIM+1) && (nattr("subdomain",like,mdim) == 0)) { // New alternate grid (full domain only) if (interfacial) { new_alt= ngetcoord(like, mdim, full=1, grid=1); } else { new_alt= ngetcoord(like, mdim, full=1, grid=2); } } } else { new_coord= double(grid); if (!is_null(alt_grid)) new_alt= double(alt_grid); interfacial= param_set(interface); } // Number of new coordinate values ncnew= numberof(new_coord); if ((ncnew > 1) && (monotonic(new_coord) == 0)) error, "New grid values not monotonic"; if (!is_null(new_alt)) { // Check consistency of specified alternate coordinate if (!ncheck_grid(new_coord, new_alt)) error, "Inconsistent regular/staggered grid specification"; } // Copy new coordinate values new_coord2= new_coord; // Copy coordinate values coord1= *(coord.data); cdims= dim_reshape(dimsof(coord1),mindim=SDIM); cmiss_value= deref(coord.missing_value); if (!is_null(cmiss_value)) { // Check if there are missing coordinate values cmiss_flag= anyof(coord1 == cmiss_value); } else { cmiss_flag= 0; } // Locate missing data values flag locate_miss= cmiss_flag || ((!periodic) && (!param_set(extrapolate))); // Focus coordinate array on interpolating dimension cdimf= dim_reshape(cdims, focus=mdim); reshape_array, coord1, cdimf; ncleft= cdimf(I0+1); ncold= cdimf(I0+2); ncright= cdimf(I0+3); if (cmiss_flag) { // Average out all dimensions except interpolating dimension avg_slab= coord//; for (mdim2=1; mdim2 <= SDIM; mdim2++) { if (mdim2 != mdim) avg_slab= nreduce(avg_slab, mdim2, "avg"); } // Copy defined coordinate values def_coord= (*(avg_slab.data))(*); wcdef= where(def_coord != cmiss_value); if (!is_where(wcdef)) error, "No defined coordinate values"; def_coord= def_coord(wcdef); // Ascending order flag ncdef= numberof(def_coord); ascending= (def_coord(I0) <= def_coord(ncdef-I1)); } else { // No missing coordinate values; determine ascending order flag ascending= (coord1(I0,I0,I0) <= coord1(I0,ncold-I1,I0)); } z_positive= NULL; if ((ncold > 1) && (mdim == ZDIM+I1)) { // Interpolating in Z dimension; set positive direction old_ascending= (monotonic(*(slab(I0).z)) == 1); z_positive= hattr(slab, "z:positive", index=I0); if (ascending != old_ascending) { // Change positive direction if (z_positive == "up") z_positive= "down" ; else z_positive= "up"; } } // Rotation counter, x period rot_count= 0; period_x= 0.; if (periodic) { // Periodic dimension if (cmiss_flag) error, "Cannot interpolate periodic dimension with missing coordinates"; // X period if (param_set(x_period)) { period_x= x_period; } else { if ( (coord.long_name != hattr(coord,"x:long_name")) || \ (coord.units != hattr(coord,"x:units")) ) error, "X_PERIOD parameter needs to be specified"; period_x= hattr(coord, "x:period"); } if ((ncleft != 1) || (ncright != 1)) error, "Internal error; multiple dimension for periodic coordinate" ncdim1= ncold+1; // Copy coordinate array with padding temcoord= array(coord1(I0), [3, 1, ncdim1, 1]); temcoord(I0,I0:ncold-I1,I0)= coord1(I0,,I0); coord1= temcoord; if (ascending) { coord1(I0,ncdim1-I1,I0)= coord1(I0,I0,I0) + period_x; } else { coord1(I0,ncdim1-I1,I0)= coord1(I0,I0,I0) - period_x; } // Ensure that new coordinate values lie to right of old coordinate values for (jnew=I0; jnew <= ncnew-I1; jnew++) { if (ascending) { if (new_coord2(jnew) < coord1(I0,I0,I0)) { rot_count= rot_count - 1; new_coord2(jnew)= new_coord2(jnew) + period_x; } } else { if (new_coord2(jnew) > coord1(I0,I0,I0)) { rot_count= rot_count - 1; new_coord2(jnew)= new_coord2(jnew) - period_x; } } } if (rot_count != 0) new_coord2= rangeop(new_coord2,"rot",count=rot_count); } else { // Non-periodic dimension ncdim1= ncold; } timer_call,"hinterp-crit"; //CRITICAL-SECTION-BEGIN: if (!is_null(op)) { // Transform old/new coordinate values if (cmiss_flag) error, "Cannot transform missing coordinate values"; if (is_number(op)) { // Exponentiation coord1(*)= coord1(*)^op; new_coord2= new_coord2^op; } else { // Logarithm if (op != "log") error, "Invalid operation - " + op; coord1(*)= log(coord1(*)); new_coord2= log(new_coord2); } } miss_flag= NULL; if (locate_miss) miss_flag= array(long,ncleft,ncnew,ncright); lcoord= array( coord1(I0), [2, ncleft, ncdim1] ); tem_flag= array(long,ncleft,ncdim1); indleft= indgen(ncleft); tem_ind= array(long,ncleft); tem_ind2= array(long,ncleft); pre_flag= array(long,ncleft); miss_left= array(long,ncleft); lo_val= array(coord1(I0), ncleft); hi_val= array(coord1(I0), ncleft); lcmin= array(coord1(I0), ncleft); lcmax= array(coord1(I0), ncleft); low_ind= array(long,ncleft,ncnew,ncright); hi_ind= array(long,ncleft,ncnew,ncright); frac_ind= array(coord1(I0), [3,ncleft,ncnew,ncright]); for (jnew=I0; jnew <= ncnew-I1; jnew++) { // New coordinate value new_val= new_coord2(jnew); for (iright=I0; iright <= ncright-I1; iright++) { lcoord(,)= coord1(,,iright); if (cmiss_flag) { // Handle missing coordinate values if (ascending) { // Coordinate values in ascending order tem_flag(*)= ((new_val >= lcoord(*)) + (cmiss_value == lcoord(*)) ) > 0; } else { // Coordinate values in descending order tem_flag(*)= ((new_val <= lcoord(*)) + (cmiss_value == lcoord(*)) ) > 0; } // Loop over all old coordinate values tem_ind(*)= -1; pre_flag(*)= 1; for (jold=I0; jold <= ncdim1-I1; jold++) { pre_flag(*)= pre_flag(*) * tem_flag(,jold); tem_ind(*)= tem_ind(*) + pre_flag(*); } // Flag out of range new coordinate values as missing data values miss_left(*)= (tem_ind(*) < 0) + (tem_ind(*) >= ncdim1-1); if (anyof(miss_left > 0)) tem_ind(where(miss_left > 0))= 0; } else { // No missing coordinate values // Loop over all but the first/last old coordinate values tem_ind(*)= 0; pre_flag(*)= 1; if (ascending) { // Coordinate values in ascending order for (jold=I0+1; jold <= ncdim1-I1-1; jold++) { pre_flag(*)= pre_flag(*)*(new_val >= lcoord(,jold)); tem_ind(*)= tem_ind(*) + pre_flag(*); } if (locate_miss) { // Flag out of range coordinate values miss_left(*)= (new_val < lcoord(,I0)) + (new_val > lcoord(,ncdim1-I1)); } } else { // Coordinate values in descending order for (jold=I0+1; jold <= ncdim1-I1-1; jold++) { pre_flag(*)= pre_flag(*)*(new_val <= lcoord(,jold)); tem_ind(*)= tem_ind(*) + pre_flag(*); } if (locate_miss) { // Flag out of range coordinate values miss_left(*)= (new_val > lcoord(,I0)) + (new_val < lcoord(,ncdim1-I1)); } } } // Bracketing higher index tem_ind2(*)= tem_ind(*) + 1; if (periodic) tem_ind2(*)= tem_ind2(*) % ncold; // Copy low/hi 2-D index values low_ind(,jnew,iright)= tem_ind(*); hi_ind(,jnew,iright)= tem_ind2(*); // Convert to 2-D index tem_ind(*)= indleft(*) + tem_ind(*)*ncleft; // Bracketing old coordinate values lo_val(*)= lcoord(tem_ind); hi_val(*)= lcoord(tem_ind+ncleft); if (cmiss_flag) { // Ensure that new coordinate value is not bracketed by missing values miss_left(*)= miss_left(*) + (hi_val(*) == cmiss_value); } if (locate_miss) { // Check for missing values in interpolated data miss_flag(,jnew,iright)= (miss_left > 0); wmiss= where(miss_left > 0); } else { wmiss= NULL; } // Fractional index (0 ... 1) if (is_where(wmiss)) { // Missing values in interpolated data frac_ind(wmiss,jnew,iright)= 0.; wdef= where(miss_left == 0); if (is_where(wdef)) { frac_ind(wdef,jnew,iright)= (new_val - lo_val(wdef)) / (hi_val(wdef) - lo_val(wdef)); } } else { // No missing values frac_ind(,jnew,iright)= (new_val - lo_val) / (hi_val - lo_val); } } } timer_return,"hinterp-crit"; //CRITICAL-SECTION-END: // Call auxiliary routine to do the actual interpolation tem_slab= ninterp(slab, mdim, low_ind, hi_ind, frac_ind, miss_flag, ncleft, ncold, ncright, ncnew, new_coord, new_alt, interfacial, coord, rot_count, period_x, z_positive, z_bot, nohistory=nohistory); return timer_return(func_name, tem_slab); } func hlegend( slab, help=, nounits=, notime=, reduced=, verbose=) /* DOCUMENT hlegend(slab,help=,nounits=0/1,notime=0/1,reduced=0/1,verbose=0/1) * Returns a descriptive string about the data in the hyperslab SLAB. * If NOUNITS is true, the data units are not appended to the string. * If NOTIME is true, do not produce legend for time subdomain. * If REDUCED is true, describe only reduced dimensions. * If VERBOSE is true, addition descriptive information is printed out. * SEE ALSO: hplot, hattr */ { func_name= "hlegend"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write,"Function HLEGEND returns a legend string for SLAB,"; write," which may be used to label plots "; write," E.g.,"; write," legend_str = hlegend(slab)"; write," returns a string describing slab."; write," Tips:"; write," 1. nounits=1 option suppresses inlcusion of data units."; write," 2. notime=1 suppresses legend for time subdomain."; write," 3. reduced=1 option describes only reduced dimensions."; write," 4. verbose=1 option prints out more descriptive information."; write," See also: hplot, hattr"; write,""; write," Usage: hlegend(slab,nounits=1,notime=1,reduced=1,verbose=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively legend_array= NULL; for (i=I0; i <= I0+numberof(slab)-1; i++) { tem_att= NULL; tem_att= hlegend( slab(i), nounits=nounits, notime=notime, reduced=reduced, verbose=verbose ); grow, legend_array, tem_att; } return timer_return(func_name, legend_array); } // Initialize legend string with case name legstr= hattr(slab,":case_name"); if (legstr != "") legstr= legstr + ": "; // Append short name of variable legstr= legstr + slab.name; if ((!param_set(nounits)) && (slab.units != "")) { // Append units string legstr= legstr + " (" + slab.units + ")"; } // Append region names if (hattr(slab,":hor_subdomain") != "") legstr= legstr + " " + hattr(slab,":hor_subdomain"); if (hattr(slab,":ver_subdomain") != "") legstr= legstr + " " + hattr(slab,":ver_subdomain"); // Append legend string describing subdomains/reduced-dimensions sublegstr= nsublegend( slab, reduced=reduced, notime=notime ); if (sublegstr != "") legstr= legstr + ", " + sublegstr; // Append slab legend string if (hattr(slab,"data:legend") != "") legstr= legstr + ";" + hattr(slab,"data:legend") if (param_set(verbose)) { // Print out additional descriptive information sizestr= "(" + strcombine(strnum((hdimsof(slab))(I0+1:)),",") + ")"; dimstr= hdimsof(slab,name=1); if (dimstr != "") dimstr= "(" + dimstr + ")"; unit_list= [ nattr("units",slab,XDIM+I1), nattr("units",slab,YDIM+I1), nattr("units",slab,ZDIM+I1), nattr("units",slab,TDIM+I1) ]; if (!is_null(slab.missing_value)) write, slab.name + ":missing_value = " + strnum(*(slab.missing_value)); write, slab.name + ":long_name = " + slab.long_name; write, slab.name + ":units = " + slab.units; write, slab.name + ":time_rep = " + hattr(slab,"data:time_rep"); write, slab.name + ":case_name = " + hattr(slab,":case_name"); write, slab.name + ":case_title = " + hattr(slab,":case_title"); write, slab.name + ":original_file = " + hattr(slab,":original_file"); write, slab.name + ":resolution = " + hattr(slab,":resolution"); write, slab.name + ":data_source = " + hattr(slab,":data_source"); write, slab.name + ":data_URL = " + hattr(slab,":data_URL"); write, slab.name + ":history = " + hattr(slab,"data:history"); write, ""; write, "size_vec = " + strcombine(strnum(nsize_vec(slab)),"x"); write, ":structure = " + slab.structure; write, ":format_URL = " + hattr(slab,":format_URL"); write, ""; write, "x:period = " + strnum(hattr(slab,"x:period")); write, "x:rotated = " + strnum(hattr(slab,"x:rotated")); write, "z:positive = " + hattr(slab,"z:positive"); write, "time:days_per_year = " + strnum(hattr(slab,"time:days_per_year")); write, ""; write, "dim:*_bounds = " + strcombine(strnum((ndim_bounds(slab))(*)),","); write, "dim:long_name = " + strcombine(nattr("long_name",slab),","); write, "dim:units = " + strcombine(unit_list,","); write, "dim:subdomain = " + strcombine(strnum(nattr("subdomain",slab)),","); write, "is_present = " + strcombine(strnum(slab.dimension(,HFMT.data)),","); write, "is_reduced = " + strcombine(strnum(slab.reduced(*)),","); write, "area_wt_dims = " + strcombine(strnum(slab.dimension(,HFMT.area_wt)),","); write, "z_bot_dims = " + strcombine(strnum(slab.dimension(,HFMT.z_bot)),","); write, slab.name + dimstr + " -> data" + sizestr; } // Return legend string return timer_return(func_name, legstr); } func hmask( slab, rmask, region_list, help=, hregion=, shrink=, full_domain=, regular_grid=, ignore_awt=, nohistory=) /* DOCUMENT hmask( slab, rmask, region_list, help=help, hregion=hregion, * shrink=0/1, full_domain=0/1, regular_grid=0/1, * ignore_awt=0/1, nohistory=0/1 ) * * HMASK selects a horizontal region HREGION in hyperslab SLAB using the mask * array RMASK and the list of region names REGION_LIST. * * Input parameters: * slab -- hyperslab data structure * (slab may also be an array of hyperslabs, * in which case an array of subdomain hyperslabs is returned.) * rmask -- array of mask values (0=> ignore, non-zero=> select), * or another slab containing mask values as data * region_list -- list of region names (one for each non-zero value in RMASK) * (If REGION_LIST is omitted, non-zero values of * RMASK are assumed to represent the region of interest. * If REGION_LIST is specified, RMASK should contain * integer values >=0, with HREGION containing the name of * the region.) * (KEYWORD PARAMETERS) * help -- help option * hregion -- horizontal subdomain name, may be an array * (should be in REGION_LIST, if specified) * shrink -- if true, the domain is shrunk to fit the masked region * full_domain -- if true, RMASK is specified on the full domain hor. grid * (By default, RMASK would be on the same horizontal * grid as the hyperslab data.) * regular_grid -- if true, RMASK is always on the regular full domain grid; * (otherwise RMASK is assumed to be on the same type of grid * as the data) * ignore_awt -- if true, do not modify area weights * nohistory -- if true, do not append history information to hyperslab * * Output: a single hyperlsab data structure of masked horizontal subdomain, * or an array of hyperslab structures, if SLAB was an array * * SEE ALSO: hget, hrestore, hsub, hplot, hop, hcat */ { func_name= "hmask"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HMASK takes a hyperslab data structure"; write," && returns a hyperslab data structure that corresponds"; write," a selected region, with all other points masked out."; write," E.g.,"; write," atlantic_t = hmask(global_t, rmask, region_list, hregion='atlantic')"; write," sets all SST values not in the Atlantic basin to missing values && so on,"; write," assuming the hyperslab GLOBAL_T contains 3-dimensional (XYZ),"; write," global temperature values, REGION_LIST contains a list of strings,"; write," numbered 1,2,3..., with 'atlantic' being one of them, &&"; write," RMASK is a 2-D array with the same resolution as the full horizontal"; write," temperature grid (!the subdomain grid), with containing integer"; write," values 0,1,2,3,... corresponding to the region list (zero values"; write," correspond to no region)."; write," If GLOBAL_T is actually an array of hyperslab, ATLANTIC_T"; write," would also be an array of hyperslabs."; write," If HREGION is an array of strings, the result would also be"; write," an array of hyperslabs, corresponding to the different regions."; write," Tips:"; write," 1. full_domain=1 allows the mask to be specified on a full domain grid,"; write," 2. regular_grid=1 allows the mask to be always specified on a regular full domain grid,"; write," rather than a staggered grid"; write," 3. A null value for REGION_LIST implies that RMASK contains a bitmask (0/1)"; write," 4. A null value || a null string value for HREGION selects the entire region"; write," 5. shrink=1 shrinks the domain to fit the masked region"; write," 6. ignore_awt=1 suppresses modification of area weights"; write," See also: hget, hplot, hop, hcat, hcopy"; write,""; write," Usage: hmask(slab, rmask, region_list, hregion='REGION', shrink=1, full_domain=1, regular_grid=1, ignore_awt=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if ( (numberof(slab) > 1) && (numberof(hregion) > 1) ) error, "SLAB && HREGION may not both be arrays"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (i=I0; i <= I0+numberof(slab)-1; i++) { tem_slab= NULL; tem_slab= hmask( slab(i), rmask, region_list, hregion=hregion, full_domain=full_domain, regular_grid=regular_grid, nohistory=nohistory ); hgrow, slab_array, tem_slab, i, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if ((!is_null(hregion)) && (!is_scalar(hregion))) { // Array of regions; handle recursively slab_array= NULL; nregion= numberof(hregion); for (i=I0; i <= nregion-I1; i++) { tem_slab= NULL; tem_slab= hmask( slab, rmask, region_list, hregion=hregion(i), full_domain=full_domain, regular_grid=regular_grid, nohistory=nohistory ); hgrow, slab_array, tem_slab, i, dimsof(hregion), destroy=1; } return timer_return(func_name, slab_array); } if (slab.type(HFMT.data) == "") error, "Error - null data values"; // History string his_str= "<" + slab.name + ">"; if (!is_null(hregion)) his_str= his_str + ",hregion=<" + hregion + ">"; if (typeof(rmask) == "struct_instance") { // Extract mask from slab if (!is_scalar(rmask)) error, "RMASK should be a scalar slab"; if (rmask.type(HFMT.data) == "") error, "RMASK slab has no data values available"; his_str= his_str + ",<" + rmask.name + ">"; // Copy mask values from slab maskval= *(rmask.data); if (!is_null(rmask.missing_value)) { // Set missing mask values to zero where_miss= where(maskval == *(rmask.missing_value)); if (is_where(where_miss)) maskval(where_miss)= 0.; } } else { // Mask array maskval= rmask; } if (is_null(region_list)) { // No region list specified; extract bit-mask for region bitmask= (maskval != 0); maskval= NULL; } else { // Region list specified // If null region name, simply return slab unchanged if (is_null(hregion)) return timer_return(func_name, slab); // If null-string region name, simply return slab unchanged if (hregion == "") return timer_return(func_name, slab); // Identify region iregion= strloc(region_list,hregion,case_fold=1,abbrev=1,comment="hregion"); // Extract bit-mask for region bitmask= (maskval == iregion); maskval= NULL; } // Mask dimensions mdims= dim_reshape(dimsof(bitmask), trim=1); nmaskdim= mdims(I0); // Check if area weights need to be modified mod_awt= (slab.type(HFMT.area_wt) != "") && (!param_set(ignore_awt)); // New area weights and dimensions area_wt1= deref(slab.area_wt); new_area_wt_dims= slab.dimension(,HFMT.area_wt); new_adims= hdimsof(slab, area_wt=1); // Dimension presence code is_present= slab.dimension(,HFMT.data); // X periodicity flag xperiodic= (hattr(slab, "x:period") != 0.) && \ (hattr(slab, "x:subdomain") == 0); full_mask= ( param_set(full_domain) || param_set(regular_grid) ); if ( full_mask ) { // Full domain (2D) mask // Reshape mask array to be 2-D mdim2= dim_reshape(mdims, mindim=2); if (mdim2(I0) > 2) error, "Mask array should be two-dimensional"; reshape_array, bitmask, mdim2; // Floating-point version of bitmask fmask= float(bitmask); // Check for presence of horizontal dimensions if ( (is_present(XDIM) <= 0) || \ (is_present(XDIM) != is_present(YDIM)) ) error, "X && Y dimensions should be present on the same grid for masking"; if (mod_awt && \ ((new_area_wt_dims(XDIM) <= 0) || (new_area_wt_dims(YDIM) <= 0))) error, "X && Y dimensions not present in area weights array"; // Current horizontal subdomain data dimensions nx= numberof(*(slab.x)); ny= numberof(*(slab.y)); // Current horizontal subdomain offsets if ((nattr("subdomain",slab,XDIM+I1) < 0) || \ (nattr("subdomain",slab,YDIM+I1) < 0)) error, "X && Y subdomains should be contiguous for full domain masking"; ix= nattr("subdomain",slab,XDIM+I1); if (ix == 0) ix= 1; iy= nattr("subdomain",slab,YDIM+I1); if (iy == 0) iy= 1; // Current rotation state x_rotated= hattr(slab, "x:rotated"); if ((is_present(XDIM) == 1) || param_set(regular_grid)) { // Mask array on regular grid if (is_null(slab.y0) || is_null(slab.y0)) error, "Full horizontal domain regular grid (X0,Y0) not found in slab"; x0= *(slab.x0); y0= *(slab.y0); nx0= numberof(x0); ny0= numberof(y0); if ( (mdim2(I0+1) != nx0) || (mdim2(I0+2) != ny0) ) error, "Mask array dimensions not compatible with full regular grid"; if ((ix+nx-1 > nx0) || (iy+ny-1 > ny0)) error, "Subdomain regular X/Y grid extends beyond full domain"; } if (is_present(XDIM) == 2) { // Data on interfacial grid if (is_null(slab.yint0) || is_null(slab.yint0)) error, "Full horizontal domain interfacial grid (XINT0,YINT0) not found in slab"; xint0= *(slab.xint0); yint0= *(slab.yint0); nxint0= numberof(xint0); nyint0= numberof(yint0); if ((ix+nx-1 > nxint0) || (iy+ny-1 > nyint0)) error, "Subdomain interfacial X/Y grid extends beyond full domain"; if (!param_set(regular_grid)) { // Mask array on interfacial grid if ( (mdim2(I0+1) != nxint0) || (mdim2(I0+2) != nyint0) ) error, "Mask array dimensions not compatible with full interfacial grid"; } else { // Translate mask from regular to interfacial grid fmask= nshiftmask(bitmask,nxint0,nyint0,xperiodic=xperiodic); bitmask= (fmask > 0.); } } if (x_rotated != 0) { // Apply rotation on full domain masks bitmask= rangeop(bitmask,"rot",1,count=-x_rotated); fmask= rangeop(fmask,"rot",1,count=-x_rotated); } // Reduce masks to subdomain bitmask= bitmask(ix-I1:ix+nx-1-I1, iy-I1:iy+ny-1-I1); fmask= fmask(ix-I1:ix+nx-1-I1, iy-I1:iy+ny-1-I1); mdims= dim_reshape(dimsof(bitmask), trim=1); } else { // Subdomain mask if (typeof(rmask) == "struct_instance") { // Mask extracted from slab; check conformance isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, slab, rmask, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; if (anyof(dim_conf <= 0)) error, "SLAB && RMASK dimensions are not conformable"; if (isuperset != 1) error, "RMASK has dimensions not present in SLAB"; mask_dims= rmask.dimension(,HFMT.data); ddims= hdimsof(rmask); mdim5= dim_reshape(mdims, mindim=SDIM); if (mod_awt) { // Broadcast area weights to conform to mask array extended= 0; for (m=I0; m <= SDIM-I1; m++) { if ((new_area_wt_dims(m) <= 0) && (mask_dims(m) > 0)) { // Introduce dimension extended= 1; new_area_wt_dims(m)= mask_dims(m); new_adims(1+m)= ddims(1+m); } } if (extended) { // Broadcast area weights area_wt1= broadcast( area_wt1, new_adims ); } } } // Floating-point version of bitmask fmask= float(bitmask); } // Copy slab new_slab= NULL; hcopy, slab, new_slab; if (param_set(shrink)) { // Prepare to shrink domain to fit masked region his_str= his_str + ",shrink=1"; for (m=I0; m <= nmaskdim-I1; m++) { if (mdims(1+m) > 1) { // Focus bitmask on dimension reshape_array, bitmask, dim_reshape( mdims, focus=m+I1 ); // Find max value along each masked dimension cwhere= where( arrayop( arrayop(bitmask, "max", 1), "max", 3) ); // Return bitmask to original shape reshape_array, bitmask, mdims; if (is_where(cwhere)) { // Check domain length isub0= cwhere(I0); isub1= cwhere(numberof(cwhere)-I1); newlen= isub1 - isub0 + 1; if (newlen < mdims(1+m)) { // Shrink domain mdims(1+m)= newlen; fmask= arrayop( fmask, [isub0, isub1], m+I1 ); bitmask= arrayop( bitmask, [isub0, isub1], m+I1 ); if (new_adims(1+m) > 1) { area_wt1= arrayop( area_wt1, [isub0, isub1], m+I1 ); new_adims(1+m)= newlen; } // Shrink slab domain if (m == XDIM) { new_slab= hsub(new_slab,limx=[I1+isub0,I1+isub1],subscript=1); } else if (m == YDIM) { new_slab= hsub(new_slab,limy=[I1+isub0,I1+isub1],subscript=1); } else if (m == ZDIM) { new_slab= hsub(new_slab,limz=[I1+isub0,I1+isub1],subscript=1); } else if (m == TDIM) { new_slab= hsub(new_slab,limt=[I1+isub0,I1+isub1],subscript=1); } else if (m == IDIM) { new_slab= hsub(new_slab,limi=[I1+isub0,I1+isub1],subscript=1); } } } } } } if (mod_awt) { // Mask area weights array using fractional mask if (!dim_conform(mdims, new_adims, trim=1, broadcast=1)) error, "Mask array dimensions not conformable with subdomain grid"; nmask, area_wt1, fmask, nmaskdim; } // Copy data data1= *(new_slab.data); if (typeof(data1) != "struct_instance") { // Mask data values if (!is_null(new_slab.missing_value)) { // Copy missing value attribute missing_value= *(new_slab.missing_value); } else { // No missing value attribute; generate new missing value missing_value= nmiss_value(data1); } // Apply mask on data nmask, data1, bitmask, nmaskdim, mark_zero=1, missing_value=missing_value; if (new_slab.type(HFMT.z_bot) != "") { // Apply mask on bottom Z values as well z_bot1= *(new_slab.z_bot); if (dim_conform(dimsof(bitmask), dimsof(z_bot1), trim=1, broadcast=1)) nmask, z_bot1, bitmask, nmaskdim, mark_zero=1, missing_value=missing_value; } else { z_bot1= NULL; } } else { z_bot1= NULL; } // Copy slab with masked fields, and new area weights hcopy, new_slab, new_slab, data=data1, missing_value=missing_value, area_wt1=area_wt1, area_wt_dims=new_area_wt_dims, z_bot1=z_bot1, overwrite=1; // Set horizontal subdomain name if (is_null(region_list)) { if (!is_null(hregion)) hset_attr, new_slab, ":hor_subdomain", hregion; } else { hset_attr, new_slab, ":hor_subdomain", region_list(iregion-I1); } if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab, "data:history") + " hmask(" + his_str + ",...);" } // Return masked hyperslab return timer_return(func_name, new_slab); } func hocnmask(slab,help=,maskcolor=, fill=,proj=,ppars=) /* DOCUMENT hocnmask,slab,help=help,maskcolor=maskcolor, * fill=fill,proj=proj,ppars=ppars * Superimpose land/depth mask corresponding to "hyperslab" data in SLAB * Input parameters: * slab -- ocean hyperslab data structure * (KEYWORD PARAMETERS) * help -- help option * maskcolor -- color index for land/depth masks * fill -- fill >= 1 implies filled contours * proj -- projection ("","NHPOLAR","SHPOLAR","MOLLWEIDE",...) * (NOTE: projection names may be abbreviated) * ppars -- projection parameters ([start_lon, extreme_lat]/...) * * SEE ALSO: hplot */ { func_name= "hocnmask"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; // Color plotting COMMON block //IDL2YORICK: #include "color_com.i" ; if (param_set(help)) { write,""; write," HOCNMASK overlays the land/depth mask corresponding to a hyperslab."; write," E.g.,"; write," slab= hget('T',z=0)"; write," hplot,slab,fill=1"; write," hocnmask,slab,fill=1"; write," superimposes land mask on a plot of SST."; write,""; write," See also: hplot"; write,""; write," Usage: hocnmask, slab, maskcolor=, fill=1, proj=..., ppars=..."; return timer_return(func_name); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (slab.structure != "HYPERSLAB1.0_SPH_SIG_OCN") error, "Hyperslab should be of type HYPERSLAB1.0_SPH_SIG_OCN"; // Determine X/Y dimensions is_present= slab.dimension(,HFMT.data); if ( (is_present(XDIM) <= 0) || (is_present(YDIM) <= 0) ) error, "X/Y dimensions not present in slab"; xint0= *(slab.xint0); yint0= *(slab.yint0); // Regular grid flag reg_grid= (is_present(XDIM) == 1) && (is_present(YDIM) == 1); // Interfacial grid land mask (full spatial domain) lmask= float( nshiftmask( (*(slab.kmax0) == 0), numberof(xint0), numberof(yint0) ) > 0); // Copy coordinates xc= xint0; yc= yint0; // Rotate X dimension, if necessary x_rotated= hattr(slab, "x:rotated"); if (x_rotated != 0) { lmask= rangeop(lmask,"rot",1,count=-x_rotated); xrotate, 360.0, xint0(I0+x_rotated) - xint0(I0), xc; } if (nattr("subdomain",slab,YDIM+I1) != 0) { // Restrict Y domain yindex= rangeloc( yint0, ndim_bounds(slab,YDIM+I1) ); if (numberof(yindex) != 2) error, "Error in Y subdomain"; lmask= lmask(,yindex(I0):yindex(I0+1)); yc= yc(yindex(I0):yindex(I0+1)); } if (nattr("subdomain",slab,XDIM+I1) != 0) { // Restrict X domain xindex= rangeloc( xint0, ndim_bounds(slab,XDIM+I1) ); if (numberof(xindex) != 2) error, "Error in X subdomain"; lmask= lmask(xindex(I0):xindex(I0+1),); xc= xc(xindex(I0):xindex(I0+1),); } // Overlay land mask contours flexp, lmask, xc, yc, levs=[1.0], overlay=1, overplot=1; } func hocnrho( t_slab, s_slab, help=, ref_depth=, pert=, nohistory=) /* DOCUMENT hocnrho(t_slab, s_slab, help=, ref_depth=, pert=0/1, * nohistory=0/1) * Computes density RHO of sea water, given the temperatures (T_SLAB, in degC) * and salinities (S_SLAB, in psu). The reference depth defaults to the actual * depth at each level, unless explicitly specified (in metres) using the * REF_DEPTH parameter. * PERT==1 causes the perturbation density, rather than the mean density * to be computed (w.r.t. the reference density profile). * SEE ALSO: hop */ { func_name= "hocnrho"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; //IDLbegin: //:common hocnrho_com, HOCNRHO_COEF; //IDLend: //YORICKbegin: extern HOCNRHO_COEF; //YORICKend: // Initialize density polynomial coefficients, if necessary if (is_null(HOCNRHO_COEF)) nocnrho; if (param_set(help)) { write,""; write," Function HOCNRHO computes the density of sea water, given T && S,"; write," E.g.,"; write," rho_slab = hocnrho(t_slab, s_slab, ref_depth=300)"; write," computes density using a reference depth of 300m."; write," Tips:"; write," 1. ref_depth= may be used to specify reference depth."; write," See also: hop"; write,""; write," Usage: hocnrho(t_slab, s_slab_b, ref_depth=)"; return timer_return(func_name, NULL); } if (is_null(t_slab) || is_null(s_slab)) error, "Null operand(s)"; if ( (typeof(t_slab) != "struct_instance") || \ (typeof(s_slab) != "struct_instance") ) error, "Operands not hyperslabs"; if ((!is_scalar(t_slab)) || (!is_scalar(s_slab))) error, "Operands should be scalar slabs"; //if ( (t_slab.structure != "HYPERSLAB1.0_SPH_SIG_OCN") or \ // (s_slab.structure != "HYPERSLAB1.0_SPH_SIG_OCN") ) // error, "Incorrect slab structure for operands" if ( (hattr(t_slab,"z:units") != "m") || \ (hattr(s_slab,"z:units") != "m") ) error, "Incorrect Z units for operands"; if ((t_slab.units != "degC") && (t_slab.units != "celsius")) error, "Unrecognized units for T_SLAB - " + t_slab.units; if (s_slab.units != "psu") error, "Unrecognized units for S_SLAB - " + s_slab.units; his_str= "<" + t_slab.name + ">,<" + s_slab.name + ">"; short_name= "rho"; long_name= "Potential density"; pert_flag= param_set(pert); if (pert_flag) { his_str= his_str + ",pert=1"; short_name= short_name + "p"; long_name= "Perturbation " + long_name; } // Ensure strong full conformance of hyperslab operands isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, t_slab, s_slab, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; if (anyof(dim_conf != 2)) error, "Nonconforming operand dimensions- " + strcombine( HFMT.coordnames(where(dim_conf != 2)), ","); if (!case_conf) error, "Operands do not have case conformance"; // Ensure that T >= -1.8C tem_slab= hop(t_slab, "max", -1.8); // T, S values data_t= *(tem_slab.data); data_s= *(s_slab.data); // Focus data arrays on Z dimension ddims= hdimsof(t_slab); ddimf= dim_reshape(ddims, focus=ZDIM+I1); nleft= ddimf(I0+1); nz= ddimf(I0+2); nright= ddimf(I0+3); reshape_array, data_t, ddimf; reshape_array, data_s, ddimf; // Missing values miss_t= deref(t_slab.missing_value); miss_s= deref(s_slab.missing_value); // Define values mask def_mask= array( char(1), ddimf ); if (!is_null(miss_t)) { // Missing T values iwhere= where(data_t == miss_t); if (is_where(iwhere)) def_mask(iwhere)= 0; } if (!is_null(miss_s)) { // Missing S values iwhere= where(data_s == miss_s); if (is_where(iwhere)) def_mask(iwhere)= 0; } if (!is_null(ref_depth)) { // Interpolate polynomial coefficients for reference depth his_str= his_str + ",ref_depth=" + strnum(ref_depth); short_name= short_name+ "_" + strnum(ref_depth); long_name= long_name+ " (z_ref=" + strnum(ref_depth) + "m)"; poly_slab= hinterp( HOCNRHO_COEF, "z", grid=[ref_depth], extrapolate=1 ); coef= *(poly_slab.data); reshape_array, coef, [1, 12]; } else { // Use local depth as reference zcoord= ngetcoord(t_slab,ZDIM+I1,slice=1); if (is_null(zcoord)) error, "Cannot determine reference depth from T_SLAB"; if ((hattr(t_slab,"z:long_name") != "depth") || \ (hattr(t_slab,"z:units") != "m")) error, "Z coordinate should correspond to depth in metres"; // Interpolate polynomial coefficients for each depth poly_slab= hinterp( HOCNRHO_COEF, "z", grid=zcoord, extrapolate=1 ); coef= *(poly_slab.data); reshape_array, coef, [2, nz, 12]; } // Output array rdat= array(double(0.), ddimf); // Loop over Z and right dimensions tq= array(double,nleft); sq= array(double,nleft); rq= array(double,nleft); cf= array(double,12); for (iz=I0; iz <= nz-I1; iz++) { if (!is_null(ref_depth)) cf(*)= coef ; else cf(*)= coef(iz,); for (iright=I0; iright <= nright-I1; iright++) { zr_mask= def_mask(,iz,iright); if (allof(zr_mask)) { // No missing values in data tq(*)= data_t(,iz,iright); sq(*)= data_s(,iz,iright); // Convert salinity to model units // (mass mixing ratio, departure from 0.035) sq(*)= (sq(*) - 35.)/1000.; // Normalize temperature and salinity by subtracting reference values tq(*)= tq(*) - cf(10-I1); sq(*)= sq(*) - cf(11-I1); // Compute normalized density rq(*)= (cf(1-I1) + (cf(4-I1) + cf(7-I1)*sq(*))*sq(*) + (cf(3-I1) + cf(8-I1)*sq(*) + cf(6-I1)*tq(*))*tq(*))*tq(*) + (cf(2-I1) + (cf(5-I1) + cf(9-I1)*sq(*))*sq(*))*sq(*); // Unnormalize density by adding reference value (g/cm^3), if necessary if (!pert_flag) rq(*)= rq(*) + cf(12-I1); // Convert to sigma units (kg/m^3) rq(*)= rq(*)*1000.; } else { // Missing values in data df= where(zr_mask); if (is_where(df)) { // Copy only defined values tq(df)= data_t(df,iz,iright); sq(df)= data_s(df,iz,iright); // Convert salinity to model units // (mass mixing ratio, departure from 0.035) sq(df)= (sq(df) - 35.)/1000.; // Normalize temperature and salinity by subtracting reference values tq(df)= tq(df) - cf(10-I1); sq(df)= sq(df) - cf(11-I1); // Compute normalized density rq(df)= (cf(1-I1) + (cf(4-I1) + cf(7-I1)*sq(df))*sq(df) + (cf(3-I1) + cf(8-I1)*sq(df) + cf(6-I1)*tq(df))*tq(df))*tq(df) + (cf(2-I1) + (cf(5-I1) + cf(9-I1)*sq(df))*sq(df))*sq(df); // Unnormalize density by adding reference value (g/cm^3),if necessary if (!pert_flag) rq(df)= rq(df) + cf(12-I1); // Convert to sigma units (kg/m^3) rq(df)= rq(df)*1000.; } // Insert missing values rq(where(zr_mask == 0))= miss_t; } // Copy density rdat(,iz,iright)= rq(*); } } // Reshape out data array reshape_array, rdat, ddims; // Create rho slab rho_slab= NULL; hcopy, t_slab, rho_slab, data=rdat, missing_value=miss_t; rho_slab.name= short_name; rho_slab.long_name= long_name; rho_slab.units= "kg/m^3"; if (!param_set(nohistory)) { // Append history info to slab hset_attr, rho_slab, "data:history", hattr(rho_slab,"data:history") + " hocnrho( " + his_str + ");" } // Return output slab return timer_return(func_name, rho_slab); } func hocndrho( t_slab, s_slab, nohistory=) /* DOCUMENT hocndrho(t_slab, s_slab, nohistory=0/1) * Returns the partial derivatives of density w.r.t. T and S, * dRHO/dT (kg/m3K) and dRHO/dS (kg/m3psu) of sea water, * given the temperatures (T_SLAB, in degC) and salinities (S_SLAB, in psu). * (RHO denotes the local potential density.) * SEE ALSO: hocnrho */ { func_name= "hocndrho"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; //IDLbegin: //:common hocnrho_com, HOCNRHO_COEF; //IDLend: //YORICKbegin: extern HOCNRHO_COEF; //YORICKend: // Initialize density polynomial coefficients, if necessary if (is_null(HOCNRHO_COEF)) nocnrho; if (is_null(t_slab) || is_null(s_slab)) error, "Null operand(s)"; if ( (typeof(t_slab) != "struct_instance") || \ (typeof(s_slab) != "struct_instance") ) error, "Operands not hyperslabs"; if ((!is_scalar(t_slab)) || (!is_scalar(s_slab))) error, "Operands should be scalar slabs"; //if ( (t_slab.structure != "HYPERSLAB1.0_SPH_SIG_OCN") or \ // (s_slab.structure != "HYPERSLAB1.0_SPH_SIG_OCN") ) // error, "Incorrect slab structure for operands" if ( (hattr(t_slab,"z:units") != "m") || \ (hattr(s_slab,"z:units") != "m") ) error, "Incorrect Z units for operands"; if ((t_slab.units != "degC") && (t_slab.units != "celsius")) error, "Unrecognized units for T_SLAB - " + t_slab.units; if (s_slab.units != "psu") error, "Unrecognized units for S_SLAB - " + s_slab.units; his_str= "<" + t_slab.name + ">,<" + s_slab.name + ">"; // Ensure strong full conformance of hyperslab operands isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, t_slab, s_slab, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; if (anyof(dim_conf != 2)) error, "Nonconforming operand dimensions- " + strcombine( HFMT.coordnames(where(dim_conf != 2)), ","); if (!case_conf) error, "Operands do not have case conformance"; // Mask out regions with T <= -1.8C tmask_slab= hmask( hver_wt(t_slab), hop(t_slab,">",-1.8) ); // T, S values data_t= *(tmask_slab.data); data_s= *(s_slab.data); // Focus data arrays on Z dimension ddims= hdimsof(tmask_slab); ddimf= dim_reshape(ddims, focus=ZDIM+I1); nleft= ddimf(I0+1); nz= ddimf(I0+2); nright= ddimf(I0+3); reshape_array, data_t, ddimf; reshape_array, data_s, ddimf; // Missing values miss_t= deref(tmask_slab.missing_value); miss_s= deref(s_slab.missing_value); // Define values mask def_mask= array( char(1), ddimf ); if (!is_null(miss_t)) { // Missing T values iwhere= where(data_t == miss_t); if (is_where(iwhere)) def_mask(iwhere)= 0; } if (!is_null(miss_s)) { // Missing S values iwhere= where(data_s == miss_s); if (is_where(iwhere)) def_mask(iwhere)= 0; } // Use local depth as reference zcoord= ngetcoord(tmask_slab,ZDIM+I1,slice=1); if (is_null(zcoord)) error, "Cannot determine reference depth from T_SLAB"; if ((hattr(tmask_slab,"z:long_name") != "depth") || \ (hattr(tmask_slab,"z:units") != "m")) error, "Z coordinate should correspond to depth in metres"; // Interpolate polynomial coefficients for each depth poly_slab= hinterp( HOCNRHO_COEF, "z", grid=zcoord, extrapolate=1 ); coef= *(poly_slab.data); reshape_array, coef, [2, nz, 12]; // Output array adat= array(double(0.), ddimf); bdat= array(double(0.), ddimf); // Loop over Z and right dimensions tq= array(double,nleft); sq= array(double,nleft); aq= array(double,nleft); bq= array(double,nleft); cf= array(double,12); for (iz=I0; iz <= nz-I1; iz++) { cf(*)= coef(iz,); for (iright=I0; iright <= nright-I1; iright++) { zr_mask= def_mask(,iz,iright); if (allof(zr_mask)) { // No missing values in data tq(*)= data_t(,iz,iright); sq(*)= data_s(,iz,iright); // Convert salinity to model units // (mass mixing ratio, departure from 0.035) sq(*)= (sq(*) - 35.)/1000.; // Normalize temperature and salinity by subtracting reference values tq(*)= tq(*) - cf(10-I1); sq(*)= sq(*) - cf(11-I1); // Compute density derivatives aq(*)= cf(1-I1) + (cf(4-I1) + cf(7-I1)*sq(*))*sq(*) + (2.*cf(3-I1) + 2.*cf(8-I1)*sq(*) + 3.*cf(6-I1)*tq(*))*tq(*); bq(*)= ( cf(4-I1) + 2.*cf(7-I1)*sq(*) + cf(8-I1)*tq(*))*tq(*) + cf(2-I1) + (2.*cf(5-I1) + 3.*cf(9-I1)*sq(*))*sq(*); // Convert to sigma units (kg/m^3) aq(*)= aq(*)*1000.; bq(*)= bq(*)*1000.; // Convert dRHO/dS from kg/m^3 to kg/m^3psu bq(*)= bq(*)/1000.; } else { // Missing values in data df= where(zr_mask); if (is_where(df)) { // Copy only defined values tq(df)= data_t(df,iz,iright); sq(df)= data_s(df,iz,iright); // Convert salinity to model units // (mass mixing ratio, departure from 0.035) sq(df)= (sq(df) - 35.)/1000.; // Normalize temperature and salinity by subtracting reference values tq(df)= tq(df) - cf(10-I1); sq(df)= sq(df) - cf(11-I1); // Compute density derivatives aq(df)= cf(1-I1) + (cf(4-I1) + cf(7-I1)*sq(df))*sq(df) + (2.*cf(3-I1) + 2.*cf(8-I1)*sq(df) + 3.*cf(6-I1)*tq(df))*tq(df); bq(df)= ( cf(4-I1) + 2.*cf(7-I1)*sq(df) + cf(8-I1)*tq(df))*tq(df) + cf(2-I1) + (2.*cf(5-I1) + 3.*cf(9-I1)*sq(df))*sq(df); // Convert to sigma units (kg/m^3) aq(df)= aq(df)*1000.; bq(df)= bq(df)*1000.; // Convert dRHO/dS from kg/m^3 to kg/m^3psu bq(df)= bq(df)/1000.; } // Insert missing values aq(where(zr_mask == 0))= miss_t; bq(where(zr_mask == 0))= miss_t; } // Copy density adat(,iz,iright)= aq(*); bdat(,iz,iright)= bq(*); } } // Reshape output data arrays reshape_array, adat, ddims; reshape_array, bdat, ddims; // Create output slab out_slab= NULL; tem_slab= NULL; hcopy, tmask_slab, tem_slab, data=adat, missing_value=miss_t; hgrow, out_slab, tem_slab, I0, 2; tem_slab= NULL; hcopy, tmask_slab, tem_slab, data=bdat, missing_value=miss_t; hgrow, out_slab, tem_slab, I0+1, 2; out_slab.name= ["dRHO/dT", "dRHO/dS"]; out_slab.long_name= ["d(density)/d(temperature)", "d(density)/d(salinity)"]; out_slab.units= ["kg/m^3K", "kg/m^3psu"]; if (!param_set(nohistory)) { // Append history info to slab hset_attr, out_slab, "data:history", hattr(out_slab,"data:history") + " hocndrho( " + his_str + ");" } // Return output slab return timer_return(func_name, out_slab); } func hop( slab_a, op, slab_b, help=, name=, units=, weak=, nocheck=, nobroadcast=, nohistory=) /* DOCUMENT hop(slab_a, op, slab_b, help=, name=, units=, weak=0/1, * nocheck=0/1, nobroadcast=0/1, nohistory=0/1) * Carries out unary/binary operations on hyperslabs. * Either of the operands may be an array of hyperslabs. If both operands * are hyperslab arrays, they should have the same dimensions. * Either of the operands may be a scalar or a broadcast-conformable * array of numbers, but not both. * * Input parameters: * slab_a -- left operand hyperslab * op -- binary operation string * (+,-,*,/,^,==,!=,<,>,<=,>=,&&,||,min,max,atan) * slab_b -- right operand hyperslab * (HOP may also be invoked with just two parameters, in which case * the first parameter is assumed to be one of the following unary opeartors, * -, !, abs, real, imaginary, sign, sqrt, floor, ceil, conj, * sin, cos, tan, asin, acos, atan, exp, log, log10, * or one of the following associative binary operators, * +,*,&&,||,min,max) * (KEYWORD PARAMETERS) * help -- help option * name -- name of the resulting data variable (overrides the default) * units -- units of the resulting data variable (overrides the default) * [units should be specified for linear operations (+/-) * between data with different units] * weak -- if set, require only "weak conformance" of operand * dimensions (i.e., only dimension lengths need match; * coordinate values/attributes need not match) * nocheck -- if set, dimension conformance checking is turned off * (but dimension lengths must be the same for both operands) * nobroadcast -- if set, do not allow dimensions to be broadcast * nohistory -- if true, do not append history information to hyperslab * * Output: hyperslab result of the binary operation, with properties * inherited from the highest-dimensional slab, if any, or from the * first operand if all slabs are of the same dimensionality * * SEE ALSO: hcopy, hplot, hmask, hcoord, hconform, hdiff */ { func_name= "hop"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HOP carries out unary/binary operations on hyperslabs."; write," E.g.,"; write," sum_slab = hop(slab_a,'+',slab_b)"; write," returns the sum of the data values in the two slabs."; write," centigrade_slab = hop(kelvin_slab,'-',273.16,units='C')"; write," converts temperature from kelvin to Centigrade."; write," neg_slab = hop('-',slab_a)"; write," returns negative of values in slab_a."; write," sine_slab = hop('sin',slab_a)"; write," returns sine of angles in slab_a."; write," prod_slab = hop('*',slab_a)"; write," returns the product of all elements in the hyperslab array slab_a."; write," Tips:"; write," 1. For unary operations, OP may be one of the following:"; write," -, !, abs, real, imaginary, sign, sqrt, floor, ceil, conj,"; write," sin, cos, tan, asin, acos, atan, exp, log, log10"; write," 2. For binary operations, OP may be one of the following:"; write," +,-,,/,^,==,!=,<,>,<=,>=,&&,||,min,max,atan"; write," 3. Comparison/logical operation returns 0.0 (false) || 1.0 (true)"; write," 4. Logical operations assume zero values are false,"; write," && non-zero values are true."; write," 5. SLAB_A && SLAB_B may be hyperslab arrays of identical dimensions,"; write," in which case the binary operation is carried between the"; write," corresponding array elements."; write," 6. Even for binary operations, SLAB_A may be omitted, in which case "; write," SLAB_B should be an array of hyperslabs, && OP should be an"; write," associative operator (+,,&&,||,min,max). In this case,"; write," the operation is carried between all the array elements,"; write," resulting in a single hyperslab."; write," 7. One of the parameters SLAB_A || SLAB_B may be specified to be"; write," a number (|| an array of numbers), but not both"; write," 8. name=... specifies the variable name for the result hyperslab."; write," 9. units=... specifies the data units for the result hyperslab."; write," 10. weak=1 option allows operations between weakly-conformant operands."; write," 11. nocheck=1 option turns off conformance checking (for operands with same dimensionality)."; write," 12. nobroadcast=1 option suppresses broadcasting of dimensions."; write," See also: hcopy, hplot, hmask, hcoord, hconform"; write,""; write," Usage: hop(slab_a, op, slab_b, name='name', units='units', weak=1, nobroadcast=1)"; return timer_return(func_name, NULL); } if (typeof(slab_a) == "string") { // Unary/associative binary operator if (!is_null(slab_b)) error, "SLAB_A may not be a string"; associative= (slab_a == "+") || (slab_a == "*") || (slab_a == "&&") || \ (slab_a == "||") || (slab_a == "min") || (slab_a == "max"); if (!associative) { // Unary operation return timer_return(func_name, nunop( slab_a, op, name=name, units=units, nohistory=nohistory)); } else { // Associative operator; handle recursively assop= slab_a; // If single operand, simply return it if (numberof(op) == 1) return timer_return(func_name, op); slab_c= hop(op(I0), assop, op(I0+1), name=name, units=units, weak=weak, nocheck=nocheck, nobroadcast=nobroadcast, nohistory=1); for (j=I0+2; j <= I0+numberof(op)-1; j++) { slab_c= hop(slab_c, assop, op(j), name=name, units=units, weak=weak, nocheck=nocheck, nobroadcast=nobroadcast, nohistory=1); } if (!param_set(nohistory)) { // Append history info to slab hset_attr, slab_c, "data:history", hattr(slab_c,"data:history") + "hop:" + strcombine(op.name,assop) + ";" } return timer_return(func_name, slab_c); } } if (typeof(op) != "string") error, "Binary operator should be a string"; if (is_null(slab_a) || is_null(slab_b)) error, "Null operand(s)"; if ( (typeof(slab_a) != "struct_instance") && \ (typeof(slab_b) != "struct_instance") ) error, "At least one operand should be a hyperslab"; if ( (typeof(slab_a) == "struct_instance") && \ (!is_scalar(slab_a)) ) { // Left operand is a slab array; handle recursively if ( (typeof(slab_b) == "struct_instance") && \ (!is_scalar(slab_b)) ) { // Right operand is also a slab array if (!dim_conform(dimsof(slab_a), dimsof(slab_b), trim=1)) error, "Non-conformable slab arrays for binary operation"; if ((!is_null(name)) && \ (numberof(name) != numberof(slab_a))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(slab_a)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hop(slab_a(j), op, slab_b(j), name=name1, units=units, weak=weak, nocheck=nocheck, nobroadcast=nobroadcast, nohistory=nohistory); hgrow, slab_array, tem_slab, j, dimsof(slab_a), destroy=1; } return timer_return(func_name, slab_array); } else { // Right operand not a slab array if ((!is_null(name)) && \ (numberof(name) != numberof(slab_a))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(slab_a)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hop(slab_a(j), op, slab_b, name=name1, units=units, weak=weak, nocheck=nocheck, nobroadcast=nobroadcast, nohistory=nohistory); hgrow, slab_array, tem_slab, j, dimsof(slab_a), destroy=1; } return timer_return(func_name, slab_array); } } if ( (typeof(slab_b) == "struct_instance") && \ (!is_scalar(slab_b)) ) { // Right operand is a slab array; handle recursively if ((!is_null(name)) && \ (numberof(name) != numberof(slab_b))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(slab_b)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hop(slab_a, op, slab_b(j), name=name1, units=units, weak=weak, nocheck=nocheck, nobroadcast=nobroadcast, nohistory=nohistory); hgrow, slab_array, tem_slab, j, dimsof(slab_b), destroy=1; } return timer_return(func_name, slab_array); } linear_op= (op == "+") || (op == "-"); compare_op= (op == "==") || (op == "!=") || (op == "<") || (op == ">") || \ (op == "<=") || (op == ">="); logical_op= (op == "&&") || (op == "||"); // Name and units options name1= NULL; if (!is_null(name)) name1= name; units1= NULL; if (!is_null(units)) units1= units; if ( (typeof(slab_a) == "struct_instance") && \ (typeof(slab_b) == "struct_instance") ) { mprefix= slab_a.name + op + slab_b.name + ": "; if (param_set(nocheck)) { // No dimension conformance checking if (!array_eq(hdimsof(slab_a),hdimsof(slab_b))) error, "Slab dimensions should be identical for nocheck=1"; // Inherit properties of left operand isuperset= 1; // Units conformance unit_conf= (slab_a.units == slab_b.units); } else { // Check conformance of hyperslab operands isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, slab_a(I0), slab_b(I0), isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; if (anyof(dim_conf == 0)) error, mprefix+"Nonconformable operand dimensions- " + strcombine( HFMT.coordnames(where(dim_conf == 0)), ","); if ( (!param_set(weak)) && anyof(dim_conf < 0) ) error, mprefix+"Specify weak=1 to conform following dimensions- " + strcombine( HFMT.coordnames(where(dim_conf < 0)), ","); if ( param_set(nobroadcast) && anyof(abs(dim_conf) < 2) ) error, mprefix+"Broadcasting required to conform following dimensions- " + strcombine( HFMT.coordnames(where(abs(dim_conf) < 2)), ","); if (isuperset == 0) error, mprefix+"No slab has superset of dimensions; use HSPROUT, if necessary" } // Create default name/unit strings if (linear_op) { // Linear operation if ( is_null(units) && (!unit_conf) ) error, mprefix+"Units option must be specified for linear operation"; // Change name only if different if (is_null(name1) && (slab_a.name != slab_b.name)) name1= slab_a.name + op + slab_b.name; } else { // Not a linear operation; default names and units if (op == "atan") { // Binary arctan operation if ( is_null(units) && (!unit_conf) ) error, mprefix+"Units option must be specified for atan operation"; if (is_null(units1)) units1= ""; if (is_null(name1)) { name1= slab_a.name + op + slab_b.name; if (slab_a.name == slab_b.name) name1= slab_a.name + "phase"; } } else { if (is_null(name1)) name1= slab_a.name + op + slab_b.name; if (is_null(units1)) { if ((op == "/") && unit_conf) { // Same units division => dimensionless result units1= ""; } else { // Other cases if (op == "*") op2= " " ; else op2= op; if (slab_a.units != "") { units1= slab_a.units; if (slab_b.units != "") units1= units1 + op2 + slab_b.units; } else { units1= slab_b.units; } } } } } // Create output data array, and copy missing value from superset slab miss_a= deref(slab_a.missing_value); miss_b= deref(slab_b.missing_value); if (isuperset == 1) { data_c= *(slab_a.data); miss_c= miss_a; // Carry out binary operation nbinop, op, *(slab_a.data), miss_a, broadcast(*(slab_b.data), dimsof(data_c)), miss_b, data_c, miss_c; his_str= "<"+slab_a.name+">"+op+"<"+hlegend(slab_b,notime=1)+">"; } else { data_c= *(slab_b.data); miss_c= miss_b; // Carry out binary operation nbinop, op, broadcast(*(slab_a.data), dimsof(data_c)), miss_a, *(slab_b.data), miss_b, data_c, miss_c; his_str= "<"+hlegend(slab_a,notime=1)+">"+op+"<"+slab_b.name+">"; } } else { if (typeof(slab_a) == "struct_instance") { // Numeric right operand mprefix= slab_a.name + op + "...: "; if ((!is_number(slab_b)) && (typeof(slab_b) != "complex")) error, mprefix+"Expected numeric right operand"; isuperset= 1; miss_a= deref(slab_a.missing_value); data_c= *(slab_a.data); miss_c= miss_a; if (!dim_conform(dimsof(slab_b), dimsof(data_c), trim=1, broadcast=1)) error, "Right operand not broadcast conformable with left operand"; // Carry out binary operation nbinop, op, *(slab_a.data), miss_a, broadcast(slab_b,dimsof(data_c)), NULL, data_c, miss_c; if (op == "^") { if (is_null(name1)) name1= slab_a.name + op + strnum(slab_b(I0)); if (is_null(units1) && (slab_a.units != "")) units1= "(" + slab_a.units + ")^" + strnum(slab_b(I0)); } // Create history string if (numberof(slab_b) == 1) { his_str= slab_a.name + op + strnum(slab_b(I0)); } else { his_str= slab_a.name + op + ".."; } } else { // Numeric left operand mprefix= "..." + op + slab_b.name + ": "; if ((!is_number(slab_a)) && (typeof(slab_a) != "complex")) error, mprefix+"Expected numeric left operand"; isuperset= 2; miss_b= deref(slab_b.missing_value); data_c= *(slab_b.data); miss_c= miss_b; if (!dim_conform(dimsof(slab_a), dimsof(data_c), trim=1, broadcast=1)) error, "Left operand not broadcast conformable with right operand"; // Carry out binary operation nbinop, op, broadcast(slab_a,dimsof(data_c)), NULL, *(slab_b.data), miss_b, data_c, miss_c; // Create history string if (numberof(slab_a) == 1) { his_str= strnum(slab_a(I0)) + op + slab_b.name; } else { his_str= ".." + op + slab_b.name; } } } // Determine default name for output slab variable name, units // Create output slab if (isuperset == 1) { hcopy,slab_a,slab_c,data=data_c,missing_value=miss_c; } else { hcopy,slab_b,slab_c,data=data_c,missing_value=miss_c; } // Set name/units attributes if (!is_null(name1)) { slab_c.name= name1; } if (!is_null(units)) { // Specified units slab_c.units= units1; } else { if (compare_op || logical_op) { // Logical result; no units slab_c.units= ""; } else { if (!is_null(units1)) slab_c.units= units1; } } if (!param_set(nohistory)) { // Append history info to slab hset_attr, slab_c, "data:history", hattr(slab_c,"data:history") + " hop: " + his_str + ";" } // Return output slab return timer_return(func_name, slab_c); } func hopen(filename, &fstruc,&fhandle,&time0,&date0,&vars, //YORICKoutput: help=,alt=,append=,scratch=,newtime=, toffset=,case_name=,z_bot_ref=, command=,silent=) /* DOCUMENT hopen,filename,fstruc,fhandle,time0,date0,vars, * help=0/1,alt=0/1,append=0/1,scratch=0/1,newtime=, * toffset=,case_name=,z_bot_ref=, * command=,silent=0/1 * * Open a netCDF history file FILENAME for reading hyperslabs * * Input parameters: * filename -- new netCDF filename to be opened * (In Yorick, FILENAME may be a list of filenames, * representing a file family.) * Optional output parameters: * fstruc -- history file data structure (required if alt=1) * fhandle -- history file data handle * time0 -- time coordinate values in file (NULL, if none) * date0 -- date values in file (NULL, if none) * vars -- names of variables present in file * (KEYWORD PARAMETERS) * help -- help option * alt -- if true, open alternate history file (!the default) * append -- if true, open hyperslab file for appending time records * scratch -- if true, delete file after it has been closed * newtime -- new time units string * If NEWTIME is specified, new time value are generated * using the record number (starting from 0), with time units * set to NEWTIME. (For the special case NEWTIME=="date", the * time values are replaced by the date values.) * toffset -- time offset; if non-zero, it is added to the time values * case_name -- if specified, overrides the case name read from the file * z_bot_ref -- if specified, overrides the reference Z_BOT read from the file * command -- execute specified string as operating system command * prior to opening the file(s), with any % characters * substituted with the file name header (i.e., excluding any * suffix, and leading pathnames). * silent -- silent mode * SEE ALSO: hclose, hget, hsave, happend, hdiff, nget_handle */ { func_name= "hopen"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Procedure HOPEN opens a netCDF history file for reading hyperslab data."; write," E.g.,"; write," hopen,'ocn.nc' "; write," opens the ocean netCDF file 'ocn.nc' as the default history file."; write," hopen,'ocn2.nc',fstruc2,fhandle2,alt=1"; write," opens the ocean netCDF file 'ocn2.nc' as an alternate history file,"; write," which may be accessed using the returned structure FSTRUC2 && file handle FHANDLE2"; write," Tips:"; write," 1. alt=1 option opens alternate history file"; write," 2. append=1 option opens hyperslab file for appending time records"; write," 3. scratch=1 option deletes file after it is closed"; write," 4. newtime='time_units'/'date' option generates new time values from record number/date."; write," 5. toffset=time_offset adds offset to time values"; write," 6. case_name='new_case_name' changes the case name"; write," 7. command='filter /tmp/%.his %.nc' applies operating system command,"; write," with occurrences of % substituted by file name header."; write," 8. Optional output parameter FHANDLE returns the file handle"; write,""; write," See also: hclose, hget, hsave, happend"; write,""; write," Usage: hopen,'netCDF_filename'[,fstruc,fhandle,time0,date0,vars],alt=1,append=1,scratch=1,newtime='time_units'/'date',toffset=..,case_name=..,command='..'"; return timer_return(func_name); } nfiles= numberof(filename); if (nfiles > 1) { //IDL2YORICK: error, "Cannot open multiple files in IDL" ; } // Execute operating system command, if specified if (!is_null(command)) oscommand, command, filename=filename; // Combine all file names allfiles= strcombine(filename,","); // Open netCDF file for reading fmeta= NULL; nc_openf, filename, fhandle, fmeta, update=param_set(append); // Determine type of history file, and call appropriate opening routine if (is_null(nc_getattr(fmeta,"","hyperslab_vars")) == 0) { fdesc= "hyperslab netCDF file"; nhyperfile, allfiles, fmeta, fhandle, fstruc, case_name=case_name; } else if (nc_vartype(fmeta, "kmt") != "") { fdesc= "oceanic netCDF history file"; nocnfile, allfiles, fmeta, fhandle, fstruc, case_name=case_name; } else if (nc_vartype(fmeta, "ntrn") != "") { fdesc= "atmospheric netCDF history file"; natmfile, allfiles, fmeta, fhandle, fstruc, case_name=case_name, z_bot_ref=z_bot_ref; } else if (nc_vartype(fmeta, "gw") != "") { fdesc= "atmospheric netCDF history file (PJR version)"; natmfilepjr, allfiles, fmeta, fhandle, fstruc, case_name=case_name, z_bot_ref=z_bot_ref; } else if (is_null(nc_getattr(fmeta,"","data_levels")) == 0) { fdesc= "IDEAL netCDF history file"; natmfile2, allfiles, fmeta, fhandle, fstruc, case_name=case_name; } else if (is_null(nc_getattr(fmeta,"","file_type")) == 0) { fdesc= "SCCM netCDF history file"; nsccmfile, allfiles, fmeta, fhandle, fstruc, case_name=case_name; } else { error, "Unknown type of netCDF history file '" + allfiles + "'"; } if ((fstruc.structure != "HYPERFILE") && param_set(append)) error, "Cannot append to non-hyperslab file"; if (param_set(newtime) && (!is_null(fstruc.time0))) { // Generate new time values template= *(fstruc.template); hset_attr, template, "time:units", newtime; fstruc.template= &(template); if (newtime == "date") { // Replace time values by date values if (is_null(fstruc.date0)) error, "Date values not defined"; fstruc.time0= &(*(fstruc.date0)); } else { // New time values nrec= numberof(*(fstruc.time0)); fstruc.time0= &( double(indgen(nrec)-I0) ); } } // Add time offset if specified if (param_set(toffset)&& (!is_null(fstruc.time0))) fstruc.time0= &( double(toffset+*(fstruc.time0)) ); // Copy time/date/variable-list for output time0= deref(fstruc.time0); date0= deref(fstruc.date0); if (fstruc.vars == "") vars= NULL ; else vars= strsplit(fstruc.vars,","); if (numberof(time0) > 1) { // Check monotonicity of time coordinate if (monotonic(time0) == 0) write, "***WARNING*** Time coordinate values not monotonic"; } // Add file handle to external list, and set file number //IDLbegin: //:grow, FILE_HANDLE_LIST, fhandle; //:fstruc.fnumber= numberof(FILE_HANDLE_LIST); //IDLend: //YORICKbegin: if (is_void(FILE_HANDLE_LIST)) FILE_HANDLE_LIST= _lst(fhandle) else _cat, FILE_HANDLE_LIST, fhandle fstruc.fnumber= _len(FILE_HANDLE_LIST) //YORICKend: // Set scratch file flag fstruc.scratch= param_set(scratch); if (!param_set(alt)) { // Change default history file if (!is_null(DEFAULT_FILE_STRUC)) { // Close any previously opened default history file hclose, silent=silent; } // New default history file DEFAULT_FILE_STRUC= fstruc; } if (!param_set(silent)) { write, "Opening "+fdesc+": "+allfiles; if (fstruc.structure != "HYPERFILE") { // History file write, ""; write, " file_type, conventions =", fstruc.ftype+", "+ fstruc.fconventions; write, " data_source =", hattr(*(fstruc.template),":data_source"); write, " case_name =", hattr(*(fstruc.template),":case_name"); write, " case_title =", hattr(*(fstruc.template),":case_title"); } if (fstruc.vars != "") write, "Variable(s): " + fstruc.vars; } return timer_return(func_name); } func hplot(slab,help=,modifier=, title=,subtitle=,xlim=,ylim=, fill=,overlay=,levs=, type=,c_labels=,width=, line_color=,label_color=,label_size=, low_color=,high_color=, demarc=,mix=,csys=,rev=,stack=, cbar=,cb_labels=, scalef=,units=,vformat=, miss_value=,miss_width=,miss_type=, miss_color=,pad=, rotx=,aspect=,proj=,ppars=,pole_fill=, position=,overplot=,nodata=, cont_width=,mask_color=,nomask=,terrain=, date=,transp=,printer=,zoom=, charsize=,charthick=,charfont=, xtitle=,xtickformat=,xtickv=,xtickname=, ytitle=,ytickformat=,ytickv=,ytickname=, xpars=,ypars=,apars=) /* DOCUMENT hplot,slab,... * Plots "hyperslab" data * Input parameters: * slab -- hyperslab data structure * (KEYWORD PARAMETERS) * help -- help option * modifier -- plot modifier string ("difference", ...) * title -- plot title * subtitle -- plot subtitle * ( The following parameters control the look of the 2-D plot; * X/Y denotes the plot coordinates, not the data coordinates ) * xlim -- X coordinate range [xmin, xmax] * ylim -- Y coordinate range [ymin, ymax] * (set x/ylim=0 for data-dependent X/Y ranges) * fill -- fill >= 1 implies filled contours * overlay -- if set, overlay color filled plots with contours * levs -- contour levels (non-numeric value => default levels) * (omitting levs forces variable-dependent contour level selection) * c_labels -- contour label flag array (re-used cyclically) * (set c_labels=[0] to suppress contour labelling) * width -- contour thickness * type -- contour linestyle * line_color -- color for contour lines (default "black") * label_color-- color for contour labels (default "black") * label_size -- size for contour labels (default 1.0) * low_color -- color for below-range values * high_color -- color for above-range values * demarc -- list of demarcation values for color plots * mix -- list of colors corresponding to each demarcation value * (Exception: For single demarcation value, three colors must be specified) **TO BE* rev -- if true, the color scale is reversed **TO BE* stack -- if true, the color scale is stacked on top of previous one * csys -- color system for mixing (="RGB" or "HSV" or "HLS") * cbar -- color bar position = [x0, y0, x1, y1] * cb_labels -- color bar labels array (flags, similar to c_label) * scalef -- scale factor for data (default 1) * (if scalef < 0, it is not displayed, and its absolute value is used) * units -- units string * vformat -- vformat for printing out values * miss_value -- maximum valid data value (default none) * miss_width -- line width for demarcating undefined values * miss_type -- line type for demarcating undefined values * miss_color -- color for missing values * pad -- if PAD==1, extrapolate nearest neighbour data values * into missing regions; * if PAD==2, also interpolate to next nearest * neighbours; * if PAD==(a float/double value), replace nearest * neighbour missing values with PAD. * rotx -- if defined, rotate X-coordinate by angle ROTX * (NOTE: xlim, ylim are assumed to be post-rotation values) * aspect -- aspect ratio for mesh/projection plots (default 1) * proj -- projection ("","NHPOLAR","SHPOLAR","MOLLWEIDE",...) * (NOTE: projection names may be abbreviated) * ppars -- projection parameters ([start_lon, extreme_lat]/...) * pole_fill -- if set, fill in appropriate polar value * nested -- if true, shade contours in a nested fashion using * "trishade.c" routine MATCONT * (a bit slower, but reduces the number of shaded polygons) * triangulate-- if set, use "trishade.c" contouring routines, * instead of IDL's "contour" procedure * (1=>TRISHADE, 2=>MATCONT) **DISABLED TEMPORARILY** * position -- plot position (normalized) = [x0, y0, x1, y1] * nodata -- if set, only plot axes * overplot -- if set, superimpose on previous plot * cont_width -- line width for continental outlines * mask_color -- color index for land/depth masks * nomask -- if set, suppress land/depth mask and padding * terrain -- slab containing terrain elevation (in m) above * sea level to be used to draw continental outlines * (special case: if terrain==1, use 30-minute topographic * elevation values from TerrainBase dataset) * date -- if set, use date as time coordinate (if available) * transp -- if set, interchanges X/Y axes * printer -- if set, plot is printed * (printer=1 used default printer; printer="printer_name" specifies printer name) * zoom -- if set, zooms into portion of previous plot * charsize -- character size for axes etc. * charthick -- character thickness for axes etc. * charfont -- character font specification * xtitle -- X axis title string * xtickformat-- X axis tick format/procedure-name string * xtickv -- X axis tick values * xtickname -- X axis tick label strings * ytitle -- Y axis title string * ytickformat-- Y axis tick format/procedure-name string * ytickv -- Y axis tick values * ytickname -- Y axis tick label strings * xpars -- IDL parameters [XTICKS, XMINOR, XTYPE, XSTYLE] * defaults to [0, 0, 0, 1] * ypars -- IDL parameters [YTICKS, YMINOR, YTYPE, YSTYLE] * defaults to [0, 0, 0, 1] * apars -- IDL parameters [X/YTHICK, TICKLEN] * defaults to [!P.THICK, !P.TICKLEN] * * SEE ALSO: hlegend, hcont, hopen, hget, hsub */ { func_name= "hplot"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; // Color plotting COMMON block //IDL2YORICK: #include "color_com.i" ; //YORICKbegin: black2_color= 2 white2_color= 3 red_color= 4 green_color= 5 blue_color= 6 cyan_color= 7 magenta_color= 8 yellow_color= 9 lgrey_color= 10 dgrey_color= 11 //YORICKend: // Initialize color plotting COMMON block if necessary //IDL2YORICK: if (is_null(n_predef)) inicolors ; if (param_set(help)) { write,""; write," HPLOT plots the data contained in a hyperslab data structure."; write," E.g.,"; write,"hplot,hop(hget('T',hregion='atlantic',mask=1,x='avg'),'-',hget('T',hregion='pacific',mask=1,x='avg'))"; write," plots the difference in zonal-mean T for the Atlantic && the Pacific."; write," Tips:"; write," 1. HPLOT accepts many of the options used by the CONTOUR/PLOT routines in IDL "; write," (E.g., title, subtitle, xtitle, charsize, charthick,"; write," overplot, nodata, ...)"; write," 2. fill=1 produces a color-filled filled contour plot"; write," 3. cbar=1 produces default plot && color bar positioning (LANDSCAPE mode)"; write," 4. position=[x0, y0, x1, y1] positions the plot in normalized coords."; write," 5. cbar=[x0, y0, x1, y1] positions the color bar"; write," 6. levs=contour levels [c_level_1, c_level_2, ...]"; write," (non-numeric value for levs forces default level selection)"; write," (omitting levs forces variable-dependent contour level selection)"; write," 7. demarc=contour/shading demarcation values [value_1, ...]"; write," 8. mix=list of colors corresponding to each demarcation value"; write," (IDL=>black:2,white:3,red:4,green:5,blue:6,yellow:7,magenta:8,cyan:9,l/dgrey:10/11)"; write," 9. fill=2/3/4/5 specifies greyscale/rev_greyscale/HSV1/HSV2 color tables"; write," 10. csys='RGB' || 'HSV' || 'HLS' chooses a color mixing scheme"; write," 11. type=[line_stypes] controls contour line types"; write," 12. c_labels=0 suppresses contour labelling"; write," 13. width=0 suppresses contour overlay on color plots"; write," 14. charsize=1.5 increases character size"; write," 15. scalef=100 divides data by 100 before plotting"; write," 16. subtitle='' suppresses plot subtitle"; write," 17. width=3,line_color=4,type=2 produces thick red dashed line plots"; write," 18. overplot=1 allows overlays on line/contour plots"; write," 19. printer=1 (|| printer='printer_name') prints plot"; write," 20. aspec=aspect_ratio controls plot aspect ratio"; write," 21. proj='nhpolar'/'shpolar'/'mollweide' produces projections"; write," 22. zoom=1 zooms into portion of previous plot"; write," See also: hlegend, hcont, hopen, hget, hsub"; write,""; write," Usage: hplot, slab, title='Plot title', (x/y)lim=[min,max], ..."; return timer_return(func_name); } if (param_set(zoom)) { // Read zoom rectangle coordinates from screen write,""; write,"Please press mouse button TWICE on the plot to define zoom rectangle"; cursor, xzoom0, yzoom0, down=1; cursor, xzoom1, yzoom1, down=1; xzoom_lim= [ min([xzoom0,xzoom1]), max([xzoom0,xzoom1]) ]; yzoom_lim= [ min([yzoom0,yzoom1]), max([yzoom0,yzoom1]) ]; } if (param_set(printer)) { //IDLbegin: // Restore plot environment //: old_dev= !D.NAME; //: old_multi= !P.MULTI; // Set up PostScript environment //: set_plot,"PS"; //: device,landscape=1,xsize=8.0,ysize=5.5,xoffset=1.5,yoffset=9.5,inches=1; //: if (param_set(fill)) device,color=1; //IDLend: } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) error, "SLAB should be a scalar"; // Axis parameters xpars2= [0, 0, 0, 1]; ypars2= [0, 0, 0, 1]; if (!is_null(xpars)) xpars2(0:numberof(xpars)-1)= xpars(*); if (!is_null(ypars)) ypars2(0:numberof(ypars)-1)= ypars(*); // Copy slab data if (slab.type(HFMT.data) == "") error, "Error - null data values"; data1= *(slab.data); if (typeof(data1) == "struct_instance") error, "Actual data must be present in slab for plotting"; // Copy slab parameters is_present= slab.dimension(,HFMT.data); is_reduced= slab.reduced; // Variable name, dimension descriptor string varname= slab.name; dimenstr= hdimsof(slab,name=1); // Slab title, modifier stitle= hattr(slab,"data:legend"); if (!param_set(modifier)) modifier= hattr(slab,"data:history"); // Long name of variable, units, missing value long_name= slab.long_name; units2= slab.units; if (is_null(miss_value)) { if (is_null(slab.missing_value)) { miss_value= 1.0e32; } else { miss_value= *(slab.missing_value) //IDL2YORICK: miss_value=0.999**(slab.missing_value) ; // (NOTE: For compatibility with the IDL convention of max_value) } } // Count dimensions that are present data_dims= hdimsof(slab); ndim= 0; plot_dims= [0]; mdim= array(long,SDIM); for (i=I0; i <= SDIM-I1; i++) { if (is_present(i) > 0) { ndim= ndim + 1; if (data_dims(i+1) == 1) error, "Please slice out "+strtoupper(HFMT.coordnames(i))+ " dimension before plotting"; grow, plot_dims, data_dims(i+1); mdim(ndim-I1)= i+I1; } } plot_dims(I0)= ndim; // Field type string fieldstr= strtolower(dimenstr); // Default mask value (for continental outlines) mval= 1; // Shade grid boxes centered at missing values half_miss= 0; if (slab.structure == "HYPERSLAB1.0_SPH_SIG_OCN") { // Ocean data; determine variable contouring/shading details // Shade only half-grid boxes with missing values at all four corners half_miss= 1; // Depth (m) mdep= 0; // Continental outline mask value if (is_present(ZDIM) != 0) { zcoord= ngetcoord(slab, ZDIM+I1); if (is_reduced(ZDIM) > 0) { mdep= zcoord(is_reduced(ZDIM) - I1); } else { if (numberof(coord) == 1) mdep= zcoord(I0); } } long_name2= NULL; miss_color2= NULL; mask_color2= NULL; nplotcontours,varname,fieldstr,mdep,hattr(slab,"time:days_per_year"), long_name2,fill,levs,c_labels,width, scalef,units2,vformat,miss_value,miss_color2, demarc,mix,csys,cb_labels,mask_color2; if (!is_null(slab.z0)) { // Do not mark missing values for "surface" fields ztop= (*(slab.z0))(I0); if ( (fieldstr == "xy") && (hattr(slab,"z:units") == "m") && \ (mdep <= ztop) ) miss_color2= NULL; } } else { long_name2= varname; if (is_null(levs)) levs= NULL; if (is_null(c_labels)) c_labels= [0, 1]; if (is_null(scalef)) scalef= 1; if (is_null(width)) width= 1.0; if (is_null(vformat)) { vformat= "%.4g" //IDL2YORICK: vformat= "g0.4" ; } miss_color2= dgrey_color; if (is_null(mix)) { mix= NULL; if (is_null(demarc)) demarc= [ 0 ]; } if (is_null(csys)) csys= NULL; if (is_null(cb_labels)) cb_labels= [0, 1]; mask_color2= lgrey_color; } if (!is_null(miss_color)) miss_color2= miss_color; if (!is_null(mask_color)) mask_color2= mask_color; // Padding details if (is_null(pad) && param_set(fill) && (!param_set(nomask))) pad= 2; // Determine units for the variable if (!is_null(units)) units2= units; if (is_null(title)) { // Construct plot title, including the variable name etc. title= hlegend(slab, nounits=1, reduced=1); } if (ndim == 0) { // Scalar hyperslab; display value and return value= data1; if (scalef < 0) value= value / abs(scalef); write,"[SCALAR] " + title + " = " + strnum(value) + " " + units2; return timer_return(func_name); } // Transpose plot flag transplot = param_set(transp); // Always transpose Z-plots if (mdim(I0) == ZDIM+I1) transplot= (!transplot); xlim2= NULL; ylim2= NULL; if (transplot) { // Transpose coordinate ranges if (param_set(ylim)) xlim2= ylim; if (param_set(xlim)) ylim2= xlim; } else { // Copy coordinate ranges if (param_set(xlim)) xlim2= xlim; if (param_set(ylim)) ylim2= ylim; } dateflag= 0; if ((mdim(I0) == TDIM+I1) || (mdim(I0+1) == TDIM+I1)) { // Time coordinate in plot if (monotonic(*(slab.time)) != 0) { // Use date as coordinate, if requested and available dateflag= param_set(date) && (!is_null(slab.date)); } else { // Time coordinate non-monotonic; use date as time coordinate if (is_null(slab.date)) error, "Time values not monotonic && date values unavailable"; dateflag= 1; } if (dateflag) { // Enforce zero origin for dates (to be corrected when labelling) if ((mdim(I0) == TDIM+I1) && (!is_null(xlim2))) xlim2= xlim2 - double(101); if ((mdim(I0+1) == TDIM+I1) && (!is_null(ylim2))) ylim2= ylim2 - double(101); } } // X axis acoord= ngetcoord( slab, mdim(I0), date=-dateflag, iparam=1 ); // Determine X axis parameters xmid= (xticks= (xminor= (xtype= NULL))); nplotrange,slab,mdim(I0),acoord, xlim2,xmid,xticks,xminor,xtickformat,xtitle,xtype, date=dateflag; if ((xpars2(I0) == 0)&&(!is_null(xticks))) xpars2(I0)= xticks; if ((xpars2(I0+1) == 0)&&(!is_null(xminor))) xpars2(I0+1)= xminor; if ((xpars2(I0+2) == 0)&&(!is_null(xtype))) xpars2(I0+2)= xtype; if ((mdim(I0) == XDIM+I1) && param_set(rotx) && \ (!is_null(xlim2))) { // Rotate X coordinate range xtem= acoord; xrotate,360.0,rotx,xtem,irot,xlim2; } if (ndim == 1) { // 1-D plot; Y axis bcoord= [0]; if (!param_set(ylim2)) ylim2= [0, 0]; if (!param_set(ytickformat)) ytickformat= ""; if (!param_set(ystyle)) ystyle= 0; if (is_null(ytitle)) ytitle= units2; // Number of coordinate values ncoord= numberof(acoord); // Copy data if (transplot) { // 1-D transposed plot; exclude undefined values at ends kmin= ncoord; for (k=ncoord-I1; k >= I0; k--) { if (data1(k) < miss_value) kmin= k; } kmax= -1; for (k=I0; k <= ncoord-I1; k++) { if (data1(k) < miss_value) kmax= k; } if (kmax < kmin) error, "Error: all undefined values"; acoord= acoord(kmin:kmax); reshape_array, data1, [2, 1, ncoord]; data1= data1(,kmin:kmax); } else { // 1-D regular plot reshape_array, data1, [2, ncoord, 1]; } } else if (ndim == 2) { // 2-D plot; Y axis bcoord= ngetcoord( slab, mdim(I0+1), date=-dateflag, iparam=1 ); if (param_set(zoom)) { // Zoom specified if (transplot) { ylim2= xzoom_lim; if (mdim(I0) != ZDIM+I1) xlim2= yzoom_lim ; else xlim2= [yzoom_lim(1), yzoom_lim(0)]; } else { xlim2= xzoom_lim; if (mdim(I0+1) != ZDIM+I1) ylim2= yzoom_lim ; else ylim2= [yzoom_lim(1), yzoom_lim(0)]; } write, "Zoom: Xlim=", xlim2; write, " Ylim=", ylim2; } // Determine Y axis parameters ymid= (yticks= (yminor= (ytype= NULL))); nplotrange,slab,mdim(I0+1),bcoord, ylim2,ymid,yticks,yminor,ytickformat,ytitle,ytype, date=dateflag; if ((ypars2(I0) == 0)&&(!is_null(yticks))) ypars2(I0)= yticks; if ((ypars2(I0+1) == 0)&&(!is_null(yminor))) ypars2(I0+1)=yminor; if ((ypars2(I0+2) == 0)&&(!is_null(ytype))) ypars2(I0+2)=ytype; if ((mdim(I0+1) == XDIM+I1) && param_set(rotx) && \ (!is_null(ylim2))) { // Rotate X coordinate range xtem= bcoord; xrotate,360.0,rotx,xtem,irot,ylim2; } if ( (fieldstr == "xy") && (!is_null(proj))) { // Horizontal (XY) projection projlist= ["mollweide", "nhpolar", "shpolar"]; iproj= strloc( projlist, proj, case_fold=1, abbrev=1, comment="proj" ); projname= projlist(iproj-I1); if (projname == "mollweide") { // Mollweide projection; set default longitude origin if (is_null(ppars)) ppars= [ xmid ]; } } // Copy data and reshape it reshape_array, data1, plot_dims; if (transplot) data1= transpose(data1); } else { error,"Cannot display slab with 3 || more dimensions "; } if (transplot) { // Transposed plot flexp,data1,bcoord,acoord, title=title,subtitle=subtitle,xlim=ylim2,ylim=xlim2, fill=fill,overlay=overlay,levs=levs, type=type,width=width,c_labels=c_labels, line_color=line_color,label_color=label_color,label_size=label_size, low_color=low_color,high_color=high_color, demarc=demarc,mix=mix,csys=csys,rev=rev,stack=stack, cbar=cbar,cb_labels=cb_labels, scalef=scalef,units=units2,vformat=vformat, miss_value=miss_value,miss_width=miss_width,miss_type=miss_type, miss_color=miss_color2,half_miss=half_miss,pad=pad, rotx=rotx,aspect=aspect,proj=proj,ppars=ppars,pole_fill=pole_fill, nested=nested,triangulate=triangulate, charsize=charsize,charthick=charthick,charfont=charfont, xtitle=ytitle,xtickformat=ytickformat,xtickv=ytickv,xtickname=ytickname, ytitle=xtitle,ytickformat=xtickformat,ytickv=xtickv,ytickname=xtickname, xpars=ypars2,ypars=xpars2,apars=apars, position=position,overplot=overplot,nodata=nodata; } else { // Regular plot flexp,data1,acoord,bcoord, title=title,subtitle=subtitle,xlim=xlim2,ylim=ylim2, fill=fill,overlay=overlay,levs=levs, type=type,width=width,c_labels=c_labels, line_color=line_color,label_color=label_color,label_size=label_size, low_color=low_color,high_color=high_color, demarc=demarc,mix=mix,csys=csys,rev=rev,stack=stack, cbar=cbar,cb_labels=cb_labels, scalef=scalef,units=units2,vformat=vformat, miss_value=miss_value,miss_width=miss_width,miss_type=miss_type, miss_color=miss_color2,half_miss=half_miss,pad=pad, rotx=rotx,aspect=aspect,proj=proj,ppars=ppars,pole_fill=pole_fill, nested=nested,triangulate=triangulate, charsize=charsize,charthick=charthick,charfont=charfont, xtitle=xtitle,xtickformat=xtickformat,xtickv=xtickv,xtickname=xtickname, ytitle=ytitle,ytickformat=ytickformat,ytickv=ytickv,ytickname=ytickname, xpars=xpars2,ypars=ypars2,apars=apars, position=position,overplot=overplot,nodata=nodata; } //HARD-EXTENSIONS-BEGIN: if ((!param_set(nomask)) && (fieldstr == "xy") && \ ( (slab.structure == "HYPERSLAB1.0_SPH_SIG_ATM") || \ (slab.structure == "HYPERSLAB1.0_SPH_SIG_OCN") ) ) { // Superimpose continental outlines if (is_null(width)) width= 1.0; if (is_null(cont_width)) cont_width= 0.5*width; cont_fill= param_set(mask_color) || \ ( param_set(fill) && \ (slab.structure == "HYPERSLAB1.0_SPH_SIG_OCN") ); hcont,slab,mval=mval,fill=cont_fill,scolor=mask_color2, terrain=terrain, width=cont_width,proj=proj,ppars=ppars,rotx=rotx,transp=transplot; } //HARD-EXTENSIONS-END: if (param_set(printer)) { //IDLbegin: // Print plot //: device,close=1; //: printstr= strcompress(string(printer),remove_all=1); //: if (printstr == "1") { //: write, "Spooling plot to printer"; //: oscommand, "lpr idl.ps", noprint=1; //: } else { //: write, "Spooling plot to printer '"+printstr+"'"; //: oscommand, "lpr -P"+printstr+" idl.ps", noprint=1; //: } //: oscommand, "/bin/rm idl.ps", noprint=1; // Restore plot environment //: set_plot, old_dev; //IDL2YORICK: !P.MULTI= old_multi ; //: inicolors; //IDLend: } return timer_return(func_name); } func hregrid( slab, dim, help=, op=, new_grid=, pad=, nohistory=) /* DOCUMENT hregrid(slab, dim, help=, op=, new_grid=, * pad=, nohistory=0/1) * HREGRID regrids data values in SLAB on the staggered grid for dimension DIM, * after carrying out operation OP. NEW_GRID=[val1,val2,...] contains the new * staggered grid coordinate values. * If NEW_GRID is not specified, the staggered grid is determined from * the SLAB coordinates, if possible; otherwise, a mid-point grid is * constructed, with one less grid-point (except for periodic grids). * * If OP="zcen", adjacent data values are averaged pairwise before * shifting to the staggered grid, with duplicated values for boundary * points with only one neighbour (unless PAD is specified). * (This is the default operation, if OP is omitted.) * * If OP="dif", adjacent data values are differenced pairwise * (forward-backward) before shifting to the staggered grid, * with zero values for boundary points with only one neighbour * (unless PAD is specified). * * If OP="zleft", data values are shifted left to staggered grid. * * If OP="zright", data values are shifted right to staggered grid. * * If OP="psum", partial sums along dimension DIM are computed * on the staggered grid. Missing values are treated as zeros. * Partial summation may be combined with HOP(..,"*",HCOORD(..,"area_wt")) * operations to compute area-weighted partial integrals. * * If OP="rpsum", partial sums are carried out in reverse order. * * PAD=padding_value may be specified for padded shifts, instead duplicating * the boundary value. * * NOHISTORY==1 disables appending of history information. * SEE ALSO: hshift, hinterp, hsub */ { func_name= "hregrid"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HREGRID regrids data to staggered grid along selected dimension."; write," E.g.,"; write," new_slab = hregrid(slab,'y',op='dif')"; write," differences adjacent data values along the Y-dimension."; write," Tips:"; write," 1. op='zcen' maybe used to shift pairwise averaged data"; write," to the staggered grid. (DEFAULT)"; write," 2. op='dif' maybe used to shift pairwise differenced data"; write," to the staggered grid."; write," 3. op='zleft'/'zright' maybe used to for left/right shifts"; write," to the staggered grid."; write," 4. op='psum'/'rpsum' maybe used to compute forward/reverse partial sums"; write," 5. new_grid=[val1,val2,...] allows staggered grid to be specified"; write," 6. pad=padding_value maybe used for padded shifts"; write," on the staggered grid."; write," See also: hshift, hinterp, hsub"; write,""; write," Usage: hregrid(slab,'x/y/z/t/i',count=..,op='zcen'/'dif'/'zleft'/'zright'/'psum'/'rpsum',new_grid=[val1,val2,...],pad=..,nohistory=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hregrid( slab(j), dim, op=op, new_grid=new_grid, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (!is_scalar(dim)) error, "Argument DIM should be a scalar string"; // Determine dimension to be staggered mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; if ((mdim == IDIM+I1) && is_null(slab.iparam)) error, "Cannot stagger i-dimension without parameter values"; // History string his_str= "<" + slab.name + ">,<" + dim + ">"; // Dimension presence/reduction codes is_present= slab.dimension(,HFMT.data); apresent= slab.dimension(,HFMT.area_wt); zpresent= slab.dimension(,HFMT.z_bot); is_reduced= slab.reduced; if (is_present(mdim-I1) <= 0) error, "Dimension not present in data"; // Periodicity flag periodic= 0; if (mdim == XDIM+I1) { // Check if X-dimension is periodic x_period= hattr(slab, "x:period"); periodic= (x_period != 0.) && (hattr(slab, "x:subdomain") == 0); } // Data type data_type= slab.type(HFMT.data); if (data_type == "LOCATOR") error, "Actual data needs to be present in the slab"; // Copy data data1= *(slab.data); missing_value= deref(slab.missing_value); // Default staggering operation (averaging) op1= "zcen"; if (param_set(op)) { op1= op; his_str= his_str + ",op=<" + op1 + ">"; } new_flag= (!is_null(new_grid)); if (new_flag) his_str= his_str + ",new_grid=[..]"; if ((op1 == "psum") || (op1 == "rpsum")) { // Compute partial sums on staggered grid and return rev= (op1 == "rpsum"); new_slab= npsum(slab,mdim,rev=rev); if (rev) { new_slab= hregrid(new_slab, dim, op="zleft", new_grid=new_grid, pad=0., nohistory=1 ); } else { new_slab= hregrid(new_slab, dim, op="zright", new_grid=new_grid, pad=0., nohistory=1 ); } if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hregrid(" + his_str + ");" } return timer_return(func_name, new_slab); } // Delete area weights array, if staggered dimension is present there area_wt1= NULL; if (apresent(mdim-I1) > 0) { area_wt1= ""; apresent(*)= 0; } // Delete Z_BOT array, if staggered dimension is present there z_bot1= NULL; if (zpresent(mdim-I1) > 0) { z_bot1= ""; zpresent(*)= 0; } // Get coordinate values coord= ngetcoord(slab,mdim,iparam=1); ncoord= numberof(coord); subdomain= nattr("subdomain", slab, mdim); if (new_flag) { // New staggered grid specified full_flag= 1; subdomain= 0; if (is_present(mdim-I1) == 1) { // Regular -> interfacial grid creg0= coord; cint0= new_grid; } else { // Interfacial -> regular grid creg0= new_grid; cint0= coord; } if (!ncheck_grid(creg0, cint0)) error, "Inconsistent regular/staggered grid specification"; } else { if ((mdim > ZDIM+I1) || (subdomain < 0)) { // Non-spatial or noncontiguous grid; no full domain defined full_flag= 0; } else { // Contiguous spatial grid creg0= ngetcoord(slab, mdim, full=1, grid=1); cint0= ngetcoord(slab, mdim, full=1, grid=2); // Check if both regular and staggered full coordinates are available full_flag= ( (!is_null(creg0)) && (!is_null(cint0)) ); } } if (full_flag) { // Shift to available staggered grid if (is_present(mdim-I1) == 1) { // Regular -> interfacial grid cfull0= creg0; cstag0= cint0; } else { // Interfacial -> regular grid cfull0= cint0; cstag0= creg0; } nfull0= numberof(cfull0); nstag0= numberof(cstag0); // No. of points on staggered grid ncoord2= ncoord + (nstag0 - nfull0); // Staggered coordinate values if (subdomain > 0) { coord2= cstag0(subdomain-I1:ncoord2-I1); } else { coord2= cstag0; } if (mdim == IDIM+I1) ilabel2= array("",numberof(new_grid)); if ((nfull0 == 1) && (nstag0 == 1)) { // Single element full grid coordinate arrays // Shift direction: 1 => forward, -1 => backward shift_dir= 1; // "Shifted" data array data2= data1; } else { // Muliple element full grid array(s) // Order code: 1 => ascending, -1 => descending order_code= 2*((monotonic(cfull0) == 1) || \ (monotonic(cstag0) == 1)) - 1; // Shift direction: 1 => forward, -1 => backward shift_dir= order_code * (2*(coord2(I0) < coord(I0)) - 1); // Shifted data array if (periodic) { // Periodic dimension if (shift_dir == 1) { // Copy data array data2= data1; // Right shifted data data1= rangeop(data2, "rot", mdim, count=1); } else { // Left shifted data data2= rangeop(data1, "rot", mdim, count=-1); } } else { // Non-periodic dimension if (shift_dir == 1) { // Right shifted data (must have ncoord2 >= ncoord) if (ncoord2 > ncoord) { // Create right padded array (increase dimension length by 1) ddims= dimsof(data1); ddimf= dim_reshape(ddims, focus=mdim); reshape_array, data1, ddimf; ddims(1+mdim-I1)= ncoord+1; ddimf(I0+2)= ncoord+1; data2= array(data1(I0), ddimf); data2(,I0:ncoord-I1,)= data1(,,); if (is_null(pad)) { data2(,ncoord+1-I1,)= data1(,ncoord-I1,); } else { data2(,ncoord+1-I1,)= pad; } reshape_array, data2, ddims; } else { // Copy data array (equal dimension lengths) data2= data1; } // Right shifted data data1= rangeop(data2, "shift", mdim, count=1, pad=pad); } else { // Left shifted data (must have ncoord2 <= ncoord) data2= rangeop(data1, "shift", mdim, count=-1, pad=pad); if (ncoord2 < ncoord) { // Truncate data by dropping last value along dimension data1= arrayop(data1, [I0, ncoord2-I1], mdim); data2= arrayop(data2, [I0, ncoord2-I1], mdim); } } } } } else { // Shift to mid-point grid subdomain= -1; creg0= ""; cint0= ""; if (ncoord == 1) error, "Cannot stagger single coordinate value"; // Compute mid-point coordinates if (periodic) { coord2= 0.5 * (coord + rangeop(coord,"rot",count=-1)); coord2(ncoord-I1)= 0.5*(coord(ncoord-I1) + coord(I0) + x_period); } else { coord2= 0.5 * (coord(I0+1:ncoord-I1) + coord(I0:ncoord-1-I1)); } ncoord2= numberof(coord2); if (mdim == IDIM+I1) { //SOFT-EXTENSIONS-BEGIN: if (hattr(slab,"ilabel:long_name") == "calendar month") { ilabel1= strmid(ngetcoord(slab,mdim),0,3); ilabel2= (ilabel1(I0+1:ncoord-I1) + ":" + op1 + ":" + ilabel11(I0:ncoord-1-I1)); } //SOFT-EXTENSIONS-END: } if (periodic) { // Periodic grid; left shift data data2= rangeop(data1,"rot",mdim,count=-1); } else { // Non-periodic grid; left shift data data2= rangeop(data1, "shift", mdim, count=-1); // Truncate data by dropping last value along dimension data1= arrayop(data1, [I0, ncoord2-I1], mdim); data2= arrayop(data2, [I0, ncoord2-I1], mdim); } } // Create output data array if ((op1 == "zleft") || (op1 == "zright")) { // Left/right staggered shift if (op1 == "zright") data2= data1; } else { // Other staggered shifts if ((op1 != "zcen") && (op1 != "dif")) error, "Invalid stagger option - " + op1; if (is_null(missing_value)) { // No missing values in data if (op1 == "zcen") { // Compute pairwise averages of data values along dimension data2(*)= 0.5*(data1(*) + data2(*)); } else if (op1 == "dif") { // Compute pairwise differences of data values along dimension data2(*)= (data2(*) - data1(*)); } } else { // Locate defined data values defined= ( ((data1 == missing_value) + (data2 == missing_value)) == 0 ); wmask= where(defined); if (is_where(wmask)) { if (op1 == "zcen") { // Compute pairwise averages of data values along dimension data2(wmask)= 0.5*(data1(wmask) + data2(wmask)); } else if (op1 == "dif") { // Compute pairwise differences of data values along dimension data2(wmask)= (data2(wmask) - data1(wmask)); } } // Insert missing values wmask= where(defined == 0); if (is_where(wmask)) data2(wmask)= missing_value; } } // Delete original data array data1= NULL; // New data dimensionality is_reduced(mdim-I1)= 0; apresent(mdim-I1)= 0; zpresent(mdim-I1)= 0; // Toggle grid type if (mdim <= ZDIM+I1) is_present(mdim-I1)= 3 - is_present(mdim-I1); // Create staggered coordinate slab new_slab= NULL; if (mdim == XDIM+I1) { hcopy, slab, new_slab, data=data2, x1=coord2, x0=creg0, xint0=cint0, area_wt1=area_wt1, z_bot1=z_bot1, area_wt_dims=apresent, z_bot_dims=zpresent, is_present=is_present, is_reduced=is_reduced; } else if (mdim == YDIM+I1) { hcopy, slab, new_slab, data=data2, y1=coord2, y0=creg0, yint0=cint0, area_wt1=area_wt1, z_bot1=z_bot1, area_wt_dims=apresent, z_bot_dims=zpresent, is_present=is_present, is_reduced=is_reduced; } else if (mdim == ZDIM+I1) { hcopy, slab, new_slab, data=data2, z1=coord2, z0=creg0, zint0=cint0, area_wt1=area_wt1, z_bot1=z_bot1, area_wt_dims=apresent, z_bot_dims=zpresent, is_present=is_present, is_reduced=is_reduced; } else if (mdim == TDIM+I1) { hcopy, slab, new_slab, data=data2, time1=coord2, date1="", area_wt1=area_wt1, z_bot1=z_bot1, area_wt_dims=apresent, z_bot_dims=zpresent, is_present=is_present, is_reduced=is_reduced; } else if (mdim == IDIM+I1) { hcopy, slab, new_slab, data=data2, iparam1=coord2, ilabel1=ilabel2, iparam0=coord2, ilabel0=ilabel2, area_wt1=area_wt1, z_bot1=z_bot1, area_wt_dims=apresent, z_bot_dims=zpresent, is_present=is_present, is_reduced=is_reduced; } if (mdim <= ZDIM+I1) { // Change grid type if (is_present(mdim-I1) == 1) { nset_attr, "grid", new_slab, mdim, "regular"; } else { nset_attr, "grid", new_slab, mdim, "interfacial"; } if (new_flag || (subdomain != 0)) { // Change domain bounds nset_attr, "lower_bound", new_slab, mdim, coord2(I0); nset_attr, "upper_bound", new_slab, mdim, coord2(ncoord2-I1); } } // Set subdomain attribute nset_attr, "subdomain", new_slab, mdim, subdomain; if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hregrid(" + his_str + ");" } return timer_return(func_name, new_slab); } func hsave( filename, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9, help=, norecord=, command=, area_wt_var=, z_bot_var=, nocheck=, notime=, format=) /* DOCUMENT hsave, filename, * slab0, slab1, slab2, slab3, slab4, * slab5, slab6, slab7, slab8, slab9, * help=, norecord=0/1, command=, area_wt_var=, z_bot_var=, * nocheck=0/1, notime=0/1, format="ccm" * * Save up to 9 hyperslabs (or hyperslab arrays) to netCDF file named * FILENAME. * By default, the T-dimension, if present, is assumed to be unlimited. * If the I dimension is also present, the data is actually saved with * with the T and I dimensions transposed, so that the last dimension is the * unlimited dimension. * If NORECORD==1, all dimensions are assumed to be limited, and are * saved in the normal order. * operations through the HAPPEND operator. * If both T and I dimensions are present, all dimensions are assumed * to be limited. * If COMMAND is specified, execute COMMAND as an operating system command * after closing the save file, with any % characters substituted with the * file name header (i.e., excluding any suffix, and leading pathnames). * If AREA_WT_VAR is non-null, it contains the name of the hyperslab * variable containing the area weights (amongst SLAB0, ..., SLAB9). * If Z_BOT_VAR is non-null, it contains the name of the hyperslab * variable containing the Z_BOT values (amongst SLAB0, ..., SLAB9). * If NOCHECK==1, area weight and Z_BOT values are not checked. * If NOTIME==1, variables with time dimension are not written. * If FORMAT=="ccm", output is in CCM netCDF format. * SEE ALSO: happend, hopen, hget */ { func_name= "hsave"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSAVE saves a set of hyperslabs as a netCDF file."; write," E.g.,"; write," hsave, 'slabfile.nc', slab1, slab2"; write," creates a netCDF file containing hyperslabs SLAB1 && SLAB2,"; write," which may themselves be arrays."; write," Tips:"; write," 1. norecord=1 forces all dimensions to be limited."; write," 2. area_wt_var= specifies the name of the area weights"; write," variable, which should be one of the slab variables."; write," 3. z_bot_var= specifies the name of the bottom Z values"; write," variable, which should be one of the slab variables."; write," 4. notime=1 suppresses writing of variables with time dimension."; write," 5. nocheck=1 suppresses checking of area weights, bottom Z values."; write," 6. format='ccm' outputs CCM netCDF format."; write,""; write," See also: happend, hopen, hget"; write,""; write," Usage: hsave, 'file_name', norecord=0/1, area_wt_var='var_name', z_bot_var='var_name', notime=0/1, nocheck=0/1, format='ccm'"; return timer_return(func_name); } // Open netCDF file fhandle= NULL; fmeta= NULL; nc_openf, filename, fhandle, fmeta, create=1; // Number of slabs nslab= numberof(slab0) + numberof(slab1) + numberof(slab2) + numberof(slab3) + numberof(slab4) + numberof(slab5) + numberof(slab6) + numberof(slab7) + numberof(slab8) + numberof(slab9); if (nslab == 0) error, "No slabs specified to save"; // Standard/interfacial dimension names if (param_set(format)) { if (strtoupper(format) == "CCM") { // CCM netCDF format std_dims= [ "lon", "lat", "lev", "time","ilabel" ]; int_dims= [ "ilon","ilat","ilev", "", "" ]; } else { error, "Unknown output format - "+format; } } else { // HOPS format std_dims= HFMT.dimnames; int_dims= HFMT.dimintnames; } // Full grid dimensions std_dims0= std_dims + "0"; int_dims0= int_dims + "0"; // General coordinate variables structure0= NULL; x1= (xint1= (x0= (xint0= NULL))); y1= (yint1= (y0= (yint0= NULL))); z1= (zint1= (z0= (zint0= NULL))); time1= (date1= NULL); ilabel1= (iparam1= NULL); ilabel0= (iparam0= NULL); days_per_year= NULL; x_atts= (y_atts= (z_atts= NULL)); time_atts= (date_atts= NULL); ilabel_atts= (iparam_atts= NULL); subdomain= array(long,SDIM); subdomainint= array(long,SDIM); //HARD-EXTENSIONS-BEGIN: // Variables for hard extensions a0= NULL; eqdx0= NULL; eqdxint0= NULL; cosdy0= NULL; cosdyint0= NULL; sigma0= NULL; sigmaint0= NULL; hgrid0= NULL; kmax0= NULL; //HARD-EXTENSIONS-END: // Record variable flag/count, dimensions for area weights, and Z_BOT values recflag= 0; ti_transp= 0; apresent0= NULL; aw_atts= NULL; aelements= NULL; area_wt1= NULL; zpresent0= NULL; zb_atts= NULL; zref= NULL; z_bot1= NULL; // Area weights/Z_BOT array write flags awrite= 1; zwrite= 1; // Variable list var_list= array("",nslab); // Special global attribute list attglob= *(HFMT.attglob); nattglob= numberof(attglob); glob_special= array("",nslab,nattglob); // "Fixed" length global string attributes attfixed= *(HFMT.attfixed); for (jslab=I0; jslab <= nslab-I1; jslab++) { // Get copy of each slab (with data) tem_slab= nslabarr( jslab+I1, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); is_present= tem_slab.dimension(,HFMT.data); // Hyperslab structure if (is_null(structure0)) { structure0= tem_slab.structure; // Determine number of structure extensions struc_list= strsplit(structure0, "_"); nextens= numberof(struc_list) - 1; } else { if (structure0 != tem_slab.structure) error, "Incompatible hyperslab structures"; } // Dimensions/variables if (jslab == I0) { // First slab; copy list of global attributes glob_atts= nattlist(tem_slab,"",noglobdata=1); // Character array dimension for representing strings nc_dimdef, fmeta, "nchar", HFMT.nchar; if (!param_set(format)) { // Copy global attributes (excepting special global attributes) nputatt, tem_slab, "", fmeta, ""; } else { // Define format specific global attributes if (strtoupper(format) == "CCM") { // CCM netCDF format nc_attrdef, fmeta, "Conventions", NULL, "NCAR-CSM"; nc_attrdef, fmeta, "case", NULL, hattr(tem_slab,":case_name"); nc_attrdef, fmeta, "title", NULL, hattr(tem_slab,":case_title"); } } } else { // Not the first slab; check if all non-special global attributes match if (!nattmatch(glob_atts, nattlist(tem_slab,"",noglobdata=1))) error, "Incompatible global attributes"; } //HARD-EXTENSIONS-BEGIN: // Handle non-coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SPH") { // SPH extension variables/dimensions if (jslab == I0) { a0= tem_slab.a0; nvarattdef, tem_slab, fmeta, "a0", "double"; } else { if (!array_eq(a0, tem_slab.a0, epsilon=1e-4)) error, "Incompatible variables for SPH extension"; } } else if (struc_list(iext+1) == "SSH") { // SSH extension variables/dimensions if (jslab == I0) { a0= tem_slab.a0; nvarattdef, tem_slab, fmeta, "a0", "double"; } else { if (!array_eq(a0, tem_slab.a0, epsilon=1e-4)) error, "Incompatible variables for SSH extension"; } } else if (struc_list(iext+1) == "SIG") { // SIG extension variables/dimensions if (jslab == I0) { nc_dimdef, fmeta, "sigma_coefs", HFMT.nsigma_coefs; } } } //HARD-EXTENSIONS-END: if (!param_set(norecord)) { if (is_present(TDIM) != 0) { // Set record flag recflag= 1; } if (recflag && (is_present(IDIM) > 0)) { // Set T/I dimension transpose flag ti_transp= 1; } } cur_list= array("",SDIM); orig_list= array("",SDIM); if (is_present(XDIM) != 0) { if (is_null(x1) && is_null(xint1)) { // X-dimension encountered for first time if (!is_null(tem_slab.x0)) { // Define X0 dimension x0= *(tem_slab.x0); nc_dimdef, fmeta, std_dims0(XDIM), numberof(x0); nvarattdef, tem_slab, fmeta, std_dims0(XDIM), "double", dimnames=[std_dims0(XDIM)]; //HARD-EXTENSIONS-BEGIN: // Handle coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SPH") { // SPH extension if (!is_null(tem_slab.eqdx0)) { eqdx0= *(tem_slab.eqdx0); nvarattdef, tem_slab, fmeta, "eqdx0", "double", dimnames=[std_dims0(XDIM)]; } } } //HARD-EXTENSIONS-END: } if (!is_null(tem_slab.xint0)) { // Define XINT0 dimension xint0= *(tem_slab.xint0); nc_dimdef, fmeta, int_dims0(XDIM), numberof(xint0); nvarattdef, tem_slab, fmeta, int_dims0(XDIM), "double", dimnames=[int_dims0(XDIM)]; //HARD-EXTENSIONS-BEGIN: // Handle coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SPH") { // SPH extension if (!is_null(tem_slab.eqdxint0)) { eqdxint0= *(tem_slab.eqdxint0); nvarattdef, tem_slab, fmeta, "eqdxint0", "double", dimnames=[int_dims0(XDIM)]; } } } //HARD-EXTENSIONS-END: } // Copy X dimension attributes x_atts= nattlist(tem_slab,"x",nogrid=1); } else { // X-dimension encountered previously; check compatibility if (!nattmatch(x_atts, nattlist(tem_slab,"x",nogrid=1))) error, "Incompatible attributes for X dimension"; if (!array_eq(x0, deref(tem_slab.x0), epsilon=HFMT.epscoord)) error, "Incompatible X0 dimension among slabs to be saved"; if (!array_eq(xint0, deref(tem_slab.xint0), epsilon=HFMT.epscoord)) error, "Incompatible XINT0 dimension among slabs to be saved"; } if (abs(is_present(XDIM)) == 1) { // Regular X grid if (is_null(x1)) { // Define X dimension x1= *(tem_slab.x); subdomain(XDIM)= hattr(tem_slab, "x:subdomain" ); nc_dimvardef, fmeta, std_dims(XDIM), numberof(x1), "double"; nputatt, tem_slab, "x", fmeta, std_dims(XDIM); } else { // Check compatibility of X dimension if ((!array_eq(x1, deref(tem_slab.x), epsilon=HFMT.epscoord)) || \ (subdomain(XDIM) != hattr(tem_slab,"x:subdomain")) ) error, "Incompatible X dimension among slabs to be saved"; } } else { // Interfacial X grid if (is_null(xint1)) { // Define XINT dimension xint1= *(tem_slab.x); subdomainint(XDIM)= hattr(tem_slab, "x:subdomain" ); nc_dimvardef, fmeta, int_dims(XDIM), numberof(xint1), "double"; nputatt, tem_slab, "x", fmeta, int_dims(XDIM); } else { // Check compatibility of XINT dimension if ((!array_eq(xint1, deref(tem_slab.x), epsilon=HFMT.epscoord)) || \ (subdomainint(XDIM) != hattr(tem_slab,"x:subdomain")) ) error, "Incompatible XINT dimension among slabs to be saved"; } } } if (is_present(YDIM) != 0) { if (is_null(y1) && is_null(yint1)) { // Y-dimension encountered for first time if (!is_null(tem_slab.y0)) { // Define Y0 dimension y0= *(tem_slab.y0); nc_dimdef, fmeta, std_dims0(YDIM), numberof(y0); nvarattdef, tem_slab, fmeta, std_dims0(YDIM), "double", dimnames=[std_dims0(YDIM)]; //HARD-EXTENSIONS-BEGIN: // Handle coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SPH") { // SPH extension if (!is_null(tem_slab.cosdy0)) { cosdy0= *(tem_slab.cosdy0); nvarattdef, tem_slab, fmeta, "cosdy0", "double", dimnames=[std_dims0(YDIM)]; } } } //HARD-EXTENSIONS-END: } if (!is_null(tem_slab.yint0)) { // Define YINT0 dimension yint0= *(tem_slab.yint0); nc_dimdef, fmeta, int_dims0(YDIM), numberof(yint0); nvarattdef, tem_slab, fmeta, int_dims0(YDIM), "double", dimnames=[int_dims0(YDIM)]; //HARD-EXTENSIONS-BEGIN: // Handle coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SPH") { // SPH extension if (!is_null(tem_slab.cosdyint0)) { cosdyint0= *(tem_slab.cosdyint0); nvarattdef, tem_slab, fmeta, "cosdyint0", "double", dimnames=[int_dims0(YDIM)]; } } } //HARD-EXTENSIONS-END: } // Copy Y dimension attributes y_atts= nattlist(tem_slab,"y",nogrid=1); } else { // Y-dimension encountered previously; check compatibility if (!nattmatch(y_atts, nattlist(tem_slab,"y",nogrid=1))) error, "Incompatible attributes for Y dimension"; if (!array_eq(y0, deref(tem_slab.y0), epsilon=HFMT.epscoord)) error, "Incompatible Y0 dimension among slabs to be saved"; if (!array_eq(yint0, deref(tem_slab.yint0), epsilon=HFMT.epscoord)) error, "Incompatible YINT0 dimension among slabs to be saved"; } if (abs(is_present(YDIM)) == 1) { // Regular Y grid if (is_null(y1)) { // Define Y dimension y1= *(tem_slab.y); subdomain(YDIM)= hattr(tem_slab, "y:subdomain" ); nc_dimvardef, fmeta, std_dims(YDIM), numberof(y1), "double"; nputatt, tem_slab, "y", fmeta, std_dims(YDIM); } else { // Check compatibility of Y dimension if ((!array_eq(y1, deref(tem_slab.y), epsilon=HFMT.epscoord)) || \ (subdomain(YDIM) != hattr(tem_slab,"y:subdomain")) ) error, "Incompatible Y dimension among slabs to be saved"; } } else { // Interfacial Y grid if (is_null(yint1)) { // Define YINT dimension yint1= *(tem_slab.y); subdomainint(YDIM)= hattr(tem_slab, "y:subdomain" ); nc_dimvardef, fmeta, int_dims(YDIM), numberof(yint1), "double"; nputatt, tem_slab, "y", fmeta, int_dims(YDIM); } else { // Check compatibility of YINT dimension if ( (!array_eq(yint1, deref(tem_slab.y), epsilon=HFMT.epscoord)) || \ (subdomainint(YDIM) != hattr(tem_slab,"y:subdomain")) ) error, "Incompatible YINT dimension among slabs to be saved"; } } } if ((is_present(XDIM) != 0) && (is_present(YDIM) != 0)) { // X and Y dimensions //HARD-EXTENSIONS-BEGIN: // Handle grid variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "ATM") { // ATM extension if (!is_null(tem_slab.hgrid0)) { if (is_null(hgrid0)) { hgrid0= *(tem_slab.hgrid0); nvarattdef, tem_slab, fmeta, "hgrid0", "char", dimnames=[std_dims0(XDIM), std_dims0(YDIM)]; } else { if (!array_eq(hgrid0, deref(tem_slab.hgrid0))) error, "Incompatible HGRID0 values"; } } } else if (struc_list(iext+1) == "OCN") { // OCN extension if (!is_null(tem_slab.kmax0)) { if (is_null(kmax0)) { kmax0= *(tem_slab.kmax0); nvarattdef, tem_slab, fmeta, "kmax0", "char", dimnames=[std_dims0(XDIM), std_dims0(YDIM)]; } else { if (!array_eq(kmax0, deref(tem_slab.kmax0))) error, "Incompatible KMAX0 values"; } } } } } //HARD-EXTENSIONS-END: if (is_present(ZDIM) != 0) { if (is_null(z1) && is_null(zint1)) { // Z-dimension encountered for first time if (!is_null(tem_slab.z0)) { // Define Z0 dimension z0= *(tem_slab.z0); nc_dimdef, fmeta, std_dims0(ZDIM), numberof(z0); nvarattdef, tem_slab, fmeta, std_dims0(ZDIM), "double", dimnames=[std_dims0(ZDIM)]; //HARD-EXTENSIONS-BEGIN: // Handle coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SIG") { // SIG extension if (!is_null(tem_slab.sigma0)) { sigma0= *(tem_slab.sigma0); nvarattdef, tem_slab, fmeta, "sigma0", "double", dimnames=["sigma_coefs",std_dims0(ZDIM)]; } } } //HARD-EXTENSIONS-END: } if (!is_null(tem_slab.zint0)) { // Define ZINT0 dimension zint0= *(tem_slab.zint0); nc_dimdef, fmeta, int_dims0(ZDIM), numberof(zint0); nvarattdef, tem_slab, fmeta, int_dims0(ZDIM), "double", dimnames=[int_dims0(ZDIM)]; //HARD-EXTENSIONS-BEGIN: // Handle coordinate variables for extensions for (iext=I0; iext <= nextens-I1; iext++) { if (struc_list(iext+1) == "SIG") { // SIG extension if (!is_null(tem_slab.sigmaint0)) { sigmaint0= *(tem_slab.sigmaint0); nvarattdef, tem_slab, fmeta, "sigmaint0", "double", dimnames=["sigma_coefs",int_dims0(ZDIM)]; } } } //HARD-EXTENSIONS-END: } // Copy Z dimension attributes z_atts= nattlist(tem_slab,"z",nogrid=1); } else { // Z-dimension encountered previously; check compatibility if (!nattmatch(z_atts, nattlist(tem_slab,"z",nogrid=1))) error, "Incompatible attributes for Z dimension"; if (!array_eq(z0, deref(tem_slab.z0), epsilon=HFMT.epscoord)) error, "Incompatible Z0 dimension among slabs to be saved"; if (!array_eq(zint0, deref(tem_slab.zint0), epsilon=HFMT.epscoord)) error, "Incompatible ZINT0 dimension among slabs to be saved"; } if (abs(is_present(ZDIM)) == 1) { // Regular Z grid if (is_null(z1)) { // Define Z dimension z1= *(tem_slab.z); subdomain(ZDIM)= hattr(tem_slab, "z:subdomain" ); nc_dimvardef, fmeta, std_dims(ZDIM), numberof(z1), "double"; nputatt, tem_slab, "z", fmeta, std_dims(ZDIM); } else { // Check compatibility of Z dimension if ( (!array_eq(z1, deref(tem_slab.z), epsilon=HFMT.epscoord)) || \ (subdomain(ZDIM) != hattr(tem_slab,"z:subdomain")) ) error, "Incompatible Z dimension among slabs to be saved"; } } else { // Interfacial Z grid if (is_null(zint1)) { // Define ZINT dimension zint1= *(tem_slab.z); subdomainint(ZDIM)= hattr(tem_slab, "z:subdomain" ); nc_dimvardef, fmeta, int_dims(ZDIM), numberof(zint1), "double"; nputatt, tem_slab, "z", fmeta, int_dims(ZDIM); } else { // Check compatibility of ZINT dimension if ( (!array_eq(zint1, deref(tem_slab.z), epsilon=HFMT.epscoord)) || \ (subdomainint(ZDIM) != hattr(tem_slab,"z:subdomain")) ) error, "Incompatible ZINT dimension among slabs to be saved"; } } } if (is_present(TDIM) != 0) { if (is_null(time1)) { // T-dimension encountered for first time // Define T dimension (may be unlimited) time1= *(tem_slab.time); ntdim= numberof(time1); if (recflag) ntdim= 0; days_per_year= hattr(tem_slab, "time:days_per_year"); nc_dimvardef, fmeta, std_dims(TDIM), ntdim, "double"; nputatt, tem_slab, HFMT.dimnames(TDIM), fmeta, std_dims(TDIM); if (!is_null(tem_slab.date)) { date1= *(tem_slab.date); if (!param_set(format)) { nvarattdef, tem_slab, fmeta, "date", "double", dimnames=[ std_dims(TDIM) ]; } } // Copy TIME/DATE attributes time_atts= nattlist(tem_slab,"time"); date_atts= nattlist(tem_slab,"date"); } else { // T-dimension encountered previously; check compatibility if (!nattmatch(time_atts, nattlist(tem_slab,"time"))) error, "Incompatible attributes for TIME dimension"; if (!nattmatch(date_atts, nattlist(tem_slab,"date"))) error, "Incompatible attributes for DATE variable"; if (!array_eq(time1, deref(tem_slab.time), epsilon=HFMT.epscoord)) error, "Incompatible T dimension among slabs to be saved"; if (!is_null(date1)) { if (!array_eq(date1, deref(tem_slab.date), epsilon=HFMT.epsdate/max([max(date1),1.0]) )) error, "Incompatible DATE values among slabs to be saved"; } } } if (is_present(IDIM) != 0) { if (is_null(ilabel1)) { // I-dimension encountered for first time if (!is_null(tem_slab.ilabel0)) { // Define ILABEL0 dimension ilabel0= *(tem_slab.ilabel0); nc_dimdef, fmeta, std_dims0(IDIM), numberof(ilabel0); nvarattdef, tem_slab, fmeta, std_dims0(IDIM), "char", dimnames=[ "nchar", std_dims0(IDIM)]; if (!is_null(tem_slab.iparam0)) { iparam0= *(tem_slab.iparam0); nvarattdef, tem_slab, fmeta, "iparam0", "double", dimnames=[ std_dims0(IDIM) ]; } } // Define I dimension (string => character array) ilabel1= *(tem_slab.ilabel); nc_dimdef, fmeta, std_dims(IDIM), numberof(ilabel1); nvarattdef, tem_slab, fmeta, HFMT.dimnames(IDIM), "char", dimnames=[ "nchar", std_dims(IDIM) ]; if (!is_null(tem_slab.iparam)) { iparam1= *(tem_slab.iparam); nvarattdef, tem_slab, fmeta, "iparam", "double", dimnames=[ std_dims(IDIM) ]; } // Copy ILABEL/IPARAM attributes ilabel_atts= nattlist(tem_slab,"ilabel"); iparam_atts= nattlist(tem_slab,"iparam"); } else { // I-dimension encountered previously; check compatibility if (!nattmatch(ilabel_atts, nattlist(tem_slab,"ilabel"))) error, "Incompatible attributes for ILABEL dimension"; if (!nattmatch(iparam_atts, nattlist(tem_slab,"iparam"))) error, "Incompatible attributes for IPARAM variable"; if (!array_eq(ilabel0,deref(tem_slab.ilabel0))) error, "Incompatible ILABEL0 dimension among slabs to be saved"; if (!array_eq(iparam0,deref(tem_slab.iparam0),epsilon=1e-4)) error, "Incompatible IPARAM0 values among slabs to be saved"; if (!array_eq(ilabel1,deref(tem_slab.ilabel))) error, "Incompatible ILABEL dimension among slabs to be saved"; if (!array_eq(iparam1,deref(tem_slab.iparam),epsilon=1e-4)) error, "Incompatible IPARAM values among slabs to be saved"; } } // Data, area weights, Z_BOT dimensions ddim_list= NULL; adim_list= NULL; zdim_list= NULL; original_dims= array("",SDIM); reduction_ops= array("",SDIM); if (ti_transp) { mlist= [XDIM, YDIM, ZDIM, IDIM, TDIM]; } else { mlist= [XDIM, YDIM, ZDIM, TDIM, IDIM]; } for (m2=I0; m2 <= SDIM-I1; m2++) { m= mlist(m2); presence_code= tem_slab.dimension(m,HFMT.data); if (presence_code != 0) { // Dimension is/was present if (abs(presence_code) == 1) { original_dims(m)= std_dims(m); } else { original_dims(m)= int_dims(m); } if (presence_code > 0) { // Dimension is present grow, ddim_list, original_dims(m); if (tem_slab.dimension(m,HFMT.area_wt) > 0) grow, adim_list, original_dims(m); if (tem_slab.dimension(m,HFMT.z_bot) > 0) grow, zdim_list, original_dims(m); } else { // Dimension reduced reduce_code= tem_slab.reduced(m); if (reduce_code < 0) { reduction_ops(m)= HFMT.reduceops(-reduce_code-I1); } else { reduction_ops(m)= strnum(reduce_code); } } } } // Variable name varname= tem_slab.name; // Check for uniqueness of variable name if (strloc(var_list, varname) > 0) error, "Duplicate variable name in hyperslab list - " + varname; // Add variable name to list var_list(jslab)= varname; // Define data variable if (tem_slab.type(HFMT.data) == "struct_instance") error, "Slab "+tem_slab.name+" does not contain actual data"; if (tem_slab.type(HFMT.data) != "complex") { // Real data type nc_vardef, fmeta, varname, tem_slab.type(HFMT.data), dimnames=ddim_list; } else { // Complex data type data_prec= "double" //IDL2YORICK: data_prec= "float" ; nc_vardef, fmeta, varname, data_prec, dimnames=ddim_list; nc_vardef, fmeta, varname+"_im", data_prec, dimnames=ddim_list; } // Save original dimension/reduction operation data attributes nc_attrdef, fmeta, "original_dims", varname, strcombine(original_dims, ","); nc_attrdef, fmeta, "reduction_ops", varname, strcombine(reduction_ops, ","); // Define data attributes nputatt, tem_slab, "data", fmeta, varname; // Copy special global attributes that may be save as data attributes in netCDF for (jatt=I0; jatt <= nattglob-I1; jatt++) { glob_special(jslab,jatt)= hattr(tem_slab, ":"+attglob(jatt)); } if (tem_slab.type(HFMT.area_wt) != "") { // Area weights present if (is_null(area_wt_var)) { if (param_set(format)) { awrite= 0; } else { // Define area weight variable and attributes nc_vardef, fmeta, varname+"_area_wt",tem_slab.type(HFMT.area_wt), dimnames=adim_list; nputatt, tem_slab, "area_wt", fmeta, varname+"_area_wt"; } } else { // Area weights variable name attribute nc_attrdef, fmeta, "area_wt_var", varname, area_wt_var; if (is_null(apresent0)) { apresent0= tem_slab.dimension(,HFMT.area_wt); aw_atts= nattlist(tem_slab,"area_wt"); aelements= hattr( tem_slab, "area_wt:elements" ); area_wt1= deref(tem_slab.area_wt); } else { if ((!array_eq( apresent0, tem_slab.dimension(,HFMT.area_wt)) ) || \ (!nattmatch(aw_atts, nattlist(tem_slab,"area_wt"))) ) error, "Area weights dimensions/attributes are not the same"; if (!param_set(nocheck)) { if (!array_eq(area_wt1, *(tem_slab.area_wt), epsilon=HFMT.epscoord)) error, "Area weight values do not match among all slabs"; } } } } if (tem_slab.type(HFMT.z_bot) != "") { // Z_BOT values present if (is_null(z_bot_var)) { if (param_set(format)) { zwrite= 0; zref= hattr( tem_slab, "z_bot:ref" ); } else { // Define Z_BOT variable and attributes nc_vardef, fmeta, varname+"_z_bot", tem_slab.type(HFMT.z_bot), dimnames=zdim_list; nputatt, tem_slab, "z_bot", fmeta, varname+"_z_bot"; } } else { // Z_BOT variable name attribute nc_attrdef, fmeta, "z_bot_var", varname, z_bot_var; if (is_null(zpresent0)) { zpresent0= tem_slab.dimension(,HFMT.z_bot); zb_atts= nattlist(tem_slab,"z_bot"); zref= hattr( tem_slab, "z_bot:ref" ); z_bot1= deref(tem_slab.z_bot); } else { if ((!array_eq( zpresent0, tem_slab.dimension(,HFMT.z_bot)) ) || \ (!nattmatch(zb_atts, nattlist(tem_slab,"z_bot"))) ) error, "Z_BOT dimensions/attributes are not the same"; if (!param_set(nocheck)) { if (!array_eq(z_bot1, *(tem_slab.z_bot), epsilon=HFMT.epscoord)) error, "Z_BOT values do not match among all slabs"; } } } } } if (!is_null(area_wt_var)) { // Area weights variable iloc= strloc(var_list, area_wt_var); if (iloc == 0) error, "Area weights variable not found among slabs"; tem_slab= nslabarr( iloc, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); awrite= 0; // Determine AREA_WT elements aelements1= hattr(tem_slab, "data:elements"); if (is_null(aelements1)) { if (is_null(aelements)) error, "Area weight elements not available"; aelements1= aelements; nc_attrdef, fmeta, "elements", area_wt_var, aelements1; } if (!is_null(apresent0)) { if ( (!array_eq( apresent0, tem_slab.dimension(,HFMT.data)) ) || \ (!nattmatch(aw_atts, nattlist(tem_slab,"area_wt"))) ) error, "Area weights variable dimensions/attributes do not match"; if (aelements != aelements1) error, "Area weight elements do not match for variable"; if (!param_set(nocheck)) { if (!array_eq(area_wt1, *(tem_slab.data), epsilon=HFMT.epscoord)) error, "Area weights array values do not match variable values"; } } } if (!is_null(z_bot_var)) { // Z_BOT variable iloc= strloc(var_list, z_bot_var); if (iloc == 0) error, "Z_BOT variable not found among slabs"; tem_slab= nslabarr( iloc, slab0, slab1, slab2, slab3, slab4, slab5, slab6, slab7, slab8, slab9 ); zwrite= 0; // Determine Z_BOT reference value zref1= hattr(tem_slab, "data:ref"); if (is_null(zref1)) { if (is_null(zref)) error, "Z_BOT reference value not available"; zref1= zref; nc_attrdef, fmeta, "ref", z_bot_var, zref1; } if (!is_null(zpresent0)) { if ( (!array_eq( zpresent0, tem_slab.dimension(,HFMT.data)) ) || \ (!nattmatch(zb_atts, nattlist(tem_slab,"z_bot"))) ) error, "Z_BOT variable dimensions/attributes do not match"; if (zref != zref1) error, "Z_BOT reference value does not match that of variable"; if (!param_set(nocheck)) { if (!array_eq(z_bot1, *(tem_slab.data), epsilon=HFMT.epscoord)) error, "Z_BOT values do not match variable values"; } } } // Auxiliary date values datevals1= NULL; datevals2= NULL; if (!param_set(format)) { // Copy auxiliary date values if (!is_null(date1)) { datename1= "date"; datevals1= date1; } // Define special global attributes for (jatt=I0; jatt <= nattglob-I1; jatt++) { if (strloc(attfixed,attglob(jatt)) > 0) { // "Fixed" length attribute// pad with spaces, or truncate glob_special(,jatt)= strpad(glob_special(,jatt),HFMT.nchar,truncate=1); } if (alleq(glob_special(,jatt))) { // All values equal; save as global attribute if (glob_special(I0,jatt) != "") { nc_attrdef, fmeta, attglob(jatt), NULL, glob_special(I0,jatt); } } else { // All values not equal; save as variable attribute for (jslab=I0; jslab <= nslab-I1; jslab++) { if (glob_special(jslab,jatt) != "") { nc_attrdef, fmeta, attglob(jatt), var_list(jslab), glob_special(jslab,jatt); } } } } // Define hyperslab global attributes nc_attrdef, fmeta, "hyperslab_vars", NULL, strcombine(var_list,","); if (!ti_transp) nc_attrdef, fmeta, "Convention", NULL, "COARDS"; } else { // Define format specific variables if (strtoupper(format) == "CCM") { // CCM netCDF format if (!is_null(date1)) { // Define date variables datename1= "date"; datename2= "datesec"; nc_vardef, fmeta, datename1, "long", dimnames=[std_dims(TDIM)]; nc_vardef, fmeta, datename2, "long", dimnames=[std_dims(TDIM)]; nc_attrdef, fmeta, "long_name", datename1, "Date (YYYYMMDD)"; nc_attrdef, fmeta, "long_name", datename2, "seconds to complete current date"; // Copy auxiliary date values datevals1= long(date1); datevals2= long(86400.*(date1 - long(date1))); } if (param_set(days_per_year)) { nc_attrdef, fmeta, "Calendar", std_dims(TDIM), strnum(days_per_year)+"_days"; } if (!is_null(hattr(tem_slab,":trunc_n"))) { nc_vardef, fmeta, "ntrn", "long"; nc_vardef, fmeta, "ntrm", "long"; nc_vardef, fmeta, "ntrk", "long"; nc_attrdef, fmeta, "long_name", "ntrn", "spectral truncation parameter N"; nc_attrdef, fmeta, "long_name", "ntrm", "spectral truncation parameter M"; nc_attrdef, fmeta, "long_name", "ntrk", "spectral truncation parameter K"; } if ((numberof(x1) == numberof(x0)) && (!is_null(cosdy0))) { nc_vardef, fmeta, "gw", "double", dimnames=[std_dims(YDIM)]; nc_attrdef, fmeta, "long_name", "gw", "gauss weights"; } if ((numberof(z1) == numberof(z0)) && (!is_null(sigma0))) { nc_vardef, fmeta, "hyam", "double", dimnames=[std_dims(ZDIM)]; nc_vardef, fmeta, "hybm", "double", dimnames=[std_dims(ZDIM)]; nc_attrdef, fmeta, "long_name", "hyam", "hybrid A coefficient at layer midpoints"; nc_attrdef, fmeta, "long_name", "hybm", "hybrid B coefficient at layer midpoints"; } if ((numberof(zint1) == numberof(zint0)) && (!is_null(sigmaint0))) { nc_vardef, fmeta, "hyai", "double", dimnames=[int_dims(ZDIM)]; nc_vardef, fmeta, "hybi", "double", dimnames=[int_dims(ZDIM)]; nc_attrdef, fmeta, "long_name", "hyai", "hybrid A coefficient at layer interfaces"; nc_attrdef, fmeta, "long_name", "hybi", "hybrid B coefficient at layer interfaces"; } if (is_null(zint1) && (!is_null(zint0))) { nc_dimvardef, fmeta, int_dims(ZDIM), numberof(zint0), "double"; nc_attrdef, fmeta, "long_name", int_dims(ZDIM), "layer interfaces"; nc_vardef, fmeta, "hyai", "double", dimnames=[int_dims(ZDIM)]; nc_vardef, fmeta, "hybi", "double", dimnames=[int_dims(ZDIM)]; nc_attrdef, fmeta, "long_name", "hyai", "hybrid A coefficient at layer interfaces"; nc_attrdef, fmeta, "long_name", "hybi", "hybrid B coefficient at layer interfaces"; } if (!is_null(zref)) { nc_vardef, fmeta, "P0", "double"; nc_attrdef, fmeta, "long_name", "P0", "reference pressure"; } } } // End of netCDF file definition fhandle= nc_enddef(fmeta); if (param_set(format)) { // Write format specific variables if (strtoupper(format) == "CCM") { // CCM netCDF format if (!is_null(hattr(tem_slab,":trunc_n"))) { nc_putvar, fhandle, "ntrn", hattr(tem_slab,":trunc_n"); nc_putvar, fhandle, "ntrm", hattr(tem_slab,":trunc_m"); nc_putvar, fhandle, "ntrk", hattr(tem_slab,":trunc_k"); } if ((numberof(x1) == numberof(x0)) && (!is_null(cosdy0))) nc_putvar, fhandle, "gw", cosdy0/a0; if ((numberof(z1) == numberof(z0)) && (!is_null(sigma0))) { nc_putvar, fhandle, "hyam", (sigma0(I0,))(*); nc_putvar, fhandle, "hybm", (sigma0(I0+1,))(*); } if ((numberof(zint1) == numberof(zint0)) && (!is_null(sigmaint0))) { nc_putvar, fhandle, "hyai", (sigmaint0(I0,))(*); nc_putvar, fhandle, "hybi", (sigmaint0(I0+1,))(*); } if (is_null(zint1) && (!is_null(zint0))) { nc_putvar, fhandle, int_dims(ZDIM), zint0; nc_putvar, fhandle, "hyai", (sigmaint0(I0,))(*); nc_putvar, fhandle, "hybi", (sigmaint0(I0+1,))(*); } if (!is_null(zref)) nc_putvar, fhandle, "P0", zref; } } // Write non-record coordinate variables if (!is_null(x1)) nc_putvar, fhandle, std_dims(XDIM), x1; if (!is_null(xint1)) nc_putvar, fhandle, int_dims(XDIM), xint1; if (!is_null(y1)) nc_putvar, fhandle, std_dims(YDIM), y1; if (!is_null(yint1)) nc_putvar, fhandle, int_dims(YDIM), yint1; if (!is_null(z1)) nc_putvar, fhandle, std_dims(ZDIM), z1; if (!is_null(zint1)) nc_putvar, fhandle, int_dims(ZDIM), zint1; if (!is_null(iparam1)) nc_putvar, fhandle, "iparam", iparam1; if (!is_null(x0)) nc_putvar, fhandle, std_dims0(XDIM), x0; if (!is_null(xint0)) nc_putvar, fhandle, int_dims0(XDIM), xint0; if (!is_null(y0)) nc_putvar, fhandle, std_dims0(YDIM), y0; if (!is_null(yint0)) nc_putvar, fhandle, int_dims0(YDIM), yint0; if (!is_null(z0)) nc_putvar, fhandle, std_dims0(ZDIM), z0; if (!is_null(zint0)) nc_putvar, fhandle, int_dims0(ZDIM), zint0; if (!is_null(iparam0)) nc_putvar, fhandle, "iparam0", iparam0; // String variables if (!is_null(ilabel1)) { nc_putvar, fhandle, std_dims(IDIM), ilabel1, nchar=HFMT.nchar; } if (!is_null(ilabel0)) { nc_putvar, fhandle, std_dims0(IDIM), ilabel0, nchar=HFMT.nchar; } //HARD-EXTENSIONS-BEGIN: if (!is_null(a0)) nc_putvar, fhandle, "a0", a0; if (!is_null(eqdx0)) nc_putvar, fhandle, "eqdx0", eqdx0; if (!is_null(eqdxint0)) nc_putvar, fhandle, "eqdxint0", eqdxint0; if (!is_null(cosdy0)) nc_putvar, fhandle, "cosdy0", cosdy0; if (!is_null(cosdyint0)) nc_putvar, fhandle, "cosdyint0", cosdyint0; if (!is_null(sigma0)) nc_putvar, fhandle, "sigma0", sigma0; if (!is_null(sigmaint0)) nc_putvar, fhandle, "sigmaint0", sigmaint0; if (!is_null(hgrid0)) nc_putvar, fhandle, "hgrid0", hgrid0; if (!is_null(kmax0)) nc_putvar, fhandle, "kmax0", kmax0; //HARD-EXTENSIONS-END: // Write other non-record variables nsave, fhandle, slab0, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab1, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab2, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab3, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab4, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab5, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab6, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab7, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab8, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nsave, fhandle, slab9, record=recflag, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; if (!recflag) { // No unlimited dimension if (!is_null(time1)) nc_putvar, fhandle, "time", time1; if (!is_null(datevals1)) nc_putvar, fhandle, datename1, datevals1; if (!is_null(datevals2)) nc_putvar, fhandle, datename2, datevals2; } else { // Unlimited T dimension; write record variables //YORICKbegin: // Set default maximum file size to 1536MB set_filesize, fhandle, 0x60000000 //YORICKend: nt1= numberof(time1); for (k=1; k <= nt1; k++) { //YORICKbegin: // Add records for time dimension nc_addrec, fhandle, time1(k-I1) //YORICKend: // Write time values nc_putvar, fhandle, "time", [time1(k-I1)], offset=[k-1], record=1; // Write date values if (!is_null(datevals1)) nc_putvar, fhandle, datename1, [datevals1(k-I1)],offset=[k-1],record=1; if (!is_null(datevals2)) nc_putvar, fhandle, datename2, [datevals2(k-I1)],offset=[k-1],record=1; if (!param_set(notime)) { // Write record variables nrecord, fhandle, k, slab0, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab1, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab2, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab3, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab4, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab5, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab6, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab7, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab8, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; nrecord, fhandle, k, slab9, k, 1, ti_transp=ti_transp, area_wt=awrite, z_bot=zwrite; } } } // Close netCDF file nc_close, fhandle; // Execute operating system command, if specified if (!is_null(command)) oscommand, command, filename=filename; return timer_return(func_name); } func hset_attr(slab,attribute,value,index=,help=) /* DOCUMENT hset_attr,slab,attribute,value,index=index,help=help * Sets the specified ATTRIBUTE of SLAB to VALUE, * where ATTRIBUTE="varname:attribute_name", or ATTRIBUTE=":attribute_name" * for global attributes. * If SLAB is an array of hyperslabs, and INDEX is specified * SLAB(INDEX) is modified. Otherwise all elements of the slab array are * modified. In this case, value may a scalar or a conformable array. * (The "units" and "long_name" attributes for the five standard dimensions * may be accessed through the array components nattr("units",slab), * and nattr("long_name",slab). The "name", "long_name", "units", * and "missing_value" attributesfor the data may accessed directly as * structure members slab.*) * SEE ALSO: hattr, hadd_attr, hcopy, hget */ { func_name= "hset_attr"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write, "Procedure HSET_ATTR sets the specified ATTRIBUTE of SLAB"; write, "to VALUE, where ATTRIBUTE='varname:attribute_name', || "; write, " ATTRIBUTE=':attribute_name' for global attributes. "; write," E.g.,"; write," hset_attr, slab, ':case_name', 'TEST_CASE'"; write," sets the global attribute 'case_name' to 'TEST_CASE'."; write," See also: hattr, had_attr, hcopy, hget"; write,""; write," Usage: hset_attr, slab,'varname:attribute', value"; return timer_return(func_name); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (is_null(index) && (!is_scalar(slab))) { // Array of hyperslabs; handle recursively if (numberof(value) == 1) { for (j=I0; j <= I0+numberof(slab)-1; j++) { hset_attr, slab, attribute, value(I0), index=j; } } else { if (!dim_conform(dimsof(slab),dimsof(value))) error, "Values array not conformable with slab array"; for (j=I0; j <= I0+numberof(slab)-1; j++) { hset_attr, slab, attribute, value(j), index=j; } } return timer_return(func_name); } // Slab array index if (numberof(slab) > 1) { if (is_null(index)) error, "Index should be specified for an array of hyperslabs"; k1= index; } else { k1= I0; } if (!is_scalar(value)) error, "Attribute value should be scalar"; // Copy attribute list/codes attlist= *(slab(k1).attlist); attcode= *(slab(k1).attcode); // Locate attribute attwhere= where(attlist(I0+2,) == attribute); if (is_where(attwhere)) { attno= attwhere(I0); // Check if "deleted" attribute if (attcode(I0+1,attno) <= 0) error, "Invalid attribute specification '" + attribute + "'"; // Attribute type/index attype= attcode(I0,attno); attinx= attcode(I0+1,attno) - I1; if (attype == 1) { // Integer attribute if (!is_integer(value)) error, "Expecting attribute value of integer type"; (*slab(k1).iatt)(attinx)=value //IDL2YORICK: slab(k1).iatt(attinx)= value ; } else if (attype == 2) { // Float attribute if (!is_number(value)) error, "Expecting attribute value of float type"; (*slab(k1).fatt)(attinx)=value //IDL2YORICK: slab(k1).fatt(attinx)= value ; } else if (attype == 3) { // String attribute if (typeof(value) != "string") error, "Expecting attribute value of string type"; (*slab(k1).satt)(attinx)=value //IDL2YORICK: slab(k1).satt(attinx)= value ; } return timer_return(func_name); } // Special handling for attributes accessible as structure members if (attribute == ":structure") { slab(k1).structure= value; return timer_return(func_name); } nlen= strlen(attribute); if (nlen > 5 ) { if ( (strmid(attribute,0,5) == "data:") && \ anyof(*(HFMT.attdata) == strmid(attribute,5,nlen-5)) ) { // Data attribute accessible as structure member attname= strmid(attribute,5,nlen-5); if (attname == "missing_value") { if (typeof(deref(slab(k1).missing_value)) != typeof(value)) error, "Cannot change type of missing value attribute; use hcopy" slab(k1).missing_value= ref(value); } else if (attname == "name") { slab(k1).name= value; } else if (attname == "long_name") { slab(k1).long_name= value; } else if (attname == "units") { slab(k1).units= value; } else { error, "Internal error 1"; } return timer_return(func_name); } } error, "Invalid attribute specification '" + attribute + "'"; } func hshift( slab, dim, help=, count=, pad=, nohistory=) /* DOCUMENT hshift(slab, dim, help=, count=, * pad=, nohistory=0/1) * HSHIFT shifts the data values in SLAB forward by COUNT grid-points along * dimension DIM. The coordinate values, area weights etc. are not affected. * Negative values of COUNT may be used for backward shifts. * For non-periodic dimensions, one data point will be lost and another will * be duplicated. * SLAB may be an array of hyperslabs. * DIM="x"/"y"/"z"/"t"/"i" => dimension to be re-introduced * * PAD=padding_value may be specified for padded shifts, instead duplicating * the boundary value. * * NOHISTORY==1 disables appending of history information. * SEE ALSO: hregrid, hinterp, hsub */ { func_name= "hshift"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSHIFT shifts data values along selected dimension."; write," E.g.,"; write," new_slab = hshift(slab,'y',count=1)"; write," moves data values forward one grid-point in the Y-grid,"; write," duplicating the first value && discarding the last value."; write," Tips:"; write," 1. Use negative shift counts for reverse shifts."; write," 2. pad=padding_value maybe used for padded shifts"; write," See also: hregrid, hinterp, hsub"; write,""; write," Usage: hshift(slab,'x/y/z/t/i',count=..,pad=..,nohistory=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hshift( slab(j), dim, count=count, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (!is_scalar(dim)) error, "Argument DIM should be a scalar string"; // Determine dimension to be shifted mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; // History string his_str= "<" + slab.name + ">,<" + dim + ">"; // Dimension presence/reduction codes is_present= slab.dimension(,HFMT.data); apresent= slab.dimension(,HFMT.area_wt); zpresent= slab.dimension(,HFMT.z_bot); is_reduced= slab.reduced; if (is_present(mdim-I1) <= 0) error, "Dimension not present in data"; // Periodicity flag periodic= 0; if (mdim == XDIM+I1) { // Check if X-dimension is periodic x_period= hattr(slab, "x:period"); periodic= (x_period != 0.) && (hattr(slab, "x:subdomain") == 0); } // Data type data_type= slab.type(HFMT.data); if (data_type == "LOCATOR") error, "Actual data needs to be present in the slab"; // Copy data data1= *(slab.data); missing_value= deref(slab.missing_value); // Shift count count1= 0; if (!is_null(count)) { count1= count; his_str= his_str + ",count=" + strnum(count1); } if (periodic) { data1= rangeop(data1,"rot",mdim,count=count1); } else { data1= rangeop(data1,"shift",mdim,count=count1,pad=pad); } // Copy slab with new data array new_slab= NULL; hcopy, slab, new_slab, data=data1; if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hshift(" + his_str + ");" } return timer_return(func_name, new_slab); } func hshop( slab, help=, delsq=, m1=, n1=, k1=, vec=, name=, precision=, nohistory=) /* DOCUMENT hshop, slab, help=0/1, delsq=, m1=, n1=, k1=, * vec=0/1, name=, precision=, nohistory=0/1 * HSHOP carries out spherical harmonic operations on hyperslab SLAB. * (If SLAB contains an array of hyperslabs, each element of the array * is operated upon.) * If SLAB contains physical space data, it automatically transformed to * spectral space and back. * * If DELSQ==n (n!=0), (del-squared)^n operation is applied on * a scalar field contained in SLAB. * * M1, N1, K1 specify the pentagonal truncation parameters. * (M1=max zonal wavenumber; N1=max meridional wavenumber for m=0; * K1=max meridional wavenumber for m=M1; * M1=N1=K1 => triangular; N1=K1>M1 => trapezoidal; K1=N1+M1 => rhomboidal) * * VEC==1 specifies that the input field is a vector in physical or spectral * space. * * If NAME is specified, change the variable name in the output slab, * * PRECISION="float"/"double" may be specified to control the data precision * in the output hyperslab(s), if SLAB contains physical space data. * * NOHISTORY==1 disables appending of history information. * SEE ALSO: hshtran, hop */ { func_name= "hshop"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSHOP carries out spherical harmonic operations on hyperslabs."; write," E.g.,"; write," psi_slab = hshop(vor_slab,delsq=-1)"; write," computes inverse Laplacian of VOR_SLAB."; write," Tips:"; write," 1. delsq=n applies del-squared operation on scalar data."; write," 2. m1=... specifies maximum zonal wavenumber."; write," 3. n1=... specifies maximum meridional wavenumber for m=0."; write," 4. k1=... specifies maximum meridional wavenumber for m=M."; write," 5. vec=1 specifies vector field input."; write," 6. precision='float'/'double' determines output precision."; write," See also: hshtran, hop"; write,""; write," Usage: hshop(slab,delsq=n,m1=m1,n1=n1,k1=k1,vec=1,name=,precision='float'/'double')"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; // Check slab structure extlist= strsplit(slab(I0).structure, "_"); if (strloc(extlist,"SSH") == 0) { // Physical space operand; handle recursively return hshtran( hshop( hshtran(slab,vec=vec,spec=1,nohistory=nohistory), delsq=delsq, m1=m1, n1=n1, k1=k1, vec=vec, name=name, nohistory=nohistory), vec=vec, phys=1, precision=precision, nohistory=nohistory); } if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively if ((!is_null(name)) && (numberof(name) != numberof(slab))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hshop(slab(j), delsq=delsq, m1=m1, n1=n1, k1=k1, vec=vec, name=name1, nohistory=nohistory); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } del_flag= param_set(delsq); // History string his_str= "<" + slab.name + ">"; // Dimension presence code is_present= slab.dimension(,HFMT.data); if ((is_present(XDIM) != 1) || (is_present(YDIM) != 1)) error, "Incorrect X/Y dimension for variable "+slab.name; // Dimension/subdomain parameters ddims= hdimsof(slab); trunc_m= ddims(1+XDIM)-1; trunc_n= ddims(1+YDIM)-1; xsubdomain= hattr(slab,"x:subdomain"); ysubdomain= hattr(slab,"y:subdomain"); if ( (xsubdomain < 0) || (xsubdomain > 1) || \ (ysubdomain < 0) || (ysubdomain > 1) ) error, "Cannot transform subdomain in spectral space"; // Determine spectral truncation parameter trunc_k= hattr(slab,":trunc_k"); if (is_null(trunc_k)) error, "Spectral truncation attribute K not defined for variable "+slab(I0).name; if (trunc_k < trunc_n) error, "K truncation value too small"; // Planetary radius a0= slab.a0; // Copy output slab new_slab= NULL; hcopy, slab, new_slab; if (param_set(m1)) { // Change M truncation his_str= his_str + ",m1=" + strnum(m1); m0= trunc_m; trunc_m= m1; if (trunc_m <= m0) { // Truncate M dimension new_slab= hsub(new_slab,limx=[1,trunc_m+1],subscript=1); } else { // Extend M dimension ddims= hdimsof(new_slab); nright= prod(ddims(I0+1:))/(m0+1); data1= *(new_slab.data); reshape_array, data1, [2, m0+1, nright]; data2= array(complex,trunc_m+1, nright); data2(I0:I0+m0,)= data1(,); data1= NULL; ddims(I0+1)= trunc_m+1; reshape_array, data2, ddims; // New coordinate array x1= double(indgen(trunc_m+1)-I0); // New area weights array apresent= array(long,SDIM); zpresent= array(long,SDIM); apresent(XDIM:YDIM)= 1; area_wt1= array(double,trunc_m+1,trunc_n+1); area_wt1(I0,I0:I0+trunc_n)= 1.; for (m=1; m <= trunc_m; m++) { nmmax= trunc_n - m*(trunc_k == trunc_n); for (nm=0; nm <= nmmax; nm++) { area_wt1(I0+m,I0+nm)= 2.; } } hcopy, new_slab, new_slab, overwrite=1, x1=x1, data=data2, area_wt1=area_wt1, area_wt_dims=apresent, z_bot1="", z_bot_dims=zpresent; data2= NULL; } hset_attr, new_slab, "x:upper_bound", double(trunc_m); if (trunc_k != trunc_n) { trunc_k= trunc_n + trunc_m; hset_attr, new_slab, ":trunc_k", trunc_k; } } if (param_set(n1) || param_set(k1)) { // Change N/K truncation n0= trunc_n; k0= trunc_k; if (param_set(n1)) { his_str= his_str + ",n1=" + strnum(n1); trunc_n= n1; } if (param_set(k1)) { his_str= his_str + ",k1=" + strnum(k1); trunc_k= k1; } else { if (trunc_k == n0) trunc_k= trunc_n; } if (trunc_k != trunc_n) { trunc_k= trunc_n + trunc_m; } // Truncate/extend data array ddims= hdimsof(new_slab); nright= prod(ddims(I0+1:))/((trunc_m+1)*(n0+1)); data1= *(new_slab.data); reshape_array, data1, [3, trunc_m+1, n0+1, nright]; data2= array(complex,trunc_m+1, trunc_n+1, nright); if (trunc_n > n0) { data2(,I0:I0+n0,)= data1(,,); } else { data2(,,)= data1(,I0:I0+trunc_n,); } data1= NULL; ddims(I0+2)= trunc_n+1; reshape_array, data2, ddims; // New coordinate array y1= double(indgen(trunc_n+1)-I0); // New area weights array apresent= array(long,SDIM); zpresent= array(long,SDIM); apresent(XDIM:YDIM)= 1; area_wt1= array(double,trunc_m+1,trunc_n+1); area_wt1(I0,I0:I0+trunc_n)= 1.; for (m=1; m <= trunc_m; m++) { nmmax= trunc_n - m*(trunc_k == trunc_n); for (nm=0; nm <= nmmax; nm++) { area_wt1(I0+m,I0+nm)= 2.; } } // Apply area weight mask on data array nmask, data2, (area_wt1 > 0), 2,missing_value=deref(new_slab.missing_value); // Creat modified slab hcopy, new_slab, new_slab, overwrite=1, y1=y1, data=data2, area_wt1=area_wt1, area_wt_dims=apresent, z_bot1="", z_bot_dims=zpresent; data2= NULL; hset_attr, new_slab, "y:upper_bound", double(trunc_n); hset_attr, new_slab, ":trunc_k", trunc_k; } if (param_set(delsq)) { // Del-squared operation his_str= his_str + ",delsq=" + strnum(delsq); // Compute multiplication factor array mnfac= array(double,trunc_m+1,trunc_n+1); for (m=0; m <= trunc_m; m++) { nmmax= trunc_n - m*(trunc_k == trunc_n); for (nm=0; nm <= nmmax; nm++) { if ((nm+m) > 0) { mnfac(I0+m,I0+nm)= (-(nm+m)*(nm+m+1.0)/a0^2)^delsq; } else { mnfac(I0+m,I0+nm)= 0.0; } } } // Apply on data array ddims= hdimsof(new_slab); nleft= ddims(I0+1)*ddims(I0+2); nright= prod(ddims(I0+1:))/nleft; data1= *(new_slab.data); reshape_array, data1, [2, nleft, nright]; for (j=I0; j <= nright-I1; j++) { data1(,j)= data1(,j) * mnfac(*); } reshape_array, data1, ddims; // Create new nyperslab hcopy, new_slab, new_slab, data=data1, overwrite=1; new_slab.units= new_slab.units + " m" + strnum(-2*delsq); data1= NULL; } if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hshop(" + his_str + ");" } if (!is_null(name)) new_slab.name= name; return timer_return(func_name, new_slab); } // -------------------------------------------------------------------- // Local Variables: // mode: text // comment-column: 3 // comment-start: ";; " // comment-start-skip: ";+ *" // fill-column: 75 // End: // -------------------------------------------------------------------- func hshtran( slab, help=, phys=, spec=, grad=, vec=, div=, curl=, preserve=, nlon=, nlat=, name1=, name2=, precision=, nohistory=) /* DOCUMENT hshtran, slab, help=0/1, phys=0/1, spec=0/1, * grad=0/1, vec=0/1, div=0/1, curl=0/1, * preserve=0/1, nlon=, nlat=, * name1=, name2=, precision=, * nohistory=0/1 * HSHTRAN carries out spherical harmonic transforms on SLAB using the * "shtran.i" package. * (If SLAB contains an array of hyperslabs, each element of the array * is transformed.) * * If PHYS==1, the output is in physical (longitude-latitude) space. * If SPEC==1, the output is in spectral (spherical harmonic) space. * One of the above two options must always be specified. * * If GRAD==1, the horizontal gradient vector of the scalar field * contained in SLAB is computed, returning a vector slab. * (If SLAB contains an array of hyperslabs, a new "inner" dimension of * length 2 is added, to represent the vector components.) * * VEC==1 specifies that the input field is a vector in physical or spectral * space. In spectral space, a vector field is always represented by its * (curl, divergence) pair ("Helmholtz decomposition"). * In this case SLAB should be a hyperslab array with an inner dimension of 2, * corresponding to the X/Y vector components in physical space, or * the (curl,divergence) components in spectral space. * (The HGATHER operator may be used to combine hyperslabs.) * * If CURL==1, curl of the vector field is returned, as a scalar. * * If DIV==1, the divergence of the vector field is returned, as a scalar. * * If PRESERVE==1, physical space properties such as the horizontal mask * and grid type are saved as part of the spectral resolution info. * * NLON/NLAT specify the number of longitudes/latitudes on the gaussian grid. * * If NAME1 is specified, change the variable name in the output slab, * appending ("X"/"Y") or ("CURL"/"DIV") suffix for vector components. * If NAME2 is also specified, use (NAME1,NAME2) for vector components. * * PRECISION="float"/"double" may be specified to control the data precision * in the output hyperslab(s). * * NOHISTORY==1 disables appending of history information. * SEE ALSO: hshop, hfft, hgather */ { func_name= "hshtran"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSHTRAN carries out spherical harmonic transforms on hyperslabs."; write," E.g.,"; write," sp_slab = hshtran(slab,spec=1)"; write," transforms physical space SLAB to spectral space."; write," Tips:"; write," 1. phys=1 specifies that output slab should be in physical space."; write," 2. spec=1 specifies that output slab should be in spectral space."; write," 3. grad=1 computes the horizontal gradient, returning a vector."; write," 4. vec=1 specifes vector field input, "; write," either (x,y) components in physical space,"; write," || (curl,divergence) pair in spectral space."; write," 5. curl=1 returns the curl of a vector field as a scalar."; write," 6. div=1 returns the divergence of a vector field as a scalar."; write," 7. preserve=1 preserves physical space mask/grid info."; write," 8. precision='float'/'double' determines output precision."; write," See also: hshop, hfft, hgather"; write,""; write," Usage: hshtran(slab,phys=1,spec=1,grad=1,vec=1,curl=1,div=1,preserve=1,nlon=...,nlat=...,name1=...,name2=...,precision='float'/'double',nohistory=0/1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; phys_flag= param_set(phys); spec_flag= param_set(spec); if ((phys_flag+spec_flag) == 0) error, "One of phys=1/spec=1 options must be specified"; // Vector input flag vecin_flag= param_set(vec); grad_flag= param_set(grad); curl_flag= param_set(curl); div_flag= param_set(div); nop_flag= (grad_flag + curl_flag + div_flag) == 0; // Physical space input operations physin_op= (curl_flag || div_flag); // Spectral space input operations specin_op= grad_flag; // Flag determining whether operator output is in spectral space spout_flag= (nop_flag && spec_flag) || curl_flag || div_flag; // Vector output flag vecout_flag= (nop_flag && vecin_flag) || grad_flag; slabdims= dimsof(slab); if (vecin_flag) { // Vector input if (grad_flag) error, "Cannot compute gradient of vector"; if (curl_flag && div_flag) error, "Cannot compute both curl && divergence"; if (slabdims(I0) == 0) error, "Pair of slabs required for vector input"; if (slabdims(I0+1) != 2) error, "Inner dimension of slab array should be exactly 2"; // Vector output flag vecout_flag= nop_flag; if (vecout_flag) { // Same output dimensions as input dimensions outdims= slabdims; } else { // Scalar output; strip inner dimension if (slabdims(I0) == 1) { outdims=1; } else { outdims= slabdims(I0)-1; grow, outdims, slabdims(I0+2:); } } if (slabdims(I0) > 2) { // Array of paired hyperslabs; handle recursively slab_array= NULL; npairs= numberof(slab)/2; for (k=I0; k <= I0+npairs-1; k++) { j= I0+2*(k-I0); tem_slab= NULL; tem_slab= hshtran(slab(j:j+1), phys=phys, spec=spec, grad=grad, vec=vec, div=div, curl=curl, preserve=preserve, nlon=nlon, nlat=nlat, name1=name1, name2=name2, precision=precision, nohistory=nohistory ); if (vecout_flag) { hgrow, slab_array, tem_slab(I0), j, outdims, destroy=1; hgrow, slab_array, tem_slab(I0+1), j+1, outdims, destroy=1; } else { hgrow, slab_array, tem_slab, k, outdims, destroy=1; } } return timer_return(func_name, slab_array); } // Check conformance of vector components isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, slab, NULL, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; if (!allof(dim_conf(*) == 2)) error, "Dimensions not fully conforming for vector components"; if (!allof(udim_conf(*) == 1)) error, "Dimension units etc. not conforming for vector components"; if (!unit_conf) error, "Data units are different for vector components"; if (slab(I0).structure != slab(I0).structure) error, "Vector components have different structure attribute"; // History string his_str= "<" + slab(I0).name + ":" + slab(I0+1).name + ">"; } else { // Scalar input if (curl_flag || div_flag) error, "Can only compute curl/divergence for vector"; // Vector output flag vecout_flag= grad_flag; if (vecout_flag) { // Introduce inner vector dimension outdims= [slabdims(I0)+1, 2]; if (slabdims(I0) > 0) grow, outdims, slabdims(I0+1:); } else { // Same output dimensions as input dimensions outdims= slabdims; } if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hshtran(slab(j), phys=phys, spec=spec, grad=grad, vec=vec, div=div, curl=curl, preserve=preserve, nlon=nlon, nlat=nlat, name1=name1, name2=name2, precision=precision, nohistory=nohistory ); if (vecout_flag) { hgrow, slab_array, tem_slab(I0), I0+2*(j-I0), outdims, destroy=1; hgrow, slab_array, tem_slab(I0+1), I0+2*(j-I0)+1, outdims,destroy=1; } else { hgrow, slab_array, tem_slab, j, outdims, destroy=1; } } return timer_return(func_name, slab_array); } // History string his_str= "<" + slab.name + ">"; } // Input precision data_type= slab(I0).type(HFMT.data); if (data_type == "LOCATOR") error, "Actual data needs to be present in the slab"; input_prec= ndataprec(data_type); // Output precision output_prec= input_prec; if (!is_null(precision)) output_prec= precision; // Data units units= slab(I0).units; // Check slab structure extlist= strsplit(slab(I0).structure, "_"); iext= strloc(extlist,"SSH"); if (iext > 0) { // Spectral space input if (nop_flag && spec_flag) return timer_return(func_name, slab); // Handle physical space input operations recursively if (physin_op) return hshtran( hshtran(slab,preserve=preserve,phys=1,nohistory=1), phys=phys, spec=spec, grad=grad, vec=vec, div=div, curl=curl, preserve=preserve, nlon=nlon, nlat=nlat, name1=name1, name2=name2, precision=output_prec, nohistory=nohistory); spin_flag= 1; } else { // Physical space input if (nop_flag && phys_flag) return timer_return(func_name, slab); iext= strloc(extlist,"SPH"); if (iext == 0) error, "Unrecognized slab structure attribute: " + slab(I0).structure; spin_flag= 0; // Handle spectral space input operations recursively if (specin_op) return hshtran( hshtran(slab,preserve=preserve,spec=1,nohistory=1), phys=phys, spec=spec, grad=grad, vec=vec, div=div, curl=curl, preserve=preserve, nlon=nlon, nlat=nlat, name1=name1, name2=name2, precision=output_prec, nohistory=nohistory); } // Dimension presence codes is_present= slab(I0).dimension(,HFMT.data); apresent= slab(I0).dimension(,HFMT.area_wt); zpresent= slab(I0).dimension(,HFMT.z_bot); if ((is_present(XDIM) != 1) || (is_present(YDIM) != 1)) error, "Incorrect X/Y dimension for variable "+slab(I0).name; if (apresent(XDIM) != apresent(YDIM)) error, "Incorrect horizontal area weights dimension for variable "+slab(I0).name; if (anyof(apresent(ZDIM:IDIM) != 0)) error, "Non-horizontal area weights dimensions variable "+slab(I0).name; // Horizontal area weights always present in output apresent(XDIM:YDIM)= 1; // No Z_BOT values in output zpresent(*)= 0; // Dimension/subdomain parameters ddims= hdimsof(slab, index=I0); nleft= ddims(I0+1)*ddims(I0+2); nright= prod(ddims(I0+1:))/nleft; xsubdomain= hattr(slab,"x:subdomain",index=I0); ysubdomain= hattr(slab,"y:subdomain",index=I0); // Determine spectral truncation parameters trunc_k= hattr(slab,":trunc_k",index=I0); if (is_null(trunc_k)) error, "Spectral truncation attribute K not defined for variable "+slab(I0).name; if (spin_flag) { // Spectral space slab if ( (xsubdomain < 0) || (xsubdomain > 1) || \ (ysubdomain < 0) || (ysubdomain > 1) ) error, "Cannot transform subdomain in spectral space"; trunc_m= ddims(1+XDIM)-1; trunc_n= ddims(1+YDIM)-1; if (param_set(nlat)) { nlat0= nlat; } else { if (trunc_m >= 2*(trunc_k-trunc_n)) { // Triangular/trapezoidal truncation nlat0= long((3*trunc_k+1)/2 + 0.9999); } else { // Rhomboidal truncation nlat0= long((2*trunc_n+trunc_k+trunc_m+1)/2 + 0.9999); } if ((nlat0 % 2) != 0) nlat0= nlat0 + 1; } if (param_set(nlon)) { nlon0= nlon; } else { if ((trunc_m == trunc_n) && (trunc_n == trunc_k)) { // Triangular truncation nlon0= 2*nlat0; } else { // Rhomboidal/trapezoidal truncation nlon0= long(3*trunc_m+1); if ((nlon0 % 2) != 0) nlon0= nlon0 + 1; } } } else { // Physical space slab if ((xsubdomain != 0) || (ysubdomain != 0)) error, "Cannot transform subdomain in physical space"; xrotated= hattr(slab,"x:rotated",index=I0); if (xrotated != 0) error, "Cannot transform rotated slab; please unrotate" nlon0= long(ddims(1+XDIM)); nlat0= long(ddims(1+YDIM)); trunc_m= hattr(slab,":trunc_m",index=I0); trunc_n= hattr(slab,":trunc_n",index=I0); if (monotonic(*(slab(I0).y)) != 1) error, "Latitude values not in ascending order"; } if (trunc_k < trunc_n) error, "K truncation value too small"; trunc= [nlon0, nlat0, trunc_m, trunc_n, trunc_k]; if (vecin_flag) { trunc2_k= hattr(slab,":trunc_k",index=I0+1); if (is_null(trunc2_k)) error, "Spectral truncation attribute K not defined for variable "+slab(I0+1).name; ddims2= hdimsof(slab, index=I0+1); if (spin_flag) { // Spectral space slab trunc2_m= ddims2(1+XDIM)-1; trunc2_n= ddims2(1+YDIM)-1; nlon2= nlon0; nlat2= nlat0; } else { // Physical space slab nlon2= ddims2(1+XDIM); nlat2= ddims2(1+YDIM); trunc2_m= hattr(slab,":trunc_m",index=I0); trunc2_n= hattr(slab,":trunc_n",index=I0); } trunc2= [nlon2, nlat2, trunc2_m, trunc2_n, trunc2_k]; if (!array_eq(trunc,trunc2)) error, "Vector components have differing spectral truncation"; } // Planetary radius a0= slab(I0).a0; if (spec_flag) his_str= his_str + ",spec=1"; if (phys_flag) his_str= his_str + ",phys=1"; // Check if spectral truncation has been initialized //IDLbegin: //:error, "Spectral transforms module SHTRAN not yet implemented in IDL"; //IDLend: // Initialize list of tables, if necessary if (is_null(HFMT.shtab)) HFMT.shtab= &(array(shtran_struc,2)); shtab= NULL; tabtrunc= array(long,5); shtablist= *(HFMT.shtab); nshtab= numberof(shtablist); for (j=I0; j <= nshtab-I1; j++) { tabtrunc(I0)= shtablist(j).nlon; tabtrunc(I0+1)= shtablist(j).nlat; tabtrunc(I0+2)= shtablist(j).m; tabtrunc(I0+3)= shtablist(j).n; tabtrunc(I0+4)= shtablist(j).k; if (array_eq(trunc, tabtrunc)) shtab= shtablist(j); } if (is_null(shtab)) { // Truncation not yet initalized; replace oldest coefficients with new ones // write, "SHINI:", trunc init= shini(nlon0, nlat0, trunc_m, trunc_n, trunc_k); deglat= (*(init.rlat))*180./pi(); deglon= double(indgen(nlon0)-I0)*360./nlon0; gauss_wt0= *(init.gw); // Delta-X dlon= double(2.0) * pi() / nlon0; // X grid box widths eqdx0= array(double,nlon0); eqdx0(*)= a0 * dlon; // Y grid box widths cosdy0= array(double,nlat0); cosdy0(*)= a0*gauss_wt0; // Compute area weights area_wt0= array(double,nlon0, nlat0); for (k=I0; k <= nlat0-I1; k++) area_wt0(,k)= cosdy0(k)*a0*dlon; // Grid-type mask hgrid0= array(char,nlon0,nlat0); if (param_set(preserve) && (!spin_flag)) { // Preserve mask/grid-type for physical space input slab; adims= hdimsof(slab, area_wt=1, index=I0); if (array_eq(adims, [SDIM, nlon0, nlat0, 1, 1, 1])) { // Copy mask information to area weights area_wt1= *(slab(I0).area_wt); area_wt0(*)= area_wt0(*) * (area_wt1(*) > 0); } if (!is_null(slab(I0).hgrid0)) hgrid0= *(slab(I0).hgrid0); } shtab= shtran_struc(nlon=nlon0,nlat=nlat0,m=trunc_m,n=trunc_n,k=trunc_k, x0=ref(deglon), y0=ref(deglat), eqdx0=ref(eqdx0), cosdy0=ref(cosdy0), area_wt0=ref(area_wt0), hgrid0=ref(hgrid0), init=&(init) ); shtablist(I0+HFMT.ishtab)= shtab; HFMT.ishtab= (HFMT.ishtab + 1) % nshtab; HFMT.shtab= &(shtablist); } // Create output template slab, without data array template= NULL; if (spin_flag == spout_flag) { // Copy with same structure hcopy, slab, template, index1=I0, data=""; } else { // Copy with alternate structure if (spout_flag) { // Coordinate arrays for spectral space slab x1= double(indgen(trunc_m+1)-I0); y1= double(indgen(trunc_n+1)-I0); // "Area weights" area_wt1= array(double,trunc_m+1,trunc_n+1); // CCM3 uses the normalization \int_{-1}^1 P_{mn}^2 d\mu = 1 // (see p. 30 of CCM3 Description Technical Note) // This means that for a field F, the average of F^2 over the globe // will equal 1/2 times the sum of the squared modulus of the // spectral coefficients. Hence the weights below. area_wt1(I0,I0:I0+trunc_n)= 0.5; for (m=1; m <= trunc_m; m++) { nmmax= trunc_n - m*(trunc_k == trunc_n); for (nm=0; nm <= nmmax; nm++) { area_wt1(I0+m,I0+nm)= 1.0; } } hcopy, slab, template, index1=I0, data="", x1=x1, y1=y1, area_wt1=area_wt1, area_wt_dims=apresent, z_bot1="", z_bot_dims=zpresent, structure0="HYPERSLAB1.0_SSH_SIG"; template.a0= a0; hset_attr, template, "area_wt:units", ""; hset_attr, template, ":trunc_k", trunc_k; hset_attr, template, "x:lower_bound", 0.; hset_attr, template, "x:upper_bound", double(trunc_m); hset_attr, template, "y:lower_bound", 0.; hset_attr, template, "y:upper_bound", double(trunc_n); } else { // Coordinate arrays and area weights for physical space slab x1= *(shtab.x0); y1= *(shtab.y0); area_wt1= *(shtab.area_wt0); hcopy, slab, template, index1=I0, data="", x1=x1, x0=x1, y1=y1, y0=y1, area_wt1=area_wt1, area_wt_dims=apresent, z_bot1="", z_bot_dims=zpresent, structure0="HYPERSLAB1.0_SPH_SIG_ATM"; template.a0= a0; template.eqdx0= &(*(shtab.eqdx0)); template.cosdy0= &(*(shtab.cosdy0)); template.hgrid0= &(*(shtab.hgrid0)); hset_attr, template, "area_wt:units", "m^2"; hset_attr, template, ":trunc_m", trunc_m; hset_attr, template, ":trunc_n", trunc_n; hset_attr, template, ":trunc_k", trunc_k; hset_attr, template, "x:lower_bound", 0.; hset_attr, template, "x:upper_bound", 360.; hset_attr, template, "y:lower_bound", -90.; hset_attr, template, "y:upper_bound", 90.; } hset_attr, template, "x:subdomain", 0; hset_attr, template, "y:subdomain", 0; } // Copy data arrays data1in= *(slab(I0).data); if (vecin_flag) data2in= *(slab(I0+1).data); if (!spin_flag) { // Physical space input if (input_prec == "float") { data1in= double(data1in); if (vecin_flag) data2in= double(data2in); } } data1= NULL; data2= NULL; if (grad_flag) { // Gradient of scalar (spectral->physical) his_str= his_str + ",grad=1"; shs2gg, data1in, data1, data2, a=a0, init=*(shtab.init); units= units + " m-1"; } else if (curl_flag) { // Curl of vector (physical->spectral) his_str= his_str + ",curl=1"; shg2sf, data2in, -data1in, data1, a=a0, init=*(shtab.init); units= units + " m-1"; } else if (div_flag) { // Divergence of vector (physical->spectral) his_str= his_str + ",div=1"; shg2sf, data1in, data2in, data1, a=a0, init=*(shtab.init); units= units + " m-1"; } else { // Simple transform operation if (vecin_flag) { // Vector input if (spin_flag) { shs2gv, data1in, data2in, data1, data2, a=a0, init=*(shtab.init); units= units + " m"; } else { shg2sv, data1in, data2in, data1, data2, a=a0, init=*(shtab.init); units= units + " m-1"; } } else { // Scalar input if (spin_flag) { shs2g, data1in, data1, init=*(shtab.init); } else { shg2s, data1in, data1, init=*(shtab.init); } } } data1in= NULL; data2in= NULL; out_slab= NULL; if (vecout_flag) { // Combine output slabs to create vector output if (!spout_flag) { // Physical space output if (output_prec == "float") { data1= float(data1); data2= float(data2); } } tem_slab= NULL; hcopy, template, tem_slab, data=data1; hgrow, out_slab, tem_slab, I0, 2, destroy=1; hcopy, template, tem_slab, data=data2; hgrow, out_slab, tem_slab, I0+1, 2, destroy=1; if (vecin_flag) { out_slab(I0).name= slab(I0).name; out_slab(I0+1).name= slab(I0+1).name; } else { if (spout_flag) { out_slab(I0).name= slab.name+"CURL"; out_slab(I0+1).name= slab.name+"DIV"; } else { out_slab(I0).name= slab.name+"X"; out_slab(I0+1).name= slab.name+"Y"; } } } else { // Scalar output if (!spout_flag) { // Physical space output if (output_prec == "float") data1= float(data1); } hcopy, template, out_slab, data=data1; } // Set units attribute out_slab.units= units; data1= NULL; data2= NULL; if (!param_set(nohistory)) { // Append history info to slab hset_attr, out_slab, "data:history", hattr(out_slab,"data:history") + " hshtran(" + his_str + ");" } // Return output slab (handle phys/spec options recursively) if (spout_flag && phys_flag) return hshtran(out_slab, phys=1, nlon=nlon, nlat=nlat, name1=name1, name2=name2, precision=output_prec, nohistory=1); if ((!spout_flag) && spec_flag) return hshtran(out_slab, spec=1, nlon=nlon, nlat=nlat, name1=name1, name2=name2, precision=output_prec, nohistory=1); if (param_set(name1)) { if (vecout_flag) { if (param_set(name2)) { out_slab(I0).name= name1; out_slab(I0+1).name= name2; } else { if (spout_flag) { out_slab(I0).name= name1+"CURL"; out_slab(I0+1).name= name1+"DIV"; } else { out_slab(I0).name= name1+"X"; out_slab(I0+1).name= name1+"Y"; } } } else { out_slab.name= name1; } } return timer_return(func_name, out_slab); } // -------------------------------------------------------------------- // Local Variables: // mode: text // comment-column: 3 // comment-start: ";; " // comment-start-skip: ";+ *" // fill-column: 75 // End: // -------------------------------------------------------------------- func hsplit( slab, dim, help=) /* DOCUMENT hsplit(slab, dim, help=) * "Splits" all slices along dimension DIM from a scalar hyperslab SLAB * to an array of hyperslabs, returning the array. * DIM="x"/"y"/"z"/"t"/"i" => dimension to be split. * SEE ALSO: hsub, hcat, hgather */ { func_name= "hsplit"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSPLIT creates an array of hyperslabs from a scalar"; write," hyperslab by splitting all slices along a selected dimension."; write," E.g.,"; write," slab_array = hsplit(slab,'i')"; write," splits the I-dimension in SLAB by returning an array of hyperslabs"; write," corresponding to all the slices along the I-dimension."; write," See also: hsub, hcat, hgather"; write,""; write," Usage: hsplit(slab,'x/y/z/t/i')"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) error, "Cannot split dimension in array of hyperslabs"; // Determine dimension to be re-introduced mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; // Coordinate values coord= ngetcoord(slab,mdim); ncoord= numberof(coord); if (ncoord == 0) error, "Dimension not present"; slab_array= NULL; for (j=I0; j <= I0+ncoord-1; j++) { // Extract slice from slab if (mdim == XDIM+I1) { tem_slab= hsub( slab, x=j+I1, subscript=1 ); } else if (mdim == YDIM+I1) { tem_slab= hsub( slab, y=j+I1, subscript=1 ); } else if (mdim == ZDIM+I1) { tem_slab= hsub( slab, z=j+I1, subscript=1 ); } else if (mdim == TDIM+I1) { tem_slab= hsub( slab, t=j+I1, subscript=1 ); } else if (mdim == IDIM+I1) { tem_slab= hsub( slab, i=j+I1, subscript=1 ); } // Append to slab array hgrow, slab_array, tem_slab, j, ncoord, destroy=1; } return timer_return(func_name, slab_array); } func hsprout( slab, dim, help=, crange=, like=, area_wt=, z_bot=,nohistory=) /* DOCUMENT hsprout(slab, dim, help=, like=, crange=, area_wt=0/1, z_bot=0/1, * nohistory=0/1) * Re-introduces (or "sprouts") dimensions in SLAB that were * eliminated by either slicing or rank-reduction. * (SLAB may be an array of hyperslabs.) * DIM="x"/"y"/"z"/"t"/"i" => dimension to be re-introduced (may be an array) * (If DIM is omitted, all reduced dimensions are re-introduced) * CRANGE= Yorick-style index value (1,2,..., or 0,-1,-2,...) to pick * a particular value of the reduced dimension coordinate * or CRANGE="avg", to re-introduce tha average coordinate value, * or CRANGE="all", to re-introduce all coordinate values through broadcasing, * or CRANGE="full", to re-introduce all the full grid coordinate values. * (If CRANGE is not specified, the sliced value of the coordinate is * re-introduced for sliced dimensions, and the first value is re-introduced * for rank-reduced dimensions.) * LIKE=LIKE_SLAB allows the re-introduced coordinate values to be obtained * from LIKE_SLAB. This allows even dimensions that were undefined in SLAB * to be introduced into SLAB. * (CRANGE value may be still be used in this case, but the default is "all") * If AREA_WT==1, the dimension is also introduced for the area weights. * If Z_BOT==1, the dimension is also introduced for the Z_BOT values. * NOHISTORY==1 disables appending of history information. * SEE ALSO: hsub, hcat, hshift */ { func_name= "hsprout"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSPROUT re-introduces selected dimension in hyperslab."; write," E.g.,"; write," new_slab = hsprout(slab,'x')"; write," re-introduces the X dimension in slab."; write," Tips:"; write," 1. crange=/'avg'/'all'/'full' may be used to select the"; write," coordinate value(s) to be re-introduced."; write," 2. like=like_slab re-introduces coordinate values from like_slab."; write," 3. area_wt=1 re-introduces the dimension for area weights as well."; write," 4. z_bot=1 re-introduces the dimension for ZBOT values as well."; write," See also: hsub, hcat, hshift"; write,""; write," Usage: hsprout(slab,'x/y/z/t/i',crange=...,like=like_slab,area_wt=0/1,z_bot=0/1,nohistory=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hsprout( slab(j), dim, crange=crange, like=like, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (is_null(dim)) { // Re-introduce all possible dimensions recursively new_slab= NULL; hcopy, slab, new_slab; for (m=I0; m <= SDIM-I1; m++) { if (slab.dimension(m,HFMT.data) <= 0) { // Reduced/undefined dimension if (is_null(like)) { if (slab.dimension(m,HFMT.data) < 0) new_slab= hsprout( new_slab, HFMT.coordnames(m),crange=crange, like=like, nohistory=nohistory ); } else { if (like.dimension(m,HFMT.data) != 0) new_slab= hsprout( new_slab, HFMT.coordnames(m),crange=crange, like=like, nohistory=nohistory ); } } } return timer_return(func_name, new_slab); } if (!is_scalar(dim)) { // Re-introduce multiple dimensions recursively new_slab= NULL; hcopy, slab, new_slab; for (j=I0; j <= numberof(dim)-I1; j++) { new_slab= hsprout( new_slab, dim(j), crange=crange, like=like, nohistory=nohistory ); } return timer_return(func_name, new_slab); } if (slab.type(HFMT.data) == "LOCATOR") error, "Actual data needs to be present in the slab"; // Determine dimension to be re-introduced mdim= strloc(HFMT.coordnames,dim,case_fold=1); if (mdim == 0) error, "Invalid dimension specification - "+dim; // History string his_str= "<" + slab.name + ">,<" + dim + ">"; // Dimension presence/reduction codes is_present= slab.dimension(,HFMT.data); is_reduced= slab.reduced(*); area_wt_dims= slab.dimension(,HFMT.area_wt); z_bot_dims= slab.dimension(,HFMT.z_bot); if (is_present(mdim-I1) > 0) error, "Dimension already present"; // Get coordinates and alternate coordinates alt_coord= NULL; full_coord= NULL; full_alt= NULL; varlist= NULL; if (!is_null(like)) { // Copy dimension from like slab if (like.dimension(mdim-I1,HFMT.data) == 0) error, "Dimension was never present in like slab"; new_present_code= abs(like.dimension(mdim-I1,HFMT.data)); crange1= "all"; subdomain_code= nattr( "subdomain", like, mdim ); coord= ngetcoord(like, mdim); if (mdim == TDIM+I1) alt_coord= deref(like.date); if (mdim == IDIM+I1) alt_coord= deref(like.iparam); // Variable name list for copying attributes grow, varlist, HFMT.dimnames(mdim-I1); if (!is_null(alt_coord)) grow, varlist, HFMT.dimaltnames(mdim-I1); if (mdim <= ZDIM+I1) { full_coord= ngetcoord(like, mdim, grid=1); full_alt= ngetcoord(like, mdim, grid=2); } else { if (mdim == IDIM+I1) { full_coord= deref(like.ilabel0); full_alt= deref(like.iparam0); } } // Ensure that full domain coordinate values are overwritten if (is_null(full_coord)) { full_coord= ""; if (mdim == IDIM+I1) full_coord= 0; } if (is_null(full_alt)) full_alt= ""; } else { // Re-introduce dimension from same slab if (is_present(mdim-I1) == 0) error, "Dimension was never present"; if (is_reduced(mdim-I1) == 0) error, "Internal error; zero reduction code for reduced dimension" new_present_code= abs(is_present(mdim-I1)); crange1= is_reduced(mdim-I1); if (crange1 < 0) crange1= 1; subdomain_code= nattr( "subdomain", slab, mdim ); coord= ngetcoord(slab, mdim); if (mdim == TDIM+I1) alt_coord= deref(slab.date); if (mdim == IDIM+I1) alt_coord= deref(slab.iparam); } ncoord= numberof(coord); if (ncoord == 0) error, "Internal error; coordinate values not available for dimension" // Override default index value, if specified if (!is_null(crange)) crange1= crange; // Null default value for new alternate coordinate new_alt= NULL; if (typeof(crange1) == "string") { // String index crange2= 0; if (crange1 == "avg") { // Average coordinate value subdomain_code= -1; if (mdim == IDIM+I1) { if (ncoord > 1) { new_coord= [ "" ]; } else { new_coord= coord; } } else { new_coord= [sum(coord)/ncoord]; } if (!is_null(alt_coord)) new_alt= [sum(alt_coord)/ncoord]; } else if (crange1 == "all") { // All coordinate values new_coord= coord; new_alt= alt_coord; } else if (crange1 == "full") { // All full coordinate values subdomain_code= 0; if (is_null(like)) { new_coord= ngetcoord( slab, mdim, full=1); if ((mdim == IDIM+I1) && (!is_null(slab.iparam0))) new_alt= *(slab.iparam0); } else { new_coord= ngetcoord( like, mdim, full=1); if ((mdim == IDIM+I1) && (!is_null(like.iparam0))) new_alt= *(like.iparam0); } if (is_null(new_coord)) error, "Full domain coordinates not available for dimension " + strtoupper(HFMT.coordnames(mdim-I1)); } else { error, "Invalid crange value - " + crange1; } } else { // Numeric index value crange2= crange1; if (crange2 <= 0) crange2= crange2 + ncoord; if ((crange2 < 1) || (crange2 > ncoord)) error, "Invalid crange value " + strnum(crange); if (subdomain_code >= 0) { // Contiguous subdomain; compute new subdomain offset if (subdomain_code == 0) { // Introduce subdomain offset subdomain_code= crange2; } else { // Shift subdomain offset subdomain_code= subdomain_code + (crange2 - 1); } } // Slice coordinates new_coord= [coord(crange2-I1)]; if (!is_null(alt_coord)) new_alt= [alt_coord(crange2-I1)]; } // Ensure that old alternate coordinate values are erased if (is_null(new_alt)) new_alt= ""; // New coordinate count new_count= numberof(new_coord); if (new_count == 0) error, "Coordinate values not available for dimension " + strtoupper(HFMT.coordnames(mdim-I1)); new_data= NULL; new_area_wt= NULL; new_z_bot= NULL; // Re-introduce dimension in data is_present(mdim-I1)= new_present_code; if (new_count > 1) { // Broadcast data dims= hdimsof( slab ); dims(1+mdim-I1)= new_count; new_data= broadcast( *(slab.data), dims ); } if (param_set(area_wt) && (slab.type(HFMT.area_wt) != "")) { // Re-introduce dimension in area weights as well area_wt_dims(mdim-I1)= is_present(mdim-I1); if (new_count > 1) { // Broadcast area weights dims= hdimsof( slab, area_wt=1 ); dims(1+mdim-I1)= new_count; new_area_wt= broadcast( *(slab.area_wt), dims ); } } else { // Eliminate dimension from area weights if ((area_wt_dims(mdim-I1) > 0) && (new_count > 0)) error, "Need to re-introduce dimension in area weights as well"; area_wt_dims(mdim-I1)= 0; } if (param_set(z_bot) && (slab.type(HFMT.z_bot) != "") && \ (mdim != ZDIM+I1) ) { // Re-introduce dimension in Z_BOT array as well z_bot_dims(mdim-I1)= is_present(mdim-I1); if (new_count > 1) { // Broadcast Z_BOT values dims= hdimsof( slab, z_bot=1 ); dims(1+mdim-I1)= new_count; new_z_bot= broadcast( *(slab.z_bot), dims ); } } else { // Eliminate dimension from Z_BOT values if ((z_bot_dims(mdim-I1) > 0) && (new_count > 0)) error, "Need to re-introduce dimension in Z_BOT values as well"; z_bot_dims(mdim-I1)= 0; } // Copy slab, re-introducing dimension new_slab= NULL; if (mdim == XDIM+I1) { hcopy, slab, new_slab, data=new_data, is_present=is_present, x1=new_coord, x0=full_coord, xint0=full_alt, area_wt1=new_area_wt, area_wt_dims=area_wt_dims, z_bot1=new_z_bot, z_bot_dims=z_bot_dims; } else if (mdim == YDIM+I1) { hcopy, slab, new_slab, data=new_data, is_present=is_present, y1=new_coord, y0=full_coord, yint0=full_alt, area_wt1=new_area_wt, area_wt_dims=area_wt_dims, z_bot1=new_z_bot, z_bot_dims=z_bot_dims; } else if (mdim == ZDIM+I1) { hcopy, slab, new_slab, data=new_data, is_present=is_present, z1=new_coord, z0=full_coord, zint0=full_alt, area_wt1=new_area_wt, area_wt_dims=area_wt_dims, z_bot1=new_z_bot, z_bot_dims=z_bot_dims; } else if (mdim == TDIM+I1) { hcopy, slab, new_slab, data=new_data, is_present=is_present, time1=new_coord, date1=new_alt, area_wt1=new_area_wt, area_wt_dims=area_wt_dims, z_bot1=new_z_bot, z_bot_dims=z_bot_dims; } else if (mdim == IDIM+I1) { hcopy, slab, new_slab, data=new_data, is_present=is_present, ilabel1=new_coord, iparam1=new_alt, ilabel0=full_coord, iparam0=full_alt, area_wt1=new_area_wt, area_wt_dims=area_wt_dims, z_bot1=new_z_bot, z_bot_dims=z_bot_dims; } if (!is_null(varlist)) { // Copy all standard coordinate attributes from like slab nvar= numberof(varlist); for (j=I0; j <= nvar-I1; j++) { ncopyatt, varlist(j), like, new_slab; } } // Set new subdomain code for dimension nset_attr, "subdomain", new_slab, mdim, subdomain_code; if (mdim <= ZDIM+I1) { // Reset subdomain bounds for spatial dimensions dimvar= HFMT.dimnames(mdim-I1); hset_attr, new_slab, dimvar+":lower_bound", new_coord(I0); hset_attr, new_slab, dimvar+":upper_bound", new_coord(new_count-I1); } if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hsprout(" + his_str + ");" } return timer_return(func_name, new_slab); } func hsub( slab, help=, limx=, limy=, limz=, limt=, limi=, x=, y=, z=, t=, i=, subscript=, rotx=, sumz=, like=, strip=, hregion=, vregion=, name=, noweight=, nohistory=) /* DOCUMENT hsub( slab, help=help, * limx=, limy=, limz=, limt=, limi=, * x=, y=, z=, t=, i=, subscript=0/1, rotx=, * sumz=0/1, like=, strip=, hregion=, vregion=, * name=, noweight=0/1, nohistory=0/1 ) * * HSUB returns a subdomain of SLAB, applying range-selection, slicing, or * rank-reduction (averaging, summing, ...) * * Input parameters: * slab -- hyperslab data structure * (slab may also be an array of hyperslabs, * in which case an array of subdomain hyperslabs is returned.) * (KEYWORD PARAMETERS) * help -- help option * lim(x/y/z/t/i) -- x/y/z/t/i regular subdomain range selection. * E.g, limx=[xmin,xmax] selects a regular subdomain, or * limx=[xval,xval], or * limx=[xval], select a one-element subdomain * (without reducing the dimension) * (x/y/z/t/i) -- x/y/z/t/i value/rank-reduction selection. * E.g, x=[xval1, xval2, ...] for irregular subdomain, or * x=xval for selecting slices, or * x="avg" or "sum" or "rms" or "min" or "max", * for weighted averaging/summing/RMS-values/extreme values * (NOTE: slicing/rank-reduction reduce dimensionality) * (NOTE: Regular subdomain range selection is done prior to * slicing/irregular-subdomain/rank-reduction opeartions.) * subscript -- subscript specification flag * (if set, assume that integer coordinate values for * coordinate ranges/lists (limx, x, ...) represent array * subscript values, starting from 1, rather than actual * coordinate values; floating point values are still assumed * represent actual coordinate values.) * rotx -- if defined, rotate X-coordinate by angle ROTX * (rotation is done before all subdomain selection operations) * sumz -- carry out summation in Z dimension using Z weights only * like -- another hyperslab data structure * (if this parameter is specified, the subdomain selection/ * rank-reduction parameters determined from this hyperslab) * strip -- list of reduced dimensions to be stripped (e.g. ["x","t","i"]) * hregion -- horizontal subdomain name * vregion -- vertical subdomain name * name -- new name for subdomain data variable * noweight -- if true, do not compute vertical weights for sigma coordinate, * and allow spatial averaging without weights. * nohistory -- if true, do not append history information to hyperslab * * Output: a single hyperlsab data structure of spatial/temporal subdomain, * or an array of hyperslab structures, if SLAB was an array * * SEE ALSO: hget, hmask, hver_wt. hcoord, hinterp, hplot, hop, hcat, hsprout, hcopy */ { func_name= "hsub"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HSUB takes a hyperslab data structure"; write," && returns a hyperslab data structure that corresponds"; write," to a spatial/temporal subdomain of the input data structure."; write," E.g.,"; write," sst_slab = hsub(t_slab, z=0)"; write," returns sst_slab containing sea surface temperature (z=0) values,"; write," assuming t_slab contains 3-dimensional (XYZ) temperature values."; write," If t_slab is actually an array of hyperslab, sst_slab would"; write," also be an array of hyperslabs."; write," Tips:"; write," 1. limx=[lonmin,lonmax], limy=[latmin,latmax], "; write," restricts the x/y coordinate ranges"; write," 2. limz=[maxdepth(m),mindepth(m)]"; write," restricts depth ranges coordinate ranges"; write," 3. limz=[maxpressure(Pa),minpressure(Pa)]"; write," restricts pressure/sigma/hybrid coordinate ranges"; write," 4. limt=[time_min,time_max] "; write," restricts time coordinate range"; write," 5. x=xval selects X slice"; write," 6. x=[xval1,xval2,...] selects irregular X subdomain"; write," 7. (y/z/t/i)=... select irregular Y/Z/t/i subdomains etc."; write," 8. (x/y/z/t/i)='avg' computes weighted average over dimension"; write," 9. (x/y/z/t/i)='sum' computes weighted sum over dimension"; write," 10. (x/y/z/t/i)='rms' computes weighted root-mean-square over dimension"; write," 11. (x/y/z/t/i)='min' computes minimum value over dimension"; write," 12. (x/y/z/t/i)='max' computes minimum value over dimension"; write," 13. subscript=1 allows coordinate ranges/values to be specified using array subscripts (1,2,...)"; write," 14. rotx= rotates X coordinate by "; write," 15. sumz=1 carries out summation in Z dimension using Z weights only"; write," 16. like=old_slab determines subdomain/rank-reduction parameters from another hyperslab"; write," 17. hregion='...', vregion='...' names horizontal/vertical subdomains"; write," 18. strip='x'/'y'/... strips reduced dimensions from slab."; write," 19. name=... specifies the variable name for the result hyperslab."; write," 20. noweight=1 allows averaging without weights"; write," See also: hget, hmask, hver_wt. hcoord, hinterp, hplot, hop, hcat, hsprout, hcopy"; write,""; write," Usage: hsub(slab, lim(x/y/z/t)=[min,max], (x/y/z/t)=[val1,...], rotx=angle, like=old_slab, ..."; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively if ((!is_null(name)) && (numberof(name) != numberof(slab))) error, "Specify name=[name1,name2,...] for hyperslab array"; slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { name1= NULL; if (!is_null(name)) name1= name(j); tem_slab= hsub( slab(j), limx=limx, limy=limy, limz=limz, limt=limt, limi=limi, x=x, y=y, z=z, t=t, i=i, subscript=subscript, rotx=rotx, like=like, strip=strip, hregion=hregion,vregion=vregion, name=name1, noweight=noweight, nohistory=nohistory ); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } // History string his_str= ""; if (slab.type(HFMT.data) == "") error, "No data in slab"; actual_data= (slab.type(HFMT.data) != "struct_instance"); // Copy slab new_slab= NULL; hcopy, slab, new_slab; if (!is_null(name)) { // Change variable name if (!actual_data) error, "name=... option may only be used with actual data in slab"; new_slab.name= name; } // Rotation parameter rotx2= NULL; if (param_set(rotx)) { rotx2= rotx; his_str= his_str + ",rotx=" + strnum(rotx); } limx2= (limy2= (limz2= (limt2= (limi2= NULL)))); if (!is_null(limx)) limx2= limx; if (!is_null(limy)) limy2= limy; if (!is_null(limz)) limz2= limz; if (!is_null(limt)) limt2= limt; if (!is_null(limi)) limi2= limi; // Check if any rank-reduction/slicing/irregular subdomain is requested xred= (yred= (zred= (tred= (ired= NULL)))); xslice= (yslice= (zslice= (tslice= (islice= NULL)))); xsel= (ysel= (zsel= (tsel= (isel= NULL)))); if (!is_null(x)) { if (typeof(x) == "string") { xred= x; } else { if (is_scalar(x) || actual_data) { xslice= x; } else { xsel= x; } } } if (!is_null(y)) { if (typeof(y) == "string") { yred= y; } else { if (is_scalar(y) || actual_data) { yslice= y; } else { ysel= y; } } } if (!is_null(z)) { if (typeof(z) == "string") { zred= z; } else { if (is_scalar(z) || actual_data) { zslice= z; } else { zsel= z; } } } if (!is_null(t)) { if (typeof(t) == "string") { tred= t; } else { if (is_scalar(t) || actual_data) { tslice= t; } else { tsel= t; } } } if (!is_null(i)) { if (typeof(i) == "string") { if (is_scalar(i)) { if (strloc(HFMT.reduceops,i) > 0) { ired= i; } else { islice= i; } } else { if (actual_data) { islice= i; } else { isel= i; } } } else { if (is_scalar(i) || actual_data) { islice= i; } else { isel= i; } } } if (!is_null(like)) { // Copy rank-reduction strings from subdomain slab his_str= his_str + ",like=<" + like.name + ">"; is_present= like.dimension(,HFMT.data); is_reduced= like.reduced(*); if (is_null(x)) { if (is_reduced(XDIM) < 0) xred= HFMT.reduceops(-is_reduced(XDIM)-I1); if (is_reduced(XDIM) > 0) xslice= (ngetcoord(like,XDIM+I1))(is_reduced(XDIM)-I1); } if (is_null(y)) { if (is_reduced(YDIM) < 0) yred= HFMT.reduceops(-is_reduced(YDIM)-I1); if (is_reduced(YDIM) > 0) yslice= (ngetcoord(like,YDIM+I1))(is_reduced(YDIM)-I1); } if (is_null(z)) { if (is_reduced(ZDIM) < 0) zred= HFMT.reduceops(-is_reduced(ZDIM)-I1); if (is_reduced(ZDIM) > 0) zslice= (ngetcoord(like,ZDIM+I1))(is_reduced(ZDIM)-I1); } if (is_null(t)) { if (is_reduced(TDIM) < 0) tred= HFMT.reduceops(-is_reduced(TDIM)-I1); if (is_reduced(TDIM) > 0) tslice= (ngetcoord(like,TDIM+I1,date=1))(is_reduced(TDIM)-I1); } if (is_null(i)) { if (is_reduced(IDIM) < 0) ired= HFMT.reduceops(-is_reduced(IDIM)-I1); if (is_reduced(IDIM) > 0) islice= (ngetcoord(like,IDIM+I1,iparam=1))(is_reduced(IDIM)-I1); } // Copy subdomain ranges from "like" slab if (is_null(limx2) && (nattr("subdomain",like,XDIM+I1) > 0)) { limx2= ndim_bounds(like,XDIM+I1); } if (is_null(limy2) && (nattr("subdomain",like,YDIM+I1) > 0)) { limy2= ndim_bounds(like,YDIM+I1); } if (is_null(limz2) && (nattr("subdomain",like,ZDIM+I1) > 0)) { limz2= ndim_bounds(like,ZDIM+I1); } if (is_null(rotx2) && (new_slab.dimension(XDIM,HFMT.data) > 0)) { // Check rotation state of "like" slab like_rotated= hattr(like, "x:rotated"); nx= numberof(*(like.x)); x_period= hattr(new_slab, "x:period"); if ( (x_period != 0.) && (like_rotated != 0) && (nx > 1) ) { // Rotate X dimension to match "like" slab rotx2= like_rotated*( (*(like.x))(I0+1) - (*(like.x))(I0) ); } } } if (!is_null(rotx2)) { // Carry out X rotation before any subdomain selection operation new_slab= nrotate(new_slab, rotx2); } // Select range subdomains, if requested if (!is_null(limi2)) new_slab= nrange(new_slab, IDIM+I1, limi2, subscript=subscript); if (!is_null(limt2)) new_slab= nrange(new_slab, TDIM+I1, limt2, subscript=subscript); if (!is_null(limz2)) new_slab= nrange(new_slab, ZDIM+I1, limz2, subscript=subscript); if (!is_null(limy2)) new_slab= nrange(new_slab, YDIM+I1, limy2, subscript=subscript); if (!is_null(limx2)) new_slab= nrange(new_slab, XDIM+I1, limx2, subscript=subscript); // Slice/irregular subdomain selection, if requested if (!is_null(islice)) new_slab= nrange(new_slab, IDIM+I1, islice, subscript=subscript, list=1); if (!is_null(tslice)) new_slab= nrange(new_slab, TDIM+I1, tslice, subscript=subscript, list=1); if (!is_null(zslice)) new_slab= nrange(new_slab, ZDIM+I1, zslice, subscript=subscript, list=1); if (!is_null(yslice)) new_slab= nrange(new_slab, YDIM+I1, yslice, subscript=subscript, list=1); if (!is_null(xslice)) new_slab= nrange(new_slab, XDIM+I1, xslice, subscript=subscript, list=1); // Check if any irregular subdomain selection is requested nxsel= (nysel= (nzsel= (ntsel= (nisel= 0)))); nxsel= numberof(xsel); nysel= numberof(ysel); nzsel= numberof(zsel); ntsel= numberof(tsel); nisel= numberof(isel); if ( nxsel+nysel+nzsel+nisel+ntsel > 0 ) { // Select coordinate values by calling HSUB recursively, and concatenate them nxval= max([1, nxsel]); nyval= max([1, nysel]); nzval= max([1, nzsel]); ntval= max([1, ntsel]); nival= max([1, nisel]); xrng= (yrng= (zrng= (trng= (irng= NULL)))); xslabs= NULL; for (ii=I0; ii <= nxval-I1; ii++) { if (nxsel > 0) xrng= [x(ii)]; yslabs= NULL; for (jj=I0; jj <= nyval-I1; jj++) { if (nysel > 0) yrng= [y(jj)]; zslabs= NULL; for (kk=I0; kk <= nzval-I1; kk++) { if (nzsel > 0) zrng= [z(kk)]; islabs= NULL; for (ll=I0; ll <= nival-I1; ll++) { if (nisel > 0) irng= [i(ll)]; tslabs= NULL; for (nn=I0; nn <= ntval-I1; nn++) { if (ntsel > 0) trng= [t(nn)]; // Extract selection sel_slab= hsub(new_slab, limx=xrng, limy=yrng, limz=zrng, limt=trng, limi=irng, subscript=subscript, nohistory=1 ); // Ensure that slab contains actual data (!a data locator) if (sel_slab.type(HFMT.data) == "struct_instance") { sel_slab= hdata(sel_slab); } // Collect T dimension values in an array hgrow, tslabs, sel_slab, nn, ntval, destroy=1; } // Concatenate T dimension to get I slabs sel_slab= ncat(TDIM+I1,tslabs,extend=1); hgrow, islabs, sel_slab, ll, nival, destroy=1; } // Concatenate I dimension to get Z slabs sel_slab= ncat(IDIM+I1,islabs,extend=1); hgrow, zslabs, sel_slab, kk, nzval, destroy=1; } // Concatenate Z dimension to get Y slabs sel_slab= ncat(ZDIM+I1,zslabs,extend=1); hgrow, yslabs, sel_slab, jj, nyval, destroy=1; } // Concatenate Y dimension to get X slabs sel_slab= ncat(YDIM+I1,yslabs,extend=1); hgrow, xslabs, sel_slab, ii, nxval, destroy=1; } // Concatenate X dimension new_slab= ncat(XDIM+I1,xslabs,extend=1); } if (param_set(sumz)) { // Carry out Z-weighted summation; save area weights if (new_slab.type(HFMT.data) == "struct_instance") { // Ensure that slab contains actual data (!a data locator) new_slab= hdata(new_slab); } old_area_wt_units= hattr(new_slab, "area_wt:units"); old_area_wt_elements= hattr(new_slab, "area_wt:elements"); old_area_wt_dims= new_slab.dimension(,HFMT.area_wt); if ( (new_slab.type(HFMT.area_wt) == "") || \ anyof(old_area_wt_dims(ZDIM:IDIM) > 0) || \ (old_area_wt_elements != "dxdy") ) error, "Slab must have 2-D (dxdy) area weights for SUMZ operation"; // Set area weights to unity (non-dimensional) prior to Z summation old_area_wt1= *(new_slab.area_wt); tem_area_wt1= old_area_wt1; tem_area_wt1(*)= (old_area_wt1(*) > 0); hcopy, new_slab, new_slab, overwrite=1, area_wt1=tem_area_wt1; hset_attr, new_slab, "area_wt:units", ""; // Sum data with Z weights new_slab= nreduce(new_slab, ZDIM+I1, "sum", noweight=noweight); // Re-introduce original area weights hcopy, new_slab, new_slab, overwrite=1, area_wt1=old_area_wt1, area_wt_dims=old_area_wt_dims; hset_attr, new_slab, "area_wt:units", old_area_wt_units; hset_attr, new_slab, "area_wt:elements", old_area_wt_elements; } if ( (!is_null(xred)) || (!is_null(yred)) || (!is_null(zred)) || \ (!is_null(tred)) || (!is_null(ired)) ) { // Carry out rank-reduction if (new_slab.type(HFMT.data) == "struct_instance") { // Ensure that slab contains actual data (!a data locator) new_slab= hdata(new_slab); } if (!is_null(xred)) new_slab= nreduce(new_slab, XDIM+I1, xred, noweight=noweight); if (!is_null(yred)) new_slab= nreduce(new_slab, YDIM+I1, yred, noweight=noweight); if (!is_null(zred)) new_slab= nreduce(new_slab, ZDIM+I1, zred, noweight=noweight); if (!is_null(tred)) new_slab= nreduce(new_slab, TDIM+I1, tred, noweight=noweight); if (!is_null(ired)) new_slab= nreduce(new_slab, IDIM+I1, ired, noweight=noweight); } // Set subdomain names, if specified if (!is_null(hregion)) hset_attr, new_slab, ":hor_subdomain", hregion; if (!is_null(vregion)) hset_attr, new_slab, ":ver_subdomain", vregion; if (param_set(strip)) { // Eliminate all trace of specified reduced dimensions // Actual data must be present in slab for stripping dimensions if (new_slab.type(HFMT.data) == "struct_instance") new_slab= hdata(new_slab); is_present= new_slab.dimension(,HFMT.data); apresent= new_slab.dimension(,HFMT.area_wt); zpresent= new_slab.dimension(,HFMT.z_bot); for (j=I0; j <= numberof(strip)-I1; j++) { mdim= strloc(HFMT.coordnames,strip(j),case_fold=1); if (mdim == 0) error, "Invalid dimension to strip - " + strip(j); if (is_present(mdim-I1) > 0) error, "Cannot strip non-reduced dimension - " + strip(j); if (is_present(mdim-I1) < 0) { // Save subdomain information as legend string sublegstr= nsublegend( new_slab, mdim, reduced=1, notime=1 ); if (sublegstr != "") { hset_attr, new_slab, "data:legend", hattr( new_slab, "data:legend" ) + sublegstr; } // Eliminate dimension is_present(mdim-I1)= 0; apresent(mdim-I1)= 0; zpresent(mdim-I1)= 0; } } // Copy stripped slab hcopy, new_slab, new_slab, overwrite=1, is_present=is_present, area_wt_dims=apresent, z_bot_dims=zpresent; } if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hsub(..." + his_str + ");" } // Return hyperslab return timer_return(func_name, new_slab); } func htbin( &fstruc, //YORICKoutput: slab, bin_size, apply=, monthly=, yearly=, overshoot=, crange=, create=, nocheck=, nohistory=) /* DOCUMENT htbin, fstruc, slab, bin_size, * apply=, monthly=0/1, yearly=0/1, overshoot=, * crange=, create=, nocheck=0/1, nohistory=0/1 * "Bin" the time-series contained in SLAB, using BIN_SIZE, by computing * the unweighted average of all values in the bin, and write the output * to the hyperslab netCDF file described by structure FSTRUC. * * NOTE: 1. SLAB need not contain actual data. * 2. The time-averaging is unweighted (unlike the t="avg" operation) * * BIN_SIZE may be a single value, or a list of values, which are used * cyclically. Negative values in a list would correspond to skipped bins. * * If MONTHLY==1, the data are binned as monthly-averages, based on the date * values. * * If YEARLY==1, the data are binned as yearly-averages, based on the date * values. * * If BIN_SIZE is not specified, data is read one record (time-slice) at a * time. Otherwise, an entire bin of data is read in at a time. The former * is a CPU time intensive operation; the latter is a memory intensive * operation. * * (BIN_SIZE may also be specified if MONTHLY/YEARLY==1, allowing for * consistency checks on the date values, and for less CPU intensive * operation.) * * If none of the parameters BIN_SIZE, MONTHLY, or YEARLY are specified, * the time-average of all the data is computed. * * APPLY is the name of a function to apply on each time-slice/bin of SLAB * prior to averaging (actual function name in Yorick; name string in IDL). * * If MONTHLY/YEARLY==1, OVERSHOOT parameter allows for the date values * of samples within a month/year to overshoot to the next month/year * by OVERSHOOT samples. That is, if OVERSHOOT==1, it is assumed that the * last sample for a monthly/yearly dataset is actually marked with the date * for the first day of the *following* month/year. * * CRANGE is a numeric parameter (see HSPROUT for more info) that determines * the time coordinate value to be associated with the bin-average. * * If CREATE="filename" is specified, a new netCDF file is created, and * its structure is returned as FSTRUC. * * If FSTRUC is null, and CREATE is not specified, it is assumed that * FSTRUC is an (output) hyperslab variable that is to be created. * (This would work only if BIN_SIZE is specified.) * * If NOCHECK==1, dimension conformance checking is turned off during * the accumulation calls to the HOP operator. * * SEE ALSO: htwrite */ { func_name= "htbin"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; // No. of slabs nslab= numberof(slab); for (j=I0; j <= nslab-I1; j++) { if (slab(j).dimension(TDIM,HFMT.data) <= 0) error, "T-dimension not present for variable " + slab(j).name; } // Copy time values time0= *(slab(I0).time); if (is_null(slab(I0).date)) { date0= NULL; } else { // Copy date values date0= *(slab(I0).date); deldate= HFMT.epsdate/max(date0); } for (j=I0+1; j <= nslab-I1; j++) { if (!array_eq(*(slab(j).time),time0,epsilon=HFMT.epscoord)) error, "Time values do not match for variable " + slab(j).name; if (!is_null(date0)) { if (!array_eq(*(slab(j).date),date0,epsilon=deldate)) error, "Date values do not match for variable " + slab(j).name; } } // History string his_str= ">"; if (!is_null(bin_size)) his_str= his_str + ",[" + strcombine(strnum(bin_size),",")+"]"; if (param_set(monthly)) his_str= his_str + ",monthly=1"; if (param_set(yearly)) his_str= his_str + ",yearly=1"; if (param_set(nocheck)) his_str= his_str + ",nocheck=1"; if (param_set(overshoot)) his_str= his_str + ",overshoot=" + strnum(overshoot); if (!is_null(crange)) his_str= his_str + ",crange=" + strnum(crange); // Overshoot count iover= 0; if (param_set(overshoot)) iover= overshoot; // Total no. of time values ntime= numberof(time0); // Slab dates array dates= array(double,nslab); // Re-introduced coordinate selection crange1= 1; if (!is_null(crange)) crange1= crange; if (!is_number(crange1)) error, "Only numeric values allowed for CRANGE"; if (param_set(bin_size)) { // Bin sizes specified nbin= numberof(bin_size); ntotbin= sum(abs(bin_size)); // Dry run through loop to determine time/date coordinates ibin0= 0; itime1= 1; time2= NULL; date2= NULL; while (itime1 <= ntime) { if (bin_size(ibin0+I0) > 0) { // Not skipped bin nsize= bin_size(ibin0+I0); if (itime1+nsize-1 > ntime) error, "Incomplete last bin"; // Time and date coordinates tcoord= time0(itime1-I1:itime1-I1+nsize-1); index1= crange1; if (index1 <= 0) index1= index1 + numberof(tcoord); grow, time2, tcoord(index1-I1); if (!is_null(date0)) { datecoord= date0(itime1-I1:itime1-I1+nsize-1); grow, date2, datecoord(index1-I1); ldate= long(datecoord + HFMT.epsdate); // write, ldate if (param_set(monthly) || param_set(yearly)) { if (param_set(monthly)) { // Ensure that all samples fall within the same month datval= (ldate/100) % 100; ndatval= 1 + ((datval(I0)-1) % 12); } else { // Ensure that all samples fall within the same year datval= ldate/10000; ndatval= datval(I0) + 1; } if (iover > 0) { if (!alleq(datval(I0:I0+nsize-1-iover))) { write, ldate(I0:I0+nsize-1-iover); error, "Samples do not fall within same month/year"; } if (!alleq(datval(I0+nsize-iover:I0+nsize-1))) { write, ldate(I0+nsize-iover:I0+nsize-1); error, "Samples do not fall within same month/year"; } if (datval(I0+nsize-1) != ndatval) { write, ldate; error, "Last sample does not fall in next month/year"; } } else { if (!alleq(datval)) { write, ldate; error, "All samples do not fall within same month/year"; } } } } } // Go to next bin, after updating record count itime1= itime1 + abs(bin_size(ibin0+I0)); ibin0= (ibin0 + 1) % nbin; } // Wet run through loop ibin0= 0; itime1= 1; irecord= 0; while (itime1 <= ntime) { if (bin_size(ibin0+I0) > 0) { // Not skipped bin; extract bin slice nsize= bin_size(ibin0+I0); bin_range= [itime1, itime1+nsize-1]; if (!is_null(apply)) { // Function to apply; read all variables together out_slab= hdata( hsub(slab,limt=bin_range,subscript=1, nohistory=1) ); if (!is_null(apply)) { // Apply function on hyperslab array out_slab= apply(out_slab) //IDL2YORICK: out_slab= call_function(apply, out_slab) ; } // Compute time-average out_slab= hsub( out_slab, t="avg", noweight=1, nohistory=1 ); // Re-introduce time dimension out_slab= hsprout( out_slab, "t", crange=crange, nohistory=1 ); } else { // No function to apply; treat each variable separately out_slab= NULL; for (j=I0; j <= nslab-I1; j++) { var_slab= hdata( hsub(slab(j),limt=bin_range,subscript=1, nohistory=1) ); // Compute time-average var_slab= hsub( var_slab, t="avg", noweight=1, nohistory=1 ); // Re-introduce time dimension var_slab= hsprout( var_slab, "t", crange=crange, nohistory=1 ); // Append to output slab array hgrow, out_slab, var_slab, j, dimsof(slab), destroy=1; } } if ((irecord == 0) && (!param_set(nohistory))) { // Append history info to slab for (j=I0; j <= numberof(out_slab)-I1; j++) { hset_attr, out_slab, "data:history", hattr(out_slab,"data:history",index=j) + " htbin(,<" +out_slab(j).name+ his_str + ");",index=j } } // Write bin average, if not skipped bin irecord= irecord + 1; htwrite, irecord, out_slab, fstruc, create=create, time0=time2, date0=date2; } // Go to next bin, after updating record count itime1= itime1 + abs(bin_size(ibin0+I0)); ibin0= (ibin0 + 1) % nbin; } } else { // No bin size specified if (param_set(monthly) || param_set(yearly)) { if (is_null(date0)) error, "Date values not present in slab(s)"; } if (is_null(fstruc) && is_null(create)) error, "Null value for FSTRUC; specify create='filename'" irecord= 0; cur_dat= -1; new_dat= -1; for (itime1=1; itime1 <= ntime+1; itime1++) { if (itime1 <= ntime) { // Get time slice data, reducing time coordinate to single value slice_slab= hdata( hsub(slab,limt=[itime1,itime1],t=1,subscript=1, nohistory=1) ); if (param_set(monthly) || param_set(yearly)) { // Get year/month number ldate= long( (*(slice_slab(I0).date))(I0) + HFMT.epsdate ); if (param_set(monthly)) { // Accumulate samples for the same month new_dat= (ldate/100) % 100; } else { // Accumulate samples for the same year new_dat= ldate/10000; } // Bin change flag if ((itime1 == 1) || (cur_dat == new_dat)) ichange= 0 ; else ichange= ichange+1; // write, ldate, ichange, (ichange > iover) } else { // Bin change flag ichange= 0; } if (!is_null(apply)) { // Apply function on time-slice slice_slab= apply(slice_slab) //IDL2YORICK: slice_slab= call_function(apply, slice_slab) ; } } if ((itime1 == ntime+1) || (ichange > iover)) { // New month/year or last time slice; compute average out_slab= hop( out_slab, "/", count, nocheck=nocheck, nohistory=1 ); // Re-introduce time dimension out_slab= hsprout( out_slab, "t", nohistory=1 ); // Time and date coordinates index1= crange1; if (index1 <= 0) index1= index1 + numberof(tcoord); for (j=I0; j <= numberof(out_slab)-I1; j++) { *out_slab(j).time= tcoord(index1-I1) //IDL2YORICK: out_slab(j).time= tcoord(index1-I1) ; if (!is_null(datecoord)) { *out_slab(j).date= datecoord(index1-I1) //IDL2YORICK: out_slab(j).date= datecoord(index1-I1) ; } } if ((irecord == 0) && (!param_set(nohistory))) { // Append history info to slab for (j=I0; j <= numberof(out_slab)-I1; j++) { hset_attr, out_slab, "data:history", hattr(out_slab,"data:history",index=j) + " htbin(,<" +out_slab(j).name+ his_str + ");",index=j } } // Write bin average irecord= irecord + 1; htwrite, irecord, out_slab, fstruc, create=create; } if (itime1 <= ntime) { if ((itime1 == 1) || (ichange > iover)) { // First slice/change of month/year; start new month/year cur_dat= new_dat; out_slab= slice_slab; count= 1; // Reset time/date arrays tcoord= *(slice_slab(I0).time); datecoord= deref(slice_slab(I0).date); } else { // Accumulate current month/year out_slab= hop( out_slab, "+", slice_slab, nocheck=nocheck, nohistory=1 ); count= count + 1; // Grow time/date arrays grow, tcoord, *(slice_slab(I0).time); if (!is_null(slice_slab(I0).date)) grow, datecoord, *(slice_slab(I0).date); } write, count, *(slice_slab(I0).time); } } } return timer_return(func_name); } func htwrite( itime, slab, &fstruc, //YORICKoutput: create=, time0=, date0=) /* DOCUMENT htwrite, itime, slab, fstruc, create=, time0=, date0= * Writes a time series to a netCDF file described by structure FSTRUC, * one record at a time. * ITIME is the current time index (>=1). * (NOTE: TSWRITE should be called from within a loop over all the time values, * with ITIME starting from 1) * SLAB contains the hyperslab corresponding to time slice ITIME. * (Unit-length T-dimension should be present in the slab.) * * If CREATE="filename" is specified, a new netCDF file is created * on the first call (ITIME==1), and its structure is returned as FSTRUC. * Subsequent calls would append to this file. * * If on the first call FSTRUC is null, and CREATE is not specified, * it is assumed that FSTRUC is an (output) hyperslab variable which * is created on the first call (ITIME==1) with time values TIME0 and * (optional) date values DATE0. * Subsequent calls would insert appropriate time slices into this hypserlab. * SEE ALSO: tsop */ { func_name= "htwrite"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; nslab= numberof(slab); nt0= numberof(time0); if (itime == 1) { // First time if ( (!is_null(create)) || (!is_null(fstruc)) ) { // Write to file happend, fstruc, slab, create=create; return timer_return(func_name); } if (is_null(time0)) error, "TIME0 values must be specified to create slab"; // Not writing to file; create output hyperslab(s) for (j=I0; j <= nslab-I1; j++) { // Create new hyperslab is_present= slab(j).dimension(,HFMT.data); ddims= hdimsof(slab, index=j); if ((is_present(TDIM) <= 0) || (ddims(1+TDIM) != 1)) error, "Unit-length t-dimension not found for variable "+slab(j).name; if (slab(j).type(HFMT.data) == "") error, "Error - null data values"; // Copy hyperslab with extended time dimension tem_slab= NULL; hcopy, slab, tem_slab, index1=j, time1=time0, date1=date0, data="", area_wt1="", z_bot1=""; // Broadcast area weights and Z_BOT values (if present) area_wt1= NULL; if (slab(j).type(HFMT.area_wt) != "") area_wt1= broadcast(*(slab(j).area_wt),hdimsof(tem_slab,area_wt=1)); z_bot1= NULL; if (slab(j).type(HFMT.z_bot) != "") z_bot1= broadcast(*(slab(j).z_bot),hdimsof(tem_slab,z_bot=1)); hcopy, tem_slab, tem_slab, overwrite=1, data=broadcast(*(slab(j).data), hdimsof(tem_slab)), area_wt1=area_wt1, z_bot1=z_bot1; // Copy extended slab hgrow, fstruc, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name); } else { // Subsequent times if (typeof(fstruc) != "struct_instance") error, "Invalid FSTRUC type - " + typeof(fstruc); if (fstruc.structure == "HYPERFILE") { // Append to save file (without checks), and return happend, fstruc, slab, nocheck=1; return timer_return(func_name); } // Not writing to file; insert data in hyperslab(s) for (j=I0; j <= nslab-I1; j++) { // Check hyperslab is_present= slab(j).dimension(,HFMT.data); time1= *(slab(j).time); if ((is_present(TDIM) <= 0) || (numberof(time1) != 1)) error, "Unit-length t-dimension not found for variable "+slab(j).name; if (time1(I0) != (*(fstruc(j).time))(itime-I1)) error, "Time values do not match"; if (slab(j).name != fstruc(j).name) error, "Variable names do not match"; // Copy data time slice (*fstruc(j).data)(,,,itime-I1:itime-I1,)= *slab(j).data //IDL2YORICK: fstruc(j).data(,,,itime-I1:itime-I1,)= slab(j).data ; // Copy area weights/Z_BOT values, if they have the time dimension if (fstruc(j).dimension(TDIM,HFMT.area_wt) > 0) (*fstruc(j).area_wt)(,,,itime-I1:itime-I1,)= *slab(j).area_wt //IDL2YORICK: fstruc(j).area_wt(,,,itime-I1:itime-I1,)= slab(j).area_wt ; if (fstruc(j).dimension(TDIM,HFMT.z_bot) > 0) (*fstruc(j).z_bot)(,,,itime-I1:itime-I1,)= *slab(j).z_bot //IDL2YORICK: fstruc(j).z_bot(,,,itime-I1:itime-I1,)= slab(j).z_bot ; } return timer_return(func_name); } return timer_return(func_name); } func hunfold( slab, help=, time1=, date1=, notranspose=, nohistory=) /* DOCUMENT hunfold, slab, help=, time1=time1, date1=date1, * notranspose=0/1, nohistory=0/1 * Unfolds the I-dimension of "folded" slab into the T-dimension, * returning the unfolded slab. * (HUNFOLD essentially tries to reverse the action of HFOLD.) * * TIME1/DATE1 parameters contains optional arrays of values for the new time * or date coordinate. * * If NOTRANSPOSE==1, do not transpose T/I dimensions. * (The dimensions are transposed by default) * * NOHISTORY==1 disables appending of history information. * SEE ALSO: hfold */ { func_name= "hunfold"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (param_set(help)) { write,""; write," Function HUNFOLD unfolds the I-dimension into the T-dimension,"; write," essentially reversing the action of HFOLD."; write," E.g.,"; write," new_slab = hunfold(slab)"; write," Tips:"; write," 1. time1=[value1,value2,...] specifies the new time coordinate"; write," 2. date1=[value1,value2,...] specifies the new date values"; write," 3. notranspose=1 prevents transposition of T/I dimensions"; write," See also: hfold"; write,""; write," Usage: hunfold(slab,time1=[...],time1=[...],notranspose=1,nohistory=1)"; return timer_return(func_name, NULL); } if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (j=I0; j <= I0+numberof(slab)-1; j++) { tem_slab= NULL; tem_slab= hunfold( slab(j), time1=time1, notranspose=notranspose, nohistory=nohistory); hgrow, slab_array, tem_slab, j, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } if (slab.type(HFMT.data) == "struct_instance") error, "Slab must contain actual data for unfolding"; // History string his_str= "<" + slab.name + ">"; if (param_set(notranspose)) his_str= his_str + ",notranspose=1"; // Copy dimension presence codes is_present= slab.dimension(,HFMT.data); apresent= slab.dimension(,HFMT.area_wt); zpresent= slab.dimension(,HFMT.z_bot); // Check slab dimensionality if (is_present(TDIM) <= 0) error, "Time dimension not present in slab"; if (is_present(IDIM) <= 0) error, "I-dimension not present in slab"; // Old slab dimensions ddims= hdimsof(slab); nt= ddims(1+TDIM); ni= ddims(1+IDIM); // New slab dimensions nt2= nt*ni; newdims= ddims; newdims(1+TDIM)= nt2; newdims(1+IDIM)= 1; t_units= hattr(slab, "time:units"); // ILABEL/IPARAM details ilabel_name= hattr(slab, "ilabel:long_name"); iparam_name= ""; iparam1= deref(slab.iparam); if (!is_null(iparam1)) iparam_name= hattr(slab, "iparam:long_name"); // New time/date coordinate new_t_units= t_units; time2= array(double,nt2); date2= ""; if (!is_null(date1)) { if (numberof(date1) != nt2) error, "Incorrect number of date values specified"; date2= date1; } if (!is_null(time1)) { // Use specified time values if (numberof(time1) != nt2) error, "Incorrect number of time values specified"; time2(*)= time1(*); new_t_units= ""; } else { // Compute new time values time0= *(slab.time); date0= deref(slab.date); if (param_set(notranspose)) { // No transposition of T/I dimensions // Determine total time interval and new time values if (nt > 1) { t_interval= time0(nt-I1) + (time0(I0+1) - time0(I0)); } else { t_interval= time0(I0); } for (j=I0; j <= ni-I1; j++) { it0= I0+(j-I0)*nt; time2(it0:it0+nt-1)= time0(*) + (j-I0)*t_interval; } if ((!is_null(date0)) && is_null(date1) && \ (t_units == "year")) { // Determine date interval and new date values if (nt > 1) { d_interval= double(10000)* (1 + long(date0(nt-I1) - date0(I0))/10000); } else { d_interval= 10000; } date2= array(double,nt2); for (j=I0; j <= ni-I1; j++) { it0= I0+(j-I0)*nt; date2(it0:it0+nt-1)= date0(*) + (j-I0)*d_interval; } } } else { // Transposing T/I dimensions if (iparam_name == "Folding month") { // New time units is month new_t_units= "month"; time2(*)= double(indgen(nt2) - I0); if ((!is_null(date0)) && is_null(date1)) { date2= array(double,nt2); for (j=I0; j <= nt-I1; j++) { ii0= I0 + (j-I0)*ni; date2(ii0:ii0+ni-1)= 10000*(long(date0(j))/10000) + iparam1(*); } } } else if (iparam_name == "Folding time") { // Same time units for (j=I0; j <= nt-I1; j++) { ii0= I0 + (j-I0)*ni; time2(ii0:ii0+ni-1)= time0(j) + iparam1(*); } } else { // Arbitrary new time units new_t_units= ""; time2(*)= double(indgen(nt2) - I0); } } } if ((nt2 > 1) && (monotonic(time2) == 0)) error, "Time coordinate values not monotonic"; // Remove I-dimension from data, tranposing if necessary is_present(IDIM)= 0; data1= *(slab.data); if (!param_set(notranspose)) data1= transpose( data1, [TDIM+I1, IDIM+I1] ); reshape_array, data1, newdims; area_wt1= NULL; if (anyof(apresent(TDIM:IDIM) > 0)) { // Unfold area weights array temdims= hdimsof(slab,area_wt=1); temdims(1+TDIM)= nt; temdims(1+IDIM)= ni; area_wt1= *(slab.area_wt); // Broadcast area weights, if necessary if (!allof(apresent(TDIM:IDIM) > 0)) area_wt1= broadcast(area_wt1, temdims); // Transpose, if necessary if (!param_set(notranspose)) area_wt1= transpose( area_wt1, [TDIM+I1, IDIM+I1] ); // Remove I-dimension and reshape array apresent(IDIM)= 0; temdims(1+TDIM)= nt2; temdims(1+IDIM)= 1; reshape_array, area_wt1, temdims; } z_bot1= NULL; if (anyof(zpresent(TDIM:IDIM) > 0)) { // Unfold Z_BOT array temdims= hdimsof(slab,z_bot=1); temdims(1+TDIM)= nt; temdims(1+IDIM)= ni; z_bot1= *(slab.z_bot); // Broadcast Z_BOT values, if necessary if (!allof(zpresent(TDIM:IDIM) > 0)) z_bot1= broadcast(z_bot1, temdims); // Transpose, if necessary if (!param_set(notranspose)) z_bot1= transpose( z_bot1, [TDIM+I1, IDIM+I1] ); // Remove I-dimension and reshape array zpresent(IDIM)= 0; temdims(1+TDIM)= nt2; temdims(1+IDIM)= 1; reshape_array, z_bot1, temdims; } // Copy unfolded slab, including data, area weight/Z_BOT values/dimensions new_slab= NULL; hcopy, slab, new_slab, data=data1, is_present=is_present, date1=date2, time1=time2, ilabel1="", iparam1="", ilabel0="", iparam0="", area_wt1=area_wt1, area_wt_dims=apresent, z_bot1=z_bot1, z_bot_dims=zpresent; // Reset T-dimension subdomain and units attribute hset_attr, new_slab, "time:subdomain", -1; hset_attr, new_slab, "time:units", new_t_units; if (!param_set(nohistory)) { // Append history info to slab hset_attr, new_slab, "data:history", hattr(new_slab,"data:history") + " hunfold(" + his_str + ",...);" } // Return output slab return timer_return(func_name, new_slab); } func hvecplot( slab_x, slab_y, help=, xskip=, yskip=, hscale=, psbot=, scale=, mag=, width=, color=, angle=, head=, arrow=, refvec=) /* DOCUMENT hvecplot, slab_x, slab_y, help=help, xskip=, yskip=, * scale=, mag=mag, width=, color= * angle, head=, arrow=, refvec= * Overlays vectors (SLAB_X, SLAB_Y) on a prior 2-D plot. * If XSKIP>0, only one of every XSKIP x-grid points is plotted. * If YSKIP>0, only one of every YSKIP y-grid points is plotted. * Parameters HSCALE (density scale height) and PSBOT (surface pressure) * may be specified to convert from pressure to log-pressure height. * The SCALE keyword is the conversion factor from the units of * (VX,VY) to the units of (X,Y) -- a time interval if (VX,VY) is a velocity * and (X,Y) is a position -- which determines the length of the * vector "darts" plotted at the (X,Y) points. If omitted, SCALE is * chosen so that the longest ray arrows have a length comparable * to a "typical" zone size. * The MAG keyword magnifies the arrows (e.g., MAG=2.0 for doubling). * WIDTH controls the line thickness, and COLOR controls the color. * ANGLE is the angle of the arrow head in degrees (defaults to 20 in IDL) * HEAD is the fractional length of the arrow head (defaults to 0.275 in IDL) * ARROW==1 draws Yorick-style arrows (in Yorick only). * REFVEC=[len,x,y] draws a reference arrow of length LEN ending at (X,Y). * SEE ALSO: hplot, vecplot */ { func_name= "hvecplot"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if ((!is_scalar(slab_x)) || (!is_scalar(slab_y))) error, "SLAB_X && SLAB_Y must be scalar hyperslabs"; // Check slab conformance isuperset= (dim_conf= (udim_conf= (unit_conf= NULL))); var_conf= (case_conf= (grid_conf= (domain_conf= NULL))); hconform, slab_y, slab_y, isuperset, dim_conf, udim_conf, unit_conf, var_conf, case_conf, grid_conf, domain_conf; if (anyof(dim_conf != 2)) error, "SLAB_X && SLAB_Y have non-conforming dimensions"; // Determine plot dimensions ddims= hdimsof(slab_x); dimenstr= strtolower(hdimsof(slab_x,name=1)); xscale= 1.0; yscale= 1.0; if (dimenstr == "xy") { nxplot= ddims(1+XDIM); nyplot= ddims(1+YDIM); xcplot= *(slab_x.x); ycplot= *(slab_x.y); if ( (hattr(slab_x,"x:units") == "degrees_east") && \ (hattr(slab_x,"y:units") == "degrees_north") ) { // Spherical geometry } else { if (hattr(slab_x,"x:units") != hattr(slab_x,"y:units")) error, "X && Y coordinates have different units"; } } else if (dimenstr == "yz") { nxplot= ddims(1+YDIM); nyplot= ddims(1+ZDIM); xcplot= *(slab_x.y); ycplot= *(slab_x.z); if (hattr(slab_x,"y:units") == "degrees_north") { // Spherical geometry xscale= 90. / (0.5*pi()*slab_x.a0); yscale= (xcplot(nxplot-I1) - xcplot(I0)) / (ycplot(nyplot-I1) - ycplot(I0)); } else { if (hattr(slab_x,"y:units") != hattr(slab_z,"y:units")) error, "Y && Z coordinates have different units"; } } else { error, "Cannot overlay plot with dimensions-"+dimenstr; } // Copy data arrays and reshape them data_x= *(slab_x.data); data_y= *(slab_y.data); reshape_array, data_x, [2, nxplot, nyplot]; reshape_array, data_y, [2, nxplot, nyplot]; // Check for missing values miss_x= deref(slab_x.missing_value); miss_y= deref(slab_y.missing_value); def_mask= array( char(1), [2,nxplot,nyplot] ); if (!is_null(miss_x)) { where_miss= where(data_x == miss_x); if (is_where(where_miss)) def_mask(where_miss)= 0; } if (!is_null(miss_y)) { where_miss= where(data_y == miss_y); if (is_where(where_miss)) def_mask(where_miss)= 0; } where_miss= where(def_mask == 0); if (is_where(where_miss)) { // Set missing data values to zero data_x(where_miss)= 0.; data_y(where_miss)= 0.; } if (param_set(hscale)) { // Switch to log-pressure height coordinates ps0= max(ycplot); if (param_set(psbot)) ps0= psbot; // Compute log-pressure height values zref= hscale * log(ps0/ycplot); // Convert Z-component of vector from pressure units to height units dzdp= (zref(I0:nyplot-I1-1) - zref(I0+1:nyplot-I1)) / (ycplot(I0+1:nyplot-I1) - ycplot(I0:nyplot-I1-1)); for (j=I0; j <= nyplot-I1; j++) { data_y(,j)= data_y(,j) * dzdp(j); } // Change Z coordinate and scale factor ycplot= zref; yscale= (xcplot(nxplot-I1) - xcplot(I0)) / (ycplot(nyplot-I1) - ycplot(I0)); } // Scale data data_x= data_x * xscale; data_y= data_y * yscale; if (!is_null(refvec)) { refvec1= refvec; refvec1(I0)= refvec1(I0)*xscale; } else { refvec1= NULL; } if (param_set(xskip)) { // Skip grid points in X direction nxnew= 1 + (nxplot-1)/xskip; xcnew= array(xcplot(I0), nxnew); dnew_x= array(data_x(I0), [2,nxnew,nyplot]); dnew_y= array(data_y(I0), [2,nxnew,nyplot]); new_mask= array(def_mask(I0), [2,nxnew,nyplot]); for (j=I0; j <= nxnew-I1; j++) { jold= I0+xskip*(j-I0); xcnew(j)= xcplot(jold); dnew_x(j,)= data_x(jold,); dnew_y(j,)= data_y(jold,); new_mask(j,)= def_mask(jold,); } nxplot= nxnew; xcplot= xcnew; data_x= dnew_x; data_y= dnew_y; def_mask= new_mask; } if (param_set(yskip)) { // Skip grid points in Y direction nynew= 1 + (nyplot-1)/yskip; ycnew= array(ycplot(I0), nynew); dnew_x= array(data_x(I0), [2,nxplot,nynew]); dnew_y= array(data_y(I0), [2,nxplot,nynew]); new_mask= array(def_mask(I0), [2,nxplot,nynew]); for (j=I0; j <= nynew-I1; j++) { jold= I0+yskip*(j-I0); ycnew(j)= ycplot(jold); dnew_x(,j)= data_x(,jold); dnew_y(,j)= data_y(,jold); new_mask(,j)= def_mask(,jold); } nyplot= nynew; ycplot= ycnew; data_x= dnew_x; data_y= dnew_y; def_mask= new_mask; } // Create X-Y mesh //IDLbegin: //:xmesh= xcplot # replicate(1, nyplot); //:ymesh= replicate(1, nxplot) # ycplot; //IDLend: //YORICKbegin: xmesh= xcplot(,-:1:nyplot); ymesh= ycplot(-:1:nxplot,); //YORICKend: // Overlay vectors on mesh fvec, data_y, data_x, ymesh, xmesh, scale=scale, mag=mag, width=width, color=color, angle=angle, head=head, arrow=arrow, refvec=refvec1; return timer_return(func_name); } func hver_wt(slab) /* DOCUMENT hver_wt(slab) * returns a version of hyperslab SLAB with vertical coordinate weights * included, i.e., with AREA_WT_ELEMENTS set to "dxdydz". * (When hyperslabs are created, the vertical coordinate weights are usually * not included.) * SEE ALSO: hsub, hcoord */ { func_name= "hver_wt"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; if (typeof(slab) != "struct_instance") error, "Argument SLAB should be a structure"; if (!is_scalar(slab)) { // Array of hyperslabs; handle recursively slab_array= NULL; for (i=I0; i <= I0+numberof(slab)-1; i++) { tem_slab= NULL; tem_slab= hver_wt( slab(i) ); hgrow, slab_array, tem_slab, i, dimsof(slab), destroy=1; } return timer_return(func_name, slab_array); } // Dimension presence code is_present= slab.dimension(,HFMT.data); // If Z dimension not present, do nothing if (is_present(ZDIM) <= 0) return timer_return(func_name, slab); // Copy area weight units, elements, and dimensions new_area_wt_units= hattr(slab, "area_wt:units"); new_area_wt_elements= hattr(slab, "area_wt:elements"); new_area_wt_dims= slab.dimension(,HFMT.area_wt); // If 3-D weights are already present, do nothing if (new_area_wt_elements == "dxdydz") return timer_return(func_name, slab); if ((slab.type(HFMT.area_wt) == "") || (new_area_wt_elements != "dxdy")) error, "Area weights array (dxdy) required to generate vertical weights"; // Check if Z dimension is already present in area weights z_area_wt= (new_area_wt_dims(ZDIM) > 0); // Dereference area weights area_wt1= *(slab.area_wt); // Determine coordinate precision coord_prec= typeof(area_wt1); if (slab.type(HFMT.z_bot) == "") { // No Z_BOT values available z_bot1= NULL; } else { // Dereference Z_BOT values z_bot1= *(slab.z_bot); z_bot_ref1= typeconv( coord_prec, hattr(slab, "z_bot:ref") ); if (!is_null(slab.missing_value)) { // Set missing bottom Z values to reference bottom value (temporarily) // (This is just for computational convenience to avoid overflows, // because area weights are always zero where bottom Z values are missing.) missing_value= *(slab.missing_value); where_missing= where(z_bot1 == missing_value); if (is_where(where_missing)) z_bot1(where_missing)= z_bot_ref1; } } // Add Z dimension to area weights new_area_wt_dims(ZDIM)= is_present(ZDIM); // Z coordinate z= *(slab.z); nz= numberof(z); // Locate Z offset iz= nattr("subdomain",slab,ZDIM+I1); if (iz < 0) error, "Cannot compute vertical weights for non-contiguous Z subdomain"; if (iz == 0) iz= 1; // Get full domain grid values if (is_null(slab.z0) || is_null(slab.zint0)) error, "Full domain regular/interfacial Z grid not available"; z0= *(slab.z0); zint0= *(slab.zint0); nz0= numberof(z0); nzint0= numberof(zint0); if (nzint0 == 1) error, "Error - cannot compute weights using single interfacial Z-level"; // Sigma coordinate flag sigma_coord= (nattr("units",slab,ZDIM+I1) == "hybrid_sigma_pressure") || \ (nattr("units",slab,ZDIM+I1) == "sigma_level"); if (sigma_coord) { if (is_null(slab.sigma0) || is_null(slab.sigmaint0)) error, "Full domain regular/interfacial sigma values not available"; s0= *(slab.sigma0); sint0= *(slab.sigmaint0); } // Check if Z values are in ascending order ascending= (zint0(I0) < zint0(I0+1)); // Determine index of top level z_positive= hattr(slab,"z:positive"); if (ascending == (z_positive == "up") ) iztop= I0+nz-1 ; else iztop= I0; if (is_present(ZDIM) == 1) { // Data on regular Z grid; get interfacial Z values in full spatial domain if (iz+nz-1 > nzint0-1) error, "Subdomain Z grid extends beyond full domain"; // Compute regular grid weights if (sigma_coord) { ds= sint0(,iz+1-I1:iz+nz-I1) - sint0(,iz-I1:iz+nz-1-I1); } else { dz= zint0(iz+1-I1:iz+nz-I1) - zint0(iz-I1:iz+nz-1-I1); } } else { // Data on interfacial Z grid; get regular Z values in full spatial domain if (nz == 1) error, "Error - cannot compute weights for single interfacial Z-level"; if ((iz+nz-1 > nzint0) || (iz+nz-1 > nz0+1)) error, "Subdomain Z grid extends beyond full domain"; // Compute interfacial grid weights; treat }-points separately if (sigma_coord) { ds= array(double,nz); ds(I0)= s0(iz-I1) - sint0(iz-I1); ds(I0+nz-1)= sint0(iz+nz-1-I1) - s0(iz+nz-2-I1); if (nz >= 3) ds(I0+1:I0+nz-2)= s0(iz+1-I1:iz+nz-2-I1) - s0(iz-I1:iz+nz-3-I1); } else { dz= array(double,nz); dz(I0)= z0(iz-I1) - zint0(iz-I1); dz(I0+nz-1)= zint0(iz+nz-1-I1) - z0(iz+nz-2-I1); if (nz >= 3) dz(I0+1:I0+nz-2)= z0(iz+1-I1:iz+nz-2-I1) - z0(iz-I1:iz+nz-3-I1); } } // If Z values are not in ascending order, flip sign of weights if (!ascending) { if (sigma_coord) ds= -ds ; else dz= -dz; } timer_call,"hver_wt-crit"; //CRITICAL-SECTION-BEGIN: // Create 1D/3D Z values arrays with same precision as the area weights z1= array(area_wt1(I0), nz); z1(*)= z(*); z3= array(area_wt1(I0), [3, 1, 1, nz]); z3(I0,I0,)= z1(*); // Area weight dimensions adims= dim_reshape(dimsof(area_wt1), mindim=5); if (is_null(z_bot1)) { // No bottom Z values available; create 3-D (XYZ) weights array if (sigma_coord) error, "Bottom Z values not available to compute vertical weights"; // New weights dimension (introduce Z dimension, if not already present) new_adims= adims; new_adims(1+ZDIM)= nz; // Broadcast area weights to new dimensions new_area_wt= broadcast( area_wt1, new_adims ); // Focus on Z dimension new_zfocus= dim_reshape( new_adims, focus=3 ); // Reshape new area weights array reshape_array, new_area_wt, new_zfocus; // Multiply "dxdy" by "dz" dz1= z1; dz1(*)= dz(*); for (k=I0; k <= I0+nz-1; k++) { new_area_wt(,k,)= dz1(k)*new_area_wt(,k,); } // Reshape final weights array reshape_array, new_area_wt, new_adims; } else { // Bottom Z values available; get dimensions zbdim= dim_reshape(dimsof(z_bot1), mindim=5); if (z_area_wt) error, "Error - area weights array has Z dimension"; if (!dim_conform(adims, zbdim, broadcast=2)) error, "Error - area weights do not conform to bottom Z values"; // Check Z_BOT dimensions z_bot_dims= slab.dimension(,HFMT.z_bot); if (!array_eq(new_area_wt_dims(XDIM:YDIM), z_bot_dims(XDIM:YDIM))) error, "Horizontal dimensions of area weights && Z_BOT do not match"; if (z_bot_dims(ZDIM) > 0) error, "Error - bottom Z values array has Z dimension"; // Add T/I dimensions to area weights, if need be if (z_bot_dims(TDIM) > 0) new_area_wt_dims(TDIM)= z_bot_dims(TDIM); if (z_bot_dims(IDIM) > 0) new_area_wt_dims(IDIM)= z_bot_dims(IDIM); // Broadcast area weights and bottom Z values to achieve conformance azbdim= dim_reshape( adims, broadcast=zbdim ); area_wt1= broadcast( area_wt1, azbdim ); z_bot1= broadcast( z_bot1, azbdim ); // New weights dimension (introduce Z dimension) new_adims= azbdim; new_adims(1+ZDIM)= nz; // Focus on Z dimension new_zfocus= dim_reshape( new_adims, focus=3 ); nxy= new_zfocus(I0+1); nti= new_zfocus(I0+3); // Reshape/create arrays reshape_array, area_wt1, [2, nxy, nti]; reshape_array, z_bot1, [2, nxy, nti]; new_area_wt= array( area_wt1(I0), new_zfocus ); if (sigma_coord) { // Compute sigma vertical weights to the same precision as area weights da= z1; db= z1; da(*)= ds(I0,); db(*)= ds(I0+1,); // Convert sigma weights to Z weights, and multiply by area weights for (k=I0; k <= I0+nz-1; k++) { new_area_wt(,k,)= area_wt1(,)*( (da(k)*z_bot_ref1) + (db(k)*z_bot1(,)) ); } } else { // Not sigma coordinates dz1= z1; dz1(*)= dz(*); // Combute 3D weights, and set weights "below bottom" to zero if (z_positive == "up") { // Upward Z coordinate for (k=I0; k <= I0+nz-1; k++) { new_area_wt(,k,)= dz1(k)*area_wt1(,)*(z1(k) >= z_bot1(,)); } if (is_present(ZDIM) == 2) { // Interfacial Z grid; handle top level differently new_area_wt(,iztop,)= new_area_wt(,iztop,)* (z1(iztop) > z_bot1(,)); } } else { // Downward Z coordinate for (k=I0; k <= I0+nz-1; k++) { new_area_wt(,k,)= dz1(k)*area_wt1(,)*(z1(k) <= z_bot1(,)); } if (is_present(ZDIM) == 2) { // Interfacial Z grid; handle top level differently new_area_wt(,iztop,)= new_area_wt(,iztop,)* (z1(iztop) < z_bot1(,)); } } } // Reshape final weights array reshape_array, new_area_wt, new_adims; } timer_return,"hver_wt-crit"; //CRITICAL-SECTION-END: // Determine dimensional Z units if (sigma_coord) z_units= hattr(slab, "z_bot:units") ; else z_units= nattr("units",slab,ZDIM+I1); // Append Z units to area weight units/elements if (new_area_wt_units == "") { new_area_wt_units= z_units; } else { new_area_wt_units= new_area_wt_units +" "+ z_units; } new_area_wt_elements= new_area_wt_elements + "dz"; // Copy slab with new area weights new_slab= NULL; hcopy, slab, new_slab, area_wt1=new_area_wt, area_wt_dims=new_area_wt_dims; // Copy area weight unit, elements, dimensions hset_attr, new_slab, "area_wt:units", new_area_wt_units; hset_attr, new_slab, "area_wt:elements", new_area_wt_elements; return timer_return(func_name, new_slab); } func natmfile( fname, fmeta, fhandle, &fstruc, //YORICKoutput: case_name=, z_bot_ref=) /* DOCUMENT natmfile, fname, fmeta, fhandle, fstruc, case_name=, z_bot_ref= * Open an atmospheric netCDF file for reading hyperslabs * * Input parameters: * fname -- new netCDF file name that has been opened by HOPEN * fmeta -- file structure descriptor for reading netCDF file * fhandle -- file handle for reading data from netCDF file * Keyword parameter: * case_name -- if specified, overrides the case name read from the file * z_bot_ref -- if specified, overrides the reference Z_BOT read from the file * Output parameter: * fstruc -- history file data structure * SEE ALSO: hopen, nocnfile, nhyperfile */ { func_name= "natmfile"; timer_call,func_name; // Hyperslab include file // hcom.pro: // Hyperslab include file // Parameters for IDL/Yorick compatibility (including error handling) // Array starting index offset, and final index negative offset // (0, 1 in IDL; 1, 0 in Yorick) I0=1 ; I1=0; // Null value ("" in IDL; [] in Yorick) NULL= []; // Hyperslab COMMON block //IDLbegin: //:common hcom, HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST //IDL-only: //IDLend: //YORICKbegin: extern HFMT, DEFAULT_FILE_STRUC, FILE_HANDLE_LIST; //YORICKend: // Initialize hyperslab format descriptor structure, if necessary if (is_null(HFMT)) ninit; // No. of standard dimensions SDIM= 5; // Indices for the five standard dimensions XDIM=I0+0 ; YDIM=I0+1 ; ZDIM=I0+2 ; TDIM=I0+3 ; IDIM=I0+4; // Seconds per day secpday= 86400.; // Get selected global attributes // Case title case_title0= nc_getattr( fmeta, "", "title" ); if (!is_null(case_title0)) { // Check for special formats if (strlen(case_title0) >= 11) { if (strmid(case_title0,0,11) == "IDEAL2NCDF:") { // IDEAL2NCDF output; call appropriate routine and return nidealfile, fname, fmeta, fhandle, fstruc, case_name=case_name; return timer_return(func_name); } } } // Case name if (is_null(case_name)) { case_name0= nc_getattr( fmeta, "", "case" ); } else { case_name0= case_name; } // Data source data_source0= nc_getattr( fmeta, "", "source" ); // File conventions fconventions= nc_getattr( fmeta, "", "Conventions" ); if (is_null(fconventions)) fconventions= ""; // File type ftype= ""; // Standard/interfacial dimension names std_dims= [ "lon", "lat", "lev", "time", "" ]; int_dims= [ "", "", "ilev", "", "" ]; // Read regular grid coordinate values x0= nc_getvar( fhandle, std_dims(XDIM)); y0= nc_getvar( fhandle, std_dims(YDIM)); z0= nc_getvar( fhandle, std_dims(ZDIM)); time0= nc_unlimited( fhandle ); // Determine coordinate dimensions nx0= numberof(x0); ny0= numberof(y0); nz0= numberof(z0); ntime0= numberof(time0); // Interfacial grid Z coordinate zint_flag= (nc_vartype(fmeta, int_dims(ZDIM)) != ""); if (zint_flag) { zint0= nc_getvar( fhandle, int_dims(ZDIM)); } else { zint0= 0.5*(z0(I0:nz0-I1-1) + z0(I0+1:nz0-I1)); } nzint0= numberof(zint0); // Ensure that all coordinate values are double x0= double(x0); y0= double(y0); z0= double(z0); zint0= double(zint0); time0= double(time0); // Ensure that coordinate variables are indeed 1-D arrays if (is_scalar(x0)) x0= [ x0 ]; if (is_scalar(y0)) y0= [ y0 ]; if (is_scalar(z0)) z0= [ z0 ]; if (is_scalar(zint0)) zint0= [ zint0 ]; if (is_scalar(time0)) time0= [ time0 ]; // Check X/Y coordinate units x_units= strtolower( nc_getattr( fmeta, std_dims(XDIM), "units" ) ); y_units= strtolower( nc_getattr( fmeta, std_dims(YDIM), "units" ) ); if ((x_units != "degrees") && (x_units != "degrees_east")) error, "Unknown X coordinate units - "+x_units; if ((y_units != "degrees") && (y_units != "degrees_north")) error, "Unknown Y coordinate units - "+y_units; // Wrap-around flag wrap_flag= (x0(nx0-I1) > 359.99); if (wrap_flag) { // Discard last X value nx0= nx0-1; x0= x0(I0:nx0-I1); } // Polar points flag poles_flag= ((y0(I0) < -89.99) && (y0(ny0-I1) > 89.99)); // Gaussian flag gaussian_flag= (nc_vartype(fmeta, "gw") != ""); if (gaussian_flag) { // Gaussian weights gaussian_flag= 1; gauss_wt0= nc_getvar( fhandle, "gw" ); } // Spectral grid flag spectral_flag= (nc_vartype(fmeta, "ntrn") != ""); // Determine grid resolution if (spectral_flag) { // Spectral grid ntrm= nc_getvar( fhandle, "ntrm" ); ntrn= nc_getvar( fhandle, "ntrn" ); ntrk= nc_getvar( fhandle, "ntrk" ); resolution0= "T" + strnum(ntrn); if (ntrm != ntrn) resolution0= resolution0 + "M" + strnum(ntrm); if (ntrk != ntrn) resolution0= resolution0 + "K" + strnum(ntrk); } else { // Not spectral grid resolution0= strnum(nx0)+"x"+strnum(ny0); } // Z coordinate attributes z_long_name= nc_getattr( fmeta, std_dims(ZDIM), "long_name" ); z_units= nc_getattr( fmeta, std_dims(ZDIM), "units" ); if (is_null(z_long_name)) z_long_name= ""; if (is_null(z_units)) z_units= ""; // Does Z coordinate increase upward? z_positive= nc_getattr( fmeta, std_dims(ZDIM), "positive" ); if (is_null(z_positive)) {