[ncl-talk] segmentation fault while using gsm_csn_xy
Zhifeng Yang
yangzf01 at gmail.com
Fri Apr 27 15:01:29 MDT 2018
Hi all,
I got a segmentation fault error while executing the following statement
calling from gsn_code.ncl
plot_object = create wksname + "_xy" xyPlotClass wks
"xyCoordData" : data_object
Here is the exact error.
Segmentation fault (core dumped)
The NCL version is 6.3.0. I also attached the ncl code and data. The main
code is "arm_sgp_trend_line_diurnal.ncl", and subroutine is
"plot_arm_sgp_trend_line_diurnal.ncl".
and also the log file using "ncl -x code.ncl" (file name is ncl_x_code.txt)
Best,
Zhifeng
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mailman.ucar.edu/pipermail/ncl-talk/attachments/20180427/6a2fba37/attachment-0001.html>
-------------- next part --------------
Copyright (C) 1995-2015 - All Rights Reserved
University Corporation for Atmospheric Research
NCAR Command Language Version 6.3.0
The use of this software is governed by a License Agreement.
See http://www.ncl.ucar.edu/ for more details.
+ ;
+ ; $Id: gsn_code.ncl,v 1.238.4.3 2010-05-06 17:13:26 haley Exp $
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ; ;
+ ; Copyright (C) 1998 ;
+ ; University Corporation for Atmospheric Research ;
+ ; All Rights Reserved ;
+ ; ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;
+ ;; File: gsn_code.ncl
+ ;;
+ ;; Author: Mary Haley
+ ;; National Center for Atmospheric Research
+ ;; PO 3000, Boulder, Colorado
+ ;;
+ ;; Date: Sat Apr 11 12:42:53 MST 1998
+ ;;
+ ;; Description: This script defines all of the basic plotting and
+ ;; miscellaneous functions and procedures used in the
+ ;; examples in the "Getting started using NCL" documention.
+ ;; The URL for this document is:
+ ;;
+ ;; http://www.ncl.ucar.edu/Document/Manuals/Getting_Started/
+ ;;
+ ;; To use the functions and procedures in this script,
+ ;; you must have the line:
+ ;;
+ ;; load "gsn_code.ncl"
+ ;;
+ ;; at the top of your NCL script, before the begin statement.
+ ;;
+
+ ;***********************************************************************;
+ ; function : smooth92d ;
+ ; var[*][*]:float ;
+ ; p:float ;
+ ; q:float ;
+ ; ;
+ ; Performs smoothing on a 2-dimensional array. ;
+ ; ;
+ ;***********************************************************************;
+ undef("smooth92d")
+ function smooth92d(var[*][*]:float,p[1]:float,q[1]:float)
+ local dims,output,coef,m,n,p4,q4,i
+ begin
+ dims = dimsizes(var)
+ output = new((/dims(0),dims(1)/),float)
+
+ coef = 1 - p - q
+ m = dims(0)
+ n = dims(1)
+ p4 = p/4.0
+ q4 = q/4.0
+
+ do i = 1, m -2
+ output(i,1:n-2) = (p4)*(var( i-1, 1 : n-2 ) + var( i, 2 : n-1) +
+ var( i+1, 1 : n-2) + var( i, 0 : n-3)) +
+ (q4)*(var(i-1, 0 : n-3 ) + var(i-1, 2 : n-1) +
+ var( i+1, 2 : n-1) + var( i+1, 0 : n-3))
+ end do
+
+ output = output + (coef * var)
+
+ if(isdimnamed(var,0).and.iscoord(var,var!0)) then
+ output!0 = var!0
+ output&$var!0$ = var&$var!0$
+ end if
+
+ if(isdimnamed(var,1).and.iscoord(var,var!1)) then
+ output!1 = var!1
+ output&$var!1$ = var&$var!1$
+ end if
+
+ return(output)
+ end
+
+ ;***********************************************************************;
+ ; function : smooth93d ;
+ ; var[*][*][*]:float ;
+ ; p:float ;
+ ; q:float ;
+ ; ;
+ ; Performs smoothing on a 3-dimensional array. ;
+ ; ;
+ ;***********************************************************************;
+ undef("smooth93d")
+ function smooth93d(var[*][*][*]:float,p[1]:float,q[1]:float)
+ local dims,output,coef,m,n,p4,q4,i
+ begin
+ dims = dimsizes(var)
+
+ output = new((/dims(0),dims(1),dims(2)/),float)
+
+ coef = 1 - p - q
+ m = dims(1)
+ n = dims(2)
+ p4 = p/4.0
+ q4 = q/4.0
+
+ do i = 1, m -2
+ output(:,i,1:n-2) = (p4)*(var( :,i-1, 1 : n-2 ) + var(:, i, 2 : n-1) +
+ var( :,i+1, 1 : n-2) + var(:, i, 0 : n-3)) +
+ (q4)*(var( :,i-1, 0 : n-3 ) + var( :,i-1, 2 : n-1) +
+ var( :,i+1, 2 : n-1) + var(:, i+1, 0 : n-3))
+ end do
+
+ output = output + (coef * var)
+
+ if(isdimnamed(var,0).and.iscoord(var,var!0)) then
+ output!0 = var!0
+ output&$var!0$ = var&$var!0$
+ end if
+
+ if(isdimnamed(var,1).and.iscoord(var,var!1)) then
+ output!1 = var!1
+ output&$var!1$ = var&$var!1$
+ end if
+ if(isdimnamed(var,2).and.iscoord(var,var!2)) then
+ output!2 = var!2
+ output&$var!2$ = var&$var!2$
+ end if
+
+ return(output)
+ end
+
+ ;***********************************************************************;
+ ; function : hsv2rgb ;
+ ; h:float ;
+ ; s:float ;
+ ; v:float ;
+ ; ;
+ ; Note: after V4.3.1, the built-in function hsvrgb was added. This ;
+ ; should be used instead of this one. ;
+ ; ;
+ ; This function maps values from the HSV color model to the RGB color ;
+ ; model. HSV is a good model for generating smooth color maps. See ;
+ ; (Computer Graphics: Principles and Practice by Foley). The return ;
+ ; value is a 2 dimensional array of rgb color triplets. The return ;
+ ; value from this function can be directly assigned to the "wkColorMap" ;
+ ; resource of a workstation object or to the second argument of ;
+ ; gsn_define_colormap. ;
+ ; ;
+ ;***********************************************************************;
+ undef("hsv2rgb")
+ function hsv2rgb (h_old[*]:float,s_old[*]:float,v_old[*]:float)
+ begin
+ ;
+ ; Make a backup copy of the HSV values.
+ ;
+ h = h_old
+ s = s_old
+ v = v_old
+ ;
+ ; This function converts between HSV and RGB color space
+ ; Input: h [0.0-360.0], s [0.0-1.0], v [0.0-1.0]
+ ; Output: r [0.0-1.0], g [0.0-1.0], b [0.0-1.0]
+ ;
+ r_g_b = new((/3,dimsizes(h)/),float)
+ r_g_b!0 = "rgb"
+ r_g_b!1 = "cmap_len"
+
+ if (any((s .eq. 0.0).and.(h.eq.0.0.or.h.eq.360))) then
+ indexs = ind((h.eq.0.0.or.h.eq.360).and.s.eq.0.0)
+ r_g_b(:,indexs) = (/v(indexs),v(indexs),v(indexs)/)
+ delete(indexs)
+ end if
+
+ f = new(dimsizes(h),float)
+ p = new(dimsizes(h),float)
+ q = new(dimsizes(h),float)
+ t = new(dimsizes(h),float)
+ i = new(dimsizes(h),integer)
+ if any(h.eq.360.0)
+ h(ind(h.eq.360.0)) = 0.0
+ end if
+
+ h = h/60.0
+ i = floattoint(floor(h))
+ f = h - i
+ p = v*(1.0 - s)
+ q = v*(1.0 - (s*f))
+ t = v*(1.0 - (s*(1.0 - f)))
+ if any(i.eq.0) then
+ indexs = ind(i.eq.0)
+ r_g_b(:,indexs) = (/v(indexs),t(indexs),p(indexs)/)
+ delete(indexs)
+ end if
+ if any(i.eq.1) then
+ indexs = ind(i.eq.1)
+ r_g_b(:,indexs) = (/q(indexs),v(indexs),p(indexs)/)
+ delete(indexs)
+ end if
+ if any(i.eq.2) then
+ indexs = ind(i.eq.2)
+ r_g_b(:,indexs) = (/p(indexs),v(indexs),t(indexs)/)
+ delete(indexs)
+ end if
+ if any(i.eq.3) then
+ indexs = ind(i.eq.3)
+ r_g_b(:,indexs) = (/p(indexs),q(indexs),v(indexs)/)
+ delete(indexs)
+ end if
+ if any(i.eq.4) then
+ indexs = ind(i.eq.4)
+ r_g_b(:,indexs) = (/t(indexs),p(indexs),v(indexs)/)
+ delete(indexs)
+ end if
+ if any(i.eq.5) then
+ indexs = ind(i.eq.5)
+ r_g_b(:,indexs) = (/v(indexs),p(indexs),q(indexs)/)
+ delete(indexs)
+ end if
+ if(any(ismissing(r_g_b)))
+ print("Warning: hsv2rgb: Some invalid HSV values were passed to hsv2rgb")
+ end if
+ return(r_g_b(cmap_len
+ end
+
+
+ ;***********************************************************************;
+ ; function : tofloat_wunits ;
+ ; x:numeric ;
+ ; ;
+ ; Convert input to float and retain units attribute. ;
+ ; ;
+ ; Note that after V5.1.1, a built-in version of "tofloat" was added. ;
+ ; ;
+ ;***********************************************************************;
+ undef("tofloat_wunits")
+ function tofloat_wunits(x:numeric)
+ local xf
+ begin
+ xf = tofloat(x)
+ if(isatt(x,"units").and..not.isatt(xf,"units")) then
+ xf at units = x at units
+ end if
+ return(xf)
+ end
+
+ ;***********************************************************************;
+ ; function : stringtoxxx ;
+ ; str : string ;
+ ; type: string ;
+ ; ;
+ ; Convert string to int, float or double, depending on type ;
+ ; ;
+ ;***********************************************************************;
+ undef("stringtoxxx")
+ function stringtoxxx(str:string,type:string)
+ begin
+ if(type.eq."double")
+ return(stringtodouble(str))
+ else
+ if(type.eq."float")
+ return(stringtofloat(str))
+ else
+ if(type.eq."integer")
+ return(stringtointeger(str))
+ end if
+ end if
+ end if
+ return(str)
+ end
+
+ ;***********************************************************************;
+ ; Function : lower_case ;
+ ; name : string ;
+ ; ;
+ ; Converts "name" to lowercase. Uses "str_lower" now. ;
+ ;***********************************************************************;
+ undef("lower_case")
+ function lower_case(name:string)
+ begin
+ return(str_lower(name))
+ end
+
+
+ ;***********************************************************************;
+ ; Function : get_long_name_units_string ;
+ ; data : numeric ;
+ ; ;
+ ; This function checks if the long_name and units attributes exist, and ;
+ ; if so, constructs a string using them. A missing value is returned ;
+ ; otherwise. ;
+ ;***********************************************************************;
+ undef("get_long_name_units_string")
+ function get_long_name_units_string(data)
+ begin
+ lu_string = new(1,string)
+ if(isatt(data,"long_name")) then
+ lu_string = data at long_name
+ ;
+ ; Comment out this code for now, because I'm not sure I want
+ ; the default behavior to change from just a long_name string
+ ; to a long_name (units) string for now. This was added around
+ ; version a031 (Jan 2004).
+ ;
+ ; if(isatt(data,"units").and.data at units.ne."") then
+ ; lu_string = lu_string + " (" + data at units + ")"
+ ; end if
+ end if
+ return(lu_string)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : copy_var_atts ;
+ ; var_from ;
+ ; var_to ;
+ ; att_names: string ;
+ ; This is almost identical to D Shea's "copy_VarAtts" routine, except ;
+ ; it allows you to specify which atts to copy. ;
+ ;***********************************************************************;
+ undef("copy_var_atts")
+ procedure copy_var_atts(var_from,var_to,att_names)
+ local i
+ begin
+ if(ismissing(att_names).or.att_names.eq."") then
+ att_names_copy = getvaratts(var_from)
+ else
+ att_names_copy = att_names
+ end if
+ if(.not.all(ismissing(att_names_copy)))
+ do i = 0,dimsizes(att_names_copy)-1
+ if (isatt(var_from,att_names_copy(i)).and.
+ .not.isatt(var_to,att_names_copy(i))) then
+ var_to@$att_names_copy(i)$ = var_from@$att_names_copy(i)$
+ end if
+ end do
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : cat_strings ;
+ ; strings : string ;
+ ; ;
+ ; Takes an array of strings and cats them into a single string. ;
+ ;***********************************************************************;
+ undef("cat_strings")
+ function cat_strings(str_array)
+ local i, slen
+ begin
+ slen = dimsizes(str_array)
+ single_string = "'" + str_array(0) + "'"
+ do i=1,slen-1
+ single_string = single_string + " '" + str_array(i) + "'"
+ end do
+
+ return(single_string)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_resources ;
+ ; res:logical ;
+ ; ;
+ ; This function takes a logical value and a list of resources, and ;
+ ; assigns them to another variable. If res is False, however, then no ;
+ ; resources are carried over, but res is set to True for future use. ;
+ ; ;
+ ;***********************************************************************;
+ undef("get_resources")
+ function get_resources(res:logical)
+ begin
+ if(res) then
+ res2 = res
+ else
+ ;
+ ; Set res2 to True, but don't carry over any resources.
+ ;
+ res2 = True
+ end if
+
+ return(res2)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : set_attr ;
+ ; res:logical ;
+ ; att_name: string ;
+ ; att_value ;
+ ; ;
+ ; Add resource and its value to a resource list if it isn't already set.;
+ ;***********************************************************************;
+ undef("set_attr")
+ procedure set_attr(res:logical,att_name:string,att_value)
+ begin
+ res = True
+ if(.not.isatt(res,att_name))
+ res@$att_name$ = att_value
+ end if
+ return
+ end
+
+ ;***********************************************************************;
+ ; Function : check_attr ;
+ ; res : logical ;
+ ; att_name : string ;
+ ; att_value ;
+ ; convert_lower: logical ;
+ ; ;
+ ; Checks if res at att_name exists and if it is equal to att_value. ;
+ ;***********************************************************************;
+ undef("check_attr")
+ function check_attr(res:logical,att_name:string,att_value,
+ convert_lower:logical)
+ local res2, new_att_value, is_att_value_string, is_att_name_string
+ begin
+ res2 = res
+
+ if(res2.and.isatt(res2,att_name))
+ if(typeof(att_value).eq."string") then
+ is_att_value_string = True
+ else
+ is_att_value_string = False
+ end if
+
+ if(typeof(res@$att_name$).eq."string") then
+ is_att_name_string = True
+ else
+ is_att_name_string = False
+ end if
+ ;
+ ; If one value is a string and the other isn't, then we can't
+ ; compare them, and we just have to return False.
+
+ if(is_att_name_string.ne.is_att_value_string) then
+ return(False)
+ end if
+
+ if(is_att_value_string.and.convert_lower)
+ new_att_value = lower_case(att_value)
+ res2@$att_name$ = lower_case(res2@$att_name$)
+ else
+ new_att_value = att_value
+ end if
+
+ if(res2@$att_name$.eq.new_att_value)
+ return(True)
+ end if
+ end if
+
+ return(False)
+ end
+
+ ;***********************************************************************;
+ ; res:logical ;
+ ; prefix: string ;
+ ; rep_prefix: string ;
+ ; ;
+ ; Get a list of resources that start with res_prefix, and replace them ;
+ ; with rep_prefix. ;
+ ;***********************************************************************;
+ undef("get_res_eq_replace")
+ function get_res_eq_replace(res,res_prefix:string,rep_prefix:string)
+ local i, j, ret_res, res2, attnames, res_index, nres2
+ begin
+ ret_res = False
+
+ if(res.and..not.any(ismissing(getvaratts(res))))
+ attnames = getvaratts(res)
+ do i = 0, dimsizes(attnames)-1
+ res2 = stringtocharacter(attnames(i))
+ nres2 = dimsizes(res2)
+ ;
+ ; Loop through the resource prefixes and determine their length
+ ; so that we only check that many characters in the resource name.
+ ;
+ do j = 0, dimsizes(res_prefix)-1
+ res_prefix_c = stringtocharacter(res_prefix(j))
+ rpclen = dimsizes(res_prefix_c)-1 ; Don't count null char
+ if(nres2.ge.rpclen.and.
+ charactertostring(res2(0:rpclen-1)).eq.res_prefix(j))
+ ret_res = True
+ ;
+ ; Make sure we have enough room in the rest of the resource name to
+ ; replace the current prefix with the rep_prefix. This code will take
+ ; something like "gsnPanelFigureStringsFontHeightF" and replace it with
+ ; "txFontHeightF".
+ ;
+ if(rep_prefix.ne."".and.nres2.gt.(rpclen+1)) then
+ resnew_attname = rep_prefix + charactertostring(res2(rpclen:nres2-2))
+ ret_res@$resnew_attname$ = res@$attnames(i)$
+ else
+ ret_res@$attnames(i)$ = res@$attnames(i)$
+ end if
+ end if
+ delete(res_prefix_c)
+ end do
+ delete(res2)
+ end do
+ delete(attnames)
+ end if
+ return(ret_res)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : get_res_eq ;
+ ; res:logical ;
+ ; prefix: string ;
+ ; ;
+ ; Get a list of resources that start with res_prefix. ;
+ ;***********************************************************************;
+ undef("get_res_eq")
+ function get_res_eq(res,res_prefix:string)
+ local i, j, ret_res, res2, attnames, res_index
+ begin
+ return(get_res_eq_replace(res,res_prefix,""))
+ end
+
+
+ ;***********************************************************************;
+ ; Function : get_res_ne ;
+ ; res:logical ;
+ ; prefix: string ;
+ ; ;
+ ; Get a list of resources that don't start with res_prefix. ;
+ ;***********************************************************************;
+ undef("get_res_ne")
+ function get_res_ne(res,res_prefix:string)
+ local i, j, ret_res, res2, attnames, res_index
+ begin
+ ret_res = False
+
+ if(res.and..not.any(ismissing(getvaratts(res))))
+ attnames = getvaratts(res)
+ do i = 0, dimsizes(attnames)-1
+ res2 = stringtocharacter(attnames(i))
+ ;
+ ; Loop through the resource prefixes and determine their length
+ ; so that we only check that many characters in the resource name.
+ ;
+ j = 0
+ found = False
+ do while(.not.found.and.j.le.dimsizes(res_prefix)-1)
+ res_prefix_c = stringtocharacter(res_prefix(j))
+ rpclen = dimsizes(res_prefix_c)-1 ; Don't count null char
+ if(dimsizes(res2).ge.rpclen.and.
+ charactertostring(res2(0:rpclen-1)).eq.res_prefix(j))
+ found = True
+ end if
+ j = j + 1
+ delete(res_prefix_c)
+ end do
+ if(.not.found) then
+ ret_res = True
+ ret_res@$attnames(i)$ = res@$attnames(i)$
+ end if
+ delete(res2)
+ end do
+ delete(attnames)
+ end if
+ return(ret_res)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : get_res_value ;
+ ; res ;
+ ; resname:string ;
+ ; default_val ;
+ ; ;
+ ; This function checks to see if the given resource has been set, and if;
+ ; so, it returns its value and removes it from the resource list. ;
+ ; Otherwise, it returns the default value which is the last argument ;
+ ; passed in. ;
+ ;***********************************************************************;
+ undef("get_res_value")
+ function get_res_value(res,resname:string,default_val)
+ local return_val
+ begin
+ if(((typeof(res).eq."logical".and.res).or.(typeof(res).ne."logical")).and.
+ .not.any(ismissing(getvaratts(res)))) then
+ if(isatt(res,resname)) then
+ return_val = res@$resname$
+ delete(res@$resname$)
+ else
+ return_val = default_val
+ end if
+ else
+ return_val = default_val
+ end if
+ return(return_val)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_res_value_keep ;
+ ; res:logical ;
+ ; resname:string ;
+ ; default_val ;
+ ; ;
+ ; This function checks to see if the given resource has been set, and if;
+ ; so, it returns its value and keeps it from the resource list. ;
+ ; Otherwise, it returns the default value which is the last argument ;
+ ; passed in. ;
+ ; ;
+ ;***********************************************************************;
+ undef("get_res_value_keep")
+ function get_res_value_keep(res,resname:string,default_val)
+ local return_val
+ begin
+ if(((typeof(res).eq."logical".and.res).or.(typeof(res).ne."logical")).and.
+ .not.any(ismissing(getvaratts(res)))) then
+ if(isatt(res,resname)) then
+ return_val = res@$resname$
+ else
+ return_val = default_val
+ end if
+ else
+ return_val = default_val
+ end if
+ return(return_val)
+ end
+
+
+ ;***********************************************************************;
+ ; This function peruses two arrays of the same length and returns pairs ;
+ ; of indices that represent ranges of data values where there are no ;
+ ; missing values. ;
+ ;***********************************************************************;
+ undef("get_non_missing_pairs")
+ function get_non_missing_pairs(x[*]:numeric,y[*]:numeric)
+ local ibeg, iend, indices, ndimx, ndimy, is_missing
+ begin
+ ndimx = dimsizes(x)
+ ndimy = dimsizes(y)
+
+ if(ndimx.ne.ndimy)
+ print("get_non_missing_pairs: x and y must be the same length")
+ end if
+
+ indices = new((/ndimx,2/),integer)
+
+ counter = 0
+ ibeg = -1 ; First non-missing point in a group.
+ do i = 0,ndimx-1
+ if(.not.ismissing(x(i)).and..not.ismissing(y(i)))
+ if(ibeg.lt.0) ; on the first point of the line
+ ibeg = i
+ iend = i ; Represents last non-missing point in a group
+ else
+ iend = i
+ end if
+ is_missing = False
+ else
+ is_missing = True
+ end if
+ if(ibeg.ge.0.and.(is_missing.or.iend.eq.ndimx-1))
+ indices(counter,0) = ibeg
+ indices(counter,1) = iend
+ ibeg = -1 ; Reinitialize
+ counter = counter + 1
+ end if
+ end do
+ return(indices)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_display_mode ;
+ ; res:logical ;
+ ; name:string ;
+ ; value ;
+ ; ;
+ ; This procedure checks if a DisplayMode resource is set, and returns ;
+ ; an integer value if it's set as a string. ;
+ ;***********************************************************************;
+ undef("get_display_mode")
+ function get_display_mode(res:logical,name:string,value)
+ local display_mode, new_display_mode
+ begin
+ display_mode = get_res_value_keep(res,name,value)
+
+ if(typeof(display_mode).ne."string") then
+ return(display_mode)
+ else
+ new_display_mode = -1 ; Default is -1 ("nocreate")
+
+ if(lower_case(display_mode).eq."nocreate") then
+ new_display_mode = -1
+ end if
+ if(lower_case(display_mode).eq."never") then
+ new_display_mode = 0
+ end if
+ if(lower_case(display_mode).eq."always") then
+ new_display_mode = 1
+ end if
+ if(lower_case(display_mode).eq."conditional") then
+ new_display_mode = 2
+ end if
+ delete(display_mode)
+ display_mode = new_display_mode
+ end if
+
+ return(new_display_mode)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : attsetvalues_check ;
+ ; plot:graphic ;
+ ; res:logical ;
+ ; ;
+ ; This procedure passes plot and res to attsetvalues only if res is ;
+ ; True and non-empty. ;
+ ;***********************************************************************;
+ undef("attsetvalues_check")
+ procedure attsetvalues_check(plot:graphic,res:logical)
+ begin
+ if(res.and..not.any(ismissing(getvaratts(res))))
+ attsetvalues(plot,res)
+ end if
+ return
+ end
+
+ ;***********************************************************************;
+ ; This function returns the list of named colors in the rgb.txt file.
+ ; This can be used to test for valid color names.
+ ;***********************************************************************;
+ undef("get_named_color_list")
+ function get_named_color_list()
+ local db_dir, lines
+ begin
+ ;---Read the rgb.txt file.
+ db_dir = ncargpath("database")
+ lines = asciiread(db_dir + "/rgb.txt",-1,"string")
+ ;
+ ; Read list of named colors off the file.
+ ;
+ ; Need to use str_get_cols and not str_get_field,
+ ; because some color names have spaces in them,
+ ; and hence we can't use a space as a delimiter.
+ ;
+ named_colors = str_strip(str_get_cols(lines,12,-1))
+ return(named_colors)
+ end
+
+ ;***********************************************************************;
+ ; This function checks the list of named colors to make sure they are
+ ; all valid. It will return a logical array of the same size as the
+ ; input array.
+ ;***********************************************************************;
+ undef("is_valid_named_colors")
+ function is_valid_named_colors(colors[*]:string)
+ local i, valid_named_colors, ncolors
+ begin
+ named_colors = str_lower(get_named_color_list()) ; list of valid colors
+ ncolors = dimsizes(colors)
+ valid_named_colors = new(ncolors,logical)
+ valid_named_colors = False ; initialize to False
+ do i=0,ncolors-1
+ if(any(str_lower(colors(i)).eq.named_colors)) then
+ valid_named_colors(i) = True
+ end if
+ end do
+ return(valid_named_colors)
+ end
+
+ ;***********************************************************************;
+ ; This function returns the list of colormap names.
+ ; This can be used to test for valid colormap names.
+ ;***********************************************************************;
+ undef("get_colormap_names")
+ function get_colormap_names()
+ local cmap_dirs, nfiles, ndirs, cmaps, i, j, tmp_files, tmp_names
+ begin
+ ;---Get the list of color map directories
+ cmap_dirs = str_split(ncargpath("colormaps"),":")
+ ndirs = dimsizes(cmap_dirs)
+
+ max_files = 500
+ cmaps = new(max_files,string)
+ nfiles = 0
+ do i=0,ndirs-1
+ tmp_files := systemfunc("ls -1 " + cmap_dirs(i))
+ nt = dimsizes(tmp_files)
+ do j=0,nt-1
+ tmp_names := str_split(tmp_files(j),".")
+ cmaps(nfiles) = str_join(tmp_names(0:dimsizes(tmp_names)-2),".")
+ nfiles = nfiles + 1
+ if(nfiles.ge.max_files) then
+ print("get_colormap_names: reached maximum limit of color maps")
+ print("Will only return " + max_files + " color map names.")
+ break
+ end if
+ end do
+ if(nfiles.ge.max_files) then
+ break
+ end if
+ end do
+ return(cmaps(0:nfiles-1))
+ end
+
+ ;***********************************************************************;
+ ; This function checks the list of color map names to see if they are
+ ; all valid. It will return a logical array of the same size as the
+ ; input array.
+ ;***********************************************************************;
+ undef("is_valid_colormap_names")
+ function is_valid_colormap_names(colormap_names[*]:string)
+ local i, valid_colormaps, ncmaps
+ begin
+ cmaps = get_colormap_names()
+ ncmaps = dimsizes(colormap_names)
+ valid_colormaps = new(ncmaps,logical)
+ valid_colormaps = False ; initialize to False
+ do i=0,ncmaps-1
+ if(any(colormap_names(i).eq.cmaps)) then
+ valid_colormaps(i) = True
+ end if
+ end do
+ return(valid_colormaps)
+ end
+
+ ;***********************************************************************;
+ ; This function returns the type of color being used:
+ ;
+ ; color index - values 0 to 255 "index"
+ ; named color - "blue" "named"
+ ; RGB triplet - (/1,0,0.5/) "rgb"
+ ; RGBA quadruplet - (/1,0,0.5,0.5/) "rgba"
+ ; color map name - "amwg" "colormap"
+ ;
+ ; A missing string is returned if no valid type is detected.
+ ;***********************************************************************;
+ undef("get_color_type")
+ function get_color_type(colors)
+ local dims_color, rank_color
+ begin
+ dims_color = dimsizes(colors)
+ rank_color = dimsizes(dims_color)
+
+ if(rank_color.eq.1.and.typeof(colors).eq."string".and.
+ all(is_valid_colormap_names(colors))) then
+ return("colormap")
+ end if
+
+ if(rank_color.eq.1.and.typeof(colors).eq."string".and.
+ all(is_valid_named_colors(colors))) then
+ return("named")
+ end if
+
+ if(dims_color(rank_color-1).eq.3.and.isnumeric(colors).and.
+ all(colors.ge.0.and.colors.le.1.0)) then
+ return("rgb")
+ end if
+
+ if(dims_color(rank_color-1).eq.4.and.isnumeric(colors).and.
+ all(colors.ge.0.and.colors.le.1.0)) then
+ return("rgba")
+ end if
+
+ if(any(typeof(colors).eq.(/"short","integer","long"/)).and.
+ all(colors.ge.0.and.colors.le.255)) then
+ return("index")
+ end if
+
+ return(new(1,string)) ; otherwise return missing
+ end
+
+ ;***********************************************************************;
+ ; This function returns the RGB triplets associated with a
+ ; given list of named colors.
+ ;
+ ; A n x 3 array is returned, where "n" is the number of
+ ; named colors input.
+ ;
+ ; If a color is not found, missing values are returned for
+ ; that color.
+ ;***********************************************************************;
+ undef("namedcolor2rgb")
+ function namedcolor2rgb(names[*]:string)
+ local db_dir, lines, named_colors, i, ii, ncolors,
+ lnames, rgb_array
+ begin
+ ;---Read list of named colors off the file.
+ named_colors = str_lower(get_named_color_list())
+ ;
+ ; Use str_sub_str to remove all tabs and spaces around
+ ; and inside the color name.
+ ;
+ lnames = str_lower(names)
+ lnames = str_sub_str(lnames," ","")
+ lnames = str_sub_str(lnames," ","")
+ named_colors = str_sub_str(named_colors," ","")
+ named_colors = str_sub_str(named_colors," ","")
+
+ ncolors = dimsizes(names)
+ rgb_array = new((/ncolors,3/),float)
+
+ ;---Read the rgb.txt file.
+ db_dir = ncargpath("database")
+ lines = asciiread(db_dir + "/rgb.txt",-1,"string")
+
+ ;---Loop through named colors and find the requested one(s).
+ do i=0,ncolors-1
+ ;---Get index into rgb.txt table. There can be more than one.
+ ii = ind(lnames(i).eq.named_colors)
+
+ ;---Get associated RGB triplet
+ if(.not.any(ismissing(ii))) then
+ rgb_array(i,0) = tointeger(str_get_field(lines(ii(0)),1,
+ " "))/255.
+ rgb_array(i,1) = tointeger(str_get_field(lines(ii(0)),2,
+ " "))/255.
+ rgb_array(i,2) = tointeger(str_get_field(lines(ii(0)),3,
+ " "))/255.
+ else
+ print("Warning: namedcolor2rgb: '" + names(i) + "' is not a valid named color.")
+ print("Will return missing values for this color.")
+ end if
+ delete(ii)
+ end do
+ return(rgb_array)
+ end
+
+ ;***********************************************************************;
+ ; This function returns the RGBA triplets associated with a
+ ; given list of named colors. The "A" value is always returned
+ ; as the value of 1.0. This function basically calls namedcolor2rgb and
+ ; adds the "A" value.
+ ;
+ ; A n x 4 array is returned, where "n" is the number of
+ ; named colors input.
+ ;
+ ; If a color is not found, missing values are returned for
+ ; that color.
+ ;***********************************************************************;
+ undef("namedcolor2rgba")
+ function namedcolor2rgba(names[*]:string)
+ local rgb_array, rgba_array
+ begin
+ rgb_array = namedcolor2rgb(names)
+ ncolors = dimsizes(rgb_array(:,0))
+ rgba_array = new((/ncolors,4/),typeof(rgb_array))
+ rgba_array(:,0:2) = rgb_array
+ rgba_array(:,3) = where(.not.ismissing(rgb_array(:,2)),1.0,
+ rgba_array at _FillValue)
+ return(rgba_array)
+ end
+
+ ;***********************************************************************;
+ ; This function returns the RGBA values given an RGB array. The
+ ; "alpha" index is set to 1.0.
+ ;
+ ; A n x 4 array is returned, where "n" is the number of
+ ; named colors input.
+ ;***********************************************************************;
+ undef("rgb2rgba")
+ function rgb2rgba(rgb)
+ local ncolors, rgba
+ begin
+ dims = dimsizes(rgb)
+ rank = dimsizes(dims)
+
+ if((rank.eq.1.and.dims.ne.3).or.(rank.eq.2.and.dims(1).ne.3).or.
+ rank.lt.1.or.rank.gt.2) then
+ print("rgb2rgba: The input must be an RGB array of length 3 or n x 3")
+ print(" Returning missing.")
+ return(new(4,float))
+ end if
+ if(rank.eq.2) then
+ ncolors = dimsizes(rgb(:,0))
+ rgba = new((/ncolors,4/),typeof(rgb))
+ rgba(:,0:2) = rgb
+ rgba(:,3) = 1
+ else
+ rgba = new(4,typeof(rgb))
+ rgba(0:2) = rgb
+ rgba(3) = 1
+ end if
+ return(rgba)
+ end
+
+ ;***********************************************************************;
+ ; This function returns the RGBA quadruplets associated with a
+ ; given list of index colors.
+ ;
+ ; A n x 4 array is returned, where "n" is the number of
+ ; named colors input.
+ ;
+ ; If any input colors are invalid, then missing will be returned.
+ ;***********************************************************************;
+ undef("indexcolor2rgba")
+ function indexcolor2rgba(wks,color_indexes[*])
+ local rgba_cmap, rgb_cmap, ncolors
+ begin
+ getvalues wks
+ "wkColorMap" : rgb_cmap
+ end getvalues
+
+ ncolors = dimsizes(rgb_cmap(:,0))
+ if(any(color_indexes.lt.0.or.color_indexes.ge.ncolors)) then
+ print("Error:indexcolor2rgba: one or more of the index colors")
+ print("are invalid. Will return missing values.")
+ msg = new(4,float)
+ return(msg)
+ else
+ rgba_cmap = rgb2rgba(rgb_cmap)
+ return(rgba_cmap(color_indexes,:))
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Given a list of color maps, color indexes, named colors, RGB, or RGBA ;
+ ; colors, convert them to RGBA colors. ;
+ ;***********************************************************************;
+ undef("convert_color_to_rgba")
+ function convert_color_to_rgba(wks,colors)
+ begin
+ color_type = get_color_type(colors)
+ if(color_type.eq."unknown")
+ print("Error: convert_color_to_rgba: invalid color(s). Returning missing.")
+ return(new(4,float))
+ end if
+
+ if(color_type.eq."rgba") then
+ rgba_colors = colors
+ else if(color_type.eq."index") then
+ rgba_colors = indexcolor2rgba(wks,colors)
+ else if(color_type.eq."colormap") then
+ rgba_colors = read_colormap_file(colors)
+ else if(color_type.eq."named") then
+ rgba_colors = namedcolor2rgba(colors)
+ else if(color_type.eq."rgb") then
+ rgba_colors = rgb2rgba(colors)
+ end if
+ end if
+ end if
+ end if
+ end if
+
+ if(all(dimsizes(rgba_colors).eq.(/1,4/))) then
+ return(rgba_colors(0,:))
+ else
+ return(rgba_colors)
+ end if
+ end
+
+
+ ;***********************************************************************;
+ ; Given two named colors and the number of colors, this
+ ; function creates a series of RGB triplets that spans
+ ; between the two colors.
+ ;***********************************************************************;
+ undef("span_two_named_colors")
+ function span_two_named_colors(named1[1]:string,named2[1]:string,ncolors,
+ opt[1]:logical)
+ local rgb, msg, hsv1, hsv2, ii, hsv_array, debug, opt2,
+ beg_hue, end_hue, beg_sat, end_sat, beg_val, end_val
+ begin
+ opt2 = opt
+
+ ;---For debug prints
+ debug = get_res_value_keep(opt2,"Debug",False)
+
+ rgb = namedcolor2rgb((/named1,named2/))
+ msg = new(3,float)
+ if(any(ismissing(rgb))) then
+ print("Error:span_two_named_colors one or both of the named colors")
+ print("are invalid. Returning missing.")
+ return(msg)
+ end if
+
+ ;---Convert to HSV.
+ hsv1 = rgbhsv(rgb(0,:))
+ hsv2 = rgbhsv(rgb(1,:))
+
+ if(debug)
+ rgbstr1 = "(" + sprintf("%7.2f", rgb(0,0)) + ", " +
+ sprintf("%7.2f", rgb(0,1)) + ", " +
+ sprintf("%7.2f", rgb(0,2)) + ") "
+ hsvstr1 = "(" + sprintf("%7.2f", hsv1(0)) + ", " +
+ sprintf("%7.2f", hsv1(1)) + ", " +
+ sprintf("%7.2f", hsv1(2)) + ") "
+ rgbstr2 = "(" + sprintf("%7.2f", rgb(1,0)) + ", " +
+ sprintf("%7.2f", rgb(1,1)) + ", " +
+ sprintf("%7.2f", rgb(1,2)) + ") "
+ hsvstr2 = "(" + sprintf("%7.2f", hsv2(0)) + ", " +
+ sprintf("%7.2f", hsv2(1)) + ", " +
+ sprintf("%7.2f", hsv2(2)) + ") "
+
+ print(named1 + ", RGB: " + rgbstr1)
+ print(named2 + ", RGB: " + rgbstr2)
+ print(named1 + ", HSV: " + hsvstr1)
+ print(named2 + ", HSV: " + hsvstr2)
+ end if
+
+ if(ncolors.le.0.or.ncolors.gt.256) then
+ print("Error:span_two_named_colors: Invalid number of colors requested.")
+ print("Defaulting to 256.")
+ ncolors = 256
+ end if
+
+ ;---Create array to return
+ hsv_array = new((/ncolors,3/),float)
+
+ ;---Generate a span of colors from first color to second
+ beg_hue = hsv1(0) ; begin HUE value
+ end_hue = hsv2(0) ; end HUE value
+ beg_sat = hsv1(1) ; begin SAT value
+ end_sat = hsv2(1) ; end SAT value
+ beg_val = hsv1(2) ; begin VAL value
+ end_val = hsv2(2) ; end VAL value
+
+ ii = ispan(0,ncolors-1,1)
+ hsv_array(:,0) = beg_hue +
+ ii*((end_hue-beg_hue)/(ncolors-1))
+ hsv_array(:,1) = beg_sat +
+ ii*((end_sat-beg_sat)/(ncolors-1))
+ hsv_array(:,2) = beg_val +
+ ii*((end_val-beg_val)/(ncolors-1))
+
+ return(hsvrgb(hsv_array))
+ end
+
+ ;***********************************************************************;
+ ; Given a list of named colors, this function creates a
+ ; series of RGB triplets that creates a span between each
+ ; set of colors. The first two colors will be set to white
+ ; and black.
+ ;
+ ; By default, it will create a color map with 256 triplets.
+ ; The "opt" variable can be used to set the following
+ ; options:
+ ;
+ ; opt at NumColorsInTable
+ ; Number of colors to put in the color table.
+ ; Must be <= 256 and > # of named colors specified.
+ ;
+ ; opt at NumColorsInRange
+ ; Number of colors to span between each set of
+ ; named colors. For example, if you specify three
+ ; colors (/"red", "green", "blue","purple"/), and
+ ; NumColorsInRange of (/5, 8, 4/), then you'll have a
+ ; color table with:
+ ;
+ ; 0 1 2 6 13 16
+ ; white black red......green......blue....purple
+ ;***********************************************************************;
+ undef("span_named_colors")
+ function span_named_colors(named_colors,opt[1]:logical)
+ local i, ncolt, ncols_per_rng, def_ncols_per_rng, nnamed,
+ rgb_array, nbeg, nend, ncpg, debug, rgbtmp, opt2
+ begin
+ opt2 = opt
+
+ ;---For debug prints
+ debug = get_res_value_keep(opt2,"Debug",False)
+
+
+ ;---Get # of colors in color table.
+ ncolt = get_res_value_keep(opt2,"NumColorsInTable",256)
+ if(ncolt.le.0) then
+ print("Error:span_named_colors: # of colors must be > 0")
+ return(new((/1,3/),float))
+ end if
+
+ ;---Background/foreground colors desired?
+ skip_bf = get_res_value_keep(opt2,"SkipBackgroundForeground",False)
+ if(ncolt.le.0) then
+ print("Error:span_named_colors: # of colors must be > 0")
+ return(new((/1,3/),float))
+ end if
+
+ ;---Check # of named colors.
+ nnamed = dimsizes(named_colors)
+ if(nnamed.le.1) then
+ print("Error:span_named_colors: You must specify more than one named color.")
+ return(new((/1,3/),float))
+ end if
+
+ ;
+ ; Get number of colors between each set of named colors.
+ ; The number in the range includes both end colors.
+ ;
+ ; Default is to use equally spaced colors.
+ ;
+ ncpg = (ncolt-2)/(nnamed-1)
+ def_ncols_per_rng = new(nnamed-1,integer)
+ def_ncols_per_rng = ncpg
+ if(opt2.and.isatt(opt2,"NumColorsInRange")) then
+ ncols_per_rng = get_res_value_keep(opt2,"NumColorsInRange",-1)
+ if(dimsizes(ncols_per_rng).ne.(nnamed-1)) then
+ print("span_named_colors: Invalid # of colors per range.")
+ print("Using equally spaced colors.")
+ delete(ncols_per_rng)
+ ncols_per_rng = def_ncols_per_rng
+ end if
+ else
+ ncols_per_rng = def_ncols_per_rng
+ end if
+
+ ;
+ ; Calculate total number of colors and create RGB
+ ; array to populate.
+ ;
+ ; Since the inside colors are part of two ranges, but only
+ ; counted once, you need to account for this. The "2" is
+ ; for the background, foreground coors.
+ ;
+ ncolt = sum(ncols_per_rng)+2-(nnamed-2)
+ rgb_array = new((/ncolt,3/),float)
+
+ if(debug) then
+ print("# colors in table = " + ncolt)
+ end if
+
+ ;---Background color defaults to white.
+ rgb_array(0,:) = (/1.,1.,1./) ; White
+ if(opt2.and.isatt(opt2,"BackgroundColor")) then
+ rgbtmp = namedcolor2rgb(opt2 at BackgroundColor)
+ if(any(ismissing(rgbtmp))) then
+ print("span_named_colors: Invalid background color.")
+ print("Defaulting to white.")
+ else
+ rgb_array(0,:) = rgbtmp
+ end if
+ end if
+
+ ;---Foreground color defaults to black.
+ rgb_array(1,:) = (/0.,0.,0./) ; Black
+ if(opt2.and.isatt(opt2,"ForegroundColor")) then
+ rgbtmp = namedcolor2rgb(opt2 at ForegroundColor)
+ if(any(ismissing(rgbtmp))) then
+ print("span_named_colors: Invalid foreground color.")
+ print("Defaulting to black.")
+ else
+ rgb_array(1,:) = rgbtmp
+ end if
+ end if
+
+ nbeg = 2
+ nend = nbeg + ncols_per_rng(0) - 1
+ do i=0,nnamed-2
+ if(debug) then
+ print("Indexes " + nbeg + " to " + nend +
+ ", "+named_colors(i)+" to "+named_colors(i+1)+
+ ", " + ncols_per_rng(i) + " colors per range")
+ end if
+ rgb_array(nbeg:nend,:) = span_two_named_colors(named_colors(i),
+ named_colors(i+1),
+ ncols_per_rng(i),opt2)
+ if(i.lt.(nnamed-2)) then
+ nbeg = nend ; Start where we ended
+ nend = nbeg + ncols_per_rng(i+1) -1
+ end if
+ end do
+
+ if(skip_bf) then
+ return(rgb_array(2:,:))
+ else
+ return(rgb_array)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : spread_colors ;
+ ; wks:graphic ;
+ ; plot:graphic ;
+ ; min_index:logical ;
+ ; max_index:logical ;
+ ; res:logical ;
+ ; ;
+ ;***********************************************************************;
+ ; In Version 6.1.0, gsnSpreadColors is basically deprecated, and ;
+ ; replaced with cnSpanFillPalette, vcSpanFillPalette, etc, which are ;
+ ; True by default. If the user sets gsnSpreadColorStart and/or ;
+ ; gsnSpreadColorEnd to something other than their default values (2 and ;
+ ; -1), then the spread_colors algorithm will kick in. ;
+ ;***********************************************************************;
+ ; ;
+ ; By default, all of the plotting routines use the first n colors from ;
+ ; a color map, where "n" is the number of contour or vector levels. ;
+ ; If "gsnSpreadColors" is set to True, then the colors are spanned ;
+ ; across the whole color map. The min_index and max_index values are ;
+ ; used for the start and end colors. If either min_index or max_index ;
+ ; is < 0 (but not both), then this indicates to use ncol-i, where "i" ;
+ ; is equal to the negative value. ;
+ ; ;
+ ; If after adjusting for negative index color(s), and ;
+ ; max_index < min_index, then the colors are reversed. ;
+ ; ;
+ ; In NCL versions 6.0.0 and earlier, if you had both xxYYYYColors set ;
+ ; and gsnSpreadColors was set to True, then the xxYYYYColors resource ;
+ ; would be ignored, and gsnSpreadColors took precedence. ;
+ ; ;
+ ; In versions 6.1.0 and later, the opposite is True. gsnSpreadColors ;
+ ; is now True by default, but if you set xxYYYYColors, then this will ;
+ ; take precedence, and no message will be printed. ;
+ ;***********************************************************************;
+ undef("spread_colors")
+ function spread_colors(wks:graphic,plot:graphic,min_index:integer,
+ max_index:integer,res:logical)
+ local ncols, lcount, fcols, icols, minix, maxix, nc, fmin, fmax, class,
+ levelcountres, cmap
+ begin
+ if(.not.isvar("GSN_SPREAD_COLOR_DEBUG")) then
+ GSN_SPREAD_COLOR_DEBUG = False
+ end if
+ if(GSN_SPREAD_COLOR_DEBUG) then
+ print("spread_colors: at the top of this function")
+ end if
+
+ class = NhlClassName(plot)
+ if(.not.any(class.eq.(/"contourPlotClass","logLinPlotClass",
+ "irregularPlotClass","vectorPlotClass",
+ "streamlinePlotClass"/)))
+ print("spread_colors: invalid plot: defaulting")
+ return(ispan(2,255,1))
+ end if
+
+
+ if (class.eq."contourPlotClass".or.class.eq."logLinPlotClass".or.
+ class.eq."irregularPlotClass")
+ levelcountres = "cnLevelCount"
+ else
+ if (class.eq."vectorPlotClass") then
+ levelcountres = "vcLevelCount"
+ else
+ levelcountres = "stLevelCount"
+ end if
+ end if
+
+ ;**********************************************************************
+ ; This code has to be replaced with the proper way to retrieve colors
+ ; once 6.1.0
+ ;**********************************************************************
+ getvalues wks
+ "wkColorMap" : cmap
+ end getvalues
+ ncols = dimsizes(cmap(:,0))
+
+ if(GSN_SPREAD_COLOR_DEBUG) then
+ print("spread_colors: size of current color map is " + ncols)
+ end if
+
+ if (class.eq."contourPlotClass".or.class.eq."vectorPlotClass".or.
+ class.eq."streamlinePlotClass")
+ getvalues plot
+ levelcountres : lcount
+ end getvalues
+ else
+ getvalues plot at contour
+ levelcountres : lcount
+ end getvalues
+ end if
+ ;
+ ; -1 indicates that min/max_index should be set equal to ncols - 1
+ ; -2 indicates that min/max_index should be set equal to ncols - 2, etc.
+ ;
+ ; If after adjusting for negative indices, and maxix < minix, then
+ ; this implies that the user wants to reverse the colors.
+ ;
+ if (min_index .lt. 0)
+ minix = ncols + min_index
+ else
+ minix = min_index
+ end if
+
+ if (max_index .lt. 0)
+ maxix = ncols + max_index
+ else
+ maxix = max_index
+ end if
+
+ ;
+ ; Make sure indices fall within range of the color map.
+ ;
+ minix = min((/ncols-1,max((/0,minix/))/))
+ maxix = min((/ncols-1,max((/0,maxix/))/))
+ ;
+ ; If maxix < minix, then colors are to be reversed.
+ ;
+ reverse = False
+ if(maxix.lt.minix)
+ reverse = True
+ itmp = maxix
+ maxix = minix
+ minix = itmp
+ end if
+
+ if(GSN_SPREAD_COLOR_DEBUG) then
+ print("spread_colors: minix/maxix = " + minix + "/" + maxix)
+ end if
+
+ fmin = new(1,float)
+ fmax = new(1,float)
+
+ fmin = minix
+ fmax = maxix
+ fcols = fspan(fmin,fmax,lcount+1)
+ if(.not.reverse)
+ icols = tointeger(fcols + 0.5)
+ else
+ icols = tointeger(fcols(::-1) + 0.5)
+ end if
+
+ if(GSN_SPREAD_COLOR_DEBUG) then
+ print("spread_colors: icols = " + icols)
+ end if
+
+ ;
+ ; There may be some cases where you want to return the indexes
+ ; here, for compatibility with NCL Version 6.0.0 and earlier.
+ ;
+ return(icols)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_overlay_plot ;
+ ; plot : graphic ;
+ ; class_name : string ;
+ ; plot_index : integer ;
+ ; ;
+ ; Get a specified overlaid plot id. This function is based on Dennis' ;
+ ; original GetOverlayPlot function. ;
+ ;***********************************************************************;
+ undef("get_overlay_plot")
+ function get_overlay_plot(plot:graphic,class_name:string,plot_index:integer)
+ begin
+ ;
+ ; Retrieve objects that have been overlaid on "plot".
+ ;
+ getvalues plot
+ "pmOverlaySequenceIds" : overlay_ids
+ end getvalues
+ ;
+ ; Loop through these objects and check if any of them are a
+ ; match.
+ ;
+ if(.not.any(ismissing(overlay_ids))) then
+ num_instances = 0
+ do i=0,dimsizes(overlay_ids)-1
+ if(NhlClassName(overlay_ids(i)).eq.class_name)
+ if(num_instances.eq.plot_index) then
+ return(overlay_ids(i))
+ end if
+ num_instances = num_instances + 1
+ end if
+ end do
+ end if
+ ;
+ ; If no match found, then check the plot itself.
+ ;
+ if(NhlClassName(plot).eq.class_name) then
+ return(plot)
+ end if
+ ;
+ ; No match found, so return a missing object.
+ ;
+ print("get_overlay_plot: Error: no plot found matching conditions")
+ print(" Returning a missing value.")
+ dum = new(1,graphic)
+ return(dum)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_contour_levels ;
+ ; plot: graphic ;
+ ; ;
+ ; Get contour levels associated with "plot". ;
+ ; ;
+ ;***********************************************************************;
+ undef("get_contour_levels")
+ function get_contour_levels(plot:graphic)
+ local overlay_plot
+ begin
+ overlay_plot = get_overlay_plot (plot, "contourPlotClass", 0)
+
+ if(.not.ismissing(overlay_plot)) then
+ getvalues overlay_plot
+ "cnLevels" : levels
+ "cnLevelFlags" : level_flags
+ end getvalues
+ levels at flags = level_flags
+ return(levels)
+ end if
+ ;
+ ; Return missing if no plot was found.
+ ;
+ dum = new(1,float)
+ return(dum)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_contour_line_thicknesses ;
+ ; plot: graphic ;
+ ; ;
+ ; Get contour line thicknesses associated with "plot". ;
+ ; ;
+ ;***********************************************************************;
+ undef("get_contour_line_thicknesses")
+ function get_contour_line_thicknesses(plot:graphic)
+ local overlay_plot
+ begin
+ overlay_plot = get_overlay_plot (plot, "contourPlotClass", 0)
+
+ if(.not.ismissing(overlay_plot)) then
+ getvalues overlay_plot
+ "cnLineThicknesses" : thicknesses
+ end getvalues
+ return(thicknesses)
+ end if
+ ;
+ ; Return missing if no plot was found.
+ ;
+ dum = new(1,float)
+ return(dum)
+ end
+
+ ;***********************************************************************;
+ ; Function : fix_zero_contour ;
+ ; levels:numeric ;
+ ; ;
+ ; Make sure the 0th contour (if it exists) really is "0" and not ;
+ ; something like "1.00001e-08". But, we also have to make sure we don't;
+ ; have values like 1e-10, 1e-9, etc, where we *do* want "1e-10" label ;
+ ; and not a "0". Don't even bother with checking if the minimum ;
+ ; difference between the levels is less than 1e-5. ;
+ ;***********************************************************************;
+ undef("fix_zero_contour")
+ function fix_zero_contour(levels)
+ begin
+ nlevels = dimsizes(levels)
+ if(nlevels.gt.1) then
+ delta_levels = min( levels(1:nlevels-1) - levels(0:nlevels-2) )
+
+ if (ismissing(delta_levels)) then
+ return(levels)
+ end if
+
+ if(delta_levels.ge.1e-5)
+ do n=1,nlevels-2
+ if(fabs(levels(n)).le.1.e-5.and.levels(n-1).lt.0..and.levels(n+1).gt.0.)
+ levels(n) = 0.0
+ end if
+ end do
+ end if
+ end if
+ return(levels)
+ end
+
+ ;***********************************************************************;
+ ; Function : set_zero_line_thickness ;
+ ; plot : graphic ;
+ ; zthickness : numeric ;
+ ; cthickness : numeric ;
+ ; ;
+ ; Make the 0-th contour line the given thickness. ;
+ ; ;
+ ; Note that this function now recognizes the cnLineThicknesses resource ;
+ ; and will set the contour lines to this thickness, if set. ;
+ ; ;
+ ; If thickness is equal to 0, then the line is just not drawn. ;
+ ; ;
+ ;***********************************************************************;
+ undef("set_zero_line_thickness")
+ function set_zero_line_thickness(plot:graphic,zthickness,cthickness)
+ begin
+ levels = get_contour_levels (plot)
+ nlevels = dimsizes(levels)
+
+ if (any(ismissing(levels)).or. nlevels.le.0) then
+ print ("set_zero_line_thickness: invalid contour levels, returning...")
+ return (plot)
+ end if
+
+ levels = fix_zero_contour (levels)
+ thicknesses = new(nlevels, float)
+ ;
+ ; If cthickness is an array, then deal with that here.
+ ;
+ ncthk = dimsizes(cthickness)
+ if(ncthk.gt.1) then
+ thicknesses = 1. ; First, default them to default thickness.
+ i = 0
+ do while(i.lt.ncthk.and.i.lt.nlevels)
+ thicknesses(i) = cthickness(i)
+ i = i + 1
+ end do
+ else
+ thicknesses = cthickness
+ end if
+
+ zeroind = ind(levels.eq.0.0) ; Get index where level equals 0.0
+ if(.not.ismissing(zeroind)) then
+ if(zthickness.gt.0) then
+ thicknesses(zeroind) = zthickness
+ else
+ thicknesses(zeroind) = 1. ; Make it 1.0, but it doesn't matter
+ ; b/c we are turning off the drawing
+ ; of this line.
+ levels at flags(zeroind) = 0 ; Turn off the zero contour line
+ end if
+ end if
+
+ overlay_plot = get_overlay_plot (plot, "contourPlotClass", 0)
+
+ if(zthickness.gt.0) then
+ setvalues overlay_plot
+ "cnMonoLineThickness" : False
+ "cnLineThicknesses" : thicknesses
+ end setvalues
+ else
+ setvalues overlay_plot
+ "cnMonoLineThickness" : False
+ "cnLevelFlags" : levels at flags
+ "cnLineThicknesses" : thicknesses
+ end setvalues
+ end if
+
+ return (plot)
+ end
+
+ ;***********************************************************************;
+ ; Function : set_line_thickness_scale ;
+ ; plot : graphic ;
+ ; scale : numeric ;
+ ; ;
+ ; Scale the line thickness by the given numbers. ;
+ ; ;
+ ;***********************************************************************;
+ undef("set_line_thickness_scale")
+ function set_line_thickness_scale(plot:graphic,scale)
+ begin
+ thicknesses = get_contour_line_thicknesses (plot)
+ nthicknesses = dimsizes(thicknesses)
+
+ if (any(ismissing(thicknesses)).or. nthicknesses.le.0) then
+ print ("set_line_thickness_scale: invalid contour line thicknesses, returning...")
+ return (plot)
+ end if
+
+ thicknesses = scale * thicknesses
+
+ overlay_plot = get_overlay_plot (plot, "contourPlotClass", 0)
+ setvalues overlay_plot
+ "cnMonoLineThickness" : False
+ "cnLineThicknesses" : thicknesses
+ end setvalues
+
+ return (plot)
+ end
+
+ ;***********************************************************************;
+ ; Function : set_pos_neg_line_pattern ;
+ ; plot : graphic ;
+ ; npattern : numeric ;
+ ; ppattern : numeric ;
+ ; ;
+ ; Set the dash pattern of negative and/or positive contour lines. ;
+ ; ;
+ ; Note that this function also sets the rest of the line patterns to 0 ;
+ ; if both npattern and ppattern aren't both set. ;
+ ; The user can use the cnLineDashPatterns resource to override this. ;
+ ; ;
+ ;***********************************************************************;
+ undef("set_pos_neg_line_pattern")
+ function set_pos_neg_line_pattern(plot:graphic,ppattern,npattern)
+ local set_pos, set_neg, levels, n, nlevels, patterns, overlay_plot
+ begin
+ levels = get_contour_levels (plot)
+ nlevels = dimsizes(levels)
+
+ if (any(ismissing(levels)) .or. nlevels.le.0) then
+ print ("set_pos_neg_line_pattern: invalid contour levels, returning...")
+ return (plot)
+ end if
+
+ levels = fix_zero_contour (levels)
+ patterns = new(nlevels,integer)
+ patterns = 0 ; default to solid line.
+
+ ;
+ ; Check if we have negative and/or positive patterns to set.
+ ;
+ if(.not.any(ismissing(npattern))) then
+ set_neg = True
+ else
+ set_neg = False
+ end if
+
+ if(.not.any(ismissing(ppattern))) then
+ set_pos = True
+ else
+ set_pos = False
+ end if
+
+ ;
+ ; Loop through and set each contour level, if applicable.
+ ;
+ do n=0,nlevels-1
+ if (set_neg.and.levels(n).lt.0.) then
+ patterns(n) = npattern
+ end if
+ if (set_pos.and.levels(n).gt.0.) then
+ patterns(n) = ppattern
+ end if
+ end do
+
+ overlay_plot = get_overlay_plot (plot, "contourPlotClass", 0)
+
+ setvalues overlay_plot
+ "cnMonoLineDashPattern" : False
+ "cnLineDashPatterns" : patterns
+ end setvalues
+
+ return (plot)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : check_for_irreg2loglin ;
+ ; res:logical ;
+ ; xlinear:logical ;
+ ; ylinear:logical ;
+ ; xlog:logical ;
+ ; ylog:logical ;
+ ; ;
+ ; If any of the sf*Array or vf*Array resources are set, this puts the ;
+ ; plot into "irregular" mode. If you want to make any of your axes log ;
+ ; or linear then, you have to overlay it on a LogLin plot. ;
+ ; ;
+ ; By setting one of the resources gsn{X,Y}AxisIrregular2Linear or ;
+ ; gsnXAxisIrregular2Log to True, the overlay is done for you. This ;
+ ; procedure checks for these resources being set and sets some logical ;
+ ; variables accordingly. ;
+ ;***********************************************************************;
+ undef("check_for_irreg2loglin")
+ procedure check_for_irreg2loglin(res:logical,xlinear:logical,
+ ylinear:logical,
+ xlog:logical,ylog:logical)
+ begin
+
+ xlinear = get_res_value(res,"gsnXAxisIrregular2Linear",xlinear)
+ ylinear = get_res_value(res,"gsnYAxisIrregular2Linear",ylinear)
+ xlog = get_res_value(res,"gsnXAxisIrregular2Log",xlog)
+ ylog = get_res_value(res,"gsnYAxisIrregular2Log",ylog)
+
+ if(ylog.and.ylinear)
+ print("Error: You cannot set both gsnYAxisIrregular2Log")
+ print("and gsnYAxisIrregular2Linear to True.")
+ exit
+ end if
+
+ if(xlog.and.xlinear)
+ print("Error: You cannot set both gsnXAxisIrregular2Log")
+ print("and gsnXAxisIrregular2Linear to True.")
+ exit
+ end if
+
+ return
+ end
+
+ ;***********************************************************************;
+ ; ;
+ ; This function checks if a data array is 1D or 2D and returns False if ;
+ ; is not. ;
+ ; ;
+ ;***********************************************************************;
+ undef("is_data_1d_or_2d")
+ function is_data_1d_or_2d(data)
+ begin
+ dims = dimsizes(data)
+ rank = dimsizes(dims)
+
+ if(rank.eq.1.or.rank.eq.2) then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+
+ ;***********************************************************************;
+ ; Function : overlay_irregular ;
+ ; wks:graphic ;
+ ; wksname: string ;
+ ; overlay_plot_object: graphic ;
+ ; data_object: graphic ;
+ ; xlinear: logical ;
+ ; ylinear: logical ;
+ ; xlog: logical ;
+ ; ylog: logical ;
+ ; type: string ;
+ ; llres: logical ;
+ ; ;
+ ; If xlinear and/or ylinear are set to linear or log, then overlay ;
+ ; plot on an irregularPlotClass so that we can linearize or logize ;
+ ; the appropriate axis. ;
+ ;***********************************************************************;
+ undef("overlay_irregular")
+ function overlay_irregular(wks,wksname,overlay_plot_object:graphic,
+ data_object:graphic,xlinear:logical,
+ ylinear:logical,xlog:logical,ylog:logical,
+ type:string,llres:logical)
+ local xaxistype,yaxistype,trxmin,trymin,trxmax,trymax,Xpts,Ypts,is_tm_mode
+ begin
+
+ if(xlinear) then
+ xaxistype = "LinearAxis"
+ else
+ if(xlog) then
+ xaxistype = "LogAxis"
+ else
+ xaxistype = "IrregularAxis"
+ end if
+ end if
+
+ if(ylinear) then
+ yaxistype = "LinearAxis"
+ else
+ if(ylog) then
+ yaxistype = "LogAxis"
+ else
+ yaxistype = "IrregularAxis"
+ end if
+ end if
+ ;
+ ; Retrieve information about existing plot so we can use these values
+ ; to create new overlay plot object.
+ ;
+ getvalues overlay_plot_object
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end getvalues
+
+ if(type.eq."contour") then
+ getvalues data_object
+ "sfXArray" : Xpts
+ "sfYArray" : Ypts
+ end getvalues
+ else
+ if(type.eq."vector".or.type.eq."streamline") then
+ getvalues data_object
+ "vfXArray" : Xpts
+ "vfYArray" : Ypts
+ end getvalues
+ end if
+ end if
+ ;
+ ; If x/yaxistype is irregular, then we must set trX/YCoordPoints.
+ ; Oherwise, we can't set trX/YCoordPoints, because we'll get an
+ ; error message. So, we have to do all kinds of tests to see which
+ ; axes are irregular, and which ones are log or linear.
+ ;
+ ; Also, if Xpts or Ypts are missing, this means the corresponding
+ ; axis can't be irregular.
+ ;
+ if(any(ismissing(Xpts)).and.xaxistype.eq."IrregularAxis") then
+ xaxistype = "LinearAxis"
+ end if
+
+ if(any(ismissing(Ypts)).and.yaxistype.eq."IrregularAxis") then
+ yaxistype = "LinearAxis"
+ end if
+ ;
+ ; If both axes at this point are Irregular, then there is no point
+ ; in overlaying it on an irregular plot class. We then have
+ ; three possible cases:
+ ;
+ ; Case 1: Both X and Y axes are either linear or log.
+ ; Case 2: X axis is irregular and Y axis is linear or log.
+ ; Case 3: Y axis is irregular and X axis is linear or log.
+ ;
+ if(xaxistype.eq."IrregularAxis".and.yaxistype.eq."IrregularAxis") then
+ return(overlay_plot_object)
+ else
+ ;
+ ; Case 1
+ ;
+ ; If pmTickMarkDisplayMode is set, we need to set it during the
+ ; create call, and not afterwards. But, we can't assume a default
+ ; default value, because it varies depending on the type of plot
+ ; being created. So, we have to do the kludgy thing of checking
+ ; for it, and only setting it if the user has set it.
+ ;
+ is_tm_mode = isatt(llres,"pmTickMarkDisplayMode")
+ if(is_tm_mode) then
+ tm_mode = get_display_mode(llres,"pmTickMarkDisplayMode","NoCreate")
+ delete(llres at pmTickMarkDisplayMode)
+ end if
+ if(xaxistype.ne."IrregularAxis".and.
+ yaxistype.ne."IrregularAxis") then
+ if(is_tm_mode) then
+ plot_object = create wksname + "_irregular" irregularPlotClass wks
+ "pmTickMarkDisplayMode" : tm_mode
+ "trXAxisType" : xaxistype
+ "trYAxisType" : yaxistype
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+ else
+ plot_object = create wksname + "_irregular" irregularPlotClass wks
+ "trXAxisType" : xaxistype
+ "trYAxisType" : yaxistype
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+ end if
+ end if
+ ;
+ ; Case 2
+ ;
+ if(xaxistype.eq."IrregularAxis".and.
+ yaxistype.ne."IrregularAxis") then
+ if(is_tm_mode) then
+ plot_object = create wksname + "_irregular" irregularPlotClass wks
+ "pmTickMarkDisplayMode" : tm_mode
+ "trXAxisType" : xaxistype
+ "trYAxisType" : yaxistype
+ "trXCoordPoints" : Xpts
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+ else
+ plot_object = create wksname + "_irregular" irregularPlotClass wks
+ "trXAxisType" : xaxistype
+ "trYAxisType" : yaxistype
+ "trXCoordPoints" : Xpts
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+ end if
+ end if
+ ;
+ ; Case 3
+ ;
+ if(yaxistype.eq."IrregularAxis".and.
+ xaxistype.ne."IrregularAxis") then
+ if(is_tm_mode) then
+ plot_object = create wksname + "_irregular" irregularPlotClass wks
+ "pmTickMarkDisplayMode" : tm_mode
+ "trXAxisType" : xaxistype
+ "trYAxisType" : yaxistype
+ "trYCoordPoints" : Ypts
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+ else
+ plot_object = create wksname + "_irregular" irregularPlotClass wks
+ "trXAxisType" : xaxistype
+ "trYAxisType" : yaxistype
+ "trYCoordPoints" : Ypts
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+ end if
+ end if
+
+ attsetvalues_check(plot_object,llres)
+
+ overlay(plot_object,overlay_plot_object)
+ plot_object@$type$ = overlay_plot_object
+ end if
+
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; function : get_plot_not_loglin ;
+ ; plot:graphic ;
+ ; ;
+ ; Determine what class type "plot" is. If it's a logLinPlotClass, then ;
+ ; It should have an attribute "contour", "vector", "xy", or ;
+ ; "streamine" that is the corresponding contour or vector plot. ;
+ ; ;
+ ;***********************************************************************;
+ undef("get_plot_not_loglin")
+ function get_plot_not_loglin(plot:graphic)
+ local class
+ begin
+ new_plot = new(1,graphic)
+ new_plot at plot_type = "unknown"
+
+ class = NhlClassName(plot)
+
+ if(class(0).ne."contourPlotClass".and.class(0).ne."vectorPlotClass".and.
+ class(0).ne."xyPlotClass".and.class(0).ne."streamlinePlotClass") then
+ if(isatt(plot,"contour")) then
+ new_plot = plot at contour
+ new_plot at plot_type = "contour"
+ else if(isatt(plot,"vector")) then
+ new_plot = plot at vector
+ new_plot at plot_type = "vector"
+ else if(isatt(plot,"streamline")) then
+ new_plot = plot at streamline
+ new_plot at plot_type = "streamline"
+ else
+ found = False
+ getvalues plot
+ "pmOverlaySequenceIds" : base_ids
+ end getvalues
+ if(.not.any(ismissing(base_ids))) then
+ nbase = dimsizes(base_ids)
+ i = 0
+ do while(.not.found.and.i.lt.nbase)
+ bclass = NhlClassName(base_ids(i))
+ if(bclass.eq."contourPlotClass") then
+ new_plot = base_ids(i)
+ new_plot at plot_type = "contour"
+ found = True
+ else if(bclass.eq."vectorPlotClass") then
+ new_plot = base_ids(i)
+ new_plot at plot_type = "vector"
+ found = True
+ else if(bclass.eq."streamlinePlotClass") then
+ new_plot = base_ids(i)
+ new_plot at plot_type = "streamline"
+ found = True
+ else if(bclass.eq."xyPlotClass") then
+ new_plot = base_ids(i)
+ new_plot at plot_type = "xy"
+ found = True
+ end if
+ end if
+ end if
+ end if
+ i = i + 1
+ end do
+ end if
+ if(.not.found) then
+ new_plot = plot(0)
+ end if
+ end if
+ end if
+ end if
+ else
+ if(class(0).eq."contourPlotClass") then
+ new_plot = plot(0)
+ new_plot at plot_type = "contour"
+ else if(class(0).eq."vectorPlotClass") then
+ new_plot = plot(0)
+ new_plot at plot_type = "vector"
+ else if(class(0).eq."streamlinePlotClass") then
+ new_plot = plot(0)
+ new_plot at plot_type = "streamline"
+ else if(class(0).eq."xyPlotClass") then
+ new_plot = plot(0)
+ new_plot at plot_type = "xy"
+ end if
+ end if
+ end if
+ end if
+ end if
+ return(new_plot)
+ end
+
+ ;***********************************************************************;
+ ; function : get_plot_labelbar ;
+ ; plot:graphic ;
+ ; ;
+ ; This function is for gsn_panel, to help it determine which plot info ;
+ ; to use to construct a labelbar. ;
+ ; ;
+ ; In a future release of NCL (> 6.1.0), we hope to make the PlotManager ;
+ ; the default labelbar, so we added some checks to this code for ;
+ ; pmLabelBarDisplayMode being equal to 1 ("Always"). ;
+ ;***********************************************************************;
+ undef("get_plot_labelbar")
+ function get_plot_labelbar(plot:graphic)
+ local found, id_class, i, ids, nids, class_name
+ begin
+ new_plot = new(1,graphic)
+
+ ;
+ ; If new_plot contains a "labelbar" attribute, it likely came
+ ; from one of the vector_scalar functions, in which the
+ ; labelbar could either be from filled contours, or colored
+ ; vectors.
+ ;
+ if(isatt(plot,"labelbar").and.isatt(plot,"labelbar_type")) then
+ new_plot = plot at labelbar
+ new_plot at plot_type = plot at labelbar_type
+ return(new_plot)
+ end if
+ ;
+ ; This part was added in NCL V6.1.0, to test for a PlotManager
+ ; labelbar. If it's there, then return this.
+ ;
+ class_name = NhlClassName(plot)
+ if(any(class_name.eq.(/"ContourPlot","VectorPlot","StreamlinePlot"/))) then
+ getvalues plot
+ "pmLabelBarDisplayMode" : lbar_mode
+ end getvalues
+ ;---lbar_mode.eq.1 --> "Always"
+ if(lbar_mode.eq.1) then
+ new_plot = plot
+ new_plot at PlotManagerLabelBar = True
+ return(new_plot)
+ end if
+ end if
+ ;
+ ; This code was added after V5.1.1. It is better to use the
+ ; overlay ids to detect what overlay plots there are, and
+ ; then figure out from resources set which ones might
+ ; potentially require a labelbar.
+ ;
+ ; Note that this test will favor contour plots over
+ ; vector over streamline plots, and it will use the
+ ; first plot that it finds.
+ ;
+ getvalues plot
+ "pmOverlaySequenceIds" : ids
+ end getvalues
+ nids = dimsizes(ids)
+ found = False
+ i = 0
+ do while(.not.found.and.i.lt.nids)
+ id_class = NhlClassName(ids(i))
+ if(id_class.eq."contourPlotClass") then
+ getvalues ids(i)
+ "cnFillOn" : cn_fillon
+ "pmLabelBarDisplayMode" : lbar_mode
+ end getvalues
+ if(lbar_mode.eq.1.or.cn_fillon) then
+ found = True
+ new_plot = ids(i)
+ new_plot at plot_type = "contour"
+ end if
+ end if
+ if(id_class.eq."vectorPlotClass") then
+ ;
+ ; Glyph styles:
+ ; 0 = linearrow, 1 = fillarrow, 2 = windbarb, 3 = curlyvector
+ ;
+ getvalues ids(i)
+ "vcGlyphStyle" : vc_glyphstyle
+ "vcMonoFillArrowFillColor" : vc_monofillarrowfillcolor
+ "vcMonoLineArrowColor" : vc_monolinearrowcolor
+ "vcMonoWindBarbColor" : vc_monowindbarbcolor
+ "pmLabelBarDisplayMode" : lbar_mode
+ end getvalues
+ if( (lbar_mode.eq.1) .or.
+ (vc_glyphstyle.eq.0.and..not.vc_monolinearrowcolor) .or.
+ (vc_glyphstyle.eq.1.and..not.vc_monofillarrowfillcolor) .or.
+ (vc_glyphstyle.eq.2.and..not.vc_monowindbarbcolor) .or.
+ (vc_glyphstyle.eq.3.and..not.vc_monolinearrowcolor)) then
+ found = True
+ new_plot = ids(i)
+ new_plot at plot_type = "vector"
+ end if
+ end if
+ if(id_class.eq."streamlinePlotClass") then
+ getvalues ids(i)
+ "stMonoLineColor" : st_monolinecolor
+ "pmLabelBarDisplayMode" : lbar_mode
+ end getvalues
+ if(lbar_mode.eq.1.or..not.st_monolinecolor) then
+ found = True
+ new_plot = ids(i)
+ new_plot at plot_type = "streamline"
+ end if
+ end if
+ i = i + 1
+ end do
+ if(found) then
+ return(new_plot)
+ end if
+ ;
+ ; If all else fails, do it the "old" way before V5.2.0.
+ ;
+ new_plot = get_plot_not_loglin(plot)
+ return(new_plot)
+ end
+
+ ;**********************************************************************;
+ ; Function : maximize_bb ;
+ ; plot : graphic ;
+ ; res : logical ;
+ ; ;
+ ; This function computes the viewport coordinates needed to optimize ;
+ ; the size of a plot on a page. If the plot is too big for the ;
+ ; viewport, then this function will decrease the plot size. ;
+ ; ;
+ ; plot : plot to maximize on the page. ;
+ ; ;
+ ; res : list of optional resources. Ones accepted include: ;
+ ; ;
+ ; "gsnBoxMargin" - margin to leave around plots (in NDC units, ;
+ ; default is 0.02) ;
+ ; ;
+ ;**********************************************************************;
+ undef("maximize_bb")
+ function maximize_bb(plot[1]:graphic,res:logical)
+ local coords, top, bot, lft, rgt, width, height, margin
+ begin
+ ;
+ ; Get resources.
+ ;
+ margin = get_res_value_keep(res,"gsnBoxMargin",0.02)
+
+ ;
+ ; Get bounding box of plot.
+ ;
+ bb = NhlGetBB(plot)
+
+ top = bb(0)
+ bot = bb(1)
+ lft = bb(2)
+ rgt = bb(3)
+
+ ;
+ ; Get height/width of plot in NDC units.
+ ;
+ uw = rgt - lft
+ uh = top - bot
+
+ ;
+ ; Calculate scale factor needed to make plot larger (or smaller, if it's
+ ; outside the viewport).
+ ;
+ scale = (1 - 2*margin)/max((/uw,uh/))
+
+ ;
+ ; Get the viewport.
+ ;
+ getvalues plot
+ "vpXF" : vpx
+ "vpYF" : vpy
+ "vpWidthF" : vpw
+ "vpHeightF" : vph
+ end getvalues
+
+ dx = scale * (vpx - lft) ; Calculate distance from plot's left position
+ ; to its leftmost annotation
+ dy = scale * (top - vpy) ; Calculate distance from plot's top position
+ ; to its topmost annotation.
+ ;
+ ; Calculate new viewport coordinates.
+ ;
+ new_uw = uw * scale
+ new_uh = uh * scale
+ new_ux = .5 * (1-new_uw)
+ new_uy = 1 - .5 * (1-new_uh)
+
+ new_vpx = new_ux + dx
+ new_vpy = new_uy - dy
+ new_vpw = vpw * scale
+ new_vph = vph * scale
+ ;
+ ; Return new coordinates
+ ;
+ return((/new_vpx,new_vpy,new_vpw,new_vph/))
+ end
+
+ ;***********************************************************************;
+ ; This procedure writes a series of strings to a given string array and ;
+ ; increments the line counter. ;
+ ;***********************************************************************;
+ undef("write_lines")
+ procedure write_lines(strs, thelines, numlines)
+ local nstrs
+ begin
+ nstrs = dimsizes(strs) ; Number of strings to write.
+ ntlines = dimsizes(thelines) ; Number of available lines.
+
+ if((numlines+nstrs).gt.ntlines) then
+ print("write_lines: error: array is not big enough to hold new lines")
+ print(" no lines will be written")
+ return
+ end if
+
+ thelines(numlines:numlines+nstrs-1) = strs ; Add strings
+ numlines = numlines + nstrs
+ end
+
+ ;***********************************************************************;
+ ; This procedure is to be used in conjunction with gsnp_write_debug_info;
+ ; It takes care of the special case where "lat2d" and "lon2d" attributes;
+ ; may be attached to the data array. You can't write 2D attributes to a ;
+ ; netCDF file, so we write them as 1D with information that we can use ;
+ ; to reconstruct the 2D array later. ;
+ ;***********************************************************************;
+ undef("add_latlon2d_debug_info")
+ procedure add_latlon2d_debug_info(data)
+ local dims_lat, dims_lon
+ begin
+ if(isatt(data,"lat2d")) then
+ dims_lat = dimsizes(data at lat2d)
+ if(dimsizes(dims_lat).eq.2) then
+ data at lat1d_yndim = dims_lat(0)
+ data at lat1d_xndim = dims_lat(1)
+ data at lat1d = ndtooned(data at lat2d)
+ delete(data at lat2d)
+ end if
+ end if
+ if(isatt(data,"lon2d")) then
+ dims_lon = dimsizes(data at lon2d)
+ if(dimsizes(dims_lon).eq.2) then
+ data at lon1d_yndim = dims_lon(0)
+ data at lon1d_xndim = dims_lon(1)
+ data at lon1d = ndtooned(data at lon2d)
+ delete(data at lon2d)
+ end if
+ end if
+ end
+
+ ;***********************************************************************;
+ ; This procedure is used in conjunction with add_laton2d_debug_info. ;
+ ; It adds back lat2d/lon2d attributes that were removed earlier, and ;
+ ; removes attribute info that was added to a data array (all in support ;
+ ; of the gsnp_write_debug_info procedure). ;
+ ;***********************************************************************;
+ undef("fix_latlon2d_debug_info")
+ procedure fix_latlon2d_debug_info(ldata)
+ begin
+ if(isatt(ldata,"lat1d").and.
+ isatt(ldata,"lat1d_yndim").and.
+ isatt(ldata,"lat1d_xndim").and.
+ isatt(ldata,"lon1d").and.
+ isatt(ldata,"lon1d_yndim").and.
+ isatt(ldata,"lon1d_xndim")) then
+ ldata at lat2d = onedtond(ldata at lat1d,(/ldata at lat1d_yndim,ldata at lat1d_xndim/))
+ ldata at lon2d = onedtond(ldata at lon1d,(/ldata at lon1d_yndim,ldata at lon1d_xndim/))
+ delete(ldata at lat1d_yndim)
+ delete(ldata at lat1d_xndim)
+ delete(ldata at lon1d_yndim)
+ delete(ldata at lon1d_xndim)
+ delete(ldata at lat1d)
+ delete(ldata at lon1d)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; This procedure is used in conjunction with add_laton2d_debug_info. ;
+ ; and gsnp_write_debug_info. It writes lines to an NCL script that ;
+ ; reconstructs lat2d and lon2d attribute information. ;
+ ;***********************************************************************;
+ undef("write_latlon2d_lines")
+ procedure write_latlon2d_lines(ldata, ldata_name[1]:string, thelines, numlines)
+ local nlines
+ begin
+ if(isatt(ldata,"lat1d").and.
+ isatt(ldata,"lat1d_yndim").and.
+ isatt(ldata,"lat1d_xndim").and.
+ isatt(ldata,"lon1d").and.
+ isatt(ldata,"lon1d_yndim").and.
+ isatt(ldata,"lon1d_xndim")) then
+ nlines = (/" " + ldata_name + "@lat2d = onedtond(" + ldata_name +
+ "@lat1d,(/" + ldata_name + "@lat1d_yndim," + ldata_name +
+ "@lat1d_xndim/))",
+ " " + ldata_name + "@lon2d = onedtond(" + ldata_name +
+ "@lon1d,(/" + ldata_name + "@lon1d_yndim," + ldata_name +
+ "@lon1d_xndim/))"/)
+
+ write_lines( nlines, thelines, numlines)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; This procedure writes a standard resource file that changes the font ;
+ ; to helvetica, foreground/background colors to white/black, and the ;
+ ; function code to "~". ;
+ ;***********************************************************************;
+ undef("write_debug_res_file")
+ procedure write_debug_res_file(resfname[1]:string)
+ local reslines
+ begin
+ reslines = (/"*wkForegroundColor : (/0.,0.,0./)",
+ "*wkBackgroundColor : (/1.,1.,1./)",
+ "*Font : helvetica",
+ "*TextFuncCode : ~"/)
+
+ asciiwrite(resfname,reslines)
+ end
+
+ ;***********************************************************************;
+ ; This procedure writes some debug info (data and plot resource values) ;
+ ; to a netCDF file and creates an NCL file to plot the data. ;
+ ;***********************************************************************;
+ undef("gsnp_write_debug_info")
+ procedure gsnp_write_debug_info(data1,data2,data3,gsn_name[1]:string,
+ plot_res[1]:logical,ndfiles[1]:integer)
+ begin
+ ;
+ ; Can only deal with up to three data files.
+ ;
+ if(ndfiles.lt.0.or.ndfiles.gt.3) then
+ print("gsnp_write_debug_info: error: can only have 0-3 data files.")
+ exit
+ end if
+ ;
+ ; Valid plot function names that this routine can be use for.
+ ;
+ gsn_names = (/"gsn_contour", "gsn_contour_map", "gsn_csm_contour",
+ "gsn_csm_contour_map", "gsn_csm_contour_map_ce",
+ "gsn_csm_contour_map_other",
+ "gsn_csm_contour_map_polar", "gsn_csm_hov",
+ "gsn_csm_lat_time", "gsn_csm_map", "gsn_csm_map_ce",
+ "gsn_csm_map_other", "gsn_csm_map_polar",
+ "gsn_csm_pres_hgt", "gsn_csm_pres_hgt_streamline",
+ "gsn_csm_pres_hgt_vector", "gsn_csm_streamline",
+ "gsn_csm_streamline_contour_map",
+ "gsn_csm_streamline_contour_map_ce",
+ "gsn_csm_streamline_contour_map_other",
+ "gsn_csm_streamline_contour_map_polar",
+ "gsn_csm_streamline_map", "gsn_csm_streamline_map_ce",
+ "gsn_csm_streamline_map_other",
+ "gsn_csm_streamline_map_polar",
+ "gsn_csm_streamline_scalar_map",
+ "gsn_csm_streamline_scalar_map_ce",
+ "gsn_csm_streamline_scalar_map_other",
+ "gsn_csm_streamline_scalar_map_polar",
+ "gsn_csm_time_lat", "gsn_csm_vector", "gsn_csm_vector_map",
+ "gsn_csm_vector_map_ce", "gsn_csm_vector_map_other",
+ "gsn_csm_vector_map_polar", "gsn_csm_vector_scalar",
+ "gsn_csm_vector_scalar_map",
+ "gsn_csm_vector_scalar_map_ce",
+ "gsn_csm_vector_scalar_map_other",
+ "gsn_csm_vector_scalar_map_polar",
+ "gsn_csm_xy", "gsn_csm_y", "gsn_histogram", "gsn_map",
+ "gsn_streamline", "gsn_streamline_contour",
+ "gsn_streamline_map", "gsn_vector",
+ "gsn_vector_contour", "gsn_vector_contour_map",
+ "gsn_vector_map", "gsn_vector_scalar", "gsn_streamline_scalar",
+ "gsn_vector_scalar_map", "gsn_streamline_scalar_map",
+ "gsn_xy", "gsn_y"/)
+
+ if(.not.any(gsn_name.eq.gsn_names)) then
+ print("gsnp_write_debug_info: error: do not recognize " + gsn_name + " as a")
+ print("valid plot function name that can be used with this procedure.")
+ exit
+ end if
+
+ ;
+ ; Create netCDF and NCL files to write to. The default will be
+ ; "debug.ncl" and "debug.nc" unless otherwise specified.
+ ;
+ debug_file = get_res_value(plot_res,"gsnDebugWriteFileName",
+ unique_string("debug"))
+
+ cdf_debug_file = debug_file + ".nc"
+ ncl_debug_file = debug_file + ".ncl"
+ res_debug_file = debug_file + ".res"
+
+ if(fileexists(cdf_debug_file).or.fileexists(ncl_debug_file).or.
+ fileexists(res_debug_file)) then
+ print("gsnp_write_debug_info: error: debug files '" + cdf_debug_file + "',")
+ print("'" + ncl_debug_file + "' and/or " + res_debug_file + " exist.")
+ print("Please remove file(s) and start script again.")
+ exit
+ else
+ dfile = addfile(cdf_debug_file,"c")
+ end if
+
+ ;
+ ; Write the plot data to the netCDF file. If the data contains the
+ ; special 2D lat2d/lon2d arrays, we have to write these as 1D arrays
+ ; and reconstruct them as 2D later.
+ ;
+ if(ndfiles.ge.1) then
+ add_latlon2d_debug_info(data1)
+ dfile->PlotData = data1 ; Write the data
+ end if
+ if(ndfiles.ge.2) then
+ add_latlon2d_debug_info(data2)
+ dfile->PlotData2 = data2
+ end if
+ if(ndfiles.ge.3) then
+ add_latlon2d_debug_info(data3)
+ dfile->PlotData3 = data3
+ end if
+
+ dfile at gsn_function = stringtochar(gsn_name) ; Write name of gsn_xxx routine
+
+ ;
+ ; If the colormap is not a name of a colormap, or a string array of
+ ; colors, then this means we have a colormap that we need to write
+ ; to the netCDF file as data.
+ ;
+ colormap = get_res_value(plot_res,"gsnDebugWriteColorMap","")
+ if(typeof(colormap).ne."string")
+ dfile->ColorMap = colormap ; Write to file so we can read later.
+ end if
+
+ ;
+ ; Get plot resources, if any.
+ ;
+ pattnames = getvaratts(plot_res)
+ if(.not.any(ismissing(pattnames))) then
+ natt = dimsizes(pattnames)
+ else
+ natt = 0
+ end if
+ ;
+ ; Get plot attributes, if any, and check if any of them are ones
+ ; that can contain big data arrays, like sfXArray, vfYArray, etc.
+ ; If so, then write these to the netCDF file. Otherwise, write them
+ ; to the file as attributes.
+ ;
+ array_resources = (/"sfXArray","sfYArray","vfXArray","vfYArray"/)
+
+ if(natt.gt.0) then
+ do i=0,natt-1
+ if(any(pattnames(i).eq.array_resources)) then
+ dfile->$pattnames(i)$ = plot_res@$pattnames(i)$
+ else
+ if(typeof(plot_res@$pattnames(i)$).eq."logical") then
+ if(plot_res@$pattnames(i)$) then
+ dfile@$pattnames(i)$ = 1
+ else
+ dfile@$pattnames(i)$ = 0
+ end if
+ else
+ dfile@$pattnames(i)$ = plot_res@$pattnames(i)$
+ end if
+ end if
+ end do
+ end if
+
+ ;
+ ; Create NCL script that plots data.
+ ;
+ q = inttochar(34) ; 34 is the decimal equivalent of double quote (")
+
+ lines = new(30+natt,string) ; Roughly how many lines we need
+ nlines = 0
+
+ write_lines("load " + q + "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_code.ncl" + q, lines, nlines)
+ write_lines("load " + q + "$NCARG_ROOT/lib/ncarg/nclscripts/csm/gsn_csm.ncl" + q, lines, nlines)
+ write_lines("", lines, nlines)
+ write_lines("begin", lines, nlines)
+ write_lines(";", lines, nlines)
+ write_lines("; Read in data.", lines, nlines)
+ write_lines(";", lines, nlines)
+ write_lines(" cdf_file = addfile(" + q + cdf_debug_file + q + "," + q + "r" + q + ")", lines, nlines)
+
+ if(ndfiles.ge.1) then
+ write_lines(" data1 = cdf_file->PlotData", lines, nlines)
+ write_latlon2d_lines(data1, "data1", lines, nlines)
+ end if
+ if(ndfiles.ge.2) then
+ write_lines(" data2 = cdf_file->PlotData2", lines, nlines)
+ write_latlon2d_lines(data2, "data2", lines, nlines)
+ end if
+ if(ndfiles.ge.3) then
+ write_lines(" data3 = cdf_file->PlotData3", lines, nlines)
+ write_latlon2d_lines(data3, "data3", lines, nlines)
+ end if
+ write_lines("", lines, nlines)
+ write_lines(";", lines, nlines)
+ write_lines("; Open PNG file.", lines, nlines)
+ write_lines(";", lines, nlines)
+ write_lines(" wks = gsn_open_wks(" + q + "png" + q + ", " + q + debug_file + q + ")", lines, nlines)
+ ;
+ ; Set colormap, if one inputted by user.
+ ;
+ if(typeof(colormap).ne."string") then
+ write_lines(" gsn_define_colormap(wks, cdf_file->ColorMap)",
+ lines, nlines)
+ else
+ if(colormap.ne."") then
+ write_lines(" gsn_define_colormap(wks," + q + colormap + q +
+ ")", lines, nlines)
+ else
+ write_lines("; gsn_define_colormap(wks, " + colormap + ")", lines, nlines)
+ end if
+ end if
+ write_lines("", lines, nlines)
+
+ ;
+ ; Loop through resources written to netCDF file and add them to NCL
+ ; script. If one of the array resources are encountered, this means the
+ ; value should be read off the file as a variable.
+ ;
+ ; If one of the ignore_resources is encountered, write it to
+ ; the script, but comment it out.
+ ;
+ ignore_resources = (/"gsnDraw","gsnFrame"/)
+
+ if(natt.gt.0) then
+ write_lines(" res = True", lines, nlines)
+ do i=0,natt-1
+ if(any(pattnames(i).eq.ignore_resources)) then
+ cc = ";" ; Set comment char
+ else
+ cc = "" ; Don't set comment char
+ end if
+ if(typeof(plot_res@$pattnames(i)$).eq."string") then
+ qc = q ; Set quote char
+ else
+ qc = "" ; Don't set quote char
+ end if
+ if(any(pattnames(i).eq.array_resources)) then
+ write_lines(cc + " res@" + pattnames(i) + " = cdf_file->" +
+ pattnames(i), lines, nlines)
+ else
+ narr = dimsizes(plot_res@$pattnames(i)$)
+ if(narr.eq.1) then
+ write_lines(cc + " res@" + pattnames(i) + " = " + qc +
+ plot_res@$pattnames(i)$ + qc, lines, nlines)
+ else
+ ;
+ ; We have to write out an array of attribute values.
+ ;
+ build_str = cc + " res@" + pattnames(i) + " = (/"
+ do na=0,narr-2
+ build_str = build_str + qc + plot_res@$pattnames(i)$(na) + qc + ", "
+ end do
+ build_str = build_str + qc + plot_res@$pattnames(i)$(narr-1) + qc + "/)"
+ write_lines(build_str, lines, nlines)
+ end if
+ end if
+ delete(qc)
+ end do
+ else
+ write_lines(" res = False", lines, nlines)
+ end if
+
+ write_lines("", lines, nlines)
+ if(ndfiles.eq.0) then
+ if(gsn_name.eq."gsn_map") then
+ proj = get_res_value_keep(plot_res,"mpProjection","CylindricalEquidistant")
+ write_lines(" plot = " + gsn_name + "(wks," + q + proj +
+ q + ", res)", lines, nlines)
+ else
+ write_lines(" plot = " + gsn_name + "(wks, res)", lines, nlines)
+ end if
+ else
+ if(ndfiles.eq.1) then
+ write_lines(" plot = " + gsn_name + "(wks, data1, res)", lines, nlines)
+ else
+ if(ndfiles.eq.2) then
+ write_lines(" plot = " + gsn_name + "(wks, data1, data2, res)", lines, nlines)
+ else
+ write_lines(" plot = " + gsn_name + "(wks, data1, data2, data3, res)", lines, nlines)
+ end if
+ end if
+ end if
+ write_lines("end", lines, nlines)
+
+ ;
+ ; Write NCL script and resource file.
+ ;
+ asciiwrite(ncl_debug_file,lines(:nlines-1))
+ write_debug_res_file(res_debug_file)
+
+ ;
+ ; Print some information.
+ ;
+ print("gsnp_write_debug_info: debug info written to:")
+ print(" '" + ncl_debug_file + "'")
+ print(" '" + cdf_debug_file + "'")
+ print(" '" + res_debug_file + "'")
+ ;
+ ; Clean up. Put the lat2d/lon2d attributes back, if there were any.
+ ;
+ if(ndfiles.ge.1) then
+ fix_latlon2d_debug_info(data1)
+ end if
+ if(ndfiles.ge.2) then
+ fix_latlon2d_debug_info(data2)
+ end if
+ if(ndfiles.ge.3) then
+ fix_latlon2d_debug_info(data3)
+ end if
+
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsnp_turn_off_tickmarks ;
+ ; res:logical ;
+ ; ;
+ ; By default, tickmarks are drawn on all plots that aren't overlaid on ;
+ ; a map. If gsnTickMarksOn is set to False, then this turns off the ;
+ ; drawing of tick marks. This procedure just sets the resources ;
+ ; necessary in order to turn off tick marks. ;
+ ;***********************************************************************;
+ undef("gsnp_turn_off_tickmarks")
+ procedure gsnp_turn_off_tickmarks(res:logical)
+ begin
+ set_attr(res,"tmXBBorderOn",False )
+ set_attr(res,"tmXBOn", False)
+ set_attr(res,"tmXTBorderOn",False)
+ set_attr(res,"tmXTOn", False)
+ set_attr(res,"tmYLBorderOn",False)
+ set_attr(res,"tmYLOn", False)
+ set_attr(res,"tmYRBorderOn",False)
+ set_attr(res,"tmYROn", False)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsnp_point_tickmarks_outward ;
+ ; plot:object ;
+ ; res:logical ;
+ ; x_major_length:numeric ;
+ ; y_major_length:numeric ;
+ ; x_minor_length:numeric ;
+ ; y_minor_length:numeric ;
+ ; major_length:numeric ;
+ ; minor_length:numeric ;
+ ; ;
+ ; By default, tickmarks are drawn pointing inwards. This procedure ;
+ ; makes them point out. This procedure also sets the major and/or minor ;
+ ; tickmarks on both axes to be the same length if the major and/or minor;
+ ; tickmarks lengths are != 0. ;
+ ;***********************************************************************;
+ undef("gsnp_point_tickmarks_outward")
+ procedure gsnp_point_tickmarks_outward(plot:graphic,res:logical,
+ x_major_length, y_major_length,
+ x_minor_length, y_minor_length,
+ major_length, minor_length,point_outward)
+ local tmres
+ begin
+ if(major_length.lt.0.)
+ getvalues plot
+ "tmXBMajorLengthF" : x_major_length
+ "tmYLMajorLengthF" : y_major_length
+ end getvalues
+ major_length = min((/x_major_length,y_major_length/))
+ if(x_major_length.gt.0..and.y_major_length.gt.0.)
+ x_major_length = min((/x_major_length,y_major_length/))
+ y_major_length = x_major_length
+ end if
+ else
+ if(x_major_length.gt.0.)
+ x_major_length = major_length
+ end if
+ if(y_major_length.gt.0.)
+ y_major_length = major_length
+ end if
+ end if
+
+ if(minor_length.lt.0.)
+ getvalues plot
+ "tmXBMinorLengthF" : x_minor_length
+ "tmYLMinorLengthF" : y_minor_length
+ end getvalues
+ if(x_minor_length.gt.0..and.y_minor_length.gt.0.)
+ x_minor_length = min((/x_minor_length,y_minor_length/))
+ y_minor_length = x_minor_length
+ end if
+ else
+ if(x_minor_length.gt.0.)
+ x_minor_length = minor_length
+ end if
+ if(y_minor_length.gt.0.)
+ y_minor_length = minor_length
+ end if
+ end if
+
+ tmres = res
+ tmres = True
+
+ set_attr(tmres,"tmXBMajorLengthF" , x_major_length)
+ set_attr(tmres,"tmXBMinorLengthF" , x_minor_length)
+ set_attr(tmres,"tmXTMajorLengthF" , x_major_length)
+ set_attr(tmres,"tmXTMinorLengthF" , x_minor_length)
+ set_attr(tmres,"tmYLMajorLengthF" , y_major_length)
+ set_attr(tmres,"tmYLMinorLengthF" , y_minor_length)
+ set_attr(tmres,"tmYRMajorLengthF" , y_major_length)
+ set_attr(tmres,"tmYRMinorLengthF" , y_minor_length)
+
+ if (point_outward) then
+ set_attr(tmres,"tmXBMajorOutwardLengthF" , x_major_length)
+ set_attr(tmres,"tmXBMinorOutwardLengthF" , x_minor_length)
+ set_attr(tmres,"tmXTMajorOutwardLengthF" , x_major_length)
+ set_attr(tmres,"tmXTMinorOutwardLengthF" , x_minor_length)
+ set_attr(tmres,"tmYLMajorOutwardLengthF" , y_major_length)
+ set_attr(tmres,"tmYLMinorOutwardLengthF" , y_minor_length)
+ set_attr(tmres,"tmYRMajorOutwardLengthF" , y_major_length)
+ set_attr(tmres,"tmYRMinorOutwardLengthF" , y_minor_length)
+ end if
+
+ attsetvalues_check(plot,tmres)
+
+ return
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsnp_uniform_tickmark_labels ;
+ ; plot:object ;
+ ; res:logical ;
+ ; font_height ;
+ ; ;
+ ; This procedure makes the tickmark labels the same font height on both ;
+ ; axes. If font_height <= 0., then a uniform font height is calculated. ;
+ ;***********************************************************************;
+ undef("gsnp_uniform_tickmark_labels")
+ procedure gsnp_uniform_tickmark_labels(plot:graphic,res:logical,
+ font_height)
+ local xbfont, ylfont, tmres
+ begin
+
+ ; Get tickmark labels sizes
+
+ if(font_height.le.0)
+ getvalues plot
+ "tmXBLabelFontHeightF" : xbfont
+ "tmYLLabelFontHeightF" : ylfont
+ end getvalues
+ font_height = min((/xbfont,ylfont/))
+ end if
+
+ ; Make tickmark label sizes the same.
+
+ tmres = res
+ tmres = True
+
+ set_attr(tmres,"tmXBLabelFontHeightF" , font_height)
+ set_attr(tmres,"tmYLLabelFontHeightF" , font_height)
+ set_attr(tmres,"tmXTLabelFontHeightF" , font_height)
+ set_attr(tmres,"tmYRLabelFontHeightF" , font_height)
+
+ attsetvalues_check(plot,tmres)
+
+ return
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsnp_shape_plot ;
+ ; plot:graphic ;
+ ; ;
+ ; If gsnShape is set to True, then the plot is scaled such that the X ;
+ ; and Y axes are proportional to each other. ;
+ ;***********************************************************************;
+ undef("gsnp_shape_plot")
+ procedure gsnp_shape_plot(plot:graphic)
+ local xf, yf, width, height, trxmin, trxmax, trymin, trymax, xrange, yrange,
+ new_xf, new_yf, new_width, new_height
+ begin
+ getvalues plot
+ "vpXF" : xf
+ "vpYF" : yf
+ "vpWidthF" : width
+ "vpHeightF" : height
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end getvalues
+
+ xrange = trxmax - trxmin
+ yrange = trymax - trymin
+
+ if(xrange.lt.yrange)
+ new_width = width * (xrange/yrange)
+ new_height = height
+ new_xf = xf + 0.5*(width-new_width)
+ new_yf = yf
+ else
+ new_height = height * (yrange/xrange)
+ new_width = width
+ new_yf = yf - 0.5*(height-new_height)
+ new_xf = xf
+ end if
+
+ setvalues plot
+ "vpXF" : new_xf
+ "vpYF" : new_yf
+ "vpWidthF" : new_width
+ "vpHeightF" : new_height
+ end setvalues
+
+ return
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsnp_scale_plot ;
+ ; plot:graphic ;
+ ; prefix:string ;
+ ; res:logical ;
+ ; ;
+ ; If gsnScale is set to True, then the plot is scaled such the tickmarks;
+ ; and tickmark labels are the same size on both axes. ;
+ ; ;
+ ; As of 5.0.1, this procedure checks the resource list to see if the ;
+ ; xxX/YArray resources are attached, and if they are 2D. If so, then we ;
+ ; also need to make sure trGridType is TriangularMesh, otherwise we ;
+ ; can't have a tickmark object. ;
+ ;***********************************************************************;
+ undef("gsnp_scale_plot")
+ procedure gsnp_scale_plot(plot:graphic,scalar_prefix,res:logical)
+ local xfont, yfont, xbfont, xlength, xmlength, ylfont, ylength, ymlength,
+ xresname, yresname, valid_tm, tr_grid_type
+ begin
+ ;
+ ; We can get/set the title sizes no matter what.
+ ;
+ getvalues plot
+ "tiXAxisFontHeightF" : xfont
+ "tiYAxisFontHeightF" : yfont
+ end getvalues
+ setvalues plot
+ "tiXAxisFontHeightF" : (xfont+yfont)/2.
+ "tiYAxisFontHeightF" : (xfont+yfont)/2.
+ end setvalues
+ ;
+ ; Here's the code for checking if we have a valid tickmark object.
+ ;
+ valid_tm = True ; Assume we have a valid one, unless proven otherwise.
+ if(res.and.scalar_prefix.ne."") then
+ xresname = scalar_prefix + "XArray"
+ yresname = scalar_prefix + "YArray"
+ if(((isatt(res,xresname).and.dimsizes(dimsizes(res@$xresname$)).gt.1).or.
+ (isatt(res,yresname).and.dimsizes(dimsizes(res@$yresname$)).gt.1))) then
+ getvalues plot
+ "trGridType" : tr_grid_type
+ end getvalues
+ if(tr_grid_type.ne.5) then
+ valid_tm = False
+ end if
+ end if
+ end if
+ if(valid_tm) then
+ getvalues plot
+ "tmXBLabelFontHeightF" : xbfont
+ "tmXBMajorLengthF" : xlength
+ "tmXBMinorLengthF" : xmlength
+ "tmYLLabelFontHeightF" : ylfont
+ "tmYLMajorLengthF" : ylength
+ "tmYLMinorLengthF" : ymlength
+ end getvalues
+
+ if(xlength.ne.0..and.ylength.ne.0.) then
+ major_length = (ylength+xlength)/2.
+ xlength = major_length
+ ylength = major_length
+ end if
+
+ if(xmlength.ne.0..and.ymlength.ne.0.) then
+ minor_length = (ymlength+xmlength)/2.
+ xmlength = minor_length
+ ymlength = minor_length
+ end if
+
+ setvalues plot
+ "tmXBLabelFontHeightF" : (xbfont+ylfont)/2.
+ "tmXBMajorLengthF" : xlength
+ "tmXBMinorLengthF" : xmlength
+ "tmYLLabelFontHeightF" : (xbfont+ylfont)/2.
+ "tmYLMajorLengthF" : ylength
+ "tmYLMinorLengthF" : ymlength
+ end setvalues
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Procedure : check_for_tickmarks_off ;
+ ; res:logical ;
+ ; ;
+ ; By default, tickmarks are drawn on all plots that aren't overlaid on ;
+ ; a map. If gsnTickMarksOn is set to False, then this turns off the ;
+ ; drawing of tick marks. This procedure checks for the setting of this ;
+ ; resource, and then calls the routine that turns off tickmarks. ;
+ ;***********************************************************************;
+ undef("check_for_tickmarks_off")
+ procedure check_for_tickmarks_off(res:logical)
+ local ticks_ons
+ begin
+
+ ; Check if turning tickmarks off.
+
+ ticks_on = get_res_value(res,"gsnTickMarksOn",True)
+ if(.not.ticks_on)
+ gsnp_turn_off_tickmarks(res)
+ end if
+ end
+
+ ;**********************************************************************;
+ ; Function : compute_device_coords ;
+ ; plot : graphic ;
+ ; res : logical ;
+ ; ;
+ ; This function computes the PDF/PS device coordinates needed to ;
+ ; make a plot fill up the full page. ;
+ ; ;
+ ; plot : the plot or the workstation ;
+ ; res : list of optional resources. Ones accepted include: ;
+ ; ;
+ ; "gsnPaperOrientation" - orientation of paper. Can be "landscape", ;
+ ; "portrait", or "auto". Default is "auto". ;
+ ; ;
+ ; "gsnPaperWidth" - width of paper (in inches, default is 8.5) ;
+ ; "gsnPaperHeight" - height of paper (in inches, default is 11.0);
+ ; "gsnPaperMargin" - margin to leave around plots (in inches, ;
+ ; default is 0.5) ;
+ ; ;
+ ; In V5.2.0, new paper size resources were added, and this function ;
+ ; was updated to recognize them (wkPaperSize, wkPaperWidthF, ;
+ ; and wkPaperHeightF). ;
+ ; ;
+ ; gsnPaperWidth and gsnPaperHeight are considered deprecated, but ;
+ ; still recognized. ;
+ ; ;
+ ; ;
+ ;**********************************************************************;
+ undef("compute_device_coords")
+ function compute_device_coords(plot,res)
+ local coords, top, bot, lft, rgt, dpi, dpi_pw, dpi_ph, dpi_margin,
+ paper_width, paper_height, paper_margin, bb, tmp_wks, wks_ph, wks_pw, def_margin
+ begin
+ def_margin = 0.5 ; Default margin, in inches.
+ def_orient = "auto" ; Best possible orientation will be used, by default.
+
+ ; Get workstation parent of plot, and retrieve paper size and width.
+ ii = ind(.not.ismissing(plot))
+ if(all(ismissing(ii))) then
+ print("compute_device_coords: Error: all input plots are missing")
+ status_exit(1)
+ end if
+
+ tmp_wks = NhlGetParentWorkstation(plot(ii(0)))
+ getvalues tmp_wks
+ "wkPaperWidthF" : wks_pw
+ "wkPaperHeightF" : wks_ph
+ end getvalues
+
+ ;
+ ; Get resources.
+ ;
+ paper_height = get_res_value_keep(res,"gsnPaperHeight",wks_ph)
+ paper_width = get_res_value_keep(res,"gsnPaperWidth",wks_pw)
+ paper_margin = get_res_value_keep(res,"gsnPaperMargin",def_margin)
+ paper_orient = get_res_value_keep(res,"gsnPaperOrientation",def_orient)
+ is_debug = get_res_value_keep(res,"gsnDebug",False)
+
+ if(is_debug)
+ print(" Paper width/height = " + paper_width + "/" + paper_height)
+ end if
+
+ ;
+ ; Check to see if any panel resources have been set. No defaults
+ ; will be assumed for these. They are only used if they have been
+ ; explicitly set by the user.
+ ;
+ lft_pnl = isatt(res,"gsnPanelLeft")
+ rgt_pnl = isatt(res,"gsnPanelRight")
+ bot_pnl = isatt(res,"gsnPanelBottom")
+ top_pnl = isatt(res,"gsnPanelTop")
+
+ lft_inv_pnl = isatt(res,"gsnPanelInvsblLeft")
+ rgt_inv_pnl = isatt(res,"gsnPanelInvsblRight")
+ bot_inv_pnl = isatt(res,"gsnPanelInvsblBottom")
+ top_inv_pnl = isatt(res,"gsnPanelInvsblTop")
+
+ if(typeof(paper_orient).eq."integer")
+ if(paper_orient.eq.0)
+ lc_orient = "portrait"
+ else
+ lc_orient = "landscape"
+ end if
+ else
+ lc_orient = lower_case(paper_orient)
+ end if
+ ;
+ ; Get the bounding box that covers all the plots. If gsnPanel
+ ; resources have been added to add white space around plots, then
+ ; count this white space in as well. Note that even though the bounding
+ ; box coordinates should be positive, it *is* possible for them to be
+ ; negative, and we need to keep these negative values in our calculations
+ ; later to preserve the aspect ratio.
+ ;
+ bb = NhlGetBB(plot)
+ dimbb = dimsizes(bb)
+ if(dimsizes(dimbb).eq.1) then
+ ;
+ ; Force newbb to be 2-dimensional so we don't have to have a
+ ; bunch of "if" tests later.
+ ;
+ newbb = new((/1,4/),float)
+ newbb(0,:) = bb
+ else
+ newbb = bb
+ end if
+
+ if(top_inv_pnl)
+ top = max((/res at gsnPanelInvsblTop,max(newbb(:,0))/))
+ else
+ if(top_pnl)
+ top = max((/1.,max(newbb(:,0))/))
+ else
+ top = max(newbb(:,0))
+ end if
+ end if
+ if(bot_inv_pnl)
+ bot = min((/res at gsnPanelInvsblBottom,min(newbb(:,1))/))
+ else
+ if(bot_pnl)
+ bot = min((/0.,min(newbb(:,1))/))
+ else
+ bot = min(newbb(:,1))
+ end if
+ end if
+ if(lft_inv_pnl)
+ lft = min((/res at gsnPanelInvsblLeft,min(newbb(:,2))/))
+ else
+ if(lft_pnl)
+ lft = min((/0.,min(newbb(:,2))/))
+ else
+ lft = min(newbb(:,2))
+ end if
+ end if
+ if(rgt_inv_pnl)
+ rgt = max((/res at gsnPanelInvsblRight,max(newbb(:,3))/))
+ else
+ if(rgt_pnl)
+ rgt = max((/1.,max(newbb(:,3))/))
+ else
+ rgt = max(newbb(:,3))
+ end if
+ end if
+
+ ; if(bot.lt.0.or.bot.gt.1.or.top.lt.0.or.top.gt.1.or. \
+ ; lft.lt.0.or.lft.gt.1.or.rgt.lt.0.or.rgt.gt.1)
+ ; print("compute_device_coords: warning: bounding box values should be between 0 and 1 inclusive. Will continue anyway.")
+ ; end if
+
+ if(bot.ge.top.or.lft.ge.rgt)
+ print("compute_device_coords: bottom must be < top and left < right")
+ return((/0,0,0,0/))
+ end if
+ ;
+ ; Debug prints
+ ;
+ if(is_debug)
+ print("-------Bounding box values for PS/PDF-------")
+ print(" top = " + top + " bot = " + bot +
+ " lft = " + lft + " rgt = " + rgt)
+ end if
+ ;
+ ; Initialization
+ ;
+ dpi = 72. ; Dots per inch.
+ dpi_pw = paper_width * dpi
+ dpi_ph = paper_height * dpi
+ dpi_margin = paper_margin * dpi
+
+ ;
+ ; Get paper height/width in dpi units
+ ;
+ pw = rgt - lft
+ ph = top - bot
+
+ lx = dpi_margin
+ ly = dpi_margin
+
+ ux = dpi_pw - dpi_margin
+ uy = dpi_ph - dpi_margin
+
+ dw = ux - lx
+ dh = uy - ly
+
+ ;
+ ; Determine orientation, and then calculate device coordinates based
+ ; on this.
+ ;
+ if(lc_orient.eq."portrait".or.
+ (lc_orient.eq."auto".and.(ph / pw).ge.1.0))
+ ;
+ ; If plot is higher than it is wide, then default to portrait if
+ ; orientation is not specified.
+ ;
+ lc_orient = "portrait"
+
+ if (ph / pw .gt. dh / dw) then
+ ; paper height limits size
+ ndc2du = dh / ph
+ else
+ ndc2du = dw / pw
+ end if
+ ;
+ ; Compute device coordinates.
+ ;
+ lx = dpi_margin + 0.5 * ( dw - pw * ndc2du) - lft * ndc2du
+ ly = dpi_margin + 0.5 * ( dh - ph * ndc2du) - bot * ndc2du
+ ux = lx + ndc2du
+ uy = ly + ndc2du
+ else
+ ;
+ ; If plot is wider than it is high, then default to landscape if
+ ; orientation is not specified.
+ ;
+ lc_orient = "landscape"
+ if (pw / ph .gt. dh / dw) then
+ ; paper height limits size
+ ndc2du = dh / pw
+ else
+ ndc2du = dw / ph
+ end if
+
+ ;
+ ; Compute device coordinates.
+ ;
+ ly = dpi_margin + 0.5 * (dh - pw * ndc2du) - (1.0 - rgt) * ndc2du
+ lx = dpi_margin + 0.5 * (dw - ph * ndc2du) - bot * ndc2du
+ ux = lx + ndc2du
+ uy = ly + ndc2du
+ end if
+
+ ;
+ ; Return device coordinates and the orientation.
+ ;
+ coords = tointeger((/lx,ly,ux,uy/))
+ coords at gsnPaperOrientation = lc_orient
+ ;
+ ; Debug prints.
+ ;
+ if(is_debug)
+ print("-------Device coordinates for PostScript-------")
+ print(" wkDeviceLowerX = " + coords(0))
+ print(" wkDeviceLowerY = " + coords(1))
+ print(" wkDeviceUpperX = " + coords(2))
+ print(" wkDeviceUpperY = " + coords(3))
+ print(" wkOrientation = " + coords at gsnPaperOrientation)
+ end if
+
+ return(coords)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : reset_device_coordinates ;
+ ; wks:graphic ;
+ ; ;
+ ; This procedure resets the PS/PDF device coordinates back to their ;
+ ; default values. The default values will be whatever ones the user ;
+ ; might have set when they called gsn_open_wks, or the defaults that ;
+ ; NCL uses if none are set. ;
+ ;***********************************************************************;
+
+ undef("reset_device_coordinates")
+ procedure reset_device_coordinates(wks)
+ begin
+ setvalues wks
+ "wkOrientation" : get_res_value(wks,"wkOrientation", 0)
+ "wkDeviceLowerX" : get_res_value(wks,"wkDeviceLowerX", 36)
+ "wkDeviceLowerY" : get_res_value(wks,"wkDeviceLowerY",126)
+ "wkDeviceUpperX" : get_res_value(wks,"wkDeviceUpperX",576)
+ "wkDeviceUpperY" : get_res_value(wks,"wkDeviceUpperY",666)
+ end setvalues
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : maximize_plot ;
+ ; plot:graphic ;
+ ; psres:logical ;
+ ; ;
+ ; This procedure takes a plot that probably has had some additional ;
+ ; objects attached to it, like a labelbar, and maximizes it in the ;
+ ; given PS or PDF workstation. ;
+ ;***********************************************************************;
+ undef("maximize_plot")
+ procedure maximize_plot(plot,psres)
+ local bb, coords, res2, tmp_wks
+ begin
+ res2 = psres
+
+ tmp_wks = NhlGetParentWorkstation(plot)
+ ;
+ ; Calculate device coords to maximize this plot on the PDF or PS
+ ; workstation.
+ ;
+ coords = compute_device_coords(plot,res2)
+ ;
+ ; Using the coordinate values just calculated, set them in the
+ ; workstation (also set the orientation).
+ ;
+ setvalues tmp_wks
+ "wkDeviceLowerX" : coords(0)
+ "wkDeviceLowerY" : coords(1)
+ "wkDeviceUpperX" : coords(2)
+ "wkDeviceUpperY" : coords(3)
+ "wkOrientation" : coords at gsnPaperOrientation
+ end setvalues
+ end
+
+ ;***********************************************************************;
+ ; Procedure : maximize_output ;
+ ; wks:graphic ;
+ ; psres:logical ;
+ ; ;
+ ; This procedure takes a workstation (that supposedly has several plots ;
+ ; drawn on it), calculates the device coordinates needed to maximize ;
+ ; the plots on a PS or PDF workstation, and then sets these device ;
+ ; coordinates back to the workstation. draw and frame happen by default ;
+ ; unless otherwise specified. ;
+ ;***********************************************************************;
+ undef("maximize_output")
+ procedure maximize_output(wks:graphic,psres:logical)
+ local calldraw, callframe, class, res2
+ begin
+ res2 = psres
+ ;
+ ; Get draw and frame values, if set.
+ ;
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ ;
+ ; Only do this type of maximization for PS or PDF workstations.
+ ; The device coordinates mean nothing for NCGM and X11 workstations.
+ ;
+ max_device = False
+ class = NhlClassName(wks)
+ if(any(class.eq.(/"psWorkstationClass","pdfWorkstationClass",
+ "documentWorkstationClass"/)))
+ max_device = True
+ ;
+ ; Calculate device coords to maximize these plots on the PDF or PS
+ ; workstation.
+ ;
+ coords = compute_device_coords(wks,res2)
+
+ ;
+ ; Using the coordinate values just calculated, set them in the
+ ; workstation (also set the orientation).
+ ;
+ setvalues wks
+ "wkDeviceLowerX" : coords(0)
+ "wkDeviceLowerY" : coords(1)
+ "wkDeviceUpperX" : coords(2)
+ "wkDeviceUpperY" : coords(3)
+ "wkOrientation" : coords at gsnPaperOrientation
+ end setvalues
+
+ end if
+
+ if(calldraw) then
+ draw(wks) ; This will draw everything on the workstation.
+ end if
+ if(callframe) then
+ frame(wks)
+ ;
+ ; Only set the device coordinates back if the frame is advanced, because
+ ; if we do it when the frame hasn't been advanced, then anything that
+ ; gets drawn on this plot later will be drawn under the old device
+ ; coordinates.
+ ;
+ ; This means that the user will have to be aware that if he/she decides to
+ ; advance the frame him/herself, then any subsequent plots draw (in which
+ ; the device coordinates are not recalculated), may be drawn incorrectly.
+ ;
+ if(max_device) then
+ reset_device_coordinates(wks)
+ end if
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Procedure : draw_and_frame ;
+ ; wks:graphic ;
+ ; plot:graphic ;
+ ; calldraw:logical ;
+ ; callframe:logical ;
+ ; ispanel: logical ;
+ ; maxbb:logical ;
+ ; ;
+ ; By default, all of the plotting routines will draw the plot and ;
+ ; advance the frame, unless the special resources gsnDraw and/or ;
+ ; gsnFrame are set to False. This procedure checks if these resources ;
+ ; had been set, and calls draw and/or frame accordingly. ;
+ ; If maxbb is True, then the plot is maximized in the NCGM, X11, PS ;
+ ; or PDF window. ;
+ ;***********************************************************************;
+ undef("draw_and_frame")
+ procedure draw_and_frame(wks:graphic,plot:graphic,calldraw:logical,
+ callframe:logical,ispanel:logical,maxbb:logical)
+ local nplots, class, coords
+ begin
+ max_device = False
+ if(maxbb) then
+ ;
+ ; If dealing with panel plots, then this means that the viewport
+ ; coordinates have already been calculated to maximize the plots in
+ ; the unit square, so we don't need to do it again here. However, we
+ ; will still need to calculate the optimal device coordinates if the
+ ; output is PDF or PS.
+ ;
+ if(.not.ispanel) then
+ ;
+ ; First, optimize the plot size in the viewport (unit square). This
+ ; may involve making it bigger or smaller.
+ ;
+ coords = maximize_bb(plot,maxbb)
+ setvalues plot
+ "vpXF" : coords(0)
+ "vpYF" : coords(1)
+ "vpWidthF" : coords(2)
+ "vpHeightF" : coords(3)
+ end setvalues
+ end if
+
+ class = NhlClassName(wks)
+ if(any(class(0).eq.(/"psWorkstationClass","pdfWorkstationClass",
+ "documentWorkstationClass"/))) then
+ ;
+ ; Keep track of whether device coordinates were recalculated.
+ ;
+ max_device = True
+ ;
+ ; Compute device coordinates that will make plot fill the whole page.
+ ;
+ coords = compute_device_coords(plot,maxbb)
+ ;
+ ; Set device coordinates to new ones.
+ ;
+ setvalues wks
+ "wkOrientation" : coords at gsnPaperOrientation
+ "wkDeviceLowerX" : coords(0)
+ "wkDeviceLowerY" : coords(1)
+ "wkDeviceUpperX" : coords(2)
+ "wkDeviceUpperY" : coords(3)
+ end setvalues
+ end if
+ end if
+
+ if(calldraw)
+ draw(plot)
+ end if
+
+ if(callframe)
+ frame(wks) ; advance the frame
+ ;
+ ; Only set the device coordinates back if the frame is advanced, because
+ ; if we do it when the frame hasn't been advanced, then anything that
+ ; gets drawn on this plot later will be drawn under the old device
+ ; coordinates.
+ ;
+ ; This means that the user will have to be aware that if he/she decides to
+ ; advance the frame him/herself, then any subsequent plots draw (in which
+ ; the device coordinates are not recalculated), may be drawn incorrectly.
+ ;
+ if(max_device) then
+ reset_device_coordinates(wks)
+ end if
+ end if
+
+ end
+
+ ;***********************************************************************;
+ ; Function : get_bb_res ;
+ ; res : list of resources ;
+ ; ;
+ ; Get list of resources for use with maximizing the plots within an ;
+ ; X11, NCGM, PS or PDF window. ;
+ ;***********************************************************************;
+ undef("get_bb_res")
+ function get_bb_res(res:logical)
+ begin
+ maxbb = get_res_value(res,"gsnMaximize", False)
+ maxbb at gsnPaperMargin = get_res_value(res,"gsnPaperMargin",0.5)
+ ;
+ ; No longer set these two, because they will be retrieved later.
+ ;
+ ; maxbb at gsnPaperHeight = get_res_value(res,"gsnPaperHeight",11.0)
+ ; maxbb at gsnPaperWidth = get_res_value(res,"gsnPaperWidth",8.5)
+ maxbb at gsnBoxMargin = get_res_value(res,"gsnBoxMargin",0.02)
+ maxbb at gsnDebug = get_res_value(res,"gsnDebug",False)
+ ;
+ ; Don't assume a default on this one, because the default will be
+ ; determined by doing a getvalues on the PostScript workstation.
+ ;
+ if(isatt(res,"gsnPaperOrientation"))
+ maxbb at gsnPaperOrientation = get_res_value(res,"gsnPaperOrientation","")
+ end if
+ ;
+ ; Indicate here whether the panel resources have been set.
+ ;
+ if(isatt(res,"gsnPanelLeft"))
+ maxbb at gsnPanelLeft = get_res_value(res,"gsnPanelLeft",0.)
+ end if
+ if(isatt(res,"gsnPanelRight"))
+ maxbb at gsnPanelRight = get_res_value(res,"gsnPanelRight",1.)
+ end if
+ if(isatt(res,"gsnPanelBottom"))
+ maxbb at gsnPanelBottom = get_res_value(res,"gsnPanelBottom",0.)
+ end if
+ if(isatt(res,"gsnPanelTop"))
+ maxbb at gsnPanelTop = get_res_value(res,"gsnPanelTop",1.)
+ end if
+
+ return(maxbb)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_blank_plot ;
+ ; wks : workstation ;
+ ; res : optional resources ;
+ ; ;
+ ; This function creates a blank tickmark object that can be used for ;
+ ; drawing primitives. ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_blank_plot")
+ function gsn_blank_plot(wks:graphic,res:logical)
+ local res2
+ begin
+ res2 = res
+ point_outward = get_res_value(res2,"gsnTickMarksPointOutward",False)
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",False)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ ticks = get_res_value(res2,"pmTickMarkDisplayMode","Always")
+ title = get_res_value(res2,"pmTitleDisplayMode","Always")
+ maxbb = get_bb_res(res2)
+
+ canvas = create "canvas" irregularPlotClass wks
+ "pmTickMarkDisplayMode" : ticks
+ "pmTitleDisplayMode" : title
+ end create
+
+ attsetvalues_check(canvas,res2)
+
+ tmres = get_res_eq(res2,"tm")
+ gsnp_point_tickmarks_outward(canvas,tmres,-1.,-1.,-1.,-1.,-1.,-1.,
+ point_outward)
+
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+
+ if(shape)
+ gsnp_shape_plot(canvas)
+ end if
+
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+
+ if(scale)
+ gsnp_scale_plot(canvas,"",False)
+ end if
+
+ draw_and_frame(wks,canvas,calldraw,callframe,False,maxbb)
+
+ return(canvas)
+ end
+
+ ;***********************************************************************;
+ ; Function : create_canvas ;
+ ; wks : workstation ;
+ ; ;
+ ; This function creates a blank LogLin plot that can be used for drawing;
+ ; primitives. ;
+ ; ;
+ ;***********************************************************************;
+ undef("create_canvas")
+ function create_canvas(wks:graphic)
+ begin
+ ;
+ ; Create a LogLinPlot that covers the entire NDC space
+ ; to use as a drawing canvas
+ ;
+ canvas = create "canvas" logLinPlotClass wks
+ "vpXF" : 0.0
+ "vpYF" : 1.0
+ "vpWidthF" : 1.0
+ "vpHeightF" : 1.0
+ end create
+
+ return(canvas)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_open_ncgm ;
+ ; name : name of output cgm file ;
+ ; ;
+ ; This function opens an NCGM output file called "<name>.ncgm" and ;
+ ; returns the workstation id. If "name" is an empty string, then the ;
+ ; NCGM is given its default name "gmeta". ;
+ ;***********************************************************************;
+ undef("gsn_open_ncgm")
+ function gsn_open_ncgm(name[1]:string)
+ local ncgm, res_file
+ begin
+ res_file=get_res_value_keep(name,"res_file","gsnapp")
+
+ if(isatt(name,"wkColorMap"))
+ ncgm = create res_file ncgmWorkstationClass defaultapp
+ "wkMetaName" : name
+ "wkColorMap" : name at wkColorMap
+ end create
+ else
+ ncgm = create res_file ncgmWorkstationClass defaultapp
+ "wkMetaName" : name
+ end create
+ end if
+
+
+ return(ncgm)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_open_x11 ;
+ ; name : name of X11 window ;
+ ; ;
+ ; This function opens an X11 output window and returns the workstation ;
+ ; id. ;
+ ;***********************************************************************;
+ undef("gsn_open_x11")
+ function gsn_open_x11(name[1]:string,res[1]:string)
+ local window
+ begin
+ ; apply width/height resources if present; must be applied at creation time.
+ imageWidth = get_res_value(res,"wkWidth",-1)
+ imageHeight = get_res_value(res,"wkHeight",-1)
+ if (imageWidth.gt.0 .and. imageHeight.gt.0) then
+ if(isatt(res,"wkColorMap"))
+ window = create name + "_x11" windowWorkstationClass defaultapp
+ "wkFormat" : "x11"
+ "wkPause" : True
+ "wkColorMap" : res at wkColorMap
+ "wkWidth" : imageWidth
+ "wkHeight" : imageHeight
+ end create
+ else
+ window = create name + "_x11" windowWorkstationClass defaultapp
+ "wkFormat" : "x11"
+ "wkPause" : True
+ "wkWidth" : imageWidth
+ "wkHeight" : imageHeight
+ end create
+ end if
+ else
+ if(isatt(res,"wkColorMap"))
+ window = create name + "_x11" windowWorkstationClass defaultapp
+ "wkFormat": "x11"
+ "wkPause" : True
+ "wkColorMap" : res at wkColorMap
+ end create
+ else
+ window = create name + "_x11" windowWorkstationClass defaultapp
+ "wkFormat": "x11"
+ "wkPause" : True
+ end create
+ end if
+ end if
+
+ return(window)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : create_labelbar ;
+ ; wks: graphic ;
+ ; nbox: integer ;
+ ; colors: array ;
+ ; labels: array ;
+ ; lbres: logical ;
+ ; ;
+ ; This function creates a labelbar given a workstation, the number of ;
+ ; boxes, the colors and labels to use, and an optional list of ;
+ ; labelbar resources. By default, lbAutoManage is set to False, the ;
+ ; perimeter is turned off, and the fill patterns are set to solid. ;
+ ; ;
+ ; "EndStyle" is a special internal resource that comes from the ;
+ ; cnLabelBarEndStyle resource. It defaults to 0 (include outer boxes), ;
+ ; and can be set to 1 (include min/max labels) or 2 (exclude outer ;
+ ; boxes). The assumption is that if this resource is set to 2, then the ;
+ ; nbox, colors, and labels that are input are set up expecting one more ;
+ ; box than you have labels (i.e. you are expecting to label the ;
+ ; interior edges only). If set to 2, then the assumption is that the ;
+ ; labels already contain the min/max values, and you have the correct ;
+ ; nbox and colors. ;
+ ; ;
+ ;***********************************************************************;
+ undef("create_labelbar")
+ function create_labelbar(wks:graphic, nbox:integer, colors, labels,
+ lbres:logical)
+ local perim_on, mono_fill_pat, label_align, labelbar_object
+ begin
+ ;
+ ; Set some defaults
+ ;
+ vpxf = get_res_value(lbres,"vpXF",0.1)
+ vpyf = get_res_value(lbres,"vpYF",0.1)
+ vpwidthf = get_res_value(lbres,"vpWidthF",0.8)
+ vpheightf = get_res_value(lbres,"vpHeightF",0.3)
+ new_labels = get_res_value(lbres,"lbLabelStrings",labels)
+ orientation = get_res_value(lbres,"lbOrientation","horizontal")
+ perim_on = get_res_value(lbres,"lbPerimOn",False)
+ font_height = get_res_value(lbres,"lbLabelFontHeightF",0.1)
+ mono_fill_pat = get_res_value(lbres,"lbMonoFillPattern",True);
+
+ if(isatt(lbres,"EndStyle")) then
+ end_style = get_res_value(lbres,"EndStyle",0)
+ if(.not.(end_style.ge.0.and.end_style.le.2)) then
+ end_style = 0
+ end if
+ if(end_style.eq.2) then
+ ; Exclude outer boxes
+ nbox2 = nbox-2
+ new_colors = get_res_value(lbres,"lbFillColors",colors(1:))
+ label_align = get_res_value(lbres,"lbLabelAlignment","ExternalEdges")
+ else
+ nbox2 = nbox
+ new_colors = get_res_value(lbres,"lbFillColors",colors)
+ if(end_style.eq.0) then
+ ; Include outer boxes
+ label_align = get_res_value(lbres,"lbLabelAlignment","InteriorEdges")
+ else
+ ; Include min max labels
+ label_align = get_res_value(lbres,"lbLabelAlignment","ExternalEdges")
+ end if
+ end if
+ else
+ nbox2 = nbox
+ new_colors = get_res_value(lbres,"lbFillColors",colors)
+ label_align = get_res_value(lbres,"lbLabelAlignment","InteriorEdges")
+ end if
+
+ labelbar_object = create "labelbar" labelBarClass wks
+ "vpXF" : vpxf
+ "vpYF" : vpyf
+ "vpWidthF" : vpwidthf
+ "vpHeightF" : vpheightf
+ "lbBoxCount" : nbox2
+ "lbFillColors" : new_colors
+ "lbLabelStrings" : new_labels
+ "lbOrientation" : orientation
+ "lbPerimOn" : perim_on
+ "lbLabelAlignment" : label_align
+ "lbLabelFontHeightF": font_height
+ "lbMonoFillPattern" : mono_fill_pat
+ "lbAutoManage" : False
+ end create
+
+ attsetvalues_check(labelbar_object,lbres)
+
+ return(labelbar_object)
+ end
+
+
+ ;***********************************************************************;
+ ; Function to determine if a cairo PS is being requested. ;
+ ;***********************************************************************;
+ undef("is_cairo_ps")
+ function is_cairo_ps(wtype)
+ local lwtype, cpsenv
+ begin
+ lwtype = lower_case(wtype)
+ cpsenv = getenv("NCARG_OLD_PS")
+ if(lwtype.eq."newps".or.(lwtype.eq."ps".and.ismissing(cpsenv))) then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function to determine if a cairo PDF is being requested. ;
+ ;***********************************************************************;
+ undef("is_cairo_pdf")
+ function is_cairo_pdf(wtype)
+ local lwtype, cpdfenv
+ begin
+ lwtype = lower_case(wtype)
+ cpdfenv = getenv("NCARG_OLD_PDF")
+ if(lwtype.eq."newpdf".or.(lwtype.eq."pdf".and.ismissing(cpdfenv))) then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function to determine if a cairo PNG is being requested. ;
+ ;***********************************************************************;
+ undef("is_cairo_png")
+ function is_cairo_png(wtype)
+ local lwtype
+ begin
+ lwtype = lower_case(wtype)
+ if(lwtype.eq."newpng".or.lwtype.eq."png") then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function to determine if a cairo EPS is being requested. ;
+ ;***********************************************************************;
+ undef("is_cairo_eps")
+ function is_cairo_eps(wtype)
+ local lwtype, cpsenv
+ begin
+ lwtype = lower_case(wtype)
+ cpsenv = getenv("NCARG_OLD_EPS")
+ if (lwtype.eq."eps".and.ismissing(cpsenv)) then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function to determine if a cairo SVG is being requested. ;
+ ;***********************************************************************;
+ undef("is_cairo_svg")
+ function is_cairo_svg(wtype)
+ local lwtype
+ begin
+ lwtype = lower_case(wtype)
+ if (lwtype.eq."svg") then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function to determine if a cairo workstation is being requested. ;
+ ;***********************************************************************;
+ undef("is_cairo_wks")
+ function is_cairo_wks(wtype)
+ begin
+ if (is_cairo_ps(wtype).or.is_cairo_pdf(wtype).or.is_cairo_png(wtype).or.
+ is_cairo_eps(wtype).or.is_cairo_svg(wtype)) then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_open_ps ;
+ ; name : name of PostScript file ;
+ ; ;
+ ; This function opens a PostScript file called "<name>.ps" and returns ;
+ ; the workstation id. If "name" is an empty string, then the PostScript ;
+ ; file is called "gmeta.ps". ;
+ ;***********************************************************************;
+ undef("gsn_open_ps")
+ function gsn_open_ps(type:string,name[1]:string)
+ local ps, res_file, wkres, wkresnew, names, i
+ begin
+ ;
+ ; If there are resources, copy them over to a logical variable,
+ ; and only grab the ones that start with "wk".
+ ;
+ if(.not.any(ismissing(getvaratts(type))))
+ wkres = True
+ names = getvaratts(type)
+ do i=0,dimsizes(names)-1
+ if(names(i).ne."_FillValue") then
+ wkres@$names(i)$ = type@$names(i)$
+ end if
+ end do
+ ;
+ ; Grab only the ones that start with "wk".
+ ;
+ wkresnew = get_res_eq(wkres,"wk")
+ delete(wkres)
+ delete(names)
+ else
+ wkresnew = False
+ end if
+
+ res_file = get_res_value_keep(name,"res_file","gsnapp")
+ ;
+ ; These PS resources are ones that must be set at the time
+ ; the workstation is created. This means that these resources
+ ; will override whatever setting you might have in a resource
+ ; file or your .hluresfile.
+ ;
+ cmodel = get_res_value(wkresnew,"wkColorModel","rgb")
+ resltn = get_res_value(wkresnew,"wkPSResolution",1800)
+ visualt = get_res_value(wkresnew,"wkVisualType","color")
+ paperSize = get_res_value(wkresnew,"wkPaperSize","")
+ paperW = get_res_value(wkresnew,"wkPaperWidthF", -1.)
+ paperH = get_res_value(wkresnew,"wkPaperHeightF", -1.)
+
+ ; Be sure to add any resources set here to "res_list" in gsn_open_wks
+ ; so they don't get set again.
+
+ ps = create res_file psWorkstationClass defaultapp
+ "wkColorModel" : cmodel
+ "wkPSResolution" : resltn
+ "wkPSFileName" : name
+ "wkPSFormat" : type
+ "wkVisualType" : visualt
+ "wkPaperSize" : paperSize
+ "wkPaperWidthF" : paperW
+ "wkPaperHeightF" : paperH
+ end create
+
+ ;
+ ; Set resources, if any.
+ ;
+ attsetvalues_check(ps,wkresnew)
+ delete(wkresnew)
+
+ ;
+ ; Retrieve the device coordinates and the orientation so we can
+ ; reset them later if necessary.
+ ;
+ getvalues ps
+ "wkOrientation" : ps at wkOrientation
+ "wkDeviceLowerX" : ps at wkDeviceLowerX
+ "wkDeviceLowerY" : ps at wkDeviceLowerY
+ "wkDeviceUpperX" : ps at wkDeviceUpperX
+ "wkDeviceUpperY" : ps at wkDeviceUpperY
+ "wkPaperWidthF" : ps at wkPaperWidthF
+ "wkPaperHeightF" : ps at wkPaperHeightF
+ end getvalues
+
+ return(ps)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_open_pdf ;
+ ; name : name of PDF file ;
+ ; ;
+ ; This function opens a PDF file called "<name>.pdf" and returns ;
+ ; the workstation id. If "name" is an empty string, then the PDF file ;
+ ; is called "gmeta.pdf". ;
+ ;***********************************************************************;
+ undef("gsn_open_pdf")
+ function gsn_open_pdf(type:string, name[1]:string)
+ local pdf, res_file, wkres, wkresnew, names, i
+ begin
+ ;
+ ; If there are resources, copy them over to a logical variable,
+ ; and only grab the ones that start with "wk".
+ ;
+ if(.not.any(ismissing(getvaratts(type))))
+ wkres = True
+ names = getvaratts(type)
+ do i=0,dimsizes(names)-1
+ if(names(i).ne."_FillValue") then
+ wkres@$names(i)$ = type@$names(i)$
+ end if
+ end do
+ ;
+ ; Grab only the ones that start with "wk".
+ ;
+ wkresnew = get_res_eq(wkres,"wk")
+ delete(wkres)
+ delete(names)
+ else
+ wkresnew = False
+ end if
+
+ res_file = get_res_value_keep(name,"res_file","gsnapp")
+ ;
+ ; These PDF resources are ones that must be set at the time
+ ; the workstation is created. This means that these resources
+ ; will override whatever setting you might have in a resource
+ ; file or your .hluresfile.
+ ;
+ cmodel = get_res_value(wkresnew,"wkColorModel","rgb")
+ resltn = get_res_value(wkresnew,"wkPDFResolution",1800)
+ visualt = get_res_value(wkresnew,"wkVisualType","color")
+ paperSize = get_res_value(wkresnew,"wkPaperSize","")
+ paperW = get_res_value(wkresnew,"wkPaperWidthF", -1.)
+ paperH = get_res_value(wkresnew,"wkPaperHeightF", -1.)
+
+ ; Be sure to add any resources set here to "res_list" in gsn_open_wks
+ ; so they don't get set again.
+
+ pdf = create res_file pdfWorkstationClass defaultapp
+ "wkColorModel" : cmodel
+ "wkPDFResolution" : resltn
+ "wkPDFFileName" : name
+ "wkPDFFormat" : type
+ "wkVisualType" : visualt
+ "wkPaperSize" : paperSize
+ "wkPaperWidthF" : paperW
+ "wkPaperHeightF" : paperH
+ end create
+
+ ;
+ ; Set resources, if any.
+ ;
+ attsetvalues_check(pdf,wkresnew)
+ delete(wkresnew)
+
+ ;
+ ; Retrieve the device coordinates and the orientation so we can
+ ; reset them later if necessary.
+ ;
+ getvalues pdf
+ "wkOrientation" : pdf at wkOrientation
+ "wkDeviceLowerX" : pdf at wkDeviceLowerX
+ "wkDeviceLowerY" : pdf at wkDeviceLowerY
+ "wkDeviceUpperX" : pdf at wkDeviceUpperX
+ "wkDeviceUpperY" : pdf at wkDeviceUpperY
+ "wkPaperWidthF" : pdf at wkPaperWidthF
+ "wkPaperHeightF" : pdf at wkPaperHeightF
+ end getvalues
+
+ return(pdf)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_open_cairo ;
+ ; name : name of cairo file/device ;
+ ; ;
+ ; This function opens a cairo file or device and returns ;
+ ; the workstation id. ;
+ ;***********************************************************************;
+ undef("gsn_open_cairo")
+ function gsn_open_cairo(type:string, name[1]:string)
+ local cairo, res_file, wkres, tmpres, names, i
+ begin
+ ;
+ ; If there are resources, copy them over to a logical variable,
+ ; and only grab the ones that start with "wk".
+ ;
+ if(.not.any(ismissing(getvaratts(type))))
+ tmpres = True
+ names = getvaratts(type)
+ do i=0,dimsizes(names)-1
+ if(names(i).ne."_FillValue") then
+ tmpres@$names(i)$ = type@$names(i)$
+ end if
+ end do
+ ;
+ ; Grab only the ones that start with "wk".
+ ;
+ wkres = get_res_eq(tmpres,"wk")
+ delete(tmpres)
+ delete(names)
+ end if
+
+ wkres = True ; force True, even if no resources present; get_res_eq() can return False.
+
+ res_file = get_res_value_keep(name,"res_file","gsnapp")
+
+ ;
+ ; Add these resources if not already present.
+ ;
+ if (.not.isatt(wkres, "wkFileName")) then
+ wkres at wkFileName = name
+ end if
+ if (.not.isatt(wkres, "wkFormat")) then
+ wkres at wkFormat = type
+ if (is_cairo_ps(type)) then
+ wkres at wkFormat = "ps" ; user can specify "ps" or "newps"
+ end if
+ if (is_cairo_pdf(type)) then
+ wkres at wkFormat = "pdf" ; user can specify "pdf" or "newpdf"
+ end if
+ end if
+
+ ;
+ ; We need to distinguish between document-based versus image-based output formats
+ ;
+ if (is_cairo_ps(type).or.is_cairo_pdf(type).or.is_cairo_eps(type).or.is_cairo_svg(type)) then
+ cairo = create_graphic(res_file, "documentWorkstationClass", "defaultapp", wkres)
+ else
+ cairo = create_graphic(res_file, "imageWorkstationClass", "defaultapp", wkres)
+ end if
+
+ delete(wkres)
+ return(cairo)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : gsn_open_image ;
+ ; type : type of image file ;
+ ; name : name of output image file ;
+ ; ;
+ ; This function opens an image file called "<name>.<type>" and ;
+ ; returns the workstation id. If "name" is an empty string, then the ;
+ ; NCGM is given a default name "gmeta.type". ;
+ ;***********************************************************************;
+ undef("gsn_open_image")
+ function gsn_open_image(type:string,name[1]:string)
+ local image, res_file
+ begin
+ res_file = get_res_value_keep(name,"res_file","gsnapp")
+ wkwidth = get_res_value_keep(type,"wkWidth",512)
+ wkheight = get_res_value_keep(type,"wkHeight",512)
+
+ if(isatt(name,"wkColorMap"))
+ image = create res_file xwdimageWorkstationClass defaultapp
+ "wkImageFileName" : name
+ "wkImageFormat" : type
+ "wkColorMap" : name at wkColorMap
+ "wkWidth" : wkwidth
+ "wkHeight" : wkheight
+ end create
+ else
+ image = create res_file xwdimageWorkstationClass defaultapp
+ "wkImageFileName" : name
+ "wkImageFormat" : type
+ "wkWidth" : wkwidth
+ "wkHeight" : wkheight
+ end create
+ end if
+
+ return(image)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : gsn_open_wks ;
+ ; type : type of workstation to open ;
+ ; name : name of workstation ;
+ ; ;
+ ; This function opens either an X11 window, an NCGM file, a Postscript ;
+ ; or a PDF file depending on "type", which can be "x11", "ncgm", "ps" ;
+ ; or "pdf". If "type" is a PS or PDF file or an NCGM, then it will be ;
+ ; named <name>.ps or <name>.pdf <name>.ncgm respectively. This function ;
+ ; also looks for a resource file called "name.res". If it exists, then ;
+ ; it loads the resources defined in that file. This function returns ;
+ ; the workstation id. ;
+ ;***********************************************************************;
+ undef("gsn_open_wks")
+ function gsn_open_wks(type[1]:string,name[1]:string)
+ local i, wks, appusrdir, name_char, not_found, res_file, res_dir, type2, realtype, suffix
+ begin
+ type2 = type ; Make copy of type and its resources
+ type2 = lower_case(type)
+ res_dir = "./" ; Default resource directory.
+ res_file = "gsnapp" ; Default resource file name.
+ valid_type = False ; Is type valid?
+
+ ;
+ ; Parse "name" to get the directory and the file prefix.
+ ;
+ if(name.ne."") then
+ name_char = stringtocharacter(name)
+ name_len = dimsizes(name_char)-1
+ i = name_len-1 ; Start checking if a directory pathname
+ not_found = True ; was specified for the resource file.
+ do while(not_found.and.i.ge.0)
+ if(name_char(i).eq."/")
+ res_dir = charactertostring(name_char(0:i))
+ not_found = False
+ end if
+ i = i - 1
+ end do
+
+ res_file = charactertostring(name_char(i+1:name_len-1))
+
+ if(isatt(name,"appUsrDir").and.not_found)
+ res_dir = name at appUsrDir ; No directory specified.
+ end if
+ end if
+
+ ; This 5-line block addresses Jira 1750; we test to make sure the target directory
+ ; exists and is writable.
+ cmdStr = "if [ -w " + res_dir + " ] ; then echo 1 ; else echo 0 ; fi"
+ if (type.ne."x11" .and. systemfunc(cmdStr).ne.1) then
+ print("gsn_open_wks: Error: directory '" + res_dir + "' does not exist or lacks write permissions.");
+ status_exit(1)
+ end if
+
+ appid = create res_file appClass defaultapp
+ "appDefaultParent" : True
+ "appUsrDir" : res_dir
+ end create
+
+ ;
+ ; If we had a case statement or an "elseif" in NCL, this next
+ ; section would look better!
+ ;
+ wks = new(1,graphic,"No_FillValue")
+
+ if (type2.eq."x11") then
+ wks = gsn_open_x11(res_file, type2)
+ valid_type = True
+ end if
+
+ if (type2.eq."oldps".or.type2.eq."oldeps".or.
+ type2.eq."epsi".or.(type2.eq."ps".and..not.ismissing(getenv("NCARG_OLD_PS"))).or.
+ (type2.eq."eps".and..not.ismissing(getenv("NCARG_OLD_EPS")))) then
+ realtype = type2 ; copy value and attributes
+ suffix = type2
+ if (realtype.eq."oldps") then
+ realtype = "ps"
+ suffix = "ps"
+ end if
+ if (realtype.eq."oldeps") then
+ realtype = "eps"
+ suffix = "eps"
+ end if
+ ps_file = get_res_value(realtype,"wkPSFileName",res_file + "." + suffix)
+ ps_file at res_file = res_file
+ wks = gsn_open_ps(realtype,res_dir+ps_file)
+ valid_type = True
+ end if
+
+ if (type2.eq."ncgm") then
+ ncgm_file = get_res_value(type2,"wkMetaName",res_file + ".ncgm")
+ ncgm_file = res_dir + ncgm_file
+ ncgm_file at res_file = res_file
+ if (isatt(type2,"wkColorMap"))
+ ncgm_file at wkColorMap = type2 at wkColorMap
+ end if
+ wks = gsn_open_ncgm(ncgm_file)
+ valid_type = True
+ end if
+
+ if (type2.eq."oldpdf".or.(type2.eq."pdf".and..not.ismissing(getenv("NCARG_OLD_PDF")))) then
+ realtype = type2 ; copy value and attributes
+ if (realtype.eq."oldpdf") then
+ realtype = "pdf"
+ end if
+ pdf_file = get_res_value(realtype,"wkPDFFileName",
+ res_file + "." + "pdf")
+ pdf_file at res_file = res_file
+ wks = gsn_open_pdf(realtype, res_dir+pdf_file)
+ valid_type = True
+ end if
+
+ if (is_cairo_wks(type2)) then
+ cairo_file = get_res_value(type2,"wkFileName", res_file)
+ if (is_cairo_png(type2)) then
+ cairo_file = get_res_value(type2,"wkImageFileName", cairo_file)
+ end if
+ cairo_file at res_file = res_file
+ wks = gsn_open_cairo(type2, res_dir+cairo_file)
+ valid_type = True
+ end if
+
+ if (type2.eq."xwd") then
+ image_file = get_res_value(type2,"wkFileName", res_file)
+ image_file at res_file = res_file
+ wks = gsn_open_image(type2, res_dir+image_file)
+ valid_type = True
+ end if
+
+ if (.not.valid_type.or.ismissing(wks)) then
+ print("Error: gsn_open_wks: '"+ type2 + "' is an invalid workstation type.")
+ exit
+ end if
+
+ ;
+ ; Apply other resources.
+ ;
+ ; First create list of resources that we *don't* want applied, as we've
+ ; should have applied them by this point.
+ ;
+ varatts = getvaratts(type2)
+ if(.not.any(ismissing(varatts))) then
+ wks_res = True
+ res_list = (/"wkColorMap","wkWidth","wkHeight","wkColorModel",
+ "wkPSResolution","wkPDFResolution","wkVisualType",
+ "wkPaperSize","wkPaperWidthF","wkPaperHeightF",
+ "_FillValue"/)
+ do i=0,dimsizes(varatts)-1
+ if(all(varatts(i).ne.res_list)) then
+ wks_res@$varatts(i)$ = type2@$varatts(i)$
+ end if
+ end do
+ attsetvalues_check(wks,wks_res)
+ delete(wks_res)
+ end if
+ delete(varatts)
+ ;
+ ; Return workstation and application id.
+ ;
+ wks at name = res_file
+ wks at app = appid
+ return(wks)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_annotation ;
+ ; plotid : graphic ;
+ ; annoid : graphic ;
+ ; resources : logical ;
+ ; ;
+ ; This function attaches one graphical object to another, for example, ;
+ ; a labelbar to a contour plot. The default is for the annotation to be ;
+ ; added to the center of the plot. You can use the amJust resource ;
+ ; to change the general location of the annotation (top/center, ;
+ ; top/left top/right, bottom/center, bottom/right, etc. You can use ;
+ ; the amOrthogonalPosF and amParallelPosF resources to then move the ;
+ ; annotation perpendicular or parallel to the plot. ;
+ ; ;
+ ; "amJust" is the corner or side of the annotation of which you want to ;
+ ; position using values for "amParallelPosF" and "amOrthogonalPosF". It ;
+ ; can be any one of the four corners, or the center of any edge of the ;
+ ; annotation. ;
+ ; ;
+ ; "amParallelPosF" is the amount to move the annotation to the right or ;
+ ; left, and "amOrthogonalPosF" is the amount to move it up and down. The;
+ ; move is applied to the corner or the side of the annotation that is ;
+ ; indicated by "amJust". ;
+ ; ;
+ ; Here's what various values of amParallelPosF and amOrthogonalPosF ;
+ ; mean for moving the annotation: ;
+ ; ;
+ ; amParallelPosF/amOrthogonalPosF ;
+ ; 0.0/ 0.0 - annotation in dead center of plot ;
+ ; 0.5/ 0.5 - annotation at bottom right of plot ;
+ ; 0.5/-0.5 - annotation at top right of plot ;
+ ; -0.5/-0.5 - annotation at top left of plot ;
+ ; -0.5/ 0.5 - annotation at bottom left of plot ;
+ ; ;
+ ; So, for example, an amJust value of "TopRight" and amParallelPosF, ;
+ ; amOrthogonalPosF values of 0.5 and -0.5 will position the top right ;
+ ; corner of the annotation in the top right corner of the plot. ;
+ ; ;
+ ; Values of just = "TopCenter", para = -0.5, orth = -0.5 will position ;
+ ; the top center of the annotation in the top left corner of the plot, ;
+ ; effectively placing part of the annotation outside the plot. ;
+ ; ;
+ ; Since adding an annotation to a plot can make it bigger, this ;
+ ; function will recognize gsnMaximize if it is set, and resize the plot ;
+ ; if necessary. ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_add_annotation")
+ function gsn_add_annotation(plot:graphic, anno:graphic, resources:logical)
+ local res2, just, para, orth, just, zone, resize, maxbb, tmp_wks
+ begin
+ res2 = get_resources(resources)
+ just = get_res_value(res2,"amJust","CenterCenter")
+ para = get_res_value(res2,"amParallelPosF",0)
+ orth = get_res_value(res2,"amOrthogonalPosF",0)
+ zone = get_res_value(res2,"amZone",0)
+ resize = get_res_value(res2,"amResizeNotify",True)
+ maxbb = get_bb_res(res2)
+ ;
+ ; Add annotation to plot.
+ ;
+ anno_id = NhlAddAnnotation(plot,anno)
+ ;
+ ; Set some resource values.
+ ;
+ setvalues anno_id
+ "amZone" : zone
+ "amJust" : just
+ "amParallelPosF" : para
+ "amOrthogonalPosF" : orth
+ "amResizeNotify" : resize
+ end setvalues
+ ;
+ ; Apply rest of resources, if any.
+ ;
+ attsetvalues_check(anno_id,res2)
+ ;
+ ; Remaximize the plot if necessary.
+ ;
+ tmp_wks = NhlGetParentWorkstation(plot)
+ draw_and_frame(tmp_wks,plot,False,False,False,maxbb)
+ ;
+ ; Return id
+ ;
+ return(anno_id)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_primitive ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; isndc: NDC space or not ;
+ ; polytype: type of primitive ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function adds a primitive to the plot "plotid", either in the ;
+ ; same data space as the data in the plot, or in NDC space. ("plotid" ;
+ ; is returned from a previous call to one of the gsn_* plotting ;
+ ; functions), "x" and "y" are the x and y locations of each point in the;
+ ; primitive, and should either be in the same data space as the data ;
+ ; from "plotid" (isndc = False) or should be values from 0 to 1 if in ;
+ ; NDC space (isndc = True). Note that using isndc = True should only ;
+ ; be used internally. It currently only works for NDC coordinates that ;
+ ; actually fall within the plot's boundaries. ;
+ ; ;
+ ; "resources" is an optional list of resources. This function returns ;
+ ; the primitive object created. polytype is the type of primitive to ;
+ ; add (polymarker, polygon, or polyline) ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_add_primitive")
+ function gsn_add_primitive(wks:graphic,plotid:graphic,x[*]:numeric,
+ y[*]:numeric,isndc:logical,polytype:string,
+ resources:logical)
+ local res2, gsid, gsres, prim_object, dummy, tfres, vpx, vpy, vpw, vph
+ begin
+ if(.not.any(polytype.eq.(/"polymarker","polygon","polyline"/)))
+ print("Warning: gsn_add_primitive: Do not recognize primitive type '"+ polytype + "'.")
+ return(0)
+ end if
+
+ res2 = get_resources(resources) ; Make a copy of resource list.
+
+ ;
+ ; After V5.1.1, this function was updated to recognize
+ ; "tf*" resources, and have them applied to the plot
+ ; in question. This is especially important for the
+ ; "tfPolyDrawOrder" resource, which allows you to control
+ ; the order which primitives are drawn.
+ ;
+ tfres = get_res_eq(res2,"tf")
+ attsetvalues_check(plotid,tfres)
+
+ ;
+ ; If in NDC space, make sure X and Y values are in the range 0 to 1 AND
+ ; within the viewport of the polot.
+ ;
+ if(isndc) then
+ getvalues plotid
+ "vpHeightF" : vph
+ "vpWidthF" : vpw
+ "vpXF" : vpx
+ "vpYF" : vpy
+ end getvalues
+ ;
+ ; This part is commented out because sometimes if values are equal
+ ; to each other, it will incorrectly register as one being greater/less
+ ; than the other value.
+ ;
+ ; if(any(x.lt.vpx.or.x.gt.(vpx+vpw).or.y.gt.vpy.or.y.lt.(vpy-vph))) then
+ ; print("Warning: gsn_add_primitive: The X and Y values must be between the viewport values of the plot if you are in NDC space.")
+ ; return(0)
+ ; end if
+ ;
+ ; Create a canvas to draw on.
+ ;
+ canvas = create "ndc_canvas" logLinPlotClass wks
+ "tfDoNDCOverlay" : True
+ "trXMinF" : vpx
+ "trXMaxF" : vpx+vpw
+ "trYMaxF" : vpy
+ "trYMinF" : vpy-vph
+ end create
+ end if
+ ;
+ ; Create a graphic style object. We have to do this instead of using
+ ; the default one, because if we add two primitive objects to a plot
+ ; and assign each one a different color, the two objects will have the
+ ; same color as the last color that was set.
+
+ gsid = create "graphic_style" graphicStyleClass wks end create
+ ;
+ ; Set graphic style resources, if any.
+ ;
+ gsres = get_res_eq(res2,"gs")
+ gmres = False
+ attsetvalues_check(gsid,gsres)
+ if(isatt(gsres,"gsLineColor"))
+ gmres = True
+ gmres at gsMarkerColor = gsres at gsLineColor
+ end if
+
+ if(any(ismissing(x)).or.any(ismissing(y)))
+ ;
+ ; If the primitive is a polymarker or polygon, then just use the
+ ; non-missing values.
+ ;
+ if(polytype.eq."polygon".or.polytype.eq."polymarker")
+ inds = ind(.not.ismissing(x).and..not.ismissing(y))
+ if(.not.any(ismissing(inds)))
+ x2 = x(inds)
+ y2 = y(inds)
+ prim_object = create polytype primitiveClass noparent
+ "prXArray" : x2
+ "prYArray" : y2
+ "prPolyType" : polytype
+ "prGraphicStyle" : gsid
+ end create
+ delete(x2)
+ delete(y2)
+ delete(inds)
+ ;
+ ; Add primitive to the plot object. If in NDC space, then add it to the
+ ; canvas, and then add the canvas as an annotation.
+ ;
+ dummy = new(1,graphic)
+ if(isndc) then
+ NhlAddPrimitive(canvas,prim_object,dummy)
+ overlay(plotid,canvas)
+ else
+ NhlAddPrimitive(plotid,prim_object,dummy)
+ end if
+ else
+ prim_object = new(1,graphic)
+ end if
+ else
+ ;
+ ; If the primitive is a polyline, then retrieve the pairs of non-missing
+ ; points, and plot them individually.
+ ;
+ dummy = new(1,graphic)
+ indices = get_non_missing_pairs(x,y)
+ i = 0
+ ;
+ ; Get the number of non-missing pairs of lines.
+ ;
+ nlines = dimsizes(ind(.not.ismissing(indices(:,0))))
+ if(.not.ismissing(nlines))
+ prim_object = new(nlines,graphic)
+ astring = new(nlines,string)
+ astring = polytype + ispan(0,nlines-1,1)
+ first_marker = True
+ do i=0,nlines-1
+ ibeg = indices(i,0)
+ iend = indices(i,1)
+ if(iend.eq.ibeg)
+ ;
+ ; If there's only one point in our line, then indicate it
+ ; with a polymarker.
+ ;
+ polytype2 = "polymarker"
+ if(first_marker)
+ attsetvalues_check(gsid,gmres)
+ first_marker = False
+ end if
+ else
+ polytype2 = "polyline"
+ end if
+ prim_object(i) = create astring(i) primitiveClass noparent
+ "prXArray" : x(ibeg:iend)
+ "prYArray" : y(ibeg:iend)
+ "prPolyType" : polytype2
+ "prGraphicStyle" : gsid
+ end create
+ if(isndc) then
+ NhlAddPrimitive(canvas,prim_object(i),dummy)
+ else
+ NhlAddPrimitive(plotid,prim_object(i),dummy)
+ end if
+ end do
+ ;
+ ; If in NDC space, we need to add the canvas as an annotation of
+ ; the plot.
+ ;
+ if(isndc) then
+ overlay(plotid,canvas)
+ end if
+ else
+ prim_object = new(1,graphic)
+ end if
+ end if
+ else
+ ;
+ ; No data is missing, so create a primitive object.
+ ;
+ prim_object = create polytype primitiveClass noparent
+ "prXArray" : x
+ "prYArray" : y
+ "prPolyType" : polytype
+ "prGraphicStyle" : gsid
+ end create
+ ;
+ ; Add primitive to the plot object.
+ ;
+ dummy = new(1,graphic)
+ if(isndc) then
+ NhlAddPrimitive(canvas,prim_object,dummy)
+ overlay(plotid,canvas)
+ else
+ NhlAddPrimitive(plotid,prim_object,dummy)
+ end if
+ end if
+
+ return(prim_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_primitive ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; isndc: NDC space or not ;
+ ; polytype: type of primitive ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function draws a primitive to the plot "plotid", either in the ;
+ ; same data space as the data in the plot, or in NDC space. ("plotid" ;
+ ; is returned from a previous call to one of the gsn_* plotting ;
+ ; functions), "x" and "y" are the x and y locations of each point in the;
+ ; primitive, and should either be in the same data space as the data ;
+ ; from "plotid" (isndc = False) or should be values from 0 to 1 if in ;
+ ; NDC space (isndc = True). Note that using isndc = True should only ;
+ ; be used internally. It currently only works for NDC coordinates that ;
+ ; actually fall within the plot's boundaries. ;
+ ; ;
+ ; "resources" is an optional list of resources. ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_primitive")
+ procedure gsn_primitive(wks:graphic,plotid:graphic,x[*]:numeric,
+ y[*]:numeric,isndc:logical,polytype:string,
+ resources:logical)
+ local res2, gsid, gsres, gmres, canvas, xf, yf, x2, y2
+ begin
+ if(.not.any(polytype.eq.(/"polymarker","polygon","polyline"/)))
+ print("Warning: gsn_primitive: Do not recognize primitive type '"+ polytype + "'.")
+ return
+ end if
+
+ res2 = get_resources(resources)
+
+ ; Create graphic style object.
+
+ gsid = create "graphic_style" graphicStyleClass wks end create
+
+ ;
+ ; Create a canvas to draw on, if this is an NDC draw.
+ ;
+ if(isndc) then
+ canvas = create_canvas(wks)
+ end if
+
+ gsres = get_res_eq(res2,"gs")
+ attsetvalues_check(gsid,gsres)
+ ;
+ ; Make sure data is float, since NhlDataPolymarker only takes floats.
+ ;
+ xf = tofloat(x)
+ yf = tofloat(y)
+ ;
+ ; Since the NhlData*/NhlNDC* routines don't accept missing values, this
+ ; routine only draws the ones that aren't missing. For polylines, a pen up
+ ; and pen down takes place after each section of missing values. We'll
+ ; handle this later.
+ ;
+ if(.not.any(ismissing(xf)).and..not.any(ismissing(yf))) then
+ x2 = xf
+ y2 = yf
+ nomsg = True
+ else
+ x2 = xf(ind(.not.ismissing(xf).and..not.ismissing(yf)))
+ y2 = yf(ind(.not.ismissing(xf).and..not.ismissing(yf)))
+ nomsg = False
+ end if
+
+ if(polytype.eq."polymarker") then
+ if(isndc) then
+ NhlNDCPolymarker(canvas,gsid,x2,y2)
+ else
+ NhlDataPolymarker(plotid,gsid,x2,y2)
+ end if
+ end if
+ if(polytype.eq."polygon") then
+ if(isndc) then
+ NhlNDCPolygon(canvas,gsid,x2,y2)
+ else
+ NhlDataPolygon(plotid,gsid,x2,y2)
+ end if
+ end if
+ if(polytype.eq."polyline".and.nomsg) then
+ if(isndc) then
+ NhlNDCPolyline(canvas,gsid,x2,y2)
+ else
+ NhlDataPolyline(plotid,gsid,x2,y2)
+ end if
+ end if
+ if(polytype.eq."polyline".and..not.nomsg) then
+ first_marker = True
+ ;
+ ; If we end up with a line with just one point, then we draw it with
+ ; a polymarker. Thus, we need to make sure the marker will be the
+ ; same color as the line.
+ ;
+ gmres = False
+ if(isatt(gsres,"gsLineColor"))
+ gmres = True
+ gmres at gsMarkerColor = gsres at gsLineColor
+ end if
+
+ indices = get_non_missing_pairs(xf,yf)
+ i = 0
+ do while(.not.ismissing(indices(i,0)).and.i.lt.dimsizes(xf))
+ ibeg = indices(i,0)
+ iend = indices(i,1)
+ if(iend.gt.ibeg)
+ if(isndc) then
+ NhlNDCPolyline(canvas,gsid,xf(ibeg:iend),yf(ibeg:iend))
+ else
+ NhlDataPolyline(plotid,gsid,xf(ibeg:iend),yf(ibeg:iend))
+ end if
+ else ; iend = ibeg --> only one point
+ if(first_marker)
+ attsetvalues_check(gsid,gmres)
+ first_marker = False
+ end if
+ if(isndc) then
+ NhlNDCPolymarker(canvas,gsid,xf(ibeg),yf(ibeg))
+ else
+ NhlDataPolymarker(plotid,gsid,xf(ibeg),yf(ibeg))
+ end if
+ end if
+ i = i + 1
+ end do
+ delete(indices)
+ end if
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : gsn_polygon ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws a filled polygon on the workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks") in the same ;
+ ; data space as the data in "plotid" (returned from a previous call to ;
+ ; one of the gsn_* plotting functions). "x" and "y" are the x and y ;
+ ; locations of each point in the polygon, and should be in the same data;
+ ; space as the data from "plotid". "resources" is an optional list of ;
+ ; resources. ;
+ ;***********************************************************************;
+ undef("gsn_polygon")
+ procedure gsn_polygon(wks:graphic,plotid:graphic,x[*]:numeric,
+ y[*]:numeric,resources:logical)
+ local res2
+ begin
+ res2 = get_resources(resources)
+ gsn_primitive(wks,plotid,x,y,False,"polygon",res2)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_polygon ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function adds a polygon to the plot "plotid", in the same data ;
+ ; space as the data in the plot ("plotid" is returned from a previous ;
+ ; call to one of the gsn_* plotting functions). "x" and "y" are the x ;
+ ; and y locations of each point in the polygon, and should be in the ;
+ ; same data space as the data from "plotid". "resources" is an optional ;
+ ; list of resources. This function returns the primitive object ;
+ ; created. ;
+ ; ;
+ ; This function is different from gsn_polygon because it actually ;
+ ; attaches the polygon to the plot. This means that if you resize or ;
+ ; move the plot, the polygon will stay with the plot. ;
+ ;***********************************************************************;
+ undef("gsn_add_polygon")
+ function gsn_add_polygon(wks:graphic,plotid:graphic,x[*]:numeric,
+ y[*]:numeric,resources:logical)
+ begin
+ res2 = get_resources(resources)
+ return(gsn_add_primitive(wks,plotid,x,y,False,"polygon",res2))
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : gsn_polygon_ndc ;
+ ; wks: workstation object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws a filled polygon on the workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks") in NDC ;
+ ; space. "x" and "y" are the x and y locations of each point in the ;
+ ; polygon, and "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_polygon_ndc")
+ procedure gsn_polygon_ndc(wks:graphic,x[*]:numeric,y[*]:numeric,
+ resources:logical)
+ local res2, dummy
+ begin
+ dummy = new(1,graphic)
+ res2 = get_resources(resources)
+ gsn_primitive(wks,dummy,x,y,True,"polygon",res2)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_polyline ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws a polyline on the workstation "wks" (the variable;
+ ; returned from a previous call to "gsn_open_wks") in the same data ;
+ ; space as the data in "plotid" (returned from a previous call to one of;
+ ; the gsn_* plotting functions). "x" and "y" are the x and y locations ;
+ ; of each point in the line, and should be in the same data space as the;
+ ; data from "plotid". "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_polyline")
+ procedure gsn_polyline(wks:graphic,plotid:graphic,x[*]:numeric,
+ y[*]:numeric,resources:logical)
+ local res2
+ begin
+ res2 = get_resources(resources)
+ gsn_primitive(wks,plotid,x,y,False,"polyline",res2)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_polyline ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: 1-dimensional array of x points ;
+ ; y: 1-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function adds a polyline to the plot "plotid", in the same data ;
+ ; space as the data in the plot ("plotid" is returned from a previous ;
+ ; call to one of the gsn_* plotting functions). "x" and "y" are the x ;
+ ; and y locations of each point in the line, and should be in the same ;
+ ; data space as the data from "plotid". "resources" is an optional list ;
+ ; of resources. This function returns the primitive object created. ;
+ ; ;
+ ; This function is different from gsn_polyline because it actually ;
+ ; attaches the line to the plot. This means that if you resize or move ;
+ ; the plot, the line will stay with the plot. ;
+ ;***********************************************************************;
+ undef("gsn_add_polyline")
+ function gsn_add_polyline(wks:graphic,plotid:graphic,x[*]:numeric,
+ y[*]:numeric,resources:logical)
+ local res2
+ begin
+ res2 = get_resources(resources)
+ return(gsn_add_primitive(wks,plotid,x,y,False,"polyline",res2))
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_polyline_ndc ;
+ ; wks: workstation object ;
+ ; x: 1-dimensional array of x ndc points ;
+ ; y: 1-dimensional array of y ndc points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws a polyline on the workstation "wks" (the variable;
+ ; returned from a previous call to "gsn_open_wks") in NDC space. ;
+ ; "x" and "y" are the x and y locations of each point in the line. ;
+ ; "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_polyline_ndc")
+ procedure gsn_polyline_ndc(wks:graphic,x[*]:numeric,y[*]:numeric,
+ resources:logical)
+ local res2, dummy
+ begin
+ dummy = new(1,graphic)
+ res2 = get_resources(resources)
+ gsn_primitive(wks,dummy,x,y,True,"polyline",res2)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_polymarker ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: n-dimensional array of x points ;
+ ; y: n-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws polymarkers on the workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks") in the same ;
+ ; data space as the data in "plotid" (returned from a previous call to ;
+ ; one of the gsn_* plotting functions). "x" and "y" are the x and y ;
+ ; locations of each marker, and should be in the same data space as the ;
+ ; data from "plotid". "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_polymarker")
+ procedure gsn_polymarker(wks:graphic,plotid:graphic,x:numeric,
+ y:numeric,resources:logical)
+ local res2, rank
+ begin
+ res2 = get_resources(resources)
+ rank = dimsizes(dimsizes(x))
+ if(rank.eq.1) then
+ gsn_primitive(wks,plotid,x,y,False,"polymarker",res2)
+ else
+ gsn_primitive(wks,plotid,ndtooned(x),ndtooned(y),False,"polymarker",res2)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_polymarker ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; x: n-dimensional array of x points ;
+ ; y: n-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function adds polymarkers to the plot "plotid", in the same ;
+ ; data space as the data in the plot ("plotid" is returned from a ;
+ ; previous call to one of the gsn_* plotting functions). "x" and "y" are;
+ ; the x and y locations of each marker, and should be in the same data ;
+ ; space as the data from "plotid". "resources" is an optional list of ;
+ ; resources. This function returns the primitive object created. ;
+ ; ;
+ ; This function is different from gsn_polymarker because it actually ;
+ ; attaches the markers to the plot. This means that if you resize or ;
+ ; move the plot, the markers will stay with the plot. ;
+ ;***********************************************************************;
+ undef("gsn_add_polymarker")
+ function gsn_add_polymarker(wks:graphic,plotid:graphic,x:numeric,
+ y:numeric,resources:logical)
+ local res2, rank
+ begin
+ res2 = get_resources(resources)
+
+ rank = dimsizes(dimsizes(x))
+ if(rank.eq.1) then
+ return(gsn_add_primitive(wks,plotid,x,y,False,"polymarker",res2))
+ else
+ return(gsn_add_primitive(wks,plotid,ndtooned(x),ndtooned(y),False,"polymarker",res2))
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_shapefile_polylines ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; fname: Name of shapefile ("xxxx.shp") ;
+ ; resources: optional resources ;
+ ; ;
+ ; ANY CHANGES MADE TO THIS CODE SHOULD POTENTIALLY BE MADE TO ;
+ ; gsn_add_shapefile_polylines BELOW!! Note that in V6.2.0, the "add" ;
+ ; version of this code was sped up significantly, so this procedure is ;
+ ; not needed so much anymore. ;
+ ;
+ ; This function draws shapefile polylines on the plot "plotid". ;
+ ; See gsn_add_shapefile_polylines if you want to add them instead (this ;
+ ; can be much slower). ;
+ ; ;
+ ; In version 6.1.0, some code was added to add checks if the lat/lon ;
+ ; segments are within the range of the map. This works best for a C.E. ;
+ ; map. You have to set the special min/max/lat/lon attributes for this ;
+ ; to work. I won't advertise this yet, because the interface could ;
+ ; probably be made better. See note about V6.2.0 above. ;
+ ;***********************************************************************;
+ undef("gsn_shapefile_polylines")
+ procedure gsn_shapefile_polylines(wks,plot,fname:string,lnres)
+ local f, segments, geometry, segsDims, geomDims, geom_segIndex,
+ geom_numSegs, segs_xyzIndex, segs_numPnts, numFeatures, i, lat, lon,
+ startSegment, numSegments, seg, startPT, endPT
+ begin
+ ;---Open the shapefile
+ f = addfile(fname,"r")
+
+ ;---Error checking
+ if(ismissing(f)) then
+ print("Error: gsn_shapefile_polylines: Can't open shapefile '" +
+ fname + "'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---We can't use this routine to plot point data
+ if(.not.any(f at geometry_type.eq.(/"polygon","polyline"/))) then
+ print("Error: gsn_shapefile_polylines: geometry_type attribute must be 'polygon' or 'polyline'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---Read data off the shapefile
+ geomDims = getfilevardimsizes(f,"geometry")
+ numFeatures = geomDims(0)
+ if(numFeatures.eq.0) then
+ print("Error: gsn_shapefile_polylines: the number of features in this file is 0.")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ segments = f->segments
+ geometry = f->geometry
+ segsDims = dimsizes(segments)
+
+ ;---Read global attributes
+ geom_segIndex = f at geom_segIndex
+ geom_numSegs = f at geom_numSegs
+ segs_xyzIndex = f at segs_xyzIndex
+ segs_numPnts = f at segs_numPnts
+
+ ;---Section to attach polylines to plot.
+ lon = f->x
+ lat = f->y
+ ;
+ ; Special check for minlat/maxlat/minlon/maxlon attributes.
+ ;
+ ; If set, then each lat/lon segment will be checked if it's
+ ; in the range. This can speed up plotting, but I need to
+ ; verify this!
+ ;
+ if(isatt(lnres,"minlon").and.isatt(lnres,"maxlon").and.
+ isatt(lnres,"minlat").and.isatt(lnres,"maxlat")) then
+ do i=0, numFeatures-1
+ startSegment = geometry(i, geom_segIndex)
+ numSegments = geometry(i, geom_numSegs)
+ do seg=startSegment, startSegment+numSegments-1
+ startPT = segments(seg, segs_xyzIndex)
+ endPT = startPT + segments(seg, segs_numPnts) - 1
+ lat_sub = lat(startPT:endPT)
+ lon_sub = lon(startPT:endPT)
+ if(.not.(all(lon_sub.lt.lnres at minlon).or.
+ all(lon_sub.gt.lnres at maxlon).or.
+ all(lat_sub.lt.lnres at minlat).or.
+ all(lat_sub.gt.lnres at maxlat))) then
+ gsn_polyline(wks, plot, lon_sub, lat_sub, lnres)
+ end if
+ delete([/lat_sub,lon_sub/])
+ end do
+ end do
+ else ; Don't do any range checking.
+ do i=0, numFeatures-1
+ startSegment = geometry(i, geom_segIndex)
+ numSegments = geometry(i, geom_numSegs)
+ do seg=startSegment, startSegment+numSegments-1
+ startPT = segments(seg, segs_xyzIndex)
+ endPT = startPT + segments(seg, segs_numPnts) - 1
+ gsn_polyline(wks, plot, lon(startPT:endPT),
+ lat(startPT:endPT), lnres)
+ end do
+ end do
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_shapefile_polylines ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; fname: Name of shapefile ("xxxx.shp") ;
+ ; resources: optional resources ;
+ ; ;
+ ; ANY CHANGES MADE TO THIS CODE SHOULD POTENTIALLY BE MADE TO ;
+ ; gsn_shapefile_polylines ABOVE!! ;
+ ; ;
+ ; This function attaches shapefile polylines to the plot "plotid". ;
+ ; See gsn_shapefile_polylines if you want to just draw them. ;
+ ; ;
+ ; In version 6.2.0 this function was significantly sped-up via the use ;
+ ; of a new resource called "gsSegments". Only one primitive object id ;
+ ; is now created. In some cases, we saw speed-ups of 80x (for example, ;
+ ; with the France_adm5 shapefile). Because of this speed-up, the code ;
+ ; added in V6.1.0 for checking for special minlat/maxlat/minlon/maxlon ;
+ ; is no longer needed. It is commented out for now. It may eventually ;
+ ; be removed once we are certain it doesn't serve any benefit. ;
+ ; ;
+ ; In version 6.1.0, some code was added to add checks if the lat/lon ;
+ ; segments are within the range of the map. This works best for a C.E. ;
+ ; map. You have to set the special min/max/lat/lon attributes for this ;
+ ; to work. I won't advertise this yet, because the interface could ;
+ ; probably be made better. THIS CODE HAS BEEN COMMENTED OUT in V6.2.0. ;
+ ; ;
+ ; In version 6.2.1, this function was modified to allow multiple plots. ;
+ ;***********************************************************************;
+ undef("gsn_add_shapefile_polylines")
+ function gsn_add_shapefile_polylines(wks,plots[*]:graphic,fname:string,lnres)
+ local f, geomDims, numFeatures, lnres2
+ begin
+ ;---Open the shapefile
+ f = addfile(fname,"r")
+
+ ;---Error checking
+ if(ismissing(f)) then
+ print("Error: gsn_add_shapefile_polylines: Can't open shapefile '" +
+ fname + "'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---We can't use this routine to plot point data
+ if(.not.any(f at geometry_type.eq.(/"polygon","polyline"/))) then
+ print("Error: gsn_add_shapefile_polylines: geometry_type attribute must be 'polygon' or 'polyline'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ if(lnres) then
+ lnres2 = lnres ; Make a copy so that we don't keep gsSegments
+ else
+ lnres2 = True
+ end if
+
+ ;---Read data off the shapefile
+ geomDims = getfilevardimsizes(f,"geometry")
+ numFeatures = geomDims(0)
+ if(numFeatures.eq.0) then
+ print("Error: gsn_add_shapefile_polylines: the number of features in this file is 0.")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;; segments = f->segments
+ ;; geometry = f->geometry
+ ;; segsDims = dimsizes(segments)
+ ;;
+ ;;;---Read global attributes
+ ;; geom_segIndex = f at geom_segIndex
+ ;; geom_numSegs = f at geom_numSegs
+ ;; segs_xyzIndex = f at segs_xyzIndex
+ ;; segs_numPnts = f at segs_numPnts
+ ;;
+ ;;;---Create array to hold all polylines
+ ;; npoly = sum(geometry(:,geom_numSegs))
+ ;; poly = new(npoly,graphic)
+ ;;
+ ;;;---Section to attach polylines to plot.
+ ;; lon = f->x
+ ;; lat = f->y
+ ;; npl = 0 ; polyline counter
+ ;;;
+ ;;; Special check for minlat/maxlat/minlon/maxlon attributes.
+ ;;;
+ ;;; If set, then each lat/lon segment will be checked if it's
+ ;;; in the range. This can speed up plotting, but I need to
+ ;;; verify this!
+ ;;;
+ ;; if(isatt(lnres,"minlon").and.isatt(lnres,"maxlon").and.\
+ ;; isatt(lnres,"minlat").and.isatt(lnres,"maxlat")) then
+ ;; do i=0, numFeatures-1
+ ;; startSegment = geometry(i, geom_segIndex)
+ ;; numSegments = geometry(i, geom_numSegs)
+ ;; do seg=startSegment, startSegment+numSegments-1
+ ;; startPT = segments(seg, segs_xyzIndex)
+ ;; endPT = startPT + segments(seg, segs_numPnts) - 1
+ ;; lat_sub = lat(startPT:endPT)
+ ;; lon_sub = lon(startPT:endPT)
+ ;; if(.not.(all(lon_sub.lt.lnres at minlon).or. \
+ ;; all(lon_sub.gt.lnres at maxlon).or. \
+ ;; all(lat_sub.lt.lnres at minlat).or. \
+ ;; all(lat_sub.gt.lnres at maxlat))) then
+ ;; poly(npl) = gsn_add_polyline(wks, plot, lon_sub, lat_sub, lnres)
+ ;; npl = npl + 1
+ ;; end if
+ ;; delete([/lat_sub,lon_sub/])
+ ;; end do
+ ;; end do
+ ;; else ; Don't do any range checking.
+ ;; do i=0, numFeatures-1
+ ;; startSegment = geometry(i, geom_segIndex)
+ ;; numSegments = geometry(i, geom_numSegs)
+ ;; do seg=startSegment, startSegment+numSegments-1
+ ;; startPT = segments(seg, segs_xyzIndex)
+ ;; endPT = startPT + segments(seg, segs_numPnts) - 1
+ ;; poly(npl) = gsn_add_polyline(wks, plot, lon(startPT:endPT), \
+ ;; lat(startPT:endPT), lnres)
+ ;; npl = npl + 1
+ ;; end do
+ ;; end do
+ ;; end if
+ ;; return(poly(0:npl-1))
+
+ ;---This is all that's needed in V6.2.0.
+ lnres2 at gsSegments = f->segments(:,0)
+ nplots = dimsizes(plots)
+ poly = new(nplots,graphic)
+ do i=0,nplots-1
+ poly(i) = gsn_add_polyline(wks, plots(i), f->x, f->y, lnres2)
+ end do
+ return(poly)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_shapefile_polygons ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; fname: Name of shapefile ("xxxx.shp") ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function attaches shapefile polygons to the plot "plotid". ;
+ ; ;
+ ; In version 6.2.0 this function was significantly sped-up via the use ;
+ ; of a new resource called "gsSegments". Only one primitive object id ;
+ ; is now created. In some cases, we saw speed-ups of 80x (for example, ;
+ ; with the France_adm5 shapefile). Because of this speed-up, the code ;
+ ; added in V6.1.0 for checking for special minlat/maxlat/minlon/maxlon ;
+ ; is no longer needed. It is commented out for now. It may eventually ;
+ ; be removed once we are certain it doesn't serve any benefit. ;
+ ; ;
+ ; In version 6.1.0, some code was added to add checks if the lat/lon ;
+ ; segments are within the range of the map. This works best for a C.E. ;
+ ; map. You have to set the special min/max/lat/lon attributes for this ;
+ ; to work. I won't advertise this yet, because the interface could ;
+ ; probably be made better. THIS CODE HAS BEEN COMMENTED OUT in V6.2.0. ;
+ ; ;
+ ; In version 6.2.1, this function was modified to allow multiple plots. ;
+ ;***********************************************************************;
+ undef("gsn_add_shapefile_polygons")
+ function gsn_add_shapefile_polygons(wks,plots[*]:graphic,fname:string,gnres)
+ local f, geomDims, numFeatures, gnres2
+ begin
+ ;---Open the shapefile
+ f = addfile(fname,"r")
+
+ ;---Error checking
+ if(ismissing(f)) then
+ print("Error: gsn_add_shapefile_polygons: Can't open shapefile '" +
+ fname + "'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---We can't use this routine to plot point data
+ if(f at geometry_type.ne."polygon") then
+ print("Error: gsn_add_shapefile_polygon: geometry_type attribute must be 'polygon'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---Read data off the shapefile
+ geomDims = getfilevardimsizes(f,"geometry")
+ numFeatures = geomDims(0)
+ if(numFeatures.eq.0) then
+ print("Error: gsn_add_shapefile_polygon: the number of features in this file is 0.")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ if(gnres) then
+ gnres2 = gnres ; Make a copy so that we don't keep gsSegments
+ else
+ gnres2 = True
+ end if
+
+ ;---Get the number of colors
+ if(.not.gnres2.or.(.not.isatt(gnres2,"gsFillColor").and.
+ .not.isatt(gnres2,"gsColors"))) then
+ getvalues wks
+ "wkColorMapLen" : cmap_len
+ end getvalues
+ gnres2 = True ; Make sure this is True
+ gnres2 at gsColors = toint(random_uniform(2,cmap_len-2,numFeatures))
+ end if
+
+ ;; segments = f->segments
+ ;; geometry = f->geometry
+ ;; segsDims = dimsizes(segments)
+ ;;
+ ;;;---Read global attributes
+ ;; geom_segIndex = f at geom_segIndex
+ ;; geom_numSegs = f at geom_numSegs
+ ;; segs_xyzIndex = f at segs_xyzIndex
+ ;; segs_numPnts = f at segs_numPnts
+ ;;
+ ;;;---Create array to hold all polylines
+ ;; npoly = sum(geometry(:,geom_numSegs))
+ ;; poly = new(npoly,graphic)
+ ;;
+ ;;;---Section to attach polygons to plot.
+ ;; lon = f->x
+ ;; lat = f->y
+ ;; npl = 0 ; polyline counter
+ ;;;
+ ;;; Special check for minlat/maxlat/minlon/maxlon attributes.
+ ;;;
+ ;;; If set, then each lat/lon segment will be checked if it's
+ ;;; in the range. This can speed up plotting, but I need to
+ ;;; verify this!
+ ;;;
+ ;; if(isatt(gnres,"minlon").and.isatt(gnres,"maxlon").and.\
+ ;; isatt(gnres,"minlat").and.isatt(gnres,"maxlat")) then
+ ;; do i=0, numFeatures-1
+ ;; startSegment = geometry(i, geom_segIndex)
+ ;; numSegments = geometry(i, geom_numSegs)
+ ;; do seg=startSegment, startSegment+numSegments-1
+ ;; startPT = segments(seg, segs_xyzIndex)
+ ;; endPT = startPT + segments(seg, segs_numPnts) - 1
+ ;; lat_sub = lat(startPT:endPT)
+ ;; lon_sub = lon(startPT:endPT)
+ ;; if(set_fill_color) then
+ ;;;---Pick a random color
+ ;; gnres at gsFillColor = toint(random_uniform(2,cmap_len-2,1))
+ ;; end if
+ ;; if(.not.(all(lon_sub.lt.gnres at minlon).or. \
+ ;; all(lon_sub.gt.gnres at maxlon).or. \
+ ;; all(lat_sub.lt.gnres at minlat).or. \
+ ;; all(lat_sub.gt.gnres at maxlat))) then
+ ;;;---Attach the line segment
+ ;; poly(npl) = gsn_add_polygon(wks, plot, lon_sub, lat_sub, gnres)
+ ;; npl = npl + 1
+ ;; end if
+ ;; delete([/lat_sub,lon_sub/])
+ ;; end do
+ ;; end do
+ ;; else
+ ;; do i=0, numFeatures-1
+ ;; startSegment = geometry(i, geom_segIndex)
+ ;; numSegments = geometry(i, geom_numSegs)
+ ;; do seg=startSegment, startSegment+numSegments-1
+ ;; startPT = segments(seg, segs_xyzIndex)
+ ;; endPT = startPT + segments(seg, segs_numPnts) - 1
+ ;; if(set_fill_color) then
+ ;;;---Pick a random color
+ ;; gnres at gsFillColor = toint(random_uniform(2,cmap_len-2,1))
+ ;; end if
+ ;;;---Attach the line segment
+ ;; poly(npl) = gsn_add_polygon(wks, plot, lon(startPT:endPT), \
+ ;; lat(startPT:endPT), gnres)
+ ;; npl = npl + 1
+ ;; end do
+ ;; end do
+ ;; end if
+ ;; return(poly)
+
+ ;---This is all that's needed in V6.2.0.
+ gnres2 at gsSegments = f->segments(:,0)
+ nplots = dimsizes(plots)
+ poly = new(nplots,graphic)
+ do i=0,nplots-1
+ poly(i) = gsn_add_polygon(wks, plots(i), f->x, f->y, gnres2)
+ end do
+ return(poly)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_shapefile_polymarkers ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; fname: Name of shapefile ("xxxx.shp") ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function attaches shapefile point data to the plot "plotid". ;
+ ; ;
+ ; In version 6.1.0, some code was added to add checks if the lat/lon ;
+ ; segments are within the range of the map. This works best for a C.E. ;
+ ; map. You have to set the special min/max/lat/lon attributes for this ;
+ ; to work. I won't advertise this yet, because the interface could ;
+ ; probably be made better. ;
+ ; ;
+ ; In version 6.2.1, this function was modified to allow multiple plots. ;
+ ;***********************************************************************;
+ undef("gsn_add_shapefile_polymarkers")
+ function gsn_add_shapefile_polymarkers(wks,plots[*]:graphic,fname:string,mkres)
+ local f, segments, geometry, segsDims, geomDims, geom_segIndex,
+ geom_numSegs, segs_xyzIndex, segs_numPnts, numFeatures, i, lat, lon,
+ startSegment, numSegments, seg, startPT, endPT, npoly, npl
+ begin
+ ;---Open the shapefile
+ f = addfile(fname,"r")
+
+ ;---Error checking
+ if(ismissing(f)) then
+ print("Error: gsn_add_shapefile_polymarkers: Can't open shapefile '" +
+ fname + "'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---We can't use this routine to plot point data
+ if(f at geometry_type.ne."point") then
+ print("Error: gsn_add_shapefile_polymarkers: geometry_type attribute must be 'point'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---Read data off the shapefile
+ geomDims = getfilevardimsizes(f,"geometry")
+ numFeatures = geomDims(0)
+ if(numFeatures.eq.0) then
+ print("Error: gsn_add_shapefile_polymarkers: the number of features in this file is 0.")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ segments = f->segments
+ geometry = f->geometry
+ segsDims = dimsizes(segments)
+
+ ;---Read global attributes
+ geom_segIndex = f at geom_segIndex
+ geom_numSegs = f at geom_numSegs
+ segs_xyzIndex = f at segs_xyzIndex
+ segs_numPnts = f at segs_numPnts
+
+ ;---Create array to hold all polymarkers
+ npoly = sum(geometry(:,geom_numSegs))
+ nplots = dimsizes(plots)
+ poly = new(npoly*nplots,graphic)
+
+ ;---Section to attach polymarkers to plots.
+ lon = f->x
+ lat = f->y
+ npl = 0 ; polyline counter
+ ;
+ ; Special check for minlat/maxlat/minlon/maxlon attributes.
+ ;
+ ; If set, then each lat/lon segment will be checked if it's
+ ; in the range. This can speed up plotting, but I need to
+ ; verify this!
+ ;
+ if(isatt(mkres,"minlon").and.isatt(mkres,"maxlon").and.
+ isatt(mkres,"minlat").and.isatt(mkres,"maxlat")) then
+ do i=0, numFeatures-1
+ startSegment = geometry(i, geom_segIndex)
+ numSegments = geometry(i, geom_numSegs)
+ do seg=startSegment, startSegment+numSegments-1
+ startPT = segments(seg, segs_xyzIndex)
+ endPT = startPT + segments(seg, segs_numPnts) - 1
+ lat_sub = lat(startPT:endPT)
+ lon_sub = lon(startPT:endPT)
+ if(.not.(all(lon_sub.lt.mkres at minlon).or.
+ all(lon_sub.gt.mkres at maxlon).or.
+ all(lat_sub.lt.mkres at minlat).or.
+ all(lat_sub.gt.mkres at maxlat))) then
+ ;---Attach the markers
+ do n=0,nplots-1
+ poly(npl) = gsn_add_polymarker(wks, plots(n), lon_sub, lat_sub, mkres)
+ npl = npl + 1
+ end do
+ end if
+ delete([/lat_sub,lon_sub/])
+ end do
+ end do
+ else ; Don't do any range checking.
+ do i=0, numFeatures-1
+ startSegment = geometry(i, geom_segIndex)
+ numSegments = geometry(i, geom_numSegs)
+ do seg=startSegment, startSegment+numSegments-1
+ startPT = segments(seg, segs_xyzIndex)
+ endPT = startPT + segments(seg, segs_numPnts) - 1
+ ;---Attach the markers
+ do n=0,nplots-1
+ poly(npl) = gsn_add_polymarker(wks, plots(n), lon(startPT:endPT),
+ lat(startPT:endPT), mkres)
+ npl = npl + 1
+ end do
+ end do
+ end do
+ end if
+ return(poly(0:npl-1))
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_shapefile_text ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; fname: Name of shapefile ("xxxx.shp") ;
+ ; vname: Name of string variable containing text strings;
+ ; resources: optional resources ;
+ ; ;
+ ; This function attaches shapefile text strings to the plot "plotid". ;
+ ; The assumption is that there are "num_features" text strings, and this;
+ ; routine gets the approximate mid lat/lon area for each text string. ;
+ ;***********************************************************************;
+ undef("gsn_add_shapefile_text")
+ function gsn_add_shapefile_text(wks,plot,fname[1]:string,vname[1]:string,txres)
+ local f, segments, geometry, segsDims, geomDims, geom_segIndex,
+ geom_numSegs, segs_xyzIndex, segs_numPnts, numFeatures, i, lat, lon,
+ startSegment, numSegments, seg, startPT, endPT, ntxt,
+ minlat, maxlat, minlon, maxlon
+ begin
+ ;---Open the shapefile
+ f = addfile(fname,"r")
+ if(.not.isfilevar(f,vname))
+ print("Error: gsn_add_shapefile_text: '" + vname + "' is not a variable")
+ print(" in file '" + fname + "'.")
+ return(new(1,graphic))
+ end if
+ ;---Error checking
+ if(ismissing(f)) then
+ print("Error: gsn_add_shapefile_text: Can't open shapefile '" +
+ fname + "'")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ ;---Read data off the shapefile
+ geomDims = getfilevardimsizes(f,"geometry")
+ numFeatures = geomDims(0)
+ if(numFeatures.eq.0) then
+ print("Error: gsn_add_shapefile_text: the number of features in this file is 0.")
+ print(" No shapefile information will be added.")
+ return(new(1,graphic))
+ end if
+
+ segments = f->segments
+ geometry = f->geometry
+ segsDims = dimsizes(segments)
+
+ ;---Read global attributes
+ geom_segIndex = f at geom_segIndex
+ geom_numSegs = f at geom_numSegs
+ segs_xyzIndex = f at segs_xyzIndex
+ segs_numPnts = f at segs_numPnts
+ numFeatures = geomDims(0)
+
+ ;---Create array to hold all text
+ text = new(numFeatures,graphic)
+
+ ;---Section to attach text to plot.
+ lon = f->x
+ lat = f->y
+ ntxt = 0 ; text counter
+ ;
+ ; Special check for minlat/maxlat/minlon/maxlon attributes.
+ ;
+ ; If set, then each lat/lon segment will be checked if it's
+ ; in the range. This can speed up plotting, but I need to
+ ; verify this!
+ ;
+ if(isatt(txres,"minlon").and.isatt(txres,"maxlon").and.
+ isatt(txres,"minlat").and.isatt(txres,"maxlat")) then
+ do i=0, numFeatures-1
+ startSegment = geometry(i, geom_segIndex)
+ numSegments = geometry(i, geom_numSegs)
+ minlat = new(1,typeof(lat))
+ maxlat = new(1,typeof(lat))
+ minlon = new(1,typeof(lon))
+ maxlon = new(1,typeof(lon))
+ do seg=startSegment, startSegment+numSegments-1
+ startPT = segments(seg, segs_xyzIndex)
+ endPT = startPT + segments(seg, segs_numPnts) - 1
+ lat_sub = lat(startPT:endPT)
+ lon_sub = lon(startPT:endPT)
+ if(.not.(all(lon_sub.lt.txres at minlon).or.
+ all(lon_sub.gt.txres at maxlon).or.
+ all(lat_sub.lt.txres at minlat).or.
+ all(lat_sub.gt.txres at maxlat))) then
+ if(any((/ismissing(minlat),ismissing(maxlat),
+ ismissing(minlon),ismissing(maxlon)/))) then
+ minlat = min(lat_sub)
+ maxlat = max(lat_sub)
+ minlon = min(lon_sub)
+ maxlon = max(lon_sub)
+ else
+ minlat = min((/minlat,min(lat_sub)/))
+ maxlat = max((/maxlat,max(lat_sub)/))
+ minlon = min((/minlon,min(lon_sub)/))
+ maxlon = max((/maxlon,max(lon_sub)/))
+ end if
+ end if
+ delete([/lat_sub,lon_sub/])
+ end do
+ ;---Attach the text string
+ if(.not.any((/ismissing(minlat),ismissing(maxlat),
+ ismissing(minlon),ismissing(maxlon)/))) then
+ avglat = (minlat+maxlat)/2.
+ avglon = (minlon+maxlon)/2.
+ print("Text = '" + f->$vname$(i) + "'")
+ print("Location = " + avglat + "/" + avglon)
+ text(ntxt) = gsn_add_text(wks, plot,f->$vname$(i),avglon,avglat,txres)
+ ntxt = ntxt + 1
+ end if
+ end do
+ else
+ do i=0, numFeatures-1
+ startSegment = geometry(i, geom_segIndex)
+ numSegments = geometry(i, geom_numSegs)
+ minlat = new(1,typeof(lat))
+ maxlat = new(1,typeof(lat))
+ minlon = new(1,typeof(lon))
+ maxlon = new(1,typeof(lon))
+ do seg=startSegment, startSegment+numSegments-1
+ startPT = segments(seg, segs_xyzIndex)
+ endPT = startPT + segments(seg, segs_numPnts) - 1
+ if(any((/ismissing(minlat),ismissing(maxlat),
+ ismissing(minlon),ismissing(maxlon)/))) then
+ minlat = min(lat(startPT:endPT))
+ maxlat = max(lat(startPT:endPT))
+ minlon = min(lon(startPT:endPT))
+ maxlon = max(lon(startPT:endPT))
+ else
+ minlat = min((/minlat,min(lat(startPT:endPT))/))
+ maxlat = max((/maxlat,max(lat(startPT:endPT))/))
+ minlon = min((/minlon,min(lon(startPT:endPT))/))
+ maxlon = max((/maxlon,max(lon(startPT:endPT))/))
+ end if
+ end do
+ ;---Attach the text string
+ if(.not.any((/ismissing(minlat),ismissing(maxlat),
+ ismissing(minlon),ismissing(maxlon)/))) then
+ avglat = (minlat+maxlat)/2.
+ avglon = (minlon+maxlon)/2.
+ text(ntxt) = gsn_add_text(wks,plot,f->$vname$(i),avglon,avglat,txres)
+ ntxt = ntxt + 1
+ end if
+ end do
+ end if
+ return(text)
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : gsn_polymarker_ndc ;
+ ; wks: workstation object ;
+ ; x: n-dimensional array of x points ;
+ ; y: n-dimensional array of y points ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws polymarkers on the workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks") in NDC ;
+ ; space. "x" and "y" are the x and y locations of each marker in NDC ;
+ ; coordinates. "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_polymarker_ndc")
+ procedure gsn_polymarker_ndc(wks:graphic,x:numeric,y:numeric,
+ resources:logical)
+ local res2, dummy, rank
+ begin
+ dummy = new(1,graphic)
+ res2 = get_resources(resources)
+
+ rank = dimsizes(dimsizes(x))
+ if(rank.eq.1) then
+ gsn_primitive(wks,dummy,x,y,True,"polymarker",res2)
+ else
+ gsn_primitive(wks,dummy,ndtooned(x),ndtooned(y),True,"polymarker",res2)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_create_labelbar_ndc ;
+ ; wks: workstation object ;
+ ; nbox: number of labelbar boxes ;
+ ; labels: labels for boxes ;
+ ; x: X NDC position of labelbar ;
+ ; y: Y NDC position of labelbar ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function is identical to gsn_create_labelbar, except the location;
+ ; of the labelbar is passed in (NDC coordinate values). ;
+ ;***********************************************************************;
+ undef("gsn_create_labelbar_ndc")
+ function gsn_create_labelbar_ndc(wks:graphic, nbox:integer, labels:string,
+ x,y,resources:logical )
+ local res2, lbres, wksname
+ begin
+ res2 = get_resources(resources)
+
+ lbres = get_res_eq(res2,(/"lb","vp"/))
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+ ;
+ ; A special test is needed for the resource lbLabelFontHeightF.
+ ; If it is set, then we need to turn off lbAutoManage. The
+ ; user can override this, of course.
+ ;
+ if(lbres.and..not.any(ismissing(getvaratts(lbres))).and.
+ isatt(lbres,"lbLabelFontHeightF"))
+ auto_manage = get_res_value(lbres,"lbAutoManage",False)
+ else
+ auto_manage = get_res_value(lbres,"lbAutoManage",True)
+ end if
+
+ ;
+ ; If x,y < 0, this is invalid, and hence don't use these values.
+ ; This was a special way to allow gsn_create_labelbar to call this
+ ; routine without needing valid x, y values.
+ ;
+ if(x.lt.0.or.y.lt.0) then
+ lbid = create wksname + "_labelbar" labelBarClass wks
+ "lbBoxCount" : nbox
+ "lbLabelStrings" : labels
+ "lbAutoManage" : auto_manage
+ end create
+ else
+ lbid = create wksname + "_labelbar" labelBarClass wks
+ "vpXF" : x
+ "vpYF" : y
+ "lbBoxCount" : nbox
+ "lbLabelStrings" : labels
+ "lbAutoManage" : auto_manage
+ end create
+ end if
+
+ if(lbres.and..not.any(ismissing(getvaratts(lbres))))
+ attsetvalues_check(lbid,lbres)
+ end if
+
+ ; Return labelbar.
+
+ return(lbid)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_create_labelbar ;
+ ; wks: workstation object ;
+ ; nbox: number of labelbar boxes ;
+ ; labels: labels for boxes ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and returns a labelbar on the workstation "wks" ;
+ ; (the variable returned from a previous call to "gsn_open_wks"). ;
+ ; "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_create_labelbar")
+ function gsn_create_labelbar(wks:graphic, nbox:integer, labels:string,
+ resources:logical )
+ begin
+ x = -1. ; Special values to tip off the routine
+ y = -1. ; that we don't have X,Y values.
+
+ labelbar = gsn_create_labelbar_ndc(wks, nbox, labels, x, y, resources)
+ return(labelbar)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_labelbar_ndc ;
+ ; wks: workstation object ;
+ ; nbox: number of labelbar boxes ;
+ ; labels: labels for boxes ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function is identical to gsn_create_labelbar_ndc except it draws ;
+ ; the labelbar that's created. ;
+ ;***********************************************************************;
+ undef("gsn_labelbar_ndc")
+ procedure gsn_labelbar_ndc(wks:graphic, nbox:integer, labels:string,
+ x,y,resources:logical )
+ local labelbar
+ begin
+ labelbar = gsn_create_labelbar_ndc(wks, nbox, labels, x, y, resources)
+ draw(labelbar)
+ delete(labelbar)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_create_legend_ndc ;
+ ; wks: workstation object ;
+ ; nitems: number of legend items ;
+ ; labels: labels for items ;
+ ; x: X NDC position of legend ;
+ ; y: Y NDC position of legend ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function draws a legend on the workstation "wks" (the variable ;
+ ; returned from a previous call to "gsn_open_wks"). "resources" is an ;
+ ; optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_create_legend_ndc")
+ function gsn_create_legend_ndc(wks:graphic, nitems:integer, labels:string,
+ x,y,resources:logical )
+ local i, res2, lgres, wksname, lgres, item_order
+ begin
+ res2 = get_resources(resources)
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ item_order = get_res_value(res2,"lgItemOrder",ispan(0,nitems-1,1))
+ ;
+ ; If x,y < 0, this is invalid, and hence don't use these values.
+ ; This was a special way to allow gsn_create_legend to call this
+ ; routine without needing valid x, y values.
+ ;
+ if(x.lt.0.or.y.lt.0) then
+ legend = create wksname + "_legend" legendClass wks
+ "lgItemCount" : nitems
+ "lgLabelStrings" : labels
+ "lgItemOrder" : item_order
+ end create
+ else
+ legend = create wksname + "_legend" legendClass wks
+ "vpXF" : x
+ "vpYF" : y
+ "lgItemCount" : nitems
+ "lgLabelStrings" : labels
+ "lgItemOrder" : item_order
+ end create
+ end if
+ lgres = get_res_eq(res2,(/"lg","vp"/))
+ if(lgres.and..not.any(ismissing(getvaratts(lgres))))
+
+ ; A special test is needed for the resource lgLabelFontHeightF.
+ ; If it is set, then we need to turn off lgAutoManage.
+
+ if(isatt(lgres,"lgLabelFontHeightF"))
+ setvalues legend
+ "lgAutoManage" : False
+ "lgLabelFontHeightF" : lgres at lgLabelFontHeightF
+ end setvalues
+ delete(lgres at lgLabelFontHeightF)
+ end if
+ attsetvalues_check(legend,lgres)
+ end if
+ ; Return legend.
+
+ return(legend)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_create_legend ;
+ ; wks: workstation object ;
+ ; nitems: number of legend items ;
+ ; labels: labels for items ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates a legend. ;
+ ;***********************************************************************;
+ undef("gsn_create_legend")
+ function gsn_create_legend(wks:graphic, nitems:integer, labels:string,
+ resources:logical )
+ begin
+ x = -1. ; Special values to tip off the routine
+ y = -1. ; that we don't have X,Y values.
+
+ legend = gsn_create_legend_ndc(wks, nitems, labels, x, y, resources)
+ return(legend)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_legend_ndc ;
+ ; wks: workstation object ;
+ ; nitems: number of legend items ;
+ ; labels: labels for items ;
+ ; x: X NDC position of legend ;
+ ; y: Y NDC position of legend ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws a legend on the workstation "wks" (the variable ;
+ ; returned from a previous call to "gsn_open_wks"). "resources" is an ;
+ ; optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_legend_ndc")
+ procedure gsn_legend_ndc(wks:graphic, nitems:integer, labels:string,
+ x,y,resources:logical )
+ local legend
+ begin
+ legend = gsn_create_legend_ndc(wks,nitems,labels,x,y,resources)
+ draw(legend)
+ delete(legend)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_create_text_ndc ;
+ ; wks: workstation object ;
+ ; text: array of text strings ;
+ ; x: n-dimensional array of x ndc positions ;
+ ; y: n-dimensional array of y ndc positions ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function draws text strings on the workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks"). "x" and ;
+ ; "y" are the x and y locations of each text string, and should be ;
+ ; specified in NDC space. "resources" is an optional list of resources. ;
+ ; This function returns the text string created. ;
+ ;***********************************************************************;
+ undef("gsn_create_text_ndc")
+ function gsn_create_text_ndc(wks:graphic, texto:string, xo:numeric,
+ yo:numeric, resources:logical )
+ local i, txid, plot_object, res, tx_res_index, x2, y2, x, y, res2,
+ calldraw, callframe
+ begin
+ ;
+ ; Any one of xo, yo, and texto can just be one element, but if two or more
+ ; are more than one element, then they must be exactly the same size.
+ ;
+ xsizes = dimsizes(xo)
+ ysizes = dimsizes(yo)
+ tsizes = dimsizes(texto)
+ xrank = dimsizes(xsizes)
+ yrank = dimsizes(ysizes)
+ trank = dimsizes(tsizes)
+ if(xrank.gt.1.and.yrank.gt.1.and..not.all(xsizes.eq.ysizes)) then
+ print("Error: gsn_text_ndc: x and y must have the same dimension sizes, or either be a single value.")
+ dummy = new(1,graphic)
+ return(dummy)
+ end if
+ if(trank.gt.1.and.
+ (xrank.gt.1.and..not.all(xsizes.eq.tsizes)) .or.
+ (yrank.gt.1.and..not.all(ysizes.eq.tsizes))) then
+ print("Error: gsn_text_ndc: text must be a single string or the same dimension size as x and/or y.")
+ dummy = new(1,graphic)
+ return(dummy)
+ end if
+ ;
+ ; Convert to 1-dimensional arrays of all the same length.
+ ;
+ if(xrank.gt.1) then
+ x = ndtooned(new(xsizes, typeof(xo)))
+ y = ndtooned(new(xsizes, typeof(yo)))
+ text = ndtooned(new(xsizes, typeof(texto)))
+ else
+ if(yrank.gt.1) then
+ x = ndtooned(new(ysizes, typeof(xo)))
+ y = ndtooned(new(ysizes, typeof(yo)))
+ text = ndtooned(new(ysizes, typeof(texto)))
+ else
+ x = new(xsizes > ysizes, typeof(xo))
+ y = new(xsizes > ysizes, typeof(yo))
+ text = new(xsizes > ysizes, typeof(texto))
+ end if
+ end if
+
+ x = ndtooned(xo)
+ y = ndtooned(yo)
+ text = ndtooned(texto)
+ len = dimsizes(x)
+
+ res2 = get_resources(resources)
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ calldraw = get_res_value(res2,"gsnDraw", False)
+ callframe = get_res_value(res2,"gsnFrame",False)
+ maxbb = get_bb_res(res2)
+
+ txres = get_res_eq(res2,"tx") ; Get text resources.
+ txid = new(len,graphic)
+
+ if((res2).and.isatt(res2,"txFuncCode")) then
+ ;
+ ; Special case where we don't have x,y values.
+ ;
+ if(all(x.lt.0).and.all(y.lt.0)) then
+ do i=0,len-1
+ txid(i) = create wksname + "_text_ndc"+i textItemClass wks
+ "txString" : text(i)
+ "txFuncCode" : res2 at txFuncCode
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ draw_and_frame(wks,txid(i),calldraw,callframe,0,maxbb)
+ end do
+ else
+ do i=0,len-1
+ txid(i) = create wksname + "_text_ndc"+i textItemClass wks
+ "txString" : text(i)
+ "txPosXF" : x(i)
+ "txPosYF" : y(i)
+ "txFuncCode" : res2 at txFuncCode
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ draw_and_frame(wks,txid(i),calldraw,callframe,0,maxbb)
+ end do
+ end if
+ else
+ ;
+ ; Special case where we don't have x,y values.
+ ;
+ if(all(x.lt.0).and.all(y.lt.0)) then
+ do i=0,len-1
+ txid(i) = create wksname + "_text_ndc"+i textItemClass wks
+ "txString" : text(i)
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ draw_and_frame(wks,txid(i),calldraw,callframe,0,maxbb)
+ end do
+ else
+ do i=0,len-1
+ txid(i) = create wksname + "_text_ndc"+i textItemClass wks
+ "txString" : text(i)
+ "txPosXF" : x(i)
+ "txPosYF" : y(i)
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ draw_and_frame(wks,txid(i),calldraw,callframe,0,maxbb)
+ end do
+ end if
+ end if
+
+ if(xrank.gt.1) then
+ return(onedtond(txid,xsizes))
+ end if
+ if(yrank.gt.1) then
+ return(onedtond(txid,ysizes))
+ end if
+ return(txid)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_create_text ;
+ ; wks: workstation object ;
+ ; text: text strings ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates text strings. ;
+ ;***********************************************************************;
+ undef("gsn_create_text")
+ function gsn_create_text(wks:graphic, text:string, resources:logical )
+ local x, y
+ begin
+ x = -1. ; Special values to tip off the routine
+ y = -1. ; that we don't have X,Y values.
+
+ txid = gsn_create_text_ndc(wks, text, x, y, resources)
+ return(txid)
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : gsn_text_ndc ;
+ ; ;
+ ; This procedure is the same as gsn_text, only it doesn't return ;
+ ; anything. ;
+ ;***********************************************************************;
+ undef("gsn_text_ndc")
+ procedure gsn_text_ndc(wks:graphic, text:string, x:numeric,
+ y:numeric, resources:logical )
+ local txid, res2
+ begin
+ if(resources) then
+ res2 = get_resources(resources)
+ else
+ res2 = True
+ end if
+ res2 at gsnDraw = True ; False by default
+ txid = gsn_create_text_ndc(wks,text,x,y,res2)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_text ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; text: array of text strings ;
+ ; x: n-dimensional array of x data positions ;
+ ; y: n-dimensional array of y data positions ;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure draws text strings on the workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks"). "x" and ;
+ ; "y" are the x and y locations of each text string, and should be ;
+ ; specified in the same data space as the data space of "plotid". ;
+ ; "resources" is an optional list of resources. ;
+ ;***********************************************************************;
+ undef("gsn_text")
+ procedure gsn_text(wks:graphic,plotid:graphic,texto:string,xo:numeric,
+ yo:numeric, resources:logical )
+ local i, txid, x2, y2, xf, yf, x, y, res2, calldraw, callframe, maxbb,
+ wksname, xsizes, ysizes, tsizes, xrank, yrank, trank, text, len, txres
+ begin
+ ;
+ ; Any one of xo, yo, and texto can just be one element, but if two or more
+ ; are more than one element, then they must be exactly the same size.
+ ;
+ xsizes = dimsizes(xo)
+ ysizes = dimsizes(yo)
+ tsizes = dimsizes(texto)
+ xrank = dimsizes(xsizes)
+ yrank = dimsizes(ysizes)
+ trank = dimsizes(tsizes)
+ if(xrank.gt.1.and.yrank.gt.1.and..not.all(xsizes.eq.ysizes)) then
+ print("Error: gsn_text: x and y must have the same dimension sizes, or either be a single value.")
+ return
+ end if
+ if(trank.gt.1.and.
+ (xrank.gt.1.and..not.all(xsizes.eq.tsizes)) .or.
+ (yrank.gt.1.and..not.all(ysizes.eq.tsizes))) then
+ print("Error: gsn_text: text must be a single string or the same dimension size as x and/or y.")
+ return
+ end if
+ ;
+ ; Convert to 1-dimensional arrays of all the same length.
+ ;
+ if(xrank.gt.1) then
+ x = ndtooned(new(xsizes, typeof(xo)))
+ y = ndtooned(new(xsizes, typeof(yo)))
+ text = ndtooned(new(xsizes, typeof(texto)))
+ else
+ if(yrank.gt.1) then
+ x = ndtooned(new(ysizes, typeof(xo)))
+ y = ndtooned(new(ysizes, typeof(yo)))
+ text = ndtooned(new(ysizes, typeof(texto)))
+ else
+ x = new(xsizes > ysizes, typeof(xo))
+ y = new(xsizes > ysizes, typeof(yo))
+ text = new(xsizes > ysizes, typeof(texto))
+ end if
+ end if
+
+ x = ndtooned(xo)
+ y = ndtooned(yo)
+ text = ndtooned(texto)
+ len = dimsizes(x)
+
+ res2 = get_resources(resources)
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",False)
+ maxbb = get_bb_res(res2)
+ ;
+ ; datatondc can't accept doubles, so have to demote doubles if they
+ ; come in.
+ ;
+ xf = tofloat(x)
+ yf = tofloat(y)
+
+ x2 = new(dimsizes(x),float)
+ y2 = new(dimsizes(y),float)
+
+ datatondc(plotid,xf,yf,x2,y2)
+
+ delete(xf)
+ delete(yf)
+ ;
+ ; The "txFuncCode" can't be set during a setvalues call. It must be
+ ; set during the creation of the object.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ txid = new(len,graphic)
+ txres = get_res_eq(res2,"tx") ; Get text resources.
+
+ if(res2.and.isatt(res2,"txFuncCode")) then
+ do i=0,len-1
+ txid = create wksname + "_text"+i textItemClass wks
+ "txString" : text(i)
+ "txPosXF" : x2(i)
+ "txPosYF" : y2(i)
+ "txFuncCode" : res2 at txFuncCode
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ draw_and_frame(wks,txid(i),calldraw,callframe,0,maxbb)
+ end do
+ else
+ do i=0,len-1
+ txid(i) = create wksname + "_text"+i textItemClass wks
+ "txString" : text(i)
+ "txPosXF" : x2(i)
+ "txPosYF" : y2(i)
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ draw_and_frame(wks,txid(i),calldraw,callframe,0,maxbb)
+ end do
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_add_text ;
+ ; wks: workstation object ;
+ ; plotid: plot object ;
+ ; text: array of text strings ;
+ ; x: n-dimensional array of x data positions ;
+ ; y: n-dimensional array of y data positions ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function adds text strings to the plot "plotid". "x" and "y" are ;
+ ; the x and y locations of each text string, and should be specified in ;
+ ; the same data space as the data space of "plotid". "resources" is an ;
+ ; optional list of TextItem and AnnoManager resources. ;
+ ; ;
+ ; This function is different from gsn_text because it actually attaches ;
+ ; the text to the plot. This means that if you resize or move the plot, ;
+ ; the text will stay with the plot. ;
+ ;***********************************************************************;
+ undef("gsn_add_text")
+ function gsn_add_text(wks:graphic,plotid:graphic,texto:string,
+ xo:numeric,yo:numeric, resources:logical )
+ local txid, txres, amres, just, res2, wksname, am_ids
+ begin
+ ;
+ ; Any one of xo, yo, and texto can just be one element, but if two or more
+ ; are more than one element, then they must be exactly the same size.
+ ;
+ xsizes = dimsizes(xo)
+ ysizes = dimsizes(yo)
+ tsizes = dimsizes(texto)
+ xrank = dimsizes(xsizes)
+ yrank = dimsizes(ysizes)
+ trank = dimsizes(tsizes)
+ if(xrank.gt.1.and.yrank.gt.1.and..not.all(xsizes.eq.ysizes)) then
+ print("Error: gsn_add_text: x and y must have the same dimension sizes, or either be a single value.")
+ dummy = new(1,graphic)
+ return(dummy)
+ end if
+ if(trank.gt.1.and.
+ (xrank.gt.1.and..not.all(xsizes.eq.tsizes)) .or.
+ (yrank.gt.1.and..not.all(ysizes.eq.tsizes))) then
+ print("Error: gsn_add_text: text must be a single string or the same dimension size as x and/or y.")
+ dummy = new(1,graphic)
+ return(dummy)
+ end if
+ ;
+ ; Convert to 1-dimensional arrays of all the same length.
+ ;
+ if(xrank.gt.1) then
+ x = ndtooned(new(xsizes, typeof(xo)))
+ y = ndtooned(new(xsizes, typeof(yo)))
+ text = ndtooned(new(xsizes, typeof(texto)))
+ else
+ if(yrank.gt.1) then
+ x = ndtooned(new(ysizes, typeof(xo)))
+ y = ndtooned(new(ysizes, typeof(yo)))
+ text = ndtooned(new(ysizes, typeof(texto)))
+ else
+ x = new(xsizes > ysizes, typeof(xo))
+ y = new(xsizes > ysizes, typeof(yo))
+ text = new(xsizes > ysizes, typeof(texto))
+ end if
+ end if
+
+ x = ndtooned(xo)
+ y = ndtooned(yo)
+ text = ndtooned(texto)
+ len = dimsizes(x)
+
+ res2 = get_resources(resources)
+ ;
+ ; The "txFuncCode" can't be set during a setvalues call. It must be
+ ; set during the creation of the object.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ txres = get_res_eq(res2,"tx") ; Get text resources.
+ txid = new(len,graphic)
+
+ if(res2.and.isatt(res2,"txFuncCode")) then
+ do i=0,len-1
+ txid(i) = create wksname + "_text"+i textItemClass wks
+ "txString" : text(i)
+ "txFuncCode" : res2 at txFuncCode
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ end do
+ else
+ do i=0,len-1
+ txid(i) = create wksname + "_text"+i textItemClass wks
+ "txString" : text(i)
+ end create
+ attsetvalues_check(txid(i),txres) ; Set text resources.
+ end do
+ end if
+ ;
+ ; Get current list of annotations that are already attached to
+ ; the plot.
+ ;
+ getvalues plotid
+ "pmAnnoViews" : text_ids
+ end getvalues
+ ;
+ ; Make sure the next text strings are first in the list.
+ ;
+ if(.not.any(ismissing(text_ids)))
+ new_text_ids = new(dimsizes(text_ids)+len,graphic)
+ new_text_ids(0:len-1) = txid
+ new_text_ids(len:) = text_ids
+ else
+ new_text_ids = txid
+ end if
+ ;
+ ; Set the old and new annotations, with the new ones being first.
+ ;
+ setvalues plotid
+ "pmAnnoViews" : new_text_ids
+ end setvalues
+ ;
+ ; Retrieve the id of the AnnoManager object created by the PlotManager and
+ ; then set its location in data coordinate space.
+ ;
+ getvalues plotid
+ "pmAnnoManagers": am_ids
+ end getvalues
+
+ tmp_just = get_res_value(txres,"txJust","CenterCenter")
+ just = get_res_value(res2,"amJust",tmp_just)
+
+ do i=0,len-1
+ setvalues am_ids(i)
+ "amDataXF" : x(i)
+ "amDataYF" : y(i)
+ "amResizeNotify" : True
+ "amTrackData" : True
+ "amJust" : just
+ end setvalues
+ end do
+
+ amres = get_res_eq(res2,"am") ; Get annomanager resources.
+ attsetvalues_check(am_ids(0),amres) ; Set annomanager resources.
+
+ if(xrank.gt.1) then
+ return(onedtond(am_ids(0:len-1),xsizes))
+ else
+ return(onedtond(am_ids(0:len-1),ysizes))
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Procedure : draw_bb ;
+ ; plot:graphic ;
+ ; opts:logical ;
+ ; ;
+ ; This procedure draws a box around the bounding box of the given plot ;
+ ; objects. ;
+ ;***********************************************************************;
+ undef("draw_bb")
+ procedure draw_bb(plot:graphic,opts:logical)
+ local wks, bb, top, bot, lft, rgt, gsres, drawit, frameit
+ begin
+ drawit = isatt(opts,"gsnDraw").and.opts at gsnDraw
+ frameit = isatt(opts,"gsnFrame").and.opts at gsnFrame
+
+ wks = NhlGetParentWorkstation(plot(0))
+ dimplot = dimsizes(plot)
+
+ if(dimplot.eq.1) then
+ ;
+ ; Force bb to be 2-dimensional so we don't have to have a
+ ; bunch of "if" tests later.
+ ;
+ bb = new((/1,4/),float)
+ bb(0,:) = NhlGetBB(plot)
+ else
+ bb = NhlGetBB(plot)
+ end if
+
+ gsres = True
+ ; gsres at gsLineThicknessF = 5.0
+ gsres at gsLineColor = "red"
+ do i=0,dimplot-1
+ top = bb(i,0)
+ bot = bb(i,1)
+ lft = bb(i,2)
+ rgt = bb(i,3)
+
+ if(drawit) then
+ draw(plot(i))
+ end if
+ gsn_polyline_ndc(wks,(/lft,rgt,rgt,lft,lft/),
+ (/bot,bot,top,top,bot/),gsres)
+ if(frameit)
+ frame(wks)
+ end if
+ end do
+ end
+
+ ;***********************************************************************;
+ ; This procedure draws or attaches markers or lines on the given plot
+ ; at coordinates associated with the input data array. For the markers,
+ ; you can have the markers colored according to where the data values
+ ; are missing. The arguments are:
+ ;
+ ; wks[1]:graphic
+ ; plot[1]:graphic
+ ; data:numeric
+ ; res[1]:logical
+ ;
+ ; This procedure examines "data" to see if it has 1D coordinate
+ ; arrays, or the special "lat2d"/"lon2d" attributes. If it has
+ ; neither, then the special "gsnCoordsX" and "gsnCoordsY" attributes
+ ; must be attached to "res", indicating the coordinates.
+ ; If you are drawing lines, then these two attributes must be 2D
+ ; and the same size as each other. If you are drawing markers,
+ ; then these arrays don't have to be 2D, but they must be the
+ ; same size. They will get converted to 1D arrays.
+ ;
+ ; By default, this procedure draws the plot, and the markers or
+ ; lines are drawn on the plot with gsn_polymarker[line], and
+ ; the frame is advanced. Nothing is attached to the plot. This
+ ; method is faster.
+ ;
+ ; If gsnCoordsAttach is set to True, then the markers or lines
+ ; are attached using gsn_add_polymarker[line], and the plot is
+ ; not drawn and the frame is not advanced, unless gsnDraw[Frame]
+ ; are set to True.
+ ;
+ ; If res at gsnCoordsX and res at gsnCoordsY are set, these will be used for the X
+ ; and Y coordinate points. Otherwise, this function will try to get
+ ; the 1D coordinate information from the input data variable, or look
+ ; for the special "lat2d", "lon2d" attributes.
+ ;
+ ; Note that this function requires the X and Y coordinates to be set the
+ ; same way. You can't set one via, say, an attribute, and the other via
+ ; a coordinate array.
+ ;
+ ; Special coordinates recognized by this routine:
+ ;
+ ; "gsnCoordsX" and "gsnCoordsY" - The X and Y coordinates to plot.
+ ; You only need to set these if the input data array
+ ; doesn't have 1D coordinate arrays attached, or doesn't
+ ; have the special "lat2d", "lon2d" attributes.
+ ;
+ ; "gsnCoordsAttach" - if True, then the markers will be
+ ; attached via gsn_add_polymarker, instead of just
+ ; drawn with gsn_polymarker. Note that gsnDraw and Frame will
+ ; both be set to False in this case.
+ ;
+ ; "gsnCoordsAsLines" - [not implemented yet] if True,
+ ; coordinates will be drawn as lines rather than markers.
+ ; This only works for 2D coordinate arrays.
+ ;
+ ; "gsnCoordsMissingColor"
+ ; "gsnCoordsNonMissingColor" - If either one of these are set,
+ ; then at locations where the data is or isn't missing, they
+ ; will be drawn in the given color
+ ;
+ ;***********************************************************************;
+ undef("gsn_coordinates")
+ procedure gsn_coordinates(wks[1]:graphic,plot[1]:graphic,
+ data:numeric,res[1]:logical)
+ local type_xcoord, type_ycoord, pres, res2, pres, dims, rank,
+ dims_xcoord, dims_ycoord, xcoord_1d, ycoord_1d, xcoord_2d, ycoord_2d,
+ xdim, ydim, calldraw, callframe, maxbb, defclr, nonmsgclr, msgclr,
+ draw_lines, draw_non_msg, attach_coords, is_msgclr_trans,
+ is_nonmsgclr_trans, is_defclr_trans, tmpstr, i, imsg
+ begin
+ res2 = res ; Make copy so we can modify it
+ imsg = new(1,integer)
+
+ ;---Check for special resources
+ maxbb = get_bb_res(res2)
+ defclr = get_res_value(res2,"gsMarkerColor",1)
+ defmrk = get_res_value(res2,"gsMarkerIndex",16)
+ msgclr = get_res_value(res2,"gsnCoordsMissingColor",imsg)
+ nonmsgclr = get_res_value(res2,"gsnCoordsNonMissingColor",imsg)
+ attach_coords = get_res_value(res2,"gsnCoordsAttach",False)
+ draw_lines = get_res_value(res2,"gsnCoordsAsLines",False)
+
+ ;---Check if color is transparent.
+ is_defclr_trans = ((typeof(defclr).eq."string".and.
+ str_lower(defclr).eq."transparent").or.
+ (typeof(defclr).eq."integer".and.defclr.eq.-1))
+ is_msgclr_trans = ((typeof(msgclr).eq."string".and.
+ str_lower(msgclr).eq."transparent").or.
+ (typeof(msgclr).eq."integer".and.msgclr.eq.-1))
+ is_nonmsgclr_trans = ((typeof(nonmsgclr).eq."string".and.
+ str_lower(nonmsgclr).eq."transparent").or.
+ (typeof(nonmsgclr).eq."integer".and.nonmsgclr.eq.-1))
+
+ if(attach_coords) then
+ calldraw = get_res_value(res2,"gsnDraw", False)
+ callframe = get_res_value(res2,"gsnFrame",False)
+ else
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ end if
+ ;
+ ; Figure out what kind of X and Y coordinates we have.
+ ; Valid kinds include:
+ ; gsnCoordsX or gsnCoordsY attributes attached to res ("res_coord").
+ ; 1D coord array attached to data ("data_coord").
+ ; 2D lat2d/lon2d attributes attached to data ("data_att")
+ ;
+ type_xcoord = ""
+ type_ycoord = ""
+ dims = dimsizes(data)
+ rank = dimsizes(dims)
+
+ ;----------------------------------------------------------------------
+ ; This section gets the X,Y coordinate arrays and converts them
+ ; to 1D for markers, and 2D for lines.
+ ;----------------------------------------------------------------------
+
+ if(res2.and.isatt(res2,"gsnCoordsLat").and.isatt(res2,"gsnCoordsLon")) then
+ type_xcoord = "res_coord"
+ type_ycoord = "res_coord"
+ if(draw_lines) then
+ xcoord_2d = res2 at gsnCoordsLon
+ ycoord_2d = res2 at gsnCoordsLat
+ else
+ xcoord_1d = ndtooned(res2 at gsnCoordsLon)
+ ycoord_1d = ndtooned(res2 at gsnCoordsLat)
+ end if
+ delete(res2 at gsnCoordsLat)
+ delete(res2 at gsnCoordsLon)
+ end if
+
+ if(res2.and.type_xcoord.eq."".and.type_ycoord.eq."".and.
+ isatt(res2,"gsnCoordsX").and.isatt(res2,"gsnCoordsY")) then
+ type_xcoord = "res_coord"
+ type_ycoord = "res_coord"
+ if(draw_lines) then
+ xcoord_2d = res2 at gsnCoordsX
+ ycoord_2d = res2 at gsnCoordsY
+ else
+ xcoord_1d = ndtooned(res2 at gsnCoordsX)
+ ycoord_1d = ndtooned(res2 at gsnCoordsY)
+ end if
+ delete(res2 at gsnCoordsX)
+ delete(res2 at gsnCoordsY)
+ end if
+
+ ;---Check if "data" contains 1D coordinate arrays.
+ xdim = rank-1
+ ydim = rank-2
+ if((type_xcoord.eq."".and.(isdimnamed(data,xdim).and.
+ iscoord(data,data!xdim))).and.
+ (type_ycoord.eq."".and.(isdimnamed(data,ydim).and.
+ iscoord(data,data!ydim)))) then
+ type_xcoord = "data_coord"
+ type_ycoord = "data_coord"
+ dd = (/dims(ydim),dims(xdim)/)
+ if(draw_lines) then
+ xcoord_2d = conform_dims(dd,data&$data!xdim$,1)
+ ycoord_2d = conform_dims(dd,data&$data!ydim$,0)
+ else
+ xcoord_1d = ndtooned(conform_dims(dd,data&$data!xdim$,1))
+ ycoord_1d = ndtooned(conform_dims(dd,data&$data!ydim$,0))
+ end if
+ end if
+
+ ;---Check if "data" contains "lat2d", "lon2d" attributes
+ if(type_xcoord.eq."".and.isatt(data,"lon2d")) then
+ type_xcoord = "data_att"
+ if(draw_lines) then
+ xcoord_2d = data at lon2d
+ else
+ xcoord_1d = ndtooned(data at lon2d)
+ end if
+ end if
+ if(type_ycoord.eq."".and.isatt(data,"lat2d")) then
+ type_ycoord = "data_att"
+ if(draw_lines) then
+ ycoord_2d = data at lat2d
+ else
+ ycoord_1d = ndtooned(data at lat2d)
+ end if
+ end if
+
+ ;---Check if "data" contains "lat1d", "lon1d" attributes
+ if(type_xcoord.eq."".and.isatt(data,"lon1d")) then
+ if(draw_lines) then
+ print("gsn_coordinates: cannot draw an unstructured grid using lines")
+ return
+ end if
+ type_xcoord = "data_att"
+ xcoord_1d = data at lon1d
+ end if
+ if(type_ycoord.eq."".and.isatt(data,"lat1d")) then
+ if(draw_lines) then
+ print("gsn_coordinates: cannot draw an unstructured grid using lines")
+ return
+ end if
+ type_ycoord = "data_att"
+ ycoord_1d = data at lat1d
+ end if
+
+ ;---Error checking
+ if(type_xcoord.eq."".or.type_ycoord.eq."") then
+ print("gsn_coordinates: no valid X and/or Y coordinate values provided.")
+ return
+ end if
+ if(type_xcoord.ne.type_ycoord) then
+ print("gsn_coordinates: conflicting X/Y coordinate values provided.")
+ return
+ end if
+
+ if(draw_lines) then
+ dims_xcoord = dimsizes(xcoord_2d)
+ dims_ycoord = dimsizes(ycoord_2d)
+ rank_xcoord = dimsizes(dims_xcoord)
+ rank_ycoord = dimsizes(dims_ycoord)
+ if(rank_xcoord.ne.2.or.rank_xcoord.ne.rank_ycoord) then
+ print("gsn_coordinates: can't draw coordinates as lines if they")
+ print(" are not 2D arrays of the same size.")
+ return
+ end if
+ ny = dims_xcoord(0)
+ nx = dims_xcoord(1)
+ if(dims_ycoord(0).ne.ny.and.dims_ycoord(1).ne.nx) then
+ print("gsn_coordinates: coordinates must have the same")
+ print(" dimensionality")
+ return
+ end if
+ else
+ dims_xcoord = dimsizes(xcoord_1d)
+ dims_ycoord = dimsizes(ycoord_1d)
+ if(dims_xcoord.ne.dims_ycoord) then
+ print("gsn_coordinates: coordinates must have the same")
+ print(" dimensionality")
+ return
+ end if
+ end if
+
+ ;---Copy over resources if True
+ if(res2) then
+ pres = res2
+ else
+ pres = True
+ end if
+
+ if(.not.attach_coords.and.calldraw) then
+ draw_and_frame(wks,plot,calldraw,False,False,maxbb)
+ end if
+
+ ;----------------------------------------------------------------------
+ ; There are three ways the markers can get drawn:
+ ; - the markers in missing data locations
+ ; - the markers in non-missing data locations
+ ; - the markers at all locations.
+ ;
+ ; If a color is specified as -1 or "transparent", then don't
+ ; waste time drawing the markers.
+ ;
+ ; If drawing lines, then you get all of them.
+ ;----------------------------------------------------------------------
+ if(draw_lines) then
+ if(attach_coords) then
+ do i=0,ny-1
+ tmpstr = unique_string("xlines")
+ plot@$tmpstr$ = gsn_add_polyline(wks,plot,xcoord_2d(i,:),
+ ycoord_2d(i,:),pres)
+ end do
+ do i=0,nx-1
+ tmpstr = unique_string("ylines")
+ plot@$tmpstr$ = gsn_add_polyline(wks,plot,xcoord_2d(:,i),
+ ycoord_2d(:,i),pres)
+ end do
+ else
+ do i=0,ny-1
+ gsn_polyline(wks,plot,xcoord_2d(i,:),
+ ycoord_2d(i,:),pres)
+ end do
+ do i=0,nx-1
+ gsn_polyline(wks,plot,xcoord_2d(:,i),
+ ycoord_2d(:,i),pres)
+ end do
+ end if
+ else
+ if(.not.ismissing(msgclr).and..not.is_msgclr_trans) then
+ pres at gsMarkerColor = msgclr
+ pres at gsMarkerIndex = defmrk
+ ii = ind(ismissing(ndtooned(data)))
+ if(.not.all(ismissing(ii))) then
+ if(attach_coords) then
+ tmpstr = unique_string("markers_msg")
+ plot@$tmpstr$ = gsn_add_polymarker(wks,plot,xcoord_1d(ii),
+ ycoord_1d(ii),pres)
+ else
+ gsn_polymarker(wks,plot,xcoord_1d(ii),ycoord_1d(ii),pres)
+ end if
+ end if
+ delete(ii)
+ end if
+ draw_non_msg = False
+ ;
+ ; Somewhat complicated logic to determine whether we want to
+ ; draw the markers at non-missing locations.
+ ;
+ if(.not.ismissing(msgclr).or..not.ismissing(nonmsgclr)) then
+ if(.not.is_nonmsgclr_trans) then
+ if(isatt(pres,"gsMarkerColor")) then
+ delete(pres at gsMarkerColor)
+ end if
+ pres at gsMarkerColor = nonmsgclr
+ pres at gsMarkerIndex = defmrk
+ draw_non_msg = True
+ else
+ if(ismissing(nonmsgclr).and..not.is_defclr_trans) then
+ if(isatt(pres,"gsMarkerColor")) then
+ delete(pres at gsMarkerColor)
+ end if
+ pres at gsMarkerColor = defclr
+ pres at gsMarkerIndex = defmrk
+ draw_non_msg = True
+ end if
+ end if
+ if(draw_non_msg) then
+ ii = ind(.not.ismissing(ndtooned(data)))
+ if(.not.all(ismissing(ii))) then
+ if(attach_coords) then
+ tmpstr = unique_string("markers_nonmsg")
+ plot@$tmpstr$ = gsn_add_polymarker(wks,plot,xcoord_1d(ii),
+ ycoord_1d(ii),pres)
+ else
+ gsn_polymarker(wks,plot,xcoord_1d(ii),ycoord_1d(ii),pres)
+ end if
+ end if
+ delete(ii)
+ end if
+ end if
+
+ if(ismissing(msgclr).and.ismissing(nonmsgclr).and.
+ .not.is_defclr_trans) then
+ pres at gsMarkerColor = defclr
+ pres at gsMarkerIndex = defmrk
+ if(attach_coords) then
+ tmpstr = unique_string("markers_all")
+ plot@$tmpstr$ = gsn_add_polymarker(wks,plot,xcoord_1d,
+ ycoord_1d,pres)
+ else
+ gsn_polymarker(wks,plot,xcoord_1d,ycoord_1d,pres)
+ end if
+ end if
+
+ end if ; draw_lines
+ if(attach_coords) then
+ draw_and_frame(wks,plot,calldraw,callframe,False,maxbb)
+ else
+ if(callframe) then
+ frame(wks)
+ end if
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_panel ;
+ ; wks: workstation object ;
+ ; plot : array of plots to put on one page. ;
+ ; dims : a 2-D array indicating number of rows and columns;
+ ; resources: optional resources ;
+ ; ;
+ ; This procedure takes the array of plots and draws them all on one ;
+ ; workstation in the configuration specified by dims. ;
+ ; ;
+ ; For example, if you have six plots and dims is (/2,3/), then the six ;
+ ; plots will be drawn in 2 rows and 3 columns. ;
+ ; ;
+ ; However, if you set gsnPanelRowSpec to True, and dims to an array of ;
+ ; integers, then each integer will represent the number of plots in that;
+ ; row. For example, setting gsnPanelRowSpec = (/2,3,1/) will cause ;
+ ; there to be two plots in the first row, three in the second row, and ;
+ ; one in the third row. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnPanelCenter ;
+ ; gsnPanelLabelBar ;
+ ; gsnPanelRowSpec ;
+ ; gsnPanelXWhiteSpacePercent ;
+ ; gsnPanelYWhiteSpacePercent ;
+ ; gsnPanelBoxes ;
+ ; gsnPanelLeft ;
+ ; gsnPanelRight ;
+ ; gsnPanelBottom ;
+ ; gsnPanelTop ;
+ ; gsnPanelSave ;
+ ; gsnDraw ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_panel_return")
+ function gsn_panel_return(wks:graphic,plot[*]:graphic,dims[*]:integer,
+ resources:logical)
+ local res, nrows, ncols, ddims, is_row_spec, row_spec, npanels, nplots,
+ perim_on
+ begin
+ res = get_resources(resources) ; Make copy of resources
+ ;
+ ; First check if paneling is to be specified by (#rows x #columns) or
+ ; by #columns per row. The default is rows x columns, unless
+ ; resource gsnPanelRowSpec is set to True
+ ;
+ is_row_spec = get_res_value(res,"gsnPanelRowSpec",False)
+ ;
+ ; Check to see if we have enough plots to fit panels, and vice versa.
+ ;
+ ddims = dimsizes(dims)
+ if(is_row_spec)
+ row_spec = dims
+ npanels = 0
+ nrows = ddims
+ ncols = max(row_spec)
+ do i=0,nrows-1
+ if(row_spec(i).lt.0)
+ print("Error: gsn_panel: you have specified a negative value for the number of plots in a row.")
+ exit
+ end if
+ npanels = npanels + row_spec(i)
+ end do
+ else
+ if(ddims.ne.2)
+ print("Error: gsn_panel: for the third argument of gsn_panel, you must either specify # rows by # columns or set gsnPanelRowSpec to True and set the number of plots per row.")
+ exit
+ end if
+ nrows = dims(0)
+ ncols = dims(1)
+ npanels = nrows * ncols
+ row_spec = new(nrows,integer)
+ row_spec = ncols
+ end if
+
+ nplots = dimsizes(plot) ; Total number of plots.
+
+ if(nplots.gt.npanels)
+ print("Warning: gsn_panel: you have more plots than you have panels.")
+ print("Only " + npanels + " plots will be drawn.")
+ nplots = npanels
+ end if
+
+ ;
+ ; Check for special resources.
+ ;
+ panel_save = get_res_value_keep(res,"gsnPanelSave",True)
+ panel_debug = get_res_value_keep(res,"gsnPanelDebug",False)
+ panel_center = get_res_value_keep(res,"gsnPanelCenter",True)
+ panel_labelbar = get_res_value_keep(res,"gsnPanelLabelBar",False)
+ panel_plotid = get_res_value_keep(res,"gsnPanelScalePlotIndex",-1)
+ calldraw = get_res_value_keep(res,"gsnDraw",True)
+ callframe = get_res_value_keep(res,"gsnFrame",True)
+ xwsp_perc = get_res_value_keep(res,"gsnPanelXWhiteSpacePercent",1.)
+ ywsp_perc = get_res_value_keep(res,"gsnPanelYWhiteSpacePercent",1.)
+ draw_boxes = get_res_value_keep(res,"gsnPanelBoxes",False)
+ x_lft = get_res_value_keep(res,"gsnPanelLeft",0.)
+ x_rgt = get_res_value_keep(res,"gsnPanelRight",1.)
+ y_bot = get_res_value_keep(res,"gsnPanelBottom",0.)
+ y_top = get_res_value_keep(res,"gsnPanelTop",1.)
+ main_string = get_res_value_keep(res,"txString","")
+ maxbb = get_bb_res(res)
+
+ lft_pnl = isatt(res,"gsnPanelLeft")
+ rgt_pnl = isatt(res,"gsnPanelRight")
+ bot_pnl = isatt(res,"gsnPanelBottom")
+ top_pnl = isatt(res,"gsnPanelTop")
+ ;
+ ; Check if a main string has been specified. If so, we need to make sure
+ ; we leave some room for it by computing y_top (if the user hasn't set
+ ; it). Also, we have to check if the font height has been set, because
+ ; this could affect the title position.
+ ;
+ if(main_string.ne."") then
+ main_string_on = True
+ main_font_hgt = get_res_value_keep(res,"txFontHeightF",0.02)
+ ;
+ ; By default, we want a distance of 0.01 between top of title and the
+ ; frame, and a distance of 0.03 between the bottom of the title (txPosYF)
+ ; and the top of the panel box (gsnPanelTop).
+ ;
+ if(y_top.eq.1.) then
+ if(isatt(res,"txPosYF"))
+ y_top = min((/1.,res at txPosYF - 0.03/))
+ else
+ y_top = min((/1.,0.96-main_font_hgt/))
+ end if
+ end if
+ else
+ main_string_on = False
+ end if
+ ;
+ ; Calculate number of plot objects that will actually be drawn.
+ ; (Panel plots plus labelbar and main string, if any.)
+ ;
+ nnewplots = nplots
+ if(panel_labelbar) then
+ nnewplots = nnewplots + 1
+ end if
+ if(main_string_on) then
+ nnewplots = nnewplots + 1
+ end if
+
+ newplots = new(nnewplots,graphic) ; Create array to save these plots
+ ; objects.
+ ;
+ ; We only need to set maxbb to True if the plots are being drawn to
+ ; a PostScript or PDF workstation, because the bounding box is already
+ ; maximized for an NCGM/X11 window.
+ ;
+ if(maxbb) then
+ class = NhlClassName(wks)
+ if(.not.any(class(0).eq.(/"psWorkstationClass", "pdfWorkstationClass",
+ "documentWorkstationClass"/)))
+ maxbb = False
+ end if
+ delete(class)
+ end if
+ ;
+ ; Get some resources for the figure strings, if they exist.
+ ;
+ if(isatt(res,"gsnPanelFigureStrings"))
+ is_figure_strings = True
+ panel_strings = get_res_value(res,"gsnPanelFigureStrings","")
+ ;
+ ; Get and set resource values for figure strings on the plots.
+ ;
+ justs = (/"bottomright", "topright", "topleft", "bottomleft"/)
+ paras = (/ 1.0, 1.0, -1.0, -1.0/)
+ orths = (/ 1.0, -1.0, -1.0, 1.0/)
+
+ amres = get_res_eq(res,"am")
+ just = lower_case(get_res_value(amres,"amJust","bottomright"))
+ ;
+ ; Look for all resources that start with gsnPanelFigureStrings, and replace
+ ; this with just "tx". This is what allows us to sneak in text resources
+ ; and have them only apply to the figure strings, and not the main string.
+ ;
+ txres = get_res_eq_replace(res,"gsnPanelFigureStrings","tx")
+ perim_on = get_res_value(txres,"txPerimOn",True)
+ bkgrn = get_res_value(txres,"txBackgroundFillColor",0)
+ else
+ is_figure_strings = False
+ end if
+ ;
+ ; Error check the values that the user has entered, to make sure
+ ; they are valid.
+ ;
+ if(xwsp_perc.lt.0.or.xwsp_perc.ge.100.)
+ print("Warning: gsn_panel: attribute gsnPanelXWhiteSpacePercent must be >= 0 and < 100.")
+ print("Defaulting to 1.")
+ xwsp_perc = 1.
+ end if
+
+ if(ywsp_perc.lt.0.or.ywsp_perc.ge.100.)
+ print("Warning: gsn_panel: attribute gsnPanelYWhiteSpacePercent must be >= 0 and < 100.")
+ print("Defaulting to 1.")
+ ywsp_perc = 1.
+ end if
+
+ if(x_lft.lt.0..or.x_lft.ge.1.)
+ print("Warning: gsn_panel: attribute gsnPanelLeft must be >= 0.0 and < 1.0")
+ print("Defaulting to 0.")
+ x_lft = 0.0
+ end if
+
+ if(x_rgt.le.0..or.x_rgt.gt.1.)
+ print("Warning: gsn_panel: attribute gsnPanelRight must be > 0.0 and <= 1.0")
+ print("Defaulting to 1.")
+ x_rgt = 1.0
+ end if
+
+ if(y_top.le.0..or.y_top.gt.1.)
+ print("Warning: gsn_panel: attribute gsnPanelTop must be > 0.0 and <= 1.0")
+ print("Defaulting to 1.")
+ y_top = 1.0
+ end if
+
+ if(y_bot.lt.0..or.y_bot.ge.1.)
+ print("Warning: gsn_panel: attribute gsnPanelBottom must be >= 0.0 and < 1.0")
+ print("Defaulting to 0.")
+ y_bot = 0.0
+ end if
+
+ if(x_rgt.le.x_lft)
+ print("Error: gsn_panel: attribute gsnPanelRight ("+x_rgt+") must be greater")
+ print("than gsnPanelLeft ("+x_lft+").")
+ exit
+ end if
+
+ if(y_top.le.y_bot)
+ print("Error: gsn_panel: attribute gsnPanelTop ("+y_top+") must be greater")
+ print("than gsnPanelBottom ("+y_bot+").")
+ exit
+ end if
+
+ ;
+ ; We assume all plots are the same size, so if we get the size of
+ ; one of them, then this should represent the size of the rest
+ ; of them. Also, count the number of non-missing plots for later.
+ ; Since some of the plots might be missing, grab the first one that
+ ; isn't, and use this one to determine plot size.
+ ;
+ ind_nomsg = ind(.not.ismissing(plot(0:nplots-1)))
+ if(all(ismissing(ind_nomsg))) then
+ print("Error: gsn_panel: all of the plots passed to gsn_panel appear to be invalid")
+ exit
+ end if
+ if(panel_plotid.ge.0.and.panel_plotid.le.(nplots-1).and.
+ .not.ismissing(plot(panel_plotid))) then
+ valid_plot = panel_plotid
+ else
+ valid_plot = ind_nomsg(0)
+ end if
+ bb = NhlGetBB(plot(valid_plot)) ; Get bounding box of this plot
+ top = bb(0)
+ bottom = bb(1)
+ left = bb(2)
+ right = bb(3)
+ delete(bb)
+ nvalid_plots = dimsizes(ind_nomsg)
+ delete(ind_nomsg)
+
+ if(panel_debug) then
+ print("There are " + nvalid_plots + " valid plots out of " + nplots + " total plots")
+ end if
+
+ ;
+ ; Get the type of plots we have. "plot" can be a map, in which case
+ ; the vector or contour plot overlaid on it will be indicated
+ ; by "plot at contour" or "plot at vector"
+ ;
+ new_plot = get_plot_not_loglin(plot(valid_plot))
+ new_plot_lab = get_plot_labelbar(plot(valid_plot))
+
+ ;
+ ; Get the font height.
+ ;
+ if(is_figure_strings.or.panel_labelbar) then
+ if(new_plot at plot_type.eq."contour") then
+ getvalues new_plot
+ "cnInfoLabelFontHeightF" : font_height
+ end getvalues
+ else if(new_plot at plot_type.eq."vector") then
+ getvalues new_plot
+ "vcRefAnnoFontHeightF" : font_height
+ end getvalues
+ else if(new_plot at plot_type.eq."xy") then
+ getvalues new_plot
+ "tiXAxisFontHeightF" : font_height
+ end getvalues
+ font_height = 0.6*font_height
+ else if(new_plot at plot_type.eq."streamline") then
+ ;
+ ; There's no equivalent font height resource for streamline to
+ ; retrieve, so just set it here.
+ ;
+ font_height = 0.01
+ else
+ font_height = 0.01
+ if((is_figure_strings.and.
+ .not.isatt(res,"gsnPanelFigureStringsFontHeightF"))) then
+ print("Warning: gsn_panel: unrecognized plot type.")
+ print("Unable to get information for various font heights.")
+ print("Make sure your font heights look okay.")
+ print("Set gsnPanelFigureStringsFontHeightF resource to control figure strings font height.")
+ end if
+ end if
+ end if
+ end if
+ end if
+ ;
+ ; Use this font height for the panel strings, if any, unless the user
+ ; has set gsnPanelFigureStringsFontHeightF.
+ ;
+ pfont_height = get_res_value(res,"gsnPanelFigureStringsFontHeightF",
+ font_height)
+ end if
+ ;
+ ; Get labelbar info.
+ ;
+ if(panel_labelbar) then
+ ;
+ ; The cnLabelBarEndStyle resource is only available with contour
+ ; plots, and it is 0 by default (IncludeOuterBoxes). We need to check
+ ; if it is 1 (IncludeMinMaxLabels) or 2 (ExcludeOuterBoxes) and do
+ ; the appropriate thing. IncludeMinMaxLabels is not currently supported.
+ ;
+ end_style = 0 ; IncludeOuterBoxes
+ if(new_plot_lab at plot_type.eq."contour") then
+ getvalues new_plot_lab
+ "cnFillOn" : fill_on
+ end getvalues
+ if(fill_on) then
+ getvalues new_plot_lab
+ "cnFillColors" : colors
+ "cnFillPatterns" : fill_patterns
+ "cnFillScales" : fill_scales
+ "cnMonoFillPattern" : mono_fill_pat
+ "cnMonoFillScale" : mono_fill_scl
+ "cnMonoFillColor" : mono_fill_col
+ "cnLevels" : levels
+ "cnLabelBarEndStyle" : end_style
+ end getvalues
+ else
+ panel_labelbar = False
+ end if
+ else if(new_plot_lab at plot_type.eq."vector") then
+ getvalues new_plot_lab
+ "vcGlyphStyle" : gstyle
+ "vcFillArrowsOn" : fill_arrows_on
+ "vcMonoLineArrowColor" : mono_line_color
+ "vcMonoFillArrowFillColor" : mono_fill_arrow
+ "vcMonoWindBarbColor" : mono_wind_barb
+ end getvalues
+ ;
+ ; 0 = linearrow, 1 = fillarrow, 2 = windbarb, 3 = curlyvector
+ ;
+ if( (fill_arrows_on .and. .not.mono_fill_arrow) .or.
+ (.not.fill_arrows_on .and. .not.mono_line_color) .or.
+ (gstyle.eq.1 .and. .not.mono_fill_arrow) .or.
+ (gstyle.eq.2 .and. .not.mono_wind_barb) .or.
+ (gstyle.eq.0 .or. gstyle.eq.3) .and. .not.mono_line_color) then
+ ;---There are no fill patterns in VectorPlot, only solids.
+ mono_fill_pat = True
+ mono_fill_scl = True
+ mono_fill_col = False
+ getvalues new_plot_lab
+ "vcLevels" : levels
+ "vcLevelColors" : colors
+ end getvalues
+ else
+ panel_labelbar = False
+ end if
+ else if(new_plot_lab at plot_type.eq."streamline") then
+ getvalues new_plot_lab
+ "stMonoLineColor" : mono_line_color
+ end getvalues
+ if(.not.mono_line_color) then
+ ;---There are no fill patterns in StreamlinePlot, only solids.
+ mono_fill_pat = True
+ mono_fill_scl = True
+ mono_fill_col = False
+ getvalues new_plot_lab
+ "stLevels" : levels
+ "stLevelColors" : colors
+ end getvalues
+ else
+ panel_labelbar = False
+ end if
+ else
+ if(.not.isatt(res,"lbLabelFontHeightF")) then
+ print("Set lbLabelFontHeightF resource to control labelbar font heights.")
+ end if
+ end if
+ end if
+ end if
+ end if
+
+ ;
+ ; plot_width : total width of plot with all of its annotations
+ ; plot_height : total height of plot with all of its annotations
+ ; total_width : plot_width plus white space on both sides
+ ; total_height: plot_height plus white space on top and bottom
+ ;
+ plot_width = right - left ; Calculate total width of plot.
+ plot_height = top - bottom ; Calculate total height of plot.
+
+ xwsp = xwsp_perc/100. * plot_width ; White space is a percentage of total
+ ywsp = ywsp_perc/100. * plot_height ; width and height.
+
+ total_width = 2.*xwsp + plot_width ; Calculate total width and height
+ total_height = 2.*ywsp + plot_height ; with white space added.
+ ;
+ ; If we are putting a global labelbar at the bottom (right), make
+ ; it 2/10 the height (width) of the plot.
+ ;
+ lbhor = True
+ if(panel_labelbar) then
+ lbres = get_res_eq(res,(/"lb","pmLabelBar","vp"/)) ; Get labelbar resources.
+ if(check_attr(lbres,"lbOrientation","vertical",True).or.
+ check_attr(lbres,"lbOrientation",1,True)) then
+ lbhor = False
+ labelbar_width = 0.20 * plot_width + 2.*xwsp
+ ;
+ ; Adjust height depending on whether we have one row or multiple rows.
+ ;
+ if(nplots.gt.1.and.nrows.gt.1) then
+ labelbar_height = (nrows-1) * (2.*ywsp + plot_height)
+ else
+ labelbar_height = plot_height
+ end if
+ else
+ set_attr(lbres,"lbOrientation","Horizontal")
+
+ labelbar_height = 0.20 * plot_height + 2.*ywsp
+ ;
+ ; Adjust width depending on whether we have one column or multiple
+ ; columns.
+ ;
+ if(nplots.gt.1.and.ncols.gt.1) then
+ labelbar_width = (ncols-1) * (2.*xwsp + plot_width)
+ else
+ labelbar_width = plot_width
+ end if
+ end if
+ else
+ labelbar_height = 0.
+ labelbar_width = 0.
+ end if
+ ;
+ ; We want:
+ ;
+ ; ncols * scale * total_width <= x_rgt - x_lft (the viewport width)
+ ; nrows * scale * total_height <= y_top - y_bot (the viewport height)
+ ; [or scale * (nrows * total_height + labelbar_height) if a labelbar
+ ; is being drawn]
+ ;
+ ; By taking the minimum of these two, we get the scale
+ ; factor that we need to fit all plots on a page.
+ ;
+ xrange = x_rgt - x_lft
+ yrange = y_top - y_bot
+
+ if(lbhor) then
+ ;
+ ; Previously, we used to include xrange and yrange as part of the min
+ ; statement. This seemed to cause problems if you set one of
+ ; gsnPanelTop/Bottom/Right/Left however, so I removed it. Initial
+ ; testing on Sylvia's panel examples seems to indicate this is okay.
+ ;
+ row_scale = yrange/(nrows*total_height+labelbar_height)
+ col_scale = xrange/(ncols*total_width)
+ scale = min((/col_scale,row_scale/))
+ yrange = yrange - scale * labelbar_height
+ else
+ ;
+ ; See above comments.
+ ;
+ row_scale = yrange/(nrows*total_height)
+ col_scale = xrange/(ncols*total_width+labelbar_width)
+ scale = min((/col_scale,row_scale/))
+ xrange = xrange - scale * labelbar_width
+ end if
+
+ new_plot_width = scale*plot_width ; Calculate new width
+ new_plot_height = scale*plot_height ; and height.
+
+ xwsp = xwsp_perc/100. * new_plot_width ; Calculate new white space.
+ ywsp = ywsp_perc/100. * new_plot_height
+
+ new_total_width = 2.*xwsp + new_plot_width ; Calculate new total width
+ new_total_height = 2.*ywsp + new_plot_height ; and height w/white space.
+
+ xsp = xrange - new_total_width*ncols ; Calculate total amt of white space
+ ysp = yrange - new_total_height*nrows ; left in both X and Y directions.
+
+ getvalues plot(valid_plot)
+ "vpXF" : vpx
+ "vpYF" : vpy
+ "vpWidthF" : vpw
+ "vpHeightF" : vph
+ end getvalues
+
+ dxl = scale * (vpx-left) ; Distance from plot's left
+ ; position to its leftmost annotation
+ dxr = scale * (right-(vpx+vpw)) ; Distance from plot's right
+ ; position to its rightmost annotation
+ dyt = scale * (top-vpy) ; Distance from plot's top
+ ; position to its topmost annotation.
+ dyb = scale * ((vpy-vph)-bottom) ; Distance from plot's bottom
+ ; position to its bottommost annotation.
+
+ ypos = y_top - ywsp - dyt -(ysp/2.+new_total_height*ispan(0,nrows-1,1))
+
+ delete(top)
+ delete(bottom)
+ delete(right)
+ delete(left)
+ ;
+ ; If we have figure strings, then determine white spacing around
+ ; the text box.
+ ;
+ if(is_figure_strings) then
+ fig_index = ind(just.eq.justs)
+ if(ismissing(fig_index))
+ fig_index = 0
+ just = justs(fig_index)
+ end if
+
+ len_pct = 0.025 ; Percentage of width/height of plot
+ ; for white space around text box.
+ if(vpw .lt. vph) then
+ wsp_hpct = (len_pct * vpw) / vph
+ wsp_wpct = len_pct
+ else
+ wsp_hpct = len_pct
+ wsp_wpct = (len_pct * vph) / vpw
+ end if
+ para = get_res_value(amres,"amParallelPosF", paras(fig_index) *
+ (0.5 - wsp_wpct))
+ orth = get_res_value(amres,"amOrthogonalPosF", orths(fig_index) *
+ (0.5 - wsp_hpct))
+ end if
+ ;
+ ; Variable to store rightmost location of rightmost plot, and topmost
+ ; location of top plot.
+ ;
+ max_rgt = 0.
+ max_top = 0.
+ ;
+ ; Variable to hold original viewport coordinates, and annotations (if
+ ; they exist).
+ ;
+ old_vp = new((/nplots,4/),float)
+ anno = new(nplots, graphic)
+ ;
+ ; Loop through each row and create each plot in the new scaled-down
+ ; size. We will draw plots later, outside the loop.
+ ;
+ num_plots_left = nplots
+ nplot = 0
+ nr = 0
+ added_anno = False ; For figure strings
+
+ do while(num_plots_left.gt.0)
+ vpy_new = ypos(nr)
+ new_ncols = min((/num_plots_left,row_spec(nr)/))
+
+ if(panel_center)
+ xsp = xrange - new_total_width*new_ncols ; space before plots.
+ else
+ xsp = xrange - new_total_width*ncols ; space before plots.
+ end if
+ ;
+ ; Calculate new x positions.
+ ;
+ xpos = x_lft + xwsp + dxl +(xsp/2.+new_total_width*ispan(0,new_ncols-1,1))
+
+ do nc = 0,new_ncols-1
+ vpx_new = xpos(nc)
+ if(.not.ismissing(plot(nplot)))
+ pplot = plot(nplot)
+ getvalues pplot
+ "vpXF" : old_vp(nplot,0)
+ "vpYF" : old_vp(nplot,1)
+ "vpWidthF" : old_vp(nplot,2)
+ "vpHeightF" : old_vp(nplot,3)
+ end getvalues
+ ;
+ ; If user setting gsnPanelXF or gsnPanelYF resources, then use these instead.
+ ; They must be set as an array of the same length as you have plots.
+ ; If any of these are negative, then use the calculated values.
+ ;
+ vpx_new = xpos(nc)
+ if(isatt(res,"gsnPanelXF").and.dimsizes(res at gsnPanelXF).eq.nplots.and.
+ res at gsnPanelXF(nplot).ge.0.and.res at gsnPanelXF(nplot).le.1) then
+ vpx_new = res at gsnPanelXF(nplot)
+ end if
+
+ vpy_new = ypos(nr)
+ if(isatt(res,"gsnPanelYF").and.dimsizes(res at gsnPanelYF).eq.nplots.and.
+ res at gsnPanelYF(nplot).ge.0.and.res at gsnPanelYF(nplot).le.1) then
+ vpy_new = res at gsnPanelYF(nplot)
+ end if
+ ;
+ ; Print out values used.
+ ;
+ if(panel_debug) then
+ print("-------Panel viewport values for each plot-------")
+ print(" plot #" + nplot)
+ print(" new x,y = " + vpx_new + "," + vpy_new)
+ print(" orig wdt,hgt = " + old_vp(nplot,2) + "," + old_vp(nplot,3))
+ print(" new wdt,hgt = " + scale*old_vp(nplot,2) + "," + scale*old_vp(nplot,3))
+ end if
+
+ setvalues pplot
+ "vpXF" : vpx_new
+ "vpYF" : vpy_new
+ "vpWidthF" : scale*old_vp(nplot,2)
+ "vpHeightF" : scale*old_vp(nplot,3)
+ end setvalues
+
+ if(is_figure_strings) then
+ if(nplot .lt. dimsizes(panel_strings).and.
+ panel_strings(nplot).ne."")
+ text = create "string" textItemClass wks
+ "txString" : panel_strings(nplot)
+ "txFontHeightF" : pfont_height
+ "txPerimOn" : perim_on
+ "txBackgroundFillColor" : bkgrn
+ end create
+ ;
+ ; Set some text resources for figure strings, if any.
+ ;
+ attsetvalues_check(text,txres)
+ ;
+ ; Add annotation to plot.
+ ;
+ anno(nplot) = NhlAddAnnotation(pplot,text)
+ added_anno = True
+ setvalues anno(nplot)
+ "amZone" : 0
+ "amJust" : just
+ "amParallelPosF" : para
+ "amOrthogonalPosF" : orth
+ "amResizeNotify" : True
+ end setvalues
+ attsetvalues_check(anno(nplot),amres)
+ delete(text)
+ end if
+ end if
+ ;
+ ; Save this plot.
+ ;
+ newplots(nplot) = pplot
+ ;
+ ; Info for possible labelbar or main_string
+ ;
+ if(main_string_on.or.panel_labelbar.or.draw_boxes) then
+ bb = NhlGetBB(pplot) ; Get bounding box of plot.
+ top = bb(0)
+ lft = bb(2)
+ bot = bb(1)
+ rgt = bb(3)
+ max_rgt = max((/rgt,max_rgt/))
+ max_top = max((/top,max_top/))
+
+ if(draw_boxes)
+ draw_bb(pplot,False)
+ end if
+ end if
+ end if ; if(.not.ismissing(plot(nplot)))
+ ;
+ ; Retain the smallest and largest x and y positions.
+ ;
+ if(nplot.eq.0) then
+ min_xpos = vpx_new
+ max_xpos = vpx_new
+ min_ypos = vpy_new
+ max_ypos = vpy_new
+ else
+ min_xpos = min( (/vpx_new,min_xpos/) )
+ max_xpos = max( (/vpx_new,max_xpos/) )
+ min_ypos = min( (/vpy_new,min_ypos/) )
+ max_ypos = max( (/vpy_new,max_ypos/) )
+ end if
+
+ nplot = nplot + 1 ; Increment plot counter
+ end do ; end of columns
+
+ num_plots_left = nplots - nplot
+ nr = nr + 1 ; increment rows
+ delete(xpos)
+ end do ; end of plots
+
+ ;
+ ; Print min/max information.
+ ;
+ if(panel_debug) then
+ print("-------min/max X,Y viewport positions for plots-------")
+ print("min/max x viewport position = " + min_xpos + "/" + max_xpos)
+ print("min/max y viewport position = " + min_ypos + "/" + max_ypos)
+ end if
+ ;
+ ; Calculate the biggest rescaled widths and heights (technically, they
+ ; should all be the same). These values will be used a few times
+ ; throughout the rest of the code.
+ ;
+ scaled_width = scale*max(old_vp(:,2))
+ scaled_height = scale*max(old_vp(:,3))
+ ;
+ ; Check if a labelbar is to be drawn at the bottom.
+ ;
+ if(panel_labelbar) then
+ if(end_style.eq.0.or.end_style.eq.2) then
+ lbres at EndStyle = end_style
+ else
+ lbres at EndStyle = 0
+ print("Warning: gsn_panel: this routine only supports a cnLabelBarEndStyle that is set to 'IncludeOuterBoxes' or 'ExcludeOuterBoxes'")
+ end if
+ ;
+ ; If plot type is unknown or xy, then we can't get labelbar information.
+ ;
+ if(new_plot at plot_type.ne."unknown".and.new_plot at plot_type.ne."xy") then
+ ;
+ ; Set labelbar height, width, and font height.
+ ;
+ labelbar_height = scale * labelbar_height
+ labelbar_width = scale * labelbar_width
+ labelbar_font_height = font_height
+ ;
+ ; Set some labelbar resources. If pmLabelBarWidth/Height are set,
+ ; use these no matter what, for the labelbar width and height. Otherwise,
+ ; use vpWidth/Height if they are set.
+ ;
+ lbres = True
+ if(isatt(lbres,"pmLabelBarWidthF")) then
+ lbres at vpWidthF = get_res_value(lbres,"pmLabelBarWidthF",labelbar_width)
+ else
+ set_attr(lbres,"vpWidthF", labelbar_width)
+ end if
+
+ if(isatt(lbres,"pmLabelBarHeightF")) then
+ lbres at vpHeightF = get_res_value(lbres,"pmLabelBarHeightF",labelbar_height)
+ else
+ set_attr(lbres,"vpHeightF",labelbar_height)
+ end if
+ ;
+ ; Set position of labelbar depending on whether it's horizontal or
+ ; vertical.
+ ;
+ if(lbhor)
+ set_attr(lbres,"vpYF",max ((/ywsp+labelbar_height,bot-ywsp/)))
+ if(ncols.eq.1.and.lbres at vpWidthF.le.scaled_width)
+ set_attr(lbres,"vpXF",min_xpos + (scaled_width-lbres at vpWidthF)/2.)
+ else
+ tmp_range = x_rgt - x_lft
+ set_attr(lbres,"vpXF",x_lft + (tmp_range - lbres at vpWidthF)/2.)
+ end if
+ lbres at vpYF = lbres at vpYF + get_res_value(lbres,"pmLabelBarOrthogonalPosF",0.)
+ lbres at vpXF = lbres at vpXF + get_res_value(lbres,"pmLabelBarParallelPosF",0.)
+ else
+ set_attr(lbres,"vpXF",min ((/1.-(xwsp+labelbar_width),max_rgt+xwsp/)))
+ if(nrows.eq.1.and.lbres at vpHeightF.le.scaled_height)
+ set_attr(lbres,"vpYF",max_ypos-(scaled_height - lbres at vpHeightF)/2.)
+ else
+ tmp_range = y_top - y_bot
+ set_attr(lbres,"vpYF",y_top-(tmp_range - lbres at vpHeightF)/2.)
+ end if
+ lbres at vpXF = lbres at vpXF + get_res_value(lbres,"pmLabelBarOrthogonalPosF",0.)
+ lbres at vpYF = lbres at vpYF + get_res_value(lbres,"pmLabelBarParallelPosF",0.)
+ end if
+ set_attr(lbres,"lbLabelFontHeightF",labelbar_font_height)
+ ;
+ ; Check if we want different fill patterns or fill scales. If so, we
+ ; have to pass these on to the labelbar.
+ ;
+ set_attr(lbres,"lbMonoFillColor",mono_fill_col)
+ if(.not.mono_fill_pat)
+ set_attr(lbres,"lbMonoFillPattern", False)
+ set_attr(lbres,"lbFillPatterns", fill_patterns)
+ end if
+ if(.not.mono_fill_scl)
+ set_attr(lbres,"lbMonoFillScale", False)
+ set_attr(lbres,"lbFillScales", fill_scales)
+ end if
+ ;
+ ; Create the labelbar. First check the levels to make sure that a
+ ; contour level with a value like 1e-8 is not really supposed to be
+ ; a value of 0.
+ ;
+ levels = fix_zero_contour(levels)
+
+ newplots(nplot) = create_labelbar(wks,dimsizes(colors),colors,
+ levels,lbres)
+ nplot = nplot + 1
+ else
+ print("Warning: gsn_panel: unrecognized plot type for getting labelbar information. Ignoring labelbar request.")
+ end if
+ end if
+ ;
+ ; Create the main string, if exists.
+ ;
+ if(main_string_on) then
+ y_top = min((/y_top,max_top/))
+ main_ypos = get_res_value_keep(res,"txPosYF",y_top + 0.03)
+ main_xpos = get_res_value_keep(res,"txPosXF",0.5)
+
+ if(panel_debug)
+ print("-------Panel title values-------")
+ print(" title = " + main_string)
+ print(" top of paneled plots = " + y_top)
+ print(" y location of title = " + main_ypos)
+ end if
+
+ if((main_ypos+main_font_hgt).gt.1)
+ print("Warning: gsn_panel: font height (" + main_font_hgt + ") of main string is too large to fit in space provided. Either decrease font size or set gsnPanelTop.")
+ end if
+
+ mntxres = get_res_eq(res,"tx")
+ mntxres = True
+ mntxres at gsnDraw = False
+ mntxres at gsnFrame = False
+ mntxres at txFontHeightF = main_font_hgt
+ newplots(nplot) = gsn_create_text_ndc(wks, main_string, main_xpos,
+ main_ypos, mntxres)
+ end if
+ ;
+ ; If some of the paneled plots are missing, we need to take these into
+ ; account so that the maximization will still work properly. For
+ ; example, if we ask for a 2 x 2 configuration, but plots 1 and 3 (the
+ ; rightmost plots) are missing, then we need to set a new resource
+ ; called gsnPanelInvsblRight to whatever approximate X value it
+ ; would have been if those plots weren't missing. Setting just gsnPanelRight
+ ; won't work in this case, because that resource is only used to control
+ ; where the plots are drawn in a 0 to 1 square, and *not* to indicate the
+ ; rightmost location of the rightmost graphic (which could be a vertical
+ ; labelbar).
+ ;
+ ; Not dealing with the case of gsnPanelRowSpec = True yet.
+ ;
+ if(.not.is_row_spec) then
+ newbb = new((/dimsizes(newplots),4/),float)
+ ;
+ ; Have to deal with special case of only having one plot.
+ ;
+ if(dimsizes(newplots).eq.1)
+ newbb(0,:) = NhlGetBB(newplots) ; Get bounding boxes of plots, plus
+ ; labelbar and text string if they
+ ; exist.
+ else
+ newbb = NhlGetBB(newplots) ; Get bounding boxes of plots, plus
+ ; labelbar and text string if they
+ ; exist.
+ end if
+ getvalues newplots(valid_plot)
+ "vpXF" : vpx
+ "vpYF" : vpy
+ "vpWidthF" : vpw
+ "vpHeightF" : vph
+ end getvalues
+ dxl = vpx-newbb(valid_plot,2)
+ dxr = newbb(valid_plot,3)-(vpx+vpw)
+ dyt = (newbb(valid_plot,0)-vpy)
+ dyb = (vpy-vph)-newbb(valid_plot,1)
+ ;
+ ; Get largest bounding box that encompasses all non-missing graphical
+ ; objects.
+ ;
+ newtop = max(newbb(:,0))
+ newbot = min(newbb(:,1))
+ newlft = min(newbb(:,2))
+ newrgt = max(newbb(:,3))
+ delete(newbb)
+
+ ;
+ ; This section checks to see if all plots along one side are
+ ; missing, because if they are, we have to pretend like they
+ ; are just invisible (i.e. do the maximization as if the invisible
+ ; plots were really there). This section needs to take
+ ; place even if no plots are missing, because it's possible the
+ ; user specified fewer plots than panels.
+ ;
+ xlft = min_xpos - dxl
+ xrgt = max_xpos + vpw + dxr
+ xtop = max_ypos + dyt
+ xbot = min_ypos - vph - dyb
+ if(.not.rgt_pnl.and.xrgt.gt.newrgt) then
+ maxbb at gsnPanelInvsblRight = xrgt
+ if(panel_debug)
+ print("gsnPanelInvsblRight = " + maxbb at gsnPanelInvsblRight)
+ end if
+ end if
+
+ if(.not.lft_pnl.and.xlft.lt.newlft) then
+ maxbb at gsnPanelInvsblLeft = xlft
+ if(panel_debug)
+ print("gsnPanelInvsblLeft = " + maxbb at gsnPanelInvsblLeft)
+ end if
+ end if
+
+ if(.not.top_pnl.and.xtop.gt.newtop) then
+ maxbb at gsnPanelInvsblTop = xtop
+ if(panel_debug)
+ print("gsnPanelInvsblTop = " + maxbb at gsnPanelInvsblTop)
+ end if
+ end if
+
+ if(.not.bot_pnl.and.xbot.lt.newbot) then
+ maxbb at gsnPanelInvsblBottom = xbot
+ if(panel_debug)
+ print("gsnPanelInvsblBottom = " + maxbb at gsnPanelInvsblBottom)
+ end if
+ end if
+ end if
+ ;
+ ; Draw plots plus labelbar and main title (if they exists). This is
+ ; also where the plots will be maximized for PostScript output,
+ ; if so indicated.
+ ;
+ if(draw_boxes)
+ draw_and_frame(wks,newplots,calldraw,False,1,maxbb)
+ else
+ draw_and_frame(wks,newplots,calldraw,callframe,1,maxbb)
+ end if
+ ;
+ ; Draw bounding boxes around each plot object for debugging purposes.
+ ;
+ if(draw_boxes)
+ do i=0,dimsizes(newplots)-1
+ if(.not.ismissing(newplots(i)))
+ draw_bb(newplots(i),False)
+ end if
+ end do
+ if(callframe) then
+ frame(wks)
+ end if
+ end if
+ ;
+ ; Debug information
+ ;
+ if(panel_debug) then
+ bb_dbg = NhlGetBB(newplots)
+ if(dimsizes(newplots).gt.1) then
+ print("-------min/max NDC values for all objects in panel-------")
+ print("min/max x position = " + min(bb_dbg(:,2)) + "/" + max(bb_dbg(:,3)))
+ print("min/max y position = " + min(bb_dbg(:,1)) + "/" + max(bb_dbg(:,0)))
+ else
+ print("-------min/max NDC values for the object in panel-------")
+ print("min/max x position = " + min(bb_dbg(2)) + "/" + max(bb_dbg(3)))
+ print("min/max y position = " + min(bb_dbg(1)) + "/" + max(bb_dbg(0)))
+ end if
+ delete(bb_dbg)
+ end if
+
+ ;
+ ; Restore plots to original size.
+ ;
+ if(.not.panel_save) then
+ do i=0,nplots-1
+ if(.not.ismissing(plot(i)))
+ if(added_anno.and..not.ismissing(anno(i)))
+ NhlRemoveAnnotation(plot(i),anno(i))
+ end if
+ setvalues plot(i)
+ "vpXF" : old_vp(i,0)
+ "vpYF" : old_vp(i,1)
+ "vpWidthF" : old_vp(i,2)
+ "vpHeightF" : old_vp(i,3)
+ end setvalues
+ end if
+ end do
+ end if
+
+ return(newplots)
+ end
+
+
+ ;***********************************************************************;
+ ; procedure gsn_panel - same as gsn_panel_return, only it doesn't return;
+ ; anything. ;
+ ;***********************************************************************;
+ undef("gsn_panel")
+ procedure gsn_panel(wks:graphic,plot[*]:graphic,dims[*]:integer,
+ resources:logical)
+ local res2
+ begin
+ res2 = get_resources(resources)
+ set_attr(res2,"gsnPanelSave",False )
+ plots = gsn_panel_return(wks,plot,dims,res2)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_attach_plots ;
+ ; base : base plot ;
+ ; plots : list of plots to attach ;
+ ; resplot1 : logical ;
+ ; resplot2 : logical ;
+ ; ;
+ ; This function attaches the list of "plots" to the "base" plot, either;
+ ; on the right Y axis or bottom X axis of the base plot. The default is ;
+ ; to attach the plots at the Y axis, unless gsnAttachPlotsXAxis is set ;
+ ; to True. ;
+ ; ;
+ ; By default, the viewport heights of all plots will be made the same, ;
+ ; appropriate tick marks and labels will be turned off, and the aspect ;
+ ; ratio preserved. ;
+ ; ;
+ ; For example, if you have the following plots and you want them ;
+ ; attached at the Y axis: ;
+ ; ;
+ ; ___________ _____ __________ ;
+ ; | | | | | | ;
+ ; | | | | | | ;
+ ; | base | | | | | ;
+ ; | | | | | | ;
+ ; | | | | | | ;
+ ; ----------- ----- ---------- ;
+ ; ;
+ ; you will end up with: ;
+ ; ;
+ ; _________________________ ;
+ ; | | | | ;
+ ; | | | | ;
+ ; | base | | | ;
+ ; | | | | ;
+ ; | | | | ;
+ ; ------------------------- ;
+ ; ;
+ ; Or, if you have the following plots and you want them attached at the ;
+ ; X axis: ;
+ ; ;
+ ; ___________ ___________ ;
+ ; | | | | ;
+ ; | | | | ;
+ ; | base | | | ;
+ ; | | ----------- ;
+ ; | | ;
+ ; ----------- ;
+ ; ;
+ ; you will end up with: ;
+ ; ;
+ ; ___________ ;
+ ; | | ;
+ ; | | ;
+ ; | base | ;
+ ; | | ;
+ ; | | ;
+ ; ----------- ;
+ ; | | ;
+ ; | | ;
+ ; | | ;
+ ; ----------- ;
+ ; ;
+ ; plotres1 and plotres2 are resources changing the default behavior of ;
+ ; this function. ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_attach_plots")
+ function gsn_attach_plots(oldbaseplot:graphic,oldplots:graphic,
+ plotres1:logical, plotres2:logical)
+ local anno, width1, width2, height1, height2, font_height1, font_height2,
+ mj_length1, mj_length2, mjo_length1, mjo_length2, mno_length1, mno_length2,
+ mno_length1, mno_length2, total_width1, total_width2, scale1, scale2, scale
+ begin
+ res1 = get_resources(plotres1)
+ res2 = get_resources(plotres2)
+ base = oldbaseplot
+ plots = oldplots
+ nplots= dimsizes(plots)
+
+ res1 at gsnMaximize = get_res_value(res1,"gsnMaximize",True)
+
+ ;---Check for maximization
+ maxbb = get_bb_res(res1)
+ if(.not.maxbb) then
+ maxbb = get_bb_res(res2)
+ end if
+
+ attach_y = .not.get_res_value(res1,"gsnAttachPlotsXAxis",False)
+ attach_y = .not.get_res_value(res2,"gsnAttachPlotsXAxis",.not.attach_y)
+ border_on = get_res_value(res1,"gsnAttachBorderOn",True)
+
+ ;
+ ; The plots to be attached may not be regular plots (contour, xy, vector,
+ ; etc), so we won't be able to retrieve tickmark info from them. We have
+ ; to see if they are overlay plots, instead, that have regular plots
+ ; overlaid on them. If so, we can use the overlaid plots for tickmark
+ ; info. If not, then we are in trouble.
+ ;
+ ; Here's the list of "regular" plot types:
+ ;
+ plot_types = (/"contourPlotClass","xyPlotClass","vectorPlotClass",
+ "streamlinePlotClass","mapPlotClass","logLinPlotClass"/)
+
+ ;
+ ; First check the base plot for "regular plotness".
+ ;
+ found_base = False
+
+ if(any(NhlClassName(base).eq.plot_types)) then
+ ;
+ ; The base plot is a regular plot.
+ ;
+ new_base = base
+ found_base = True
+ else
+ ;
+ ; The base plot is not a regular plot, so find out if it has a regular
+ ; plot overlaid on it.
+ ;
+ getvalues base
+ "pmOverlaySequenceIds" : base_ids
+ end getvalues
+ if(.not.ismissing(base_ids(0))) then
+ j = 0
+ ;
+ ; Loop through the overlaid plots and find a "regular" one. We will
+ ; use the first one we find.
+ ;
+ do while(j.lt.dimsizes(base_ids).and..not.found_base)
+ if(any(NhlClassName(base_ids(j)).eq.plot_types)) then
+ new_base = base_ids(j)
+ found_base = True
+ end if
+ j = j + 1
+ end do
+ end if
+ end if
+
+ if(.not.found_base) then
+ print("Warning: gsn_attach_plots: the base plot is an unrecognized plot type; may get unexpected results.")
+ new_base = base
+ end if
+ getvalues new_base
+ "trGridType" : grid_type
+ end getvalues
+ if(grid_type.ge.3) then
+ print("Warning: gsn_attach_plots: the base plot is either spherical or triangular, so can't fix the tickmarks")
+ found_base = False
+ end if
+ ;
+ ; Now test the plots to be attached, and see if they are "regular" plots.
+ ;
+ found_plots = new(nplots,logical)
+ new_plots = new(nplots,graphic)
+ found_plots = False
+
+ do i=0,nplots-1
+ if(any(NhlClassName(plots(i)).eq.plot_types)) then
+ new_plots(i) = plots(i)
+ found_plots(i) = True
+ else
+ getvalues plots(i)
+ "pmOverlaySequenceIds" : tmp_plot_ids
+ end getvalues
+
+ if(.not.ismissing(tmp_plot_ids(0))) then
+ j = 0
+ ;
+ ; Loop through the overlaid plots and find a "regular" one. We will
+ ; use the first one we find.
+ ;
+ do while(j.lt.dimsizes(tmp_plot_ids).and..not.found_plots(i))
+ if(any(NhlClassName(tmp_plot_ids(j)).eq.plot_types)) then
+ new_plots(i) = tmp_plot_ids(j)
+ found_plots(i) = True
+ end if
+ j = j + 1
+ end do
+ end if
+ delete(tmp_plot_ids)
+ end if
+ if(.not.found_plots(i)) then
+ print("Warning: gsn_attach_plots: unrecognized plot type, may get unexpected results.")
+ new_plots(i) = plots(i)
+ found_plots(i) = False
+ end if
+ end do
+ ;
+ ; Retrieve tickmark lengths and font height labels so we can make
+ ; them the same size later.
+ ;
+ ; Also get the viewport widths and heights so we can maintain the
+ ; aspect ratio, but yet make the heights or widths the same.
+ ;
+ getvalues base
+ "vpWidthF" : width1
+ "vpHeightF" : height1
+ "tiMainFontHeightF" : main_font_height1
+ end getvalues
+
+ widths = new(dimsizes(plots),float)
+ heights = new(dimsizes(plots),float)
+
+ do i=0,nplots-1
+ getvalues plots(i)
+ "vpWidthF" : widths(i)
+ "vpHeightF" : heights(i)
+ end getvalues
+ end do
+
+ mj_lengths = new(nplots,float)
+ mjo_lengths = new(nplots,float)
+ mn_lengths = new(nplots,float)
+ mno_lengths = new(nplots,float)
+ font_heights = new(nplots,float)
+
+ if(attach_y)
+ ;
+ ; If didn't find a regular base plot, then we can't do anything
+ ; about the tickmarks.
+ ;
+ if(found_base) then
+ getvalues new_base
+ "tmXBMajorLengthF" : mj_length1
+ "tmXBMajorOutwardLengthF" : mjo_length1
+ "tmXBMinorLengthF" : mn_length1
+ "tmXBMinorOutwardLengthF" : mno_length1
+ "tmXBLabelFontHeightF" : font_height1
+ end getvalues
+ end if
+
+ do i=0,nplots-1
+ ;
+ ; If didn't find a regular plot, then we can't do anything
+ ; about the tickmarks.
+ ;
+ if(found_plots(i)) then
+ getvalues new_plots(i)
+ "tmXBMajorLengthF" : mj_lengths(i)
+ "tmXBMajorOutwardLengthF" : mjo_lengths(i)
+ "tmXBMinorLengthF" : mn_lengths(i)
+ "tmXBMinorOutwardLengthF" : mno_lengths(i)
+ "tmXBLabelFontHeightF" : font_heights(i)
+ end getvalues
+ end if
+ end do
+ else
+ ;
+ ; If didn't find a regular base plot, then we can't do anything
+ ; about the tickmarks.
+ ;
+ if(found_base) then
+ getvalues new_base
+ "tmYLMajorLengthF" : mj_length1
+ "tmYLMajorOutwardLengthF" : mjo_length1
+ "tmYLMinorLengthF" : mn_length1
+ "tmYLMinorOutwardLengthF" : mno_length1
+ "tmYLLabelFontHeightF" : font_height1
+ end getvalues
+ end if
+
+ do i=0,nplots-1
+ if(found_plots(i)) then
+ getvalues new_plots(i)
+ "tmYLMajorLengthF" : mj_lengths(i)
+ "tmYLMajorOutwardLengthF" : mjo_lengths(i)
+ "tmYLMinorLengthF" : mn_lengths(i)
+ "tmYLMinorOutwardLengthF" : mno_lengths(i)
+ "tmYLLabelFontHeightF" : font_heights(i)
+ end getvalues
+ end if
+ end do
+ end if
+
+ ;
+ ; Calculate the scale factor needed to make the plots the same
+ ; size in the appropriate axis. If we are attaching plots at the Y axis,
+ ; then we want to make them the same height. Otherwise, we want to make
+ ; them the same width. We do this by keeping the size of the largest
+ ; plot the same, and scaling the rest of the plots to be the same height
+ ; (or width).
+ ;
+ scales = new(nplots,float)
+ if(attach_y) then
+ if(any(height1.lt.heights)) then
+ scale1 = max(heights)/height1
+ scales = max(heights)/heights
+ else
+ scale1 = 1.
+ scales = height1/heights
+ end if
+ else
+ if(any(width1.lt.widths)) then
+ scale1 = max(widths)/width1
+ scales = max(widths)/widths
+ else
+ scale1 = 1.
+ scales = width1/widths
+ end if
+ end if
+ ;
+ ; Because we are attaching plots along an axis, turn off
+ ; tickmarks and labels where appropriate.
+ ;
+ if(attach_y) then
+ if(found_base) then
+ setvalues new_base
+ "tmYUseLeft" : get_res_value(res1,"tmYUseLeft",False)
+ "tmYROn" : get_res_value(res1,"tmYROn",False)
+ "tmYRLabelsOn" : get_res_value(res1,"tmYRLabelsOn",False)
+ "tmYRBorderOn" : get_res_value(res1,"tmYRBorderOn",border_on)
+ end setvalues
+ end if
+ do i=0,nplots-2
+ if(found_plots(i)) then
+ setvalues new_plots(i)
+ "tmYUseLeft" : get_res_value(res2,"tmYUseLeft",False)
+ "tmYLOn" : get_res_value(res2,"tmYLOn",False)
+ "tmYLBorderOn" : get_res_value(res2,"tmYLBorderOn",border_on)
+ "tmYROn" : get_res_value(res2,"tmYROn",False)
+ "tmYRLabelsOn" : get_res_value(res2,"tmYRLabelsOn",False)
+ "tmYRBorderOn" : get_res_value(res2,"tmYRBorderOn",border_on)
+ "tiYAxisOn" : get_res_value(res2,"tiYAxisOn",False)
+ end setvalues
+ end if
+ end do
+ if(found_plots(nplots-1)) then
+ setvalues new_plots(nplots-1)
+ "tmYUseLeft" : get_res_value(res2,"tmYUseLeft",False)
+ "tiYAxisOn" : get_res_value(res2,"tiYAxisOn",False)
+ "tmYLOn" : get_res_value(res2,"tmYLOn",False)
+ "tmYLBorderOn" : get_res_value(res2,"tmYLBorderOn",border_on)
+ "tmYLLabelsOn" : get_res_value(res1,"tmYLLabelsOn",False)
+ end setvalues
+ end if
+ else
+ if(found_base) then
+ setvalues new_base
+ "tmXUseBottom" : get_res_value(res1,"tmXUseBottom",False)
+ "tmXBOn" : get_res_value(res1,"tmXBOn",False)
+ "tmXBBorderOn" : get_res_value(res1,"tmXBBorderOn",border_on)
+ "tmXBLabelsOn" : get_res_value(res1,"tmXBLabelsOn",False)
+ "tiXAxisOn" : get_res_value(res1,"tiXAxisOn",False)
+ end setvalues
+ end if
+ do i=0,nplots-2
+ if(found_plots(i)) then
+ setvalues new_plots(i)
+ "tmXUseBottom" : get_res_value(res2,"tmXUseBottom",False)
+ "tmXBOn" : get_res_value(res2,"tmXBOn",False)
+ "tmXBBorderOn" : get_res_value(res2,"tmXBBorderOn",border_on)
+ "tmXBLabelsOn" : get_res_value(res2,"tmXBLabelsOn",False)
+ "tmXTOn" : get_res_value(res2,"tmXTOn",False)
+ "tmXTBorderOn" : get_res_value(res2,"tmXTBorderOn",border_on)
+ "tmXTLabelsOn" : get_res_value(res2,"tmXTLabelsOn",False)
+ "tiMainOn" : get_res_value(res2,"tiMainOn",False)
+ "tiXAxisOn" : get_res_value(res2,"tiXAxisOn",False)
+ end setvalues
+ end if
+ end do
+ if(found_plots(nplots-1)) then
+ setvalues new_plots(nplots-1)
+ "tmXUseBottom" : get_res_value(res2,"tmXUseBottom",False)
+ "tmXTOn" : get_res_value(res2,"tmXTOn",False)
+ "tmXTBorderOn" : get_res_value(res2,"tmXTBorderOn",border_on)
+ "tmXTLabelsOn" : get_res_value(res2,"tmXTLabelsOn",False)
+ "tiMainOn" : get_res_value(res2,"tiMainOn",False)
+ end setvalues
+ end if
+ end if
+
+ ;
+ ; Now that we've turned off the tickmark stuff, retrieve the bounding box
+ ; of each plot.
+ ;
+ ; First create arrays to hold bounding box and viewport information.
+ ;
+ bbs = new((/nplots,4/),float)
+ vpxs = new((/nplots/),float)
+ vpys = new((/nplots/),float)
+ vphs = new((/nplots/),float)
+ vpws = new((/nplots/),float)
+
+ bb1 = NhlGetBB(base) ; Get bounding box of plot
+ top1 = bb1(0)
+ bot1 = bb1(1)
+ lft1 = bb1(2)
+ rgt1 = bb1(3)
+
+ ;
+ ; Have to deal with special case of only having one plot.
+ ;
+ if(nplots.eq.1)
+ bbs(0,:) = NhlGetBB(plots)
+ else
+ bbs = NhlGetBB(plots)
+ end if
+
+ tops = bbs(:,0)
+ bots = bbs(:,1)
+ lfts = bbs(:,2)
+ rgts = bbs(:,3)
+ ;
+ ; Retrieve viewports.
+ ;
+ ; Calculate the largest scale factor possible that will allow us
+ ; to fit all plots on the page, with 0.5% white space on the ends.
+ ;
+ getvalues base
+ "vpYF" : vpy1
+ "vpHeightF" : vph1
+ "vpXF" : vpx1
+ "vpWidthF" : vpw1
+ end getvalues
+
+ do i=0,nplots-1
+ getvalues plots(i)
+ "vpYF" : vpys(i)
+ "vpHeightF" : vphs(i)
+ "vpXF" : vpxs(i)
+ "vpWidthF" : vpws(i)
+ end getvalues
+ end do
+
+ if(maxbb) then
+ if(attach_y) then
+ total_height1 = top1 - bot1
+ total_heights = tops - bots
+ total_width1 = (vpx1+vpw1) - lft1
+ total_widths = vpws
+ total_widths(nplots-1) = rgts(nplots-1) - vpxs(nplots-1)
+
+ scale_widths = 1. / (1.01 * (scale1*total_width1 + sum(scales*total_widths)))
+ scale_height1 = 1. / (1.01 * scale1*total_height1)
+ scale_heights = 1. / (1.01 * scales*total_heights)
+ scale = min((/scale_height1,min(scale_heights),min(scale_widths)/))
+ else
+ total_width1 = rgt1 - lft1
+ total_widths = rgts - lfts
+ total_height1 = vph1 + (top1 - vpy1)
+ total_heights = vphs
+ total_heights(nplots-1) = vpys(nplots-1)-bots(nplots-1)
+
+ scale_heights = 1. / (1.01 * (scale1*total_height1 + sum(scales*total_heights)))
+ scale_width1 = 1. / (1.01 * scale1*total_width1)
+ scale_widths = 1. / (1.01 * scales*total_widths)
+ scale = min((/scale_width1,min(scale_heights),min(scale_widths)/))
+ end if
+ else
+ scale = 1.0
+ end if
+
+ ;
+ ; Resize all plots with new scale factor, and set sizes of tick marks
+ ; and tick marks labels to be the same.
+ ;
+ new_scale1 = scale * scale1
+ new_scales = scale * scales
+
+ if(found_base) then
+ new_mj_length = (new_scale1*mj_length1 + sum(new_scales*mj_lengths))/(nplots+1)
+ new_mjo_length = (new_scale1*mjo_length1 + sum(new_scales*mjo_lengths))/(nplots+1)
+ new_mn_length = (new_scale1*mn_length1 + sum(new_scales*mn_lengths))/(nplots+1)
+ new_mno_length = (new_scale1*mno_length1 + sum(new_scales*mno_lengths))/(nplots+1)
+ new_font_height = (new_scale1*font_height1 + sum(new_scales*font_heights))/(nplots+1)
+ else
+ new_font_height = sum(new_scales*font_heights)/nplots
+ end if
+ new_main_font_height = new_scale1*main_font_height1
+
+ if(found_base) then
+ if(attach_y) then
+ mj_length = get_res_value(res1,"tmXBMajorLengthF",new_mj_length)
+ mjo_length = get_res_value(res1,"tmXBMajorOutwardLengthF",
+ new_mjo_length)
+ mn_length = get_res_value(res1,"tmXBMinorLengthF",new_mn_length)
+ mno_length = get_res_value(res1,"tmXBMinorOutwardLengthF",
+ new_mno_length)
+ else
+ mj_length = get_res_value(res1,"tmYLMajorLengthF",new_mj_length)
+ mjo_length = get_res_value(res1,"tmYLMajorOutwardLengthF",
+ new_mjo_length)
+ mn_length = get_res_value(res1,"tmYLMinorLengthF",new_mn_length)
+ mno_length = get_res_value(res1,"tmYLMinorOutwardLengthF",
+ new_mno_length)
+ end if
+ end if
+
+ font_heightxl = get_res_value(res1,"tmXBFontHeightF",new_font_height)
+ font_heightyl = get_res_value(res1,"tmYLFontHeightF",new_font_height)
+ font_heightx = get_res_value(res1,"tiXAxisFontHeightF",new_font_height)
+ font_heighty = get_res_value(res1,"tiYAxisFontHeightF",new_font_height)
+ main_font_height = get_res_value(res2,"tiMainFontHeightF",
+ max((/new_main_font_height,new_font_height/)))
+
+ setvalues base
+ "vpHeightF" : new_scale1 * height1
+ "vpWidthF" : new_scale1 * width1
+ end setvalues
+
+ if(found_base) then
+ setvalues new_base
+ "tiXAxisFontHeightF" : font_heightx
+ "tiYAxisFontHeightF" : font_heighty
+ "tiMainFontHeightF" : main_font_height
+
+ "tmYRMajorLengthF" : mj_length
+ "tmYRMajorOutwardLengthF" : mjo_length
+ "tmYRMinorLengthF" : mn_length
+ "tmYRMinorOutwardLengthF" : mno_length
+
+ "tmYLMajorLengthF" : mj_length
+ "tmYLMajorOutwardLengthF" : mjo_length
+ "tmYLMinorLengthF" : mn_length
+ "tmYLMinorOutwardLengthF" : mno_length
+
+ "tmXBMajorLengthF" : mj_length
+ "tmXBMajorOutwardLengthF" : mjo_length
+ "tmXBMinorLengthF" : mn_length
+ "tmXBMinorOutwardLengthF" : mno_length
+
+ "tmXTMajorLengthF" : mj_length
+ "tmXTMajorOutwardLengthF" : mjo_length
+ "tmXTMinorLengthF" : mn_length
+ "tmXTMinorOutwardLengthF" : mno_length
+
+ "tmXBLabelFontHeightF" : font_heightxl
+ "tmYLLabelFontHeightF" : font_heightyl
+ end setvalues
+ end if
+
+ if(found_base) then
+ if(attach_y) then
+ mj_length = get_res_value(res2,"tmXBMajorLengthF",new_mj_length)
+ mjo_length = get_res_value(res2,"tmXBMajorOutwardLengthF",
+ new_mjo_length)
+ mn_length = get_res_value(res2,"tmXBMinorLengthF",new_mn_length)
+ mno_length = get_res_value(res2,"tmXBMinorOutwardLengthF",
+ new_mno_length)
+ else
+ mj_length = get_res_value(res2,"tmYLMajorLengthF",new_mj_length)
+ mjo_length = get_res_value(res2,"tmYLMajorOutwardLengthF",
+ new_mjo_length)
+ mn_length = get_res_value(res2,"tmYLMinorLengthF",new_mn_length)
+ mno_length = get_res_value(res2,"tmYLMinorOutwardLengthF",
+ new_mno_length)
+ end if
+ end if
+
+ font_heightxl = get_res_value(res2,"tmXBFontHeightF",new_font_height)
+ font_heightyl = get_res_value(res2,"tmYLFontHeightF",new_font_height)
+ font_heightx = get_res_value(res2,"tiXAxisFontHeightF",new_font_height)
+ font_heighty = get_res_value(res2,"tiYAxisFontHeightF",new_font_height)
+ main_font_height = get_res_value(res2,"tiMainFontHeightF",
+ max((/new_main_font_height,new_font_height/)))
+
+ do i=0,nplots-1
+ setvalues plots(i)
+ "vpHeightF" : new_scales * heights(i)
+ "vpWidthF" : new_scales * widths(i)
+ end setvalues
+
+ if(found_plots(i)) then
+ setvalues new_plots(i)
+ "tiXAxisFontHeightF" : font_heightx
+ "tiYAxisFontHeightF" : font_heighty
+ "tiMainFontHeightF" : main_font_height
+ end setvalues
+ if(found_base) then
+ setvalues new_plots(i)
+ "tmYRMajorLengthF" : mj_length
+ "tmYRMajorOutwardLengthF" : mjo_length
+ "tmYRMinorLengthF" : mn_length
+ "tmYRMinorOutwardLengthF" : mno_length
+
+ "tmYLMajorLengthF" : mj_length
+ "tmYLMajorOutwardLengthF" : mjo_length
+ "tmYLMinorLengthF" : mn_length
+ "tmYLMinorOutwardLengthF" : mno_length
+
+ "tmXBMajorLengthF" : mj_length
+ "tmXBMajorOutwardLengthF" : mjo_length
+ "tmXBMinorLengthF" : mn_length
+ "tmXBMinorOutwardLengthF" : mno_length
+
+ "tmXTMajorLengthF" : mj_length
+ "tmXTMajorOutwardLengthF" : mjo_length
+ "tmXTMinorLengthF" : mn_length
+ "tmXTMinorOutwardLengthF" : mno_length
+
+ "tmXBLabelFontHeightF" : font_heightxl
+ "tmYLLabelFontHeightF" : font_heightyl
+ end setvalues
+ end if
+ end if
+ end do
+ ;
+ ; Get new bounding boxes and sizes of resized plots, so we can
+ ; figure out where to position the base plot.
+ ;
+ bb1 = NhlGetBB(base) ; Get bounding box of plot
+
+ top1 = bb1(0)
+ bot1 = bb1(1)
+ lft1 = bb1(2)
+ rgt1 = bb1(3)
+
+ if(nplots.eq.1)
+ bbs(0,:) = NhlGetBB(plots)
+ else
+ bbs = NhlGetBB(plots)
+ end if
+ tops = bbs(:,0)
+ bots = bbs(:,1)
+ lfts = bbs(:,2)
+ rgts = bbs(:,3)
+
+ getvalues base
+ "vpYF" : vpy1
+ "vpHeightF" : vph1
+ "vpXF" : vpx1
+ "vpWidthF" : vpw1
+ end getvalues
+
+ do i=0,nplots-1
+ getvalues plots(i)
+ "vpYF" : vpys(i)
+ "vpHeightF" : vphs(i)
+ "vpXF" : vpxs(i)
+ "vpWidthF" : vpws(i)
+ end getvalues
+ end do
+
+ if(attach_y) then
+ total_height1 = top1 - bot1
+ total_heights = tops - bots
+ total_width1 = (vpx1+vpw1) - lft1
+ total_widths = vpws
+ total_widths(nplots-1) = rgts(nplots-1) - vpxs(nplots-1)
+ total_width_left = max((/0.,1. - (total_width1 + sum(total_widths))/))
+ total_height_left = max((/1. - max((/total_height1,max(total_heights)/))/))
+ else
+ total_width1 = rgt1 - lft1
+ total_widths = rgts - lfts
+ total_height1 = vph1 + (top1 - vpy1)
+ total_heights = vphs
+ total_heights(nplots-1) = vpys(nplots-1)-bots(nplots-1)
+
+ total_height_left = max((/0.,1. - (total_height1 + sum(total_heights))/))
+ total_width_left = max((/0.,1. - max((/total_width1,max(total_widths)/))/))
+ end if
+
+ new_vpx1 = total_width_left/2. + (vpx1-lft1)
+ new_vpy1 = 1. - (total_height_left/2. + (top1-vpy1))
+
+ setvalues base
+ "vpYF" : new_vpy1
+ "vpXF" : new_vpx1
+ end setvalues
+
+ ;
+ ; Attach each plot. If attaching them on the X axis, then start with
+ ; the bottommost plot. If attaching on the Y axis, start with the
+ ; rightmost plot.
+ ;
+ annos = new(nplots,graphic)
+
+ zone = get_res_value(res2,"amZone",1)
+ orth = get_res_value(res2,"amOrthogonalPosF",0.0)
+ para = get_res_value(res2,"amParallelPosF",0.5)
+
+ if(attach_y) then
+ side = get_res_value(res2,"amSide","Right")
+ just = get_res_value(res2,"amJust","CenterLeft")
+ else
+ side = get_res_value(res2,"amSide","Bottom")
+ just = get_res_value(res2,"amJust","TopCenter")
+ end if
+
+ do i=nplots-1,0,1
+ if(i.gt.0) then
+ annos(i) = NhlAddAnnotation(plots(i-1),plots(i))
+ else
+ annos(0) = NhlAddAnnotation(base,plots(0))
+ end if
+ setvalues annos(i)
+ "amZone" : zone
+ "amJust" : just
+ "amSide" : side
+ "amResizeNotify" : True ; Allow resize if plot resized.
+ "amParallelPosF" : para
+ "amOrthogonalPosF": orth
+ end setvalues
+ end do
+
+ ;---The plot does not get drawn in this function!
+ wks = NhlGetParentWorkstation(base)
+ draw_and_frame(wks,base,False,False,0,maxbb)
+
+ return(annos)
+ end
+
+ ;***********************************************************************;
+ ; Function : get_rgb_values ;
+ ; named_colors: string array of named colors ;
+ ; ;
+ ; This is a deprecated function. Use namedcolor2rgb instead. ;
+ ;***********************************************************************;
+ undef("get_rgb_values")
+ function get_rgb_values(named_colors)
+ begin
+ print("get_rgb_values: this function is deprecated.")
+ print(" Use 'namedcolor2rgb' instead.")
+ return(namedcolor2rgb(named_colors))
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : gsn_define_colormap ;
+ ; wks: workstation object ;
+ ; cmap: Colormap ;
+ ; ;
+ ; This procedure defines a color map for workstation "wks" (the ;
+ ; variable returned from a previous call to "gsn_open_wks") using float ;
+ ; RGB values or a pre-defined color name. ;
+ ;***********************************************************************;
+ undef("gsn_define_colormap")
+ procedure gsn_define_colormap(wks:graphic, cmap)
+ begin
+ dim_cmap = dimsizes(cmap)
+ if((typeof(cmap).eq."float".and.(dimsizes(dim_cmap).ne.2.or.
+ dim_cmap(1).ne.3)).or.
+ (typeof(cmap).eq."string".and.dimsizes(dim_cmap).ne.1))
+ print("Warning: gsn_define_colormap: cmap must either be an n x 3 float array,")
+ print("a single pre-defined colormap name, or a 1-dimensional string array of named colors.")
+ else
+ setvalues wks
+ "wkColorMap" : cmap
+ end setvalues
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_retrieve_colormap ;
+ ; wks: workstation object ;
+ ; ;
+ ; This function retrieves the current color map in use for workstation ;
+ ; "wks". "wks is the workstation id returned from a call to ;
+ ; gsn_open_wks. The return variable will be an n x 3 array, where n is ;
+ ; the number of colors, and the 3 represents the R, G, and B values. ;
+ ;***********************************************************************;
+ undef("gsn_retrieve_colormap")
+ function gsn_retrieve_colormap(wks:graphic)
+ begin
+ getvalues wks
+ "wkColorMap" : cmap
+ end getvalues
+
+ return(cmap)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_reverse_colormap ;
+ ; wks: workstation object ;
+ ; ;
+ ; This function reverses the current color map in use for workstation ;
+ ; "wks". The foregound/background colors will stay the same. ;
+ ;***********************************************************************;
+ undef("gsn_reverse_colormap")
+ procedure gsn_reverse_colormap(wks:graphic)
+ begin
+ getvalues wks
+ "wkColorMap" : cmap
+ end getvalues
+ cmap(2:,:) = cmap(2::-1,:) ; reverse (exclude fore/back)
+ gsn_define_colormap (wks, cmap)
+ return
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_merge_colormaps ;
+ ; wks: workstation object ;
+ ; cmap1: colormap ;
+ ; cmap2: colormap ;
+ ; ;
+ ; This procedure two colormaps into one, and then sets the workstaion ;
+ ; to use this new colormap. If the merged colormaps exceed 255 colors, ;
+ ; then only the first 255 colors will be used. ;
+ ; ;
+ ; Both cmaps must either be an n x 3 float array, an array of color ;
+ ; names, or a single string representing a pre-defined colormap name. ;
+ ; Each colormap is assumed to have its own background/foreground color, ;
+ ; so the first two colors of the second color map are not included in ;
+ ; the new color map. ;
+ ;***********************************************************************;
+ undef("gsn_merge_colormaps")
+ procedure gsn_merge_colormaps(wks:graphic,cmap1,cmap2)
+ local dim_cmap1, dim_cmap2, new_cmap1, new_cmap2, len_cmap1, len_cmap2
+ begin
+ dim_cmap1 = dimsizes(cmap1)
+ dim_cmap2 = dimsizes(cmap2)
+ ;
+ ; Error checking.
+ ;
+ if((typeof(cmap1).eq."float".and.(dimsizes(dim_cmap1).ne.2.or.
+ dim_cmap1(1).ne.3)).or.
+ (typeof(cmap1).eq."string".and.dimsizes(dim_cmap1).ne.1))
+ print("Warning: gsn_merge_colormaps: cmap1 must either be an n x 3 float array,")
+ print("a single pre-defined colormap name, or a 1-dimensional string array of named colors.")
+ end if
+
+ if((typeof(cmap2).eq."float".and.(dimsizes(dim_cmap2).ne.2.or.
+ dim_cmap2(1).ne.3)).or.
+ (typeof(cmap2).eq."string".and.dimsizes(dim_cmap2).ne.1))
+ print("Warning: gsn_merge_colormaps: cmap2 must either be an n x 3 float array,")
+ print("a single pre-defined colormap name, or a 1-dimensional string array of named colors.")
+ end if
+
+ ;
+ ; Get first colormap in RGB values, and include background and
+ ; foreground colors.
+ ;
+ if(typeof(cmap1).eq."float") then
+ new_cmap1 = cmap1
+ else
+ gsn_define_colormap(wks,cmap1)
+ new_cmap1 = gsn_retrieve_colormap(wks)
+ end if
+ len_cmap1 = dimsizes(new_cmap1(:,0))
+
+ ;
+ ; Get second colormap in RGB values, and ignore background and
+ ; foreground colors.
+ ;
+ if(typeof(cmap2).eq."float") then
+ len_cmap2 = dimsizes(cmap2(:,0)) - 2
+ if(len_cmap2.gt.0) then
+ new_cmap2 = cmap2(2:,:)
+ else
+ len_cmap2 = 0
+ end if
+ else
+ ;
+ ; Test if the strings are named colors or a color map.
+ ; If it's a color map, then we will drop the foreground/background
+ ; colors and only append colors 2 and on. If it is named colors,
+ ; then we'll append all of the named colors.
+ ;
+ if(all(is_valid_named_colors(cmap2))) then
+ rgb_values = namedcolor2rgb(cmap2)
+ indices = ind(.not.ismissing(rgb_values(:,0)))
+ new_cmap2 = new((/dimsizes(indices),3/),"float")
+ new_cmap2(:,0) = rgb_values(indices,0) ; Must be named colors.
+ new_cmap2(:,1) = rgb_values(indices,1)
+ new_cmap2(:,2) = rgb_values(indices,2)
+ delete([/indices,rgb_values/])
+ else
+ gsn_define_colormap(wks,cmap2) ; Must be a color map name.
+ tmp_cmap2 = gsn_retrieve_colormap(wks)
+ new_cmap2 = tmp_cmap2(2:,:)
+ delete(tmp_cmap2)
+ end if
+ len_cmap2 = dimsizes(new_cmap2(:,0))
+ end if
+
+ ;
+ ; Make sure two colormaps don't total more than 256 colors.
+ ;
+ if(len_cmap1.ge.256) then
+ len_cmap1 = 256
+ len_cmap2 = 0
+ else
+ if( (len_cmap1+len_cmap2).gt.256 ) then
+ len_cmap2 = 256-len_cmap1
+ end if
+ end if
+ ;
+ ; Create new merged colormap.
+ ;
+ len_cmap = len_cmap1+len_cmap2
+ new_cmap = new((/len_cmap,3/),float)
+
+ new_cmap(0:len_cmap1-1,:) = new_cmap1(0:len_cmap1-1,:)
+ if(len_cmap2.gt.0)
+ new_cmap(len_cmap1:,:) = new_cmap2(0:len_cmap2-1,:)
+ end if
+
+ gsn_define_colormap(wks,new_cmap)
+ end
+
+ ;***********************************************************************;
+ ; Function : scalar_field ;
+ ; sfname : string ;
+ ; data : numeric ;
+ ; res : logical ;
+ ; ;
+ ; This function creates a scalarField or meshScalarField object. ;
+ ;***********************************************************************;
+ undef("scalar_field")
+ function scalar_field(sfname:string,data:numeric,res2:logical)
+ local dims, rank
+ begin
+ ;
+ ; Check input data. If it is 2D, then create a scalar field.
+ ; If it is 1D, then it must have coordinate arrays the same length.
+ ;
+ dims = dimsizes(data)
+ rank = dimsizes(dims)
+ if(rank.ne.1.and.rank.ne.2) then
+ print("Error: scalar_field: The input data must either be 1-dimensional or 2-dimensional")
+ dum = new(1,graphic)
+ return(dum)
+ end if
+
+ ;
+ ; Get sf resources.
+ ;
+ if(rank.eq.2) then
+
+ ; Create the data object; also, check for a missing value and
+ ; set during the create call (if you don't do this, then if the
+ ; user's happens by freak chance to have a constant field of
+ ; missing values, it will choke.
+
+ if(isatt(data,"_FillValue")) then
+ ;
+ ; We need to check for stride, because if we have a case where
+ ; we are creating a scalar field that will be used with the vector
+ ; field, and we are setting the stride for both via setvalues rather
+ ; than during a create call, then at some point the sizes of the
+ ; vector and scalar fields will be different and you will get a
+ ; warning message:
+ ;
+ ; warning:VectorPlotSetValues: ignoring vcScalarFieldData: size does
+ ; not match vcVectorFieldData
+ ;
+ if(isatt(res2,"sfXCStride").and.isatt(res2,"sfYCStride")) then
+ data_object = create sfname scalarFieldClass noparent
+ "sfMissingValueV" : data at _FillValue
+ "sfDataArray" : data
+ "sfXCStride" : get_res_value(res2,"sfXCStride",1)
+ "sfYCStride" : get_res_value(res2,"sfYCStride",1)
+ end create
+ else
+ data_object = create sfname scalarFieldClass noparent
+ "sfMissingValueV" : data at _FillValue
+ "sfDataArray" : data
+ end create
+ end if
+ else
+ if(isatt(res2,"sfXCStride").and.isatt(res2,"sfYCStride")) then
+ data_object = create sfname scalarFieldClass noparent
+ "sfDataArray" : data
+ "sfXCStride" : get_res_value(res2,"sfXCStride",1)
+ "sfYCStride" : get_res_value(res2,"sfYCStride",1)
+ end create
+ else
+ data_object = create sfname scalarFieldClass noparent
+ "sfDataArray" : data
+ end create
+ end if
+ end if
+ else
+ ;
+ ; Rank is 1. This means we have to use the mesh scalar object.
+ ; Make sure sfXArray and sfYArray have been set.
+ ;
+ if(isatt(res2,"sfXArray").and.isatt(res2,"sfYArray")) then
+ ;
+ ; Create the data object.
+ ;
+ if(isatt(data,"_FillValue")) then
+ data_object = create sfname meshScalarFieldClass noparent
+ "sfDataArray" : data
+ "sfMissingValueV" : data at _FillValue
+ "sfXArray" : get_res_value(res2,"sfXArray",1)
+ "sfYArray" : get_res_value(res2,"sfYArray",1)
+ end create
+ else
+ data_object = create sfname meshScalarFieldClass noparent
+ "sfDataArray" : data
+ "sfXArray" : get_res_value(res2,"sfXArray",1)
+ "sfYArray" : get_res_value(res2,"sfYArray",1)
+ end create
+ end if
+ else
+ print("Error: scalar_field: If the input data is 1-dimensional, you must set sfXArray and sfYArray to 1-dimensional arrays of the same length.")
+ dum = new(1,graphic)
+ return(dum)
+ end if
+ end if
+
+ return(data_object)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : vector_field ;
+ ; name : string ;
+ ; u : numeric ;
+ ; v : numeric ;
+ ; res : logical ;
+ ; ;
+ ; This function creates a vectorField object. ;
+ ;***********************************************************************;
+ undef("vector_field")
+ function vector_field(vfname:string,u:numeric,v:numeric,res2:logical)
+ begin
+ ;
+ ; We need to check for stride, because if we have a case where
+ ; we are creating a scalar field that will be used with the vector
+ ; field, and we are setting the stride for both via setvalues rather
+ ; than during a create call, then at some point the sizes of the
+ ; vector and scalar fields will be different and you will get a
+ ; warning message:
+ ;
+ ; warning:VectorPlotSetValues: ignoring vcScalarFieldData: size does
+ ; not match vcVectorFieldData
+ ;
+ if(isatt(res2,"vfXCStride").and.isatt(res2,"vfYCStride")) then
+ data_object = create vfname vectorFieldClass noparent
+ "vfUDataArray" : u
+ "vfVDataArray" : v
+ "vfXCStride" : get_res_value(res2,"vfXCStride",1)
+ "vfYCStride" : get_res_value(res2,"vfYCStride",1)
+ end create
+ else
+ data_object = create vfname vectorFieldClass noparent
+ "vfUDataArray" : u
+ "vfVDataArray" : v
+ end create
+ end if
+
+ ; Check for missing values.
+
+ if(isatt(u,"_FillValue")) then
+ setvalues data_object
+ "vfMissingUValueV" : u at _FillValue
+ end setvalues
+ end if
+ if(isatt(v,"_FillValue")) then
+ setvalues data_object
+ "vfMissingVValueV" : v at _FillValue
+ end setvalues
+ end if
+
+ return(data_object)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : hist_columns ;
+ ; wks: workstation object ;
+ ; xy: graphic ;
+ ; binvalues: numeric ;
+ ; barlocs: numeric ;
+ ; barwidth: numeric ;
+ ; colors ;
+ ; compare: logical ;
+ ; gsres: logical ;
+ ; ;
+ ; xy - xy plot id to draw columns on ;
+ ; bins - the center of each bin range. ;
+ ; binvalues - the number of values in the corresponding bin ;
+ ; barlocs - the start of the first bar in each bin ;
+ ; width - the width of the bar ;
+ ; colors - array of colors to use (ints or color names) ;
+ ; gsres - optional primitive resources ;
+ ; ;
+ ; This function creates the columns for a histogram plot. The Y axis ;
+ ; will represent the number of values in a bin and a percentage. ;
+ ; ;
+ ;***********************************************************************;
+ undef("hist_columns")
+ function hist_columns(wks[1]:graphic,xy[1]:graphic,binvalues:numeric,
+ barlocs[*][*]:numeric, barwidth[*]:numeric,
+ colors, compare:logical, gsres:logical)
+ local i, nbins, dims, nbinvalues, gsres, xpoints, ypoints, multibars,
+ col_dims, col_rank
+ begin
+ dims = dimsizes(barlocs)
+ nbarsinbin = dims(0)
+ nbars = dims(1)
+ delete(dims)
+
+ dims = dimsizes(binvalues)
+ if(dimsizes(dims).eq.1) then
+ nbinvalues = dims(0)
+ else
+ nbinvalues = dims(1)
+ end if
+ delete(dims)
+ if(nbars.ne.nbinvalues) then
+ print("Error: hist_columns: Dimension sizes of bins (" + nbars+ ") and binvalues (" + nbinvalues + ") must be the same")
+ return
+ end if
+
+ if(nbarsinbin.ge.2)
+ multibars = True
+ else
+ multibars = False
+ end if
+
+ ;
+ ; Set up arrays to hold polygon points.
+ ;
+ if(multibars) then
+ xpoints = new((/nbarsinbin,nbars,5/),float)
+ ypoints = new((/nbarsinbin,nbars,5/),float)
+ polygons = new((/nbarsinbin,nbars/),graphic)
+ else
+ xpoints = new((/nbars,5/),float)
+ ypoints = new((/nbars,5/),float)
+ polygons = new(nbars,graphic)
+ end if
+ ;
+ ; Set up variable to hold resources.
+ ;
+ gsres = True
+ set_attr(gsres,"gsEdgesOn",True)
+ ;
+ ; Begin assigning polygon points.
+ ;
+ if(multibars)
+ do i=0,nbarsinbin-1
+ ypoints(i,:,0) = (/0/)
+ ypoints(i,:,1) = (/binvalues(i,:)/)
+ ypoints(i,:,2) = (/ypoints(i,:,1)/)
+ ypoints(i,:,3) = (/0/)
+ ypoints(i,:,4) = (/0/)
+
+ xpoints(i,:,0) = (/barlocs(i,:)/)
+ xpoints(i,:,1) = (/xpoints(i,:,0)/)
+ xpoints(i,:,2) = (/barlocs(i,:) + barwidth/)
+ xpoints(i,:,3) = (/xpoints(i,:,2)/)
+ xpoints(i,:,4) = (/xpoints(i,:,0)/)
+ end do
+ else
+ ypoints(:,0) = (/0/)
+ ypoints(:,1) = (/binvalues/)
+ ypoints(:,2) = (/ypoints(:,1)/)
+ ypoints(:,3) = (/0/)
+ ypoints(:,4) = (/0/)
+
+ xpoints(:,0) = (/barlocs(0,:)/)
+ xpoints(:,1) = (/xpoints(:,0)/)
+ xpoints(:,2) = (/barlocs(0,:) + barwidth/)
+ xpoints(:,3) = (/xpoints(:,2)/)
+ xpoints(:,4) = (/xpoints(:,0)/)
+ end if
+
+ if(compare)
+ fillindex = get_res_value(gsres,"gsFillIndex",(/0,6/))
+ else
+ if(multibars) then
+ fillindex = get_res_value(gsres,"gsFillIndex",0)
+ if(dimsizes(dimsizes(fillindex)).eq.1) then
+ ftmp = new(nbarsinbin,typeof(fillindex))
+ ftmp = fillindex
+ delete(fillindex)
+ fillindex = ftmp
+ delete(ftmp)
+ end if
+ else
+ fillindex = get_res_value(gsres,"gsFillIndex",0)
+ end if
+ end if
+ ;
+ ; Make sure fill indices are between 0 and 17.
+ ; No more, because you have have added your own fill index.
+ ;
+ ; fillindex = min((/max((/max(fillindex),0/)),17/))
+
+ col_dims = dimsizes(colors)
+ col_rank = dimsizes(col_dims)
+ ncolors = col_dims(0)
+ do i = 0, nbars - 1
+ if(col_rank.eq.1) then
+ gsres at gsFillColor = colors(i % ncolors)
+ else
+ gsres at gsFillColor = colors(i % ncolors,:)
+ end if
+ if(multibars)
+ ;
+ ; Add the remaining histogram bars first, so that they will be drawn
+ ; second. The first histogram bars will thus be drawn on top, if
+ ; they are being stacked.
+ ;
+ do j=nbarsinbin-1,0,1
+ gsres at gsFillIndex = fillindex(j)
+ if(binvalues at horizontal) then
+ polygons(j,i) = gsn_add_polygon(wks,xy,ypoints(j,i,:),
+ xpoints(j,i,:), gsres)
+ else
+ polygons(j,i) = gsn_add_polygon(wks,xy,xpoints(j,i,:),
+ ypoints(j,i,:), gsres)
+ end if
+ end do
+ else
+ gsres at gsFillIndex = fillindex
+ if(binvalues at horizontal) then
+ polygons(i) = gsn_add_polygon(wks,xy,ypoints(i,:),xpoints(i,:),gsres)
+ else
+ polygons(i) = gsn_add_polygon(wks,xy,xpoints(i,:),ypoints(i,:),gsres)
+ end if
+ end if
+ end do
+ ;
+ ; Return the polygons created as attributes of the XY plot. This is
+ ; necessary, b/c otherwise the polygons will go away when you exit the
+ ; function.
+ ;
+ var_string = unique_string("hpolygons")
+ xy@$var_string$ = polygons
+ return(xy)
+ end
+
+ ;***********************************************************************;
+ ; Function : compute_hist_vals ;
+ ; x: numeric or string ;
+ ; binlocs: numeric or string ;
+ ; nbinlocs: integer ;
+ ; bin_width: numeric ;
+ ; setinterval: logical ;
+ ; setdiscrete: integer ;
+ ; minmaxbins: logical ;
+ ; count_msg: logical ;
+ ; isnice: integer ;
+ ; compare: integer ;
+ ; sidebyside: integer ;
+ ; ;
+ ; By default, this routine calculates a nice set of ranges for "binning";
+ ; the given data. The following cases are possible: ;
+ ; ;
+ ; 1. If setinterval is True, then the user has set their own bin ;
+ ; intervals via either the gsnHistogramBinIntervals or the ;
+ ; gsnHistogramClassIntervals resource (stored in binlocs array). ;
+ ; ;
+ ; 2. If setdiscrete is True, then the user has set discrete bin values ;
+ ; via the gsnHistogramDiscreteBinValues resource (stored in ;
+ ; "binlocs" array). ;
+ ; ;
+ ; 3. If neither setinterval or setdiscrete is True, and if the resource ;
+ ; gsnHistogramBinWidth is set, then its value will be used as a bin ;
+ ; width (bin_width). By default, bin_width will only be used as an ;
+ ; approximate value, because it attempts to select "nice" values ;
+ ; based on a width close to bin_width. If the resource ;
+ ; gsnHistogramSelectNiceIntervals (isnice) is set to False, then ;
+ ; you will get a bin width exactly equal to bin_width. ;
+ ; ;
+ ; 4. If neither setinterval or setdiscrete is True, and if the resource ;
+ ; gsnHistogramNumberOfBins is set, then its value (nbinlocs) will be ;
+ ; used to determine the number of bins. By default, nbinlocs is only ;
+ ; used as an approximate value, because it attempts to select "nice" ;
+ ; values based on a number of bins close to nbinlocs. If the ;
+ ; resource gsnHistogramSelectNiceIntervals (isnice) is set to False, ;
+ ; then you will get a number of bins exactly equal to nbinlocs. ;
+ ; ;
+ ; 5. If no special resources are set, then this routine defaults to ;
+ ; calculating approximately 10 "nice" bin intervals, based on the ;
+ ; range of the data. ;
+ ; ;
+ ;***********************************************************************;
+ undef("compute_hist_vals")
+ function compute_hist_vals(xx,binlocs,nbinlocs[1]:integer,
+ bin_width:numeric,setinterval:logical,
+ setdiscrete:logical, minmaxbins:logical,
+ count_msg:logical,isnice:logical,
+ compare:logical,sidebyside:logical)
+ local xmin, xmax, new_binlocs, nbars, buckets, x, i
+ begin
+ if(isnumeric(xx)) then
+ xmin = tofloat(min(xx))
+ xmax = tofloat(max(xx))
+ end if
+
+ ;
+ ; If the bins are set, need to determine if you want to have the bins
+ ; represent ranges of values or discrete values.
+ ;
+ if(setdiscrete) then
+ new_binlocs = binlocs
+ nbars = dimsizes(new_binlocs) ; # of bars equals # of binlocs
+ nsets = dimsizes(new_binlocs) ; # of bars equals # of binlocs
+ else
+ ;
+ ; Check if range values have been set by user, or if we need to
+ ; calculate them.
+ ;
+ if(setinterval) then
+ new_binlocs = binlocs
+ else
+ if(nbinlocs.lt.0) then
+ if(bin_width.lt.0.) then
+ nbinlocs = 10 ; Default to 10 bin locations.
+ else
+ nbinlocs = floattointeger(((xmax - xmin)/bin_width))
+ if(nbinlocs.le.0) then
+ print("Warning: compute_hist_vals: cannot use given bin width. Defaulting...")
+ nbinlocs = 10
+ end if
+ end if
+ end if
+ if(.not.setdiscrete) then
+ if(isnice) then
+ ;
+ ; Based on min and max of data, compute a new min/max/step that will
+ ; give us "nice" bin values.
+ ;
+ nicevals = nice_mnmxintvl(xmin,xmax,nbinlocs,True)
+ nvals = floattoint((nicevals(1) - nicevals(0))/nicevals(2) + 1)
+ new_binlocs = fspan(nicevals(0),nicevals(1),nvals)
+ else
+ ;
+ ; Don't bother with "nice" values; just span the data.
+ ;
+ new_binlocs = fspan(xmin,xmax,nbinlocs+1)
+ end if
+ end if
+ end if
+ nbars = dimsizes(new_binlocs)-1
+ end if
+ ;
+ ; Count number of values in a particular bin range, or exactly
+ ; equal to a bin value if discrete.
+ ;
+ if(compare.or.sidebyside) then
+ dims = dimsizes(xx)
+ nsets = dims(0)
+ npts = dims(1)
+ x = xx
+ else
+ nsets = 1
+ npts = dimsizes(xx)
+ x = new((/1,npts/),typeof(xx))
+ x(0,:) = xx
+ end if
+
+ ;
+ ; Set up variable to hold binned values. Binned values can have
+ ; unequal spacing.
+ ;
+ num_in_bins = new((/nsets,nbars/),integer)
+ ;
+ ; Count the values in each discrete bin.
+ ;
+ if(setdiscrete) then
+ do j = 0,nsets-1
+ do i = 0, nbars-1
+ num_in_bins(j,i) = num(x(j,:).eq.new_binlocs(i))
+ end do
+ end do
+ else
+ ;
+ ; Count the values in each bin interval. Bin intervals can be
+ ; of length 0, meaning an exact count is done.
+ ;
+ do j = 0,nsets-1
+ do i = 0, nbars-1
+ if(new_binlocs(i).eq.new_binlocs(i+1)) then
+ num_in_bins(j,i) = num(x(j,:).eq.new_binlocs(i))
+ else
+ ;
+ ; Special tests for last interval are required.
+ ;
+ if(i.eq.(nbars-1)) then
+ if(nbars.gt.1.and.new_binlocs(i).eq.new_binlocs(i-1)) then
+ num_in_bins(j,i) = num(x(j,:).gt.new_binlocs(i).and.
+ x(j,:).le.new_binlocs(i+1))
+ else
+ num_in_bins(j,i) = num(x(j,:).ge.new_binlocs(i).and.
+ x(j,:).le.new_binlocs(i+1))
+ end if
+ else
+ ;
+ ; If the previous interval was not really an interval, but an exact
+ ; bin value, then be careful not to count those values in the current
+ ; interval.
+ ;
+ if(i.gt.0.and.new_binlocs(i).eq.new_binlocs(i-1)) then
+ num_in_bins(j,i) = num(x(j,:).gt.new_binlocs(i).and.
+ x(j,:).lt.new_binlocs(i+1))
+ else
+ num_in_bins(j,i) = num(x(j,:).ge.new_binlocs(i).and.
+ x(j,:).lt.new_binlocs(i+1))
+ end if
+ end if
+ end if
+ end do
+ end do
+ end if
+ ;
+ ; If minmaxbins is True, then we need to also count the values
+ ; outside the range of our new_binlocs.
+ ;
+ if(minmaxbins) then
+ new_num_in_bins = new((/nsets,nbars+2/),integer)
+ new_num_in_bins(:,1:nbars) = num_in_bins
+ do j = 0,nsets-1
+ new_num_in_bins(j,0) = num(x(j,:).lt.new_binlocs(0))
+ new_num_in_bins(j,nbars+1) = num(x(j,:).gt.new_binlocs(nbars))
+ end do
+ delete(num_in_bins)
+ num_in_bins = new_num_in_bins
+ delete(new_num_in_bins)
+ nbars = nbars + 2
+ end if
+ ;
+ ; Count number of missing values.
+ ;
+ num_missing = new(nsets,integer)
+ if(isatt(x,"_FillValue")) then
+ do j = 0,nsets-1
+ num_missing(j) = num(ismissing(x(j,:)))
+ end do
+ else
+ num_missing = 0
+ end if
+ ;
+ ; If count_msg is True, then we need to bin the number of missing values.
+ ;
+ if(count_msg) then
+ new_num_in_bins = new((/nsets,nbars+1/),integer)
+ new_num_in_bins(:,0:nbars-1) = num_in_bins
+ new_num_in_bins(:,nbars) = num_missing
+
+ delete(num_in_bins)
+ num_in_bins = new_num_in_bins
+ delete(new_num_in_bins)
+ nbars = nbars + 1
+ end if
+
+ ;
+ ; Calculate percentages, both with and without missing points included.
+ ;
+ npts_nomiss = npts - num_missing
+
+ if(compare.or.sidebyside) then
+ percs = (100.*num_in_bins)/tofloat(npts)
+ percs_nomiss = new((/nsets,nbars/),float)
+ do i=0,nsets-1
+ percs_nomiss(i,:) = (100.*num_in_bins(i,:))/tofloat(npts_nomiss(i))
+ end do
+ else
+ percs = (100.*num_in_bins(0,:))/tofloat(npts)
+ percs_nomiss = (100.*num_in_bins(0,:))/tofloat(npts_nomiss)
+ end if
+ ;
+ ; Return information.
+ ;
+ num_in_bins at NumMissing = num_missing
+ num_in_bins at binlocs = new_binlocs
+ num_in_bins at percentages = percs
+ num_in_bins at percentages_nm = percs_nomiss
+
+ delete(x)
+ if(compare.or.sidebyside) then
+ return(num_in_bins)
+ else
+ return(num_in_bins(0,:))
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_histogram ;
+ ; wks: workstation object ;
+ ; xdata: numeric or string ;
+ ; res: resources ;
+ ; ;
+ ; This function draws a histogram plot. The user can enter the bin ;
+ ; ranges, discrete bin values, or let this function calculate ones ;
+ ; automatically. This function will also compare multiple sets of ;
+ ; histograms. If xdata is a string, then you must be using ;
+ ; discrete values, and not ranges. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnHistogramNumberOfBins - Indicates number of bin intervals you ;
+ ; want. The default is around 10. ;
+ ; ;
+ ; gsnHistogramBinWidth - Instead of indicating number of bins, you can ;
+ ; specify a bin width. Depending on whether SelectNiceIntervals ;
+ ; is set to True, you will either get exactly bins of this size, ;
+ ; or approximately this size. ;
+ ; ;
+ ; gsnHistogramBarWidthPercent - This indicates the percentage of the ;
+ ; the bin width that the bar width should be. The default is 66% ;
+ ; for single histograms, and 50% for comparison. ;
+ ; ;
+ ; gsnHistogramSelectNiceIntervals - Indicates whether we want ;
+ ; gsn_histogram to select "nice" range values. Default is True. ;
+ ; ;
+ ; gsnHistogramComputePercentages - If True, then percentage values ;
+ ; will be put on right (top) axis. Default is False. ;
+ ; ;
+ ; gsnHistogramComputePercentagesNoMissing - If True, percentage values ;
+ ; will be put on the right (top) axis, and the number of missing ;
+ ; values will be subtracted from the total number of values ;
+ ; before the percentages are calculated. ;
+ ; ;
+ ; gsnHistogramPercentSign - If True, then a percent sign (%) is used on;
+ ; the percentage axis. ;
+ ; ;
+ ; gsnHistogramClassIntervals - By default, gsn_histogram will pick the ;
+ ; bin class intervals for you. If you set this, then it will use ;
+ ; these values for the bin ranges. ;
+ ; ;
+ ; gsnHistogramBinIntervals - Same as gsnHistogramClassIntervals. ;
+ ; ;
+ ; gsnHistogramMinMaxBinsOn - If this is True, then two extra bins will ;
+ ; be added that count all the values less than the smallest bin, ;
+ ; and greater than the largest bin. This resource can only be ;
+ ; used when BinIntervals or ClassIntervals are set. ;
+ ; ;
+ ; gsnHistogramDiscreteClassValues - By default, gsn_histogram will bin ;
+ ; your data into ranges. If you set this resource, then your data;
+ ; is assumed to already be "binned", and it just counts the number;
+ ; of values exactly equal to the discrete values. ;
+ ; ;
+ ; gsnHistogramDiscreteBinValues - Same as ;
+ ; gsnHistogramDiscreteClassValues. ;
+ ; ;
+ ; gsnHistogramCompare - Compare two fields. ;
+ ; ;
+ ; gsnHistogramHorizontal - Draw horizontal bars. Default is False ;
+ ; ;
+ ; The number of missing values counted is returned as an attribute ;
+ ; called "NumMissing". ;
+ ; ;
+ ; This function does the following: ;
+ ; ;
+ ; 1. Sets/retrieves all of the special "gsn" resource allowed and ;
+ ; checks validity of data. ;
+ ; 2. Calls "compute_hist_vals" to calculate bins (if not specified by ;
+ ; user) and count number of values in each bin range, or equal to ;
+ ; each discrete bin value. ;
+ ; 3. Count number of bin locations and bars. ;
+ ; 4. Calculate width of bins and bars in each bin. ;
+ ; 5. Figure out color indices to use for bar colors. ;
+ ; 6. Calculate axis limits for plot, and create plot. ;
+ ; 7. Set some post-resources for labeling the percentage axis. ;
+ ; 8. Set some post-resources for labeling the other axis. ;
+ ; 9. Set some post-resources for labeling the axis that indicates the ;
+ ; bin ranges or discrete values. ;
+ ;10. Apply resources set by user. ;
+ ;11. Calculate starting locations of each bar. ;
+ ;12. Add a percent label, if there is one. ;
+ ;13. Force tickmarks to point outward. ;
+ ;14. Create histogram. ;
+ ;15. Draw and advance frame. ;
+ ;16. Return histogram information. ;
+ ;***********************************************************************;
+ undef("gsn_histogram")
+ function gsn_histogram(wks[1]:graphic,xdata, resources:logical)
+ local res2, calldraw, callframe, maxbb, ispercent, bins, nbars,
+ setdiscrete, setinterval,top, bottom, left, right, lenc, tmp,
+ colors, locs, lbs, compare
+ begin
+ dummy = new(1,graphic) ; Dummy graphic to return if things go wrong.
+ ;
+ ; 1. Retrieve special resources.
+ ;
+ res2 = get_resources(resources)
+
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(xdata,new(1,float),new(1,float),"gsn_histogram",
+ res2,1)
+ end if
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ nbins = get_res_value(res2,"gsnHistogramNumberOfBins",-1)
+ xbin_width = get_res_value(res2,"gsnHistogramBinWidth",-1)
+ minmaxbins = get_res_value(res2,"gsnHistogramMinMaxBinsOn",False)
+ count_msg = get_res_value(res2,"gsnHistogramBinMissing",False)
+ perc_nomiss= get_res_value(res2,"gsnHistogramComputePercentagesNoMissing",False)
+ ispercent = get_res_value(res2,"gsnHistogramComputePercentages",perc_nomiss)
+ percentsign= get_res_value(res2,"gsnHistogramPercentSign",False)
+ isnice = get_res_value(res2,"gsnHistogramSelectNiceIntervals",True)
+ compare = get_res_value(res2,"gsnHistogramCompare",False)
+ sidebyside = get_res_value(res2,"gsnHistogramSideBySide",False)
+ horizontal = get_res_value(res2,"gsnHistogramHorizontal",False)
+ bar_spc_perc = get_res_value(res2,"gsnHistogramBarSpacingPercent",0.)
+
+ setdiscrete= False
+ setinterval= False
+ ;
+ ; xdata can be nD. The left most dimension indicates the number of bars
+ ; per bin, and the rightmost dimension the data values.
+
+ ; In the case where the leftmost dimension is 2, there's
+ ; the special case of "comparing" histograms - that is, the bars
+ ; will be stacked (gsnHistogramCompare = True)
+ ;
+ ; If the leftmost dimension is > 2, then the bars will be
+ ; side by side (sidebyside = True).
+ ;
+
+ ;
+ ; Also, if gsnHistogramCompare is set to True, then
+ ; double-check that data is correct size.
+ ;
+ dims = dimsizes(xdata)
+ rank = dimsizes(dims)
+ if(rank.eq.1) then
+ nbars_per_bin = 1
+ else
+ nbars_per_bin = dims(0)
+ end if
+
+ ;
+ ; If comparing two fields, then first dimension must be two.
+ ;
+ if(compare) then
+ if(nbars_per_bin.ne.2.or.rank.eq.1) then
+ print("Error: gsn_histogram: If comparing two fields, then you must input a 2D array dimensioned 2 x npts.")
+ print("No plot will be drawn.")
+ return(dummy)
+ end if
+ else
+ if(rank.eq.2.and.dims(0).eq.2) then
+ if(.not.sidebyside) then
+ print("gsn_histogram: You input a 2D array dimensioned 2 x npts, so will go into compare mode.")
+ compare = True
+ end if
+ end if
+ end if
+
+ ;
+ ; If you have > 2 leftmost dimensions, then we are in "side-by-side" mode.
+ ;
+ if(rank.gt.1.and..not.compare) then
+ sidebyside = True
+ end if
+ ;
+ ; Calculate the percentage of the bin width that the bar width should
+ ; be.
+ ;
+ if(compare) then
+ bar_wdt_perc = 0.5
+ else
+ if(sidebyside) then
+ bar_wdt_perc = 1./(nbars_per_bin+1)
+ else
+ bar_wdt_perc = 0.66667
+ end if
+ end if
+ bar_wdt_perc_was_set = False
+ if(isatt(res2,"gsnHistogramBarWidthPercent")) then
+ if(res2 at gsnHistogramBarWidthPercent.le.0.or.
+ res2 at gsnHistogramBarWidthPercent.gt.100.) then
+ print("gsn_histogram: The bar width percentage must be in the range (0,100.].")
+ print(" Defaulting to " + bar_wdt_perc)
+ else
+ bar_wdt_perc = 0.01*res2 at gsnHistogramBarWidthPercent
+ bar_wdt_perc_was_set = True
+ end if
+ delete(res2 at gsnHistogramBarWidthPercent)
+ end if
+ ;
+ ; Check if user explicitly specified bin values. If so, and they represent
+ ; end points, then make sure there are at least two values and sort them.
+ ;
+ if(isatt(res2,"gsnHistogramClassIntervals").or.
+ isatt(res2,"gsnHistogramBinIntervals"))
+ setinterval = True
+ if(isatt(res2,"gsnHistogramClassIntervals"))
+ bins = tofloat(get_res_value(res2,"gsnHistogramClassIntervals",1.))
+ else
+ bins = tofloat(get_res_value(res2,"gsnHistogramBinIntervals",1.))
+ end if
+ nbins = dimsizes(bins)
+ if(nbins.lt.2)
+ print("Error: gsn_histogram: There must be at least two values in the bin intervals. No plot will be drawn.")
+ return(dummy)
+ end if
+ if(max(bins).lt.min(xdata).or.min(bins).gt.max(xdata))
+ print("Error: gsn_histogram: The bin values you picked are out of range. No plot will be drawn.")
+ return(dummy)
+ end if
+ qsort(bins) ; Sort the bins and put back into "bins" variable.
+ end if
+ ;
+ ; If setting the mid point values, then you only need at least one value.
+ ; But, you can't be setting both Intervals and Discrete values.
+ ;
+ if(isatt(res2,"gsnHistogramDiscreteClassValues").or.
+ isatt(res2,"gsnHistogramDiscreteBinValues"))
+ if(setinterval) then
+ print("warning: gsn_histogram: You already set gsnHistogramClassIntervals,")
+ print("so ignoring gsnHistogramDiscreteClassValues.")
+ ;
+ ; Delete so they don't get passed on to other routines.
+ ;
+ if(isatt(res2,"gsnHistogramDiscreteBinValues")) then
+ delete(res2 at gsnHistogramDiscreteBinValues)
+ end if
+ if(isatt(res2,"gsnHistogramDiscreteClassValues")) then
+ delete(res2 at gsnHistogramDiscreteClassValues)
+ end if
+ else
+ setdiscrete = True
+ if(isnumeric(xdata)) then
+ if(isatt(res2,"gsnHistogramDiscreteBinValues")) then
+ bins = tofloat(get_res_value(res2,"gsnHistogramDiscreteBinValues",1))
+ else
+ bins = tofloat(get_res_value(res2,"gsnHistogramDiscreteClassValues",1))
+ end if
+ if(max(bins).lt.min(xdata).or.min(bins).gt.max(xdata)) then
+ print("Error: gsn_histogram: The bin values you picked are out of range. No plot will be drawn.")
+ return(dummy)
+ end if
+ else
+ if(isatt(res2,"gsnHistogramDiscreteBinValues")) then
+ bins = get_res_value(res2,"gsnHistogramDiscreteBinValues",1)
+ else
+ bins = get_res_value(res2,"gsnHistogramDiscreteClassValues",1)
+ end if
+ end if
+ end if
+ end if
+ ;
+ ; You can only count bin values outside the intervals if the intervals
+ ; were set explicitly by the user.
+ ;
+ if(.not.setinterval) then
+ minmaxbins = False
+ end if
+
+ if(.not.setinterval.and..not.setdiscrete) then
+ bins = 0.
+ end if
+
+ if(setinterval.and..not.isnumeric(xdata)) then
+ print("Error: gsn_histogram: If you are doing bin intervals,")
+ print(" your data must be numeric.")
+ return(dummy)
+ end if
+
+ ;
+ ; 2. Get number of values in each bin (num_in_bins) and bin locations
+ ; (num_in_bins at binlocs).
+ ;
+ num_in_bins = compute_hist_vals(xdata,bins,nbins,xbin_width,setinterval,
+ setdiscrete,minmaxbins,count_msg,
+ isnice,compare,sidebyside)
+
+ if(all(ismissing(num_in_bins)))
+ print("Error: gsn_histogram: Unable to calculate bin values. No plot will be drawn.")
+ return(dummy)
+ end if
+
+ if(all(num_in_bins.eq.0))
+ print("Error: gsn_histogram: No data found in selected bins. No plot will be drawn.")
+ return(dummy)
+ end if
+ ;
+ ; 3. Count number of bars and bin locations. If minmaxbins is True, then
+ ; later we need to account for two extra bars. Also, if count_msg is
+ ; True, then this adds one extra bar.
+ ;
+ nbinlocs = dimsizes(num_in_bins at binlocs)
+ if(compare.or.sidebyside)
+ dims = dimsizes(num_in_bins)
+ nbars = dims(1)
+ delete(dims)
+ else
+ nbars = dimsizes(num_in_bins)
+ end if
+ ;
+ ; 4. Calculate width of histogram bins and bars in each bin. If
+ ; comparing two fields, then the histogram bars must be slightly
+ ; smaller in width to accomodate two bars. If doing side-by-side
+ ; bars, then the bars need to be even smaller.
+ ;
+ ; A note about how the bin widths are calculated: the bin locations
+ ; (that is, the bin "tickmarks") will be placed along the X axis such
+ ; that the first bin location is at X = 0, and the last bin location
+ ; is at X = 1.0. When dealing with discrete values, the bin tickmark
+ ; falls in the *middle* of the bar, whereas for intervals, the bin
+ ; tickmarks fall on either side of the bar. The width of each bin,
+ ; then, is [1.0/(the number of bin locations - 1)]. So, for example,
+ ; if you have 2 discrete values, the first bin tickmark is at X=0,
+ ; and the second bin tickmark at X=1.0, giving a bin width of
+ ; 1.0. For the special case where you have only 1 discrete value,
+ ; you essentially don't have a bin width, so "bin_width" will just
+ ; be equal to 1.
+ ;
+ extra_bins = 0
+
+ if(minmaxbins) then
+ extra_bins = 2
+ end if
+
+ if(count_msg) then
+ extra_bins = extra_bins + 1
+ end if
+
+ if(nbinlocs.gt.1) then
+ bin_width = 1./(nbinlocs-1+extra_bins)
+ else
+ bin_width = 1.
+ end if
+
+ ;
+ ; Calculate the width of the histogram bar. It needs to be smaller
+ ; if we are comparing two histograms.
+ ;
+ if(sidebyside) then
+ if(bar_spc_perc.gt.0.and.bar_spc_perc.le.100) then
+ bar_spcng = 0.01 * bar_spc_perc * bin_width
+ if(.not.bar_wdt_perc_was_set) then
+ bar_width = (bin_width - (bar_spcng*nbars))/nbars
+ else
+ bar_width = bar_wdt_perc * bin_width
+ end if
+ if( ((bar_spcng*nbars) + (bar_width*nbars)).gt.bin_width)
+ print("Warning: gsn_histogram: The bar spacing and bar width combined is wider than the bin width.")
+ print("Will default to no spacing.")
+ bar_spc_perc = 0
+ bar_width = (bin_width - (bar_spcng*nbars))/nbars
+ end if
+ lft_margin = 0.5*bar_spcng
+ if(bar_width.le.0) then
+ print("Warning: gsn_histogram: The bar spacing percentage selected is too large for the bin width.")
+ print("Will default to no spacing.")
+ bar_spc_perc = 0
+ end if
+ end if
+ if(bar_spc_perc.eq.0) then
+ bar_spcng = 0.0
+ bar_width = bar_wdt_perc * bin_width
+ lft_margin = 0.5*(bin_width - (nbars*bar_width))
+ end if
+ if(setdiscrete) then
+ lft_margin = -lft_margin
+ end if
+ else
+ bar_width = bar_wdt_perc * bin_width
+ end if
+ if(compare.and.1.3333*bar_width.gt.bin_width) then
+ print("Warning: gsn_histogram: The bar width percentage selected is too large for this comparison histogram.")
+ print(" Resetting to " + 1/1.3333 + " for better results")
+ bar_width = bin_width/1.3333
+ end if
+
+ ;
+ ; 5. Get set of color indexes to use for filling bars. Span the full
+ ; color map when color-filling the bins.
+ ;
+ getvalues wks
+ "wkColorMapLen" : lenc
+ end getvalues
+ if(isatt(res2,"gsnHistogramBarColors")) then
+ colors = get_res_value(res2,"gsnHistogramBarColors",1)
+ else
+ if(isatt(res2,"gsFillColor")) then
+ colors = get_res_value(res2,"gsFillColor",1)
+ else
+ tmp = (lenc-2)/nbars
+ if(tmp .eq. 0 )
+ print("Warning: gsn_histogram: not enough colors, using single color")
+ colors = new(nbars,integer)
+ colors = 2
+ else
+ colors = new(nbars,integer)
+ tmpc = ispan(2,lenc,tmp)
+ if(dimsizes(tmpc).ne.dimsizes(colors))
+ colors = tmpc(0:dimsizes(colors)-1)
+ else
+ colors = tmpc
+ end if
+ delete(tmpc)
+ end if
+ delete(tmp)
+ end if
+ end if
+ ;
+ ; 6. Calculate axis limits for plot, and create plot.
+ ;
+ if(horizontal) then
+ left = 0.
+ right = max(num_in_bins) * 1.1
+ if(setdiscrete) then
+ if(nbars.gt.1) then
+ bottom = -0.6667 * bin_width
+ top = 1. + 0.6667 * bin_width
+ else
+ bottom = -0.6667
+ top = 0.6667
+ end if
+ else
+ bottom = 0
+ top = 1.
+ end if
+ else
+ if(setdiscrete) then
+ if(nbars.gt.1) then
+ left = -0.6667 * bin_width
+ right = 1. + 0.6667 * bin_width
+ else
+ left = -0.6667
+ right = 0.6667
+ end if
+ else
+ left = 0.
+ right = 1.
+ end if
+ bottom = 0.
+ top = max(num_in_bins) * 1.1
+ end if
+
+ ;
+ ; Create plot class with limits.
+ ;
+ res2 at trXMinF = get_res_value(res2,"trXMinF",left)
+ res2 at trXMaxF = get_res_value(res2,"trXMaxF",right)
+ res2 at trYMinF = get_res_value(res2,"trYMinF",bottom)
+ res2 at trYMaxF = get_res_value(res2,"trYMaxF",top)
+
+ xy = create "xy" logLinPlotClass wks
+ "pmTickMarkDisplayMode" : "Always"
+ "pmTitleDisplayMode" : "Always"
+ "trXMinF" : res2 at trXMinF
+ "trXMaxF" : res2 at trXMaxF
+ "trYMinF" : res2 at trYMinF
+ "trYMaxF" : res2 at trYMaxF
+ end create
+ ;
+ ; 7. Set some post-resources for labeling the percentage axis, if desired.
+ ;
+ ; If gsnHistogramComputePercentages is True, then we'll add percentage
+ ; labels to the right (or top) axis.
+ ;
+ ; If we are comparing two sets of data, and we want to have a
+ ; percent calculation on the other axis, then in order for this
+ ; axis to correctly represent both sets of data, they must both
+ ; have the same number of missing values, or no missing values at
+ ; all.
+ ;
+ if(compare.and.perc_nomiss) then
+ if(num_in_bins at NumMissing(0).ne.num_in_bins at NumMissing(1)) then
+ print("Warning: gsn_histogram: When comparing two sets of data, you must have")
+ print("the same number of missing values in both sets (or no missing values at")
+ print("all) in order to display a percentage calculation on the other axis.")
+ print("gsnHistogramComputePercentages will be set to False.")
+ ispercent = False
+ perc_nomiss = False
+ end if
+ end if
+ ;
+ ; The default is to include the total number of data points in the
+ ; percentage calculate, even if there are missing values. The user
+ ; must set gsnHistogramComputePercentagesNoMissing to True if he doesn't
+ ; want the missing values included in the calculation.
+ ;
+ if(ispercent) then
+ if(compare) then
+ dims = dimsizes(xdata)
+ npts = dims(1)
+ else
+ npts = dimsizes(xdata) ; Total number of points.
+ end if
+ if(perc_nomiss) then
+ npts = npts - num_in_bins at NumMissing(0) ; Don't include missing values
+ ; in calculation.
+ end if
+ ;
+ ; Compute min, max, and step necessary to later get "nice" values for
+ ; the percentages.
+ ;
+ xnpts = get_res_value(res2,"gsnHistogramNptsForPercent",npts)*1.
+ if(horizontal) then
+ nicevals = nice_mnmxintvl(res2 at trXMinF,min((/100.,
+ 100.*(res2 at trXMaxF/xnpts)/)),7,False)
+ else
+ nicevals = nice_mnmxintvl(res2 at trYMinF,min((/100.,
+ 100.*(res2 at trYMaxF/xnpts)/)),7,False)
+ end if
+ nvals = floattoint((nicevals(1) - nicevals(0))/nicevals(2) + 1)
+ ;
+ ; Generate nice values for minor and major percent tick marks. For
+ ; the minor tick marks, just add one tick between each major.
+ ;
+ pnice = fspan(nicevals(0),nicevals(1),nvals)
+ pmnice = fspan(nicevals(0)-nicevals(2)*0.5,
+ nicevals(1)+nicevals(2)*0.5, 2*nvals+1)
+ ;
+ ; Calculate the bin values that correspond to these percentages.
+ ; These are the values we'll use for the tick marks.
+ ;
+ bins_at_pnice = 0.01 * (xnpts * pnice)
+ bins_at_pmnice = 0.01 * (xnpts * pmnice)
+ ;
+ ; Set some resources to control tickmarks.
+ ;
+ if(horizontal) then
+ set_attr(res2,"tmXUseBottom", False)
+ set_attr(res2,"tmXTOn",True)
+ set_attr(res2,"tmXTLabelsOn",True)
+ set_attr(res2,"tmXTMode","Explicit")
+ set_attr(res2,"tmXTValues",bins_at_pnice)
+ set_attr(res2,"tmXTMinorValues",bins_at_pmnice)
+ if(percentsign)
+ set_attr(res2,"tmXTLabels",pnice+"%")
+ else
+ set_attr(res2,"tmXTLabels",pnice)
+ end if
+ else
+ set_attr(res2,"tmYUseLeft", False)
+ set_attr(res2,"tmYROn",True)
+ set_attr(res2,"tmYRLabelsOn",True)
+ set_attr(res2,"tmYRMode","Explicit")
+ set_attr(res2,"tmYRValues",bins_at_pnice)
+ set_attr(res2,"tmYRMinorValues",bins_at_pmnice)
+ if(percentsign)
+ set_attr(res2,"tmYRLabels",pnice+"%")
+ else
+ set_attr(res2,"tmYRLabels",pnice)
+ end if
+ end if
+ end if
+ ;
+ ; 8. Set some post-resources for labeling the other axis, if desired.
+ ;
+ axis_string = get_long_name_units_string(xdata)
+ if(.not.ismissing(axis_string)) then
+ if(horizontal) then
+ set_attr(res2,"tiYAxisString",axis_string)
+ else
+ set_attr(res2,"tiXAxisString",axis_string)
+ end if
+ else
+ if(setinterval) then
+ if(horizontal) then
+ set_attr(res2,"tiYAxisString","Class Intervals")
+ else
+ set_attr(res2,"tiXAxisString","Class Intervals")
+ end if
+ end if
+ end if
+ ;
+ ;
+ ; 9. Set some post-resources for labeling the axis that indicates the
+ ; bin ranges or discrete values. If minmaxbins is True, then we
+ ; need to make sure not to label the end bin locations. Also, if
+ ; count_msg is True, then we need to add a special label for this.
+ ;
+ if(minmaxbins) then
+ if(.not.count_msg) then
+ lbs = new(nbinlocs+2,string)
+ lbs(0) = ""
+ lbs(1:nbinlocs) = num_in_bins at binlocs
+ lbs(nbinlocs+1) = ""
+ else
+ lbs = new(nbinlocs+3,string)
+ lbs(0) = ""
+ lbs(1:nbinlocs) = num_in_bins at binlocs
+ lbs(nbinlocs+1) = ""
+ lbs(nbinlocs+2) = "# msg"
+ end if
+ else
+ if(.not.count_msg) then
+ lbs = num_in_bins at binlocs
+ else
+ lbs = new(nbinlocs+1,string)
+ lbs(0:nbinlocs-1) = num_in_bins at binlocs
+ lbs(nbinlocs) = "# msg"
+ end if
+ end if
+ ;
+ ; Calculate location for tickmarks.
+ ;
+ nlbs = dimsizes(lbs)
+ if(nlbs.gt.1) then
+ lbs_vals = fspan(0.,1.,nlbs)
+ else
+ lbs_vals = 0.0
+ end if
+
+ if(count_msg.and.setinterval) then
+ dx = lbs_vals(nlbs-1) - lbs_vals(nlbs-2)
+ lbs_vals(nlbs-1) = lbs_vals(nlbs-2) + dx/2.
+ end if
+
+ if(horizontal) then
+ set_attr(res2,"tiXAxisString","Frequency")
+ set_attr(res2,"tmYROn",False)
+ set_attr(res2,"tmYLMode","EXPLICIT")
+ set_attr(res2,"tmYLValues",lbs_vals)
+ set_attr(res2,"tmYLLabels",lbs)
+ else
+ set_attr(res2,"tiYAxisString","Frequency")
+ set_attr(res2,"tmXTOn",False)
+ set_attr(res2,"tmXBMode","EXPLICIT")
+ set_attr(res2,"tmXBValues",lbs_vals)
+ set_attr(res2,"tmXBLabels",lbs)
+ end if
+ ;
+ ; 10. Apply resources set by user.
+ ;
+ xyres = get_res_ne(res2,"gs")
+ attsetvalues_check(xy,xyres)
+ ;
+ ; 11. Calculate starting locations of each bar.
+ ; If comparing two fields, then the second set of bars will be
+ ; slightly to the right (or above for horizontal bars) of the
+ ; first set of bars.
+ ;
+ ; If doing side-by-side bars, then each new set of bars
+ ; will start to the right of the previous bar. (This may
+ ; change in future to allow some white space.)
+ ;
+ if(sidebyside) then
+ bar_locs = new((/nbars_per_bin,nbars/),float)
+ bar_locs(0,:) = lft_margin + ispan(0,nbars-1,1)*bin_width
+ do i=1,nbars_per_bin-1
+ bar_locs(i,:) = bar_locs(0,:) + i*(bar_width+bar_spcng)
+ end do
+ else
+ if(setdiscrete) then
+ if(compare) then
+ bar_locs = new((/2,nbars/),float)
+ bar_locs(0,:) = -.5*bar_width + bin_width * ispan(0,nbars-1,1)
+ bar_locs(1,:) = -.166667*bar_width + bin_width * ispan(0,nbars-1,1)
+ else
+ bar_locs = new((/1,nbars/),float)
+ bar_locs = -.5*bar_width + bin_width * ispan(0,nbars-1,1)
+ end if
+ else
+ if(compare) then
+ bar_locs = new((/2,nbars/),float)
+ bar_locs(0,:) = .5*(bin_width-(bar_width+0.3333*bar_width)) +
+ bin_width*ispan(0,nbars-1,1)
+ bar_locs(1,:) = bar_locs(0,:) + 0.3333*bar_width
+ else
+ bar_locs = new((/1,nbars/),float)
+ bar_locs = .5*(bin_width-bar_width) + bin_width*ispan(0,nbars-1,1)
+ end if
+ end if
+ end if
+ ;
+ ; 12. Add a right Y (or top X axis) "Percent" label.
+ ;
+ if(ispercent.and..not.percentsign)
+ if(horizontal) then
+ getvalues xy
+ "tiXAxisFontHeightF" : font_height
+ end getvalues
+ txangle = 0.
+ txside = "top"
+ else
+ getvalues xy
+ "tiYAxisFontHeightF" : font_height
+ end getvalues
+ txangle = 90.
+ txside = "right"
+ end if
+
+ perc_string = "Percent"
+ if(perc_nomiss) then
+ perc_string = perc_string + " (missing values not counted)"
+ else
+ if(num_in_bins at NumMissing(0).gt.1.or.
+ (compare.and.num_in_bins at NumMissing(1).gt.1)) then
+ perc_string = perc_string + " (missing values counted)"
+ end if
+ end if
+
+ hist_axis_string = create "axis_string" textItemClass wks
+ "txString" : perc_string
+ "txFontHeightF" : font_height
+ "txAngleF" : txangle
+ end create
+
+ anno = NhlAddAnnotation(xy,hist_axis_string)
+
+ setvalues anno
+ "amZone" : 3 ; Just outside plot area
+ "amJust" : "centercenter"
+ "amSide" : txside
+ "amParallelPosF" : 0.5
+ "amOrthogonalPosF": 0.03
+ "amResizeNotify" : True ; Resize if plot resized.
+ end setvalues
+ end if
+ ;
+ ; 13. Force tickmarks to be the same length, and pointing outward.
+ ;
+ tmres = get_res_eq(res2,"tm") ; Get tickmark resources
+ gsnp_point_tickmarks_outward(xy,tmres,-1.,-1.,-1.,-1.,-1.,-1.,True)
+ gsnp_uniform_tickmark_labels(xy,tmres,0.)
+ ;
+ ; 14. Create (but don't draw) histogram plot.
+ ;
+ gsres = get_res_eq(res2,"gs") ; Get GraphicStyle resources.
+ num_in_bins at horizontal = horizontal ; horizontal or vertical bars
+
+ histogram = hist_columns(wks,xy,num_in_bins,bar_locs,bar_width,
+ colors,compare,gsres)
+ ;
+ ; 15. Draw and advance frame.
+ ;
+ draw_and_frame(wks,histogram,calldraw,callframe,0,maxbb)
+ ;
+ ; 16. Return histogram and the values.
+ ;
+ ; Return begin, mid, and end point location of each bar.
+ ;
+ if(compare.or.sidebyside) then
+ histogram at BeginBarLocs = bar_locs
+ histogram at MidBarLocs = bar_locs + 0.5*bar_width
+ histogram at EndBarLocs = bar_locs + bar_width
+ else
+ histogram at BeginBarLocs = bar_locs(0,:)
+ histogram at MidBarLocs = bar_locs(0,:) + 0.5*bar_width
+ histogram at EndBarLocs = bar_locs(0,:) + bar_width
+ end if
+ histogram at BinLocs = num_in_bins at binlocs
+ histogram at NumInBins = num_in_bins
+ histogram at NumMissing = num_in_bins at NumMissing
+ histogram at Percentages = num_in_bins at percentages
+ histogram at PercentagesNoMissing = num_in_bins at percentages_nm
+ return(histogram)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : gsn_contour ;
+ ; wks: workstation object ;
+ ; data: 1 or 2-dimensional data ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a contour plot to the workstation ;
+ ; "wks" (the variable returned from a previous call to "gsn_open_wks"). ;
+ ; "data" is the 2-dimensional data to be contoured, and "resources" is ;
+ ; an optional list of resources. The id of the contour plot is returned.;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_contour")
+ function gsn_contour(wks:graphic, data:numeric, resources:logical )
+ local i, data_object, plot_object, res, sf_res_index,
+ datares, cnres, llres, cn_res_index, ll_res_index, calldraw, callframe,
+ force_x_linear, force_y_linear, force_x_log, force_y_log,
+ trxmin, trxmax, trymin, trymax, res2, scale, shape, sprdcols,
+ is_lb_mode, lb_mode
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_contour: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ cnres = False
+ llres = False
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(data,new(1,float),new(1,float),"gsn_contour",res2,1)
+ end if
+
+ force_x_linear = False
+ force_y_linear = False
+ force_x_log = False
+ force_y_log = False
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ data_object = scalar_field(wksname+"_data",data,res2)
+
+ sfres = get_res_eq(res2,"sf")
+ attsetvalues_check(data_object,sfres)
+
+ ;
+ ; Create plot object. Make sure you set the tension values (if
+ ; any) when you create the plot. This works better than setting
+ ; them later.
+ ;
+ xtension = get_res_value(res2,"trXTensionF", 2.0)
+ ytension = get_res_value(res2,"trYTensionF", 2.0)
+
+ ;
+ ; Temporarily (I hope), I need to check if trGridType is being set.
+ ; If so, it needs to be set during the create call, or otherwise it
+ ; will cause the tickmarks to possibly not appear.
+ ; pmLabelBarDisplayMode is another resource that can only be set at
+ ; create time. Too bad it has to be so clunky.
+ ;
+ is_lb_mode = isatt(res2,"pmLabelBarDisplayMode")
+ if(is_lb_mode) then
+ lb_mode = get_display_mode(res2,"pmLabelBarDisplayMode","NoCreate")
+ delete(res2 at pmLabelBarDisplayMode)
+ end if
+ if (is_lb_mode) then
+ if(res2.and.isatt(res2,"trGridType")) then
+ plot_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : data_object
+ "pmLabelBarDisplayMode" : lb_mode
+ "trXTensionF" : xtension
+ "trYTensionF" : ytension
+ "trGridType" : res2 at trGridType
+ end create
+ delete(res2 at trGridType)
+ else
+ plot_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : data_object
+ "pmLabelBarDisplayMode" : lb_mode
+ "trXTensionF" : xtension
+ "trYTensionF" : ytension
+ end create
+ end if
+ else
+ if(res2.and.isatt(res2,"trGridType")) then
+ plot_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : data_object
+ "trXTensionF" : xtension
+ "trYTensionF" : ytension
+ "trGridType" : res2 at trGridType
+ end create
+ delete(res2 at trGridType)
+ else
+ plot_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : data_object
+ "trXTensionF" : xtension
+ "trYTensionF" : ytension
+ end create
+ end if
+ end if
+
+ ; Check for existence of data at long_name and use it in a title it
+ ; it exists.
+
+ if(isatt(data,"long_name")) then
+ set_attr(res2,"tiMainString",data at long_name)
+ end if
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"cnSpanFillPalette")) then
+ res2 at cnSpanFillPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourZeroLineThicknessF")) then
+ zthickness = res2 at gsnContourZeroLineThicknessF
+ if(.not.get_res_value_keep(res2,"cnMonoLineThickness",True).and.
+ isatt(res2,"cnLineThicknesses")) then
+ cthickness = get_res_value(res2,"cnLineThicknesses",1.)
+ else
+ cthickness = get_res_value(res2,"cnLineThicknessF",1.)
+ end if
+ delete(res2 at gsnContourZeroLineThicknessF)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourLineThicknessesScale")) then
+ linescale = res2 at gsnContourLineThicknessesScale
+ delete(res2 at gsnContourLineThicknessesScale)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourNegLineDashPattern")) then
+ npattern = res2 at gsnContourNegLineDashPattern
+ delete(res2 at gsnContourNegLineDashPattern)
+ else
+ npattern = new(1,integer) ; Set to missing
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourPosLineDashPattern")) then
+ ppattern = res2 at gsnContourPosLineDashPattern
+ delete(res2 at gsnContourPosLineDashPattern)
+ else
+ ppattern = new(1,integer) ; Set to missing
+ end if
+
+ check_for_irreg2loglin(res2,force_x_linear,force_y_linear,
+ force_x_log,force_y_log)
+ check_for_tickmarks_off(res2)
+
+ cnres = get_res_ne(res2,"sf")
+
+ ;
+ ; Don't let pmTickMarkDisplayMode be set after the fact if we are
+ ; going to overlay this plot later, because you might get an error
+ ; message about warning:PlotManagerSetValues: TickMark annotation
+ ; cannot be added after NhlCreate.
+ ; Also any tr[X/Y][Max/Min]F resources that go outside the data boundaries
+ ; must be temporarily removed because they are not permitted when using the
+ ; irregular transformation. However, do not remove them if they are inside
+ ; the boundaries or there will be an error later when the data boundaries
+ ; are checked
+ ;
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log) then
+ getvalues plot_object
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end getvalues
+ if(isatt(cnres,"pmTickMarkDisplayMode")) then
+ delete(cnres at pmTickMarkDisplayMode)
+ end if
+ if (force_x_linear .or. force_x_log) then
+ if(isatt(cnres,"trXMinF")) then
+ if (cnres at trXMinF .lt. trxmin) then
+ delete(cnres at trXMinF)
+ end if
+ end if
+ if(isatt(cnres,"trXMaxF")) then
+ if (cnres at trXMaxF .gt. trxmax) then
+ delete(cnres at trXMaxF)
+ end if
+ end if
+ end if
+ if (force_y_linear .or. force_y_log) then
+ if(isatt(cnres,"trYMinF")) then
+ if (cnres at trYMinF .lt. trymin) then
+ delete(cnres at trYMinF)
+ end if
+ end if
+ if(isatt(cnres,"trYMaxF")) then
+ if (cnres at trYMaxF .gt. trymax) then
+ delete(cnres at trYMaxF)
+ end if
+ end if
+ end if
+ llres = get_res_eq(res2,(/"pm","tr","vp"/))
+ end if
+
+ attsetvalues_check(plot_object,cnres)
+
+ if(isvar("zthickness")) then
+ plot_object = set_zero_line_thickness(plot_object,zthickness,cthickness)
+ delete(zthickness)
+ end if
+
+ if(isvar("linescale")) then
+ plot_object = set_line_thickness_scale(plot_object,linescale)
+ delete(linescale)
+ end if
+
+ if(.not.ismissing(npattern).or..not.ismissing(ppattern)) then
+ plot_object = set_pos_neg_line_pattern(plot_object,ppattern,npattern)
+ end if
+
+ if(sprdcols.and..not.isatt(res2,"cnFillColors")) then
+ cnres2 = True
+ set_attr(cnres2,"cnFillColors",
+ spread_colors(wks,plot_object,min_index,max_index,res2))
+ attsetvalues(plot_object,cnres2)
+ end if
+
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(plot_object)
+ end if
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(plot_object,"sf",resources)
+ end if
+ ;
+ ; Check if we need to force the X or Y axis to be linear or log.
+ ;
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ overlay_plot_object = plot_object
+ delete(plot_object)
+
+ plot_object = overlay_irregular(wks,wksname,overlay_plot_object,
+ data_object,force_x_linear,
+ force_y_linear,force_x_log,
+ force_y_log,"contour",llres)
+ end if
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ plot_object at data = data_object
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_contour_map ;
+ ; wks: workstation object ;
+ ; data: 1 or 2-dimensional data ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a contour plot over a map plot to the ;
+ ; workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "data" is the 2-dimensional data to be contoured, ;
+ ; and "resources" is an optional list of resources. The id of the map ;
+ ; plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_contour_map")
+ function gsn_contour_map(wks:graphic,data:numeric,
+ resources:logical)
+ local i, data_object, contour_object, res, sf_res_index,
+ cn_res_index, mp_res_index, map_object, res2, scale, shape, sprdcols
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_contour_map: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(data,new(1,float),new(1,float),"gsn_contour_map",res2,1)
+ end if
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ ; Create contour plot.
+
+ cnres = get_res_eq(res2,(/"sf","tr"/))
+ cnres = True
+ cnres at gsnDraw = False
+ cnres at gsnFrame = False
+ contour_object = gsn_contour(wks,data,cnres)
+ delete(cnres)
+
+ ; Check for existence of data at long_name and use it in a title it
+ ; it exists.
+
+ if(isatt(data,"long_name")) then
+ set_attr(res2,"tiMainString",data at long_name)
+ end if
+
+ ; Create map object.
+
+ map_object = create wksname + "_map" mapPlotClass wks end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ scale = get_res_value(res2,"gsnScale",False)
+ shape = get_res_value(res2,"gsnShape",scale)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"cnSpanFillPalette")) then
+ res2 at cnSpanFillPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ mpres = get_res_eq(res2,(/"mp","vp","pmA","pmO","pmT","tm"/))
+ cnres = get_res_ne(res2,(/"mp","sf","vp"/))
+
+ attsetvalues_check(map_object,mpres)
+ attsetvalues_check(contour_object,cnres)
+ if(sprdcols.and..not.isatt(res2,"cnFillColors")) then
+ cnres2 = True
+ set_attr(cnres2,"cnFillColors",
+ spread_colors(wks,contour_object,min_index,max_index,res2))
+ attsetvalues(contour_object,cnres2)
+ end if
+
+ overlay(map_object,contour_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(contour_object,"sf",resources)
+ end if
+
+ draw_and_frame(wks,map_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ map_object at data = contour_object at data
+ map_object at contour = contour_object
+ return(map_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_map ;
+ ; wks: workstation object ;
+ ; projection: Map projection ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a map plot to the workstation "wks" ;
+ ; (the variable returned from a previous call to "gsn_open_wks"). ;
+ ; "projection" is one of the ten supported map projections, and ;
+ ; "resources" is an optional list of resources. The id of the map plot ;
+ ; is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_map")
+ function gsn_map(wks:graphic, projection:string, resources:logical )
+ local i, plot_object, res2, res3
+ begin
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ if(.not.isatt(res2,"mpProjection")) then
+ res2 at mpProjection = "CylindricalEquidistant"
+ end if
+ gsnp_write_debug_info(new(1,float),new(1,float),new(1,float),"gsn_map",
+ res2,0)
+ end if
+
+ ; Create plot object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ ;
+ ; Check if the user is setting tiMainString. If so, then set
+ ; pmTitleDisplayMode to "Always" (unless the user is also setting
+ ; this himself). Otherwise, just use the default value of "NoCreate".
+ ;
+ if(res2.and.isatt(res2,"tiMainString")) then
+ title_display = get_res_value(res2,"pmTitleDisplayMode","Always")
+ else
+ title_display = get_res_value(res2,"pmTitleDisplayMode","NoCreate")
+ end if
+
+ plot_object = create wksname + "_map" mapPlotClass wks
+ "mpProjection" : projection
+ "pmTitleDisplayMode" : title_display
+ end create
+
+ ; Check to see if any resources were set.
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+
+ attsetvalues_check(plot_object,res2)
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object.
+
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_streamline ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U array ;
+ ; v: 2-dimensional V array ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a streamline plot to the workstation ;
+ ; "wks" (the variable returned from a previous call to "gsn_open_wks"). ;
+ ; "u" and "v" are the 2-dimensional arrays to be streamlined, and ;
+ ; "resources" is an optional list of resources. The id of the streamline;
+ ; plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_streamline")
+ function gsn_streamline(wks:graphic,u[*][*]:numeric,v[*][*]:numeric,
+ resources:logical)
+ local i, data_object,plot_object,res,vf_res_index,st_res_index,
+ force_x_linear, force_y_linear, force_x_log, force_y_log, stres2,
+ trxmin, trxmax, trymin, trymax, ll_res_index, llres, res2, scale, shape
+ begin
+ llres = False
+ res2 = get_resources(resources)
+
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,new(1,float),"gsn_streamline",res2,2)
+ end if
+
+ force_x_linear = False
+ force_y_linear = False
+ force_x_log = False
+ force_y_log = False
+
+ ; Create the data object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ data_object = vector_field(wksname+"_data",u,v,res2)
+
+ ; Create plot object.
+
+ plot_object = create wksname + "_stream" streamlinePlotClass wks
+ "stVectorFieldData" : data_object
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"stSpanLevelPalette")) then
+ res2 at stSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ check_for_irreg2loglin(res2,force_x_linear,force_y_linear,
+ force_x_log,force_y_log)
+ check_for_tickmarks_off(res2)
+
+ vfres = get_res_eq(res2,"vf")
+ stres = get_res_ne(res2,"vf")
+ attsetvalues_check(data_object,vfres)
+ attsetvalues_check(plot_object,stres)
+
+ if(sprdcols.and..not.isatt(res2,"stLevelColors")) then
+ stres2 = True
+ set_attr(stres2,"stLevelColors",
+ spread_colors(wks,plot_object,min_index,max_index,res2))
+ attsetvalues(plot_object,stres2)
+ end if
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ llres = get_res_eq(res2,(/"tr","vp"/))
+ end if
+
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(plot_object)
+ end if
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(plot_object,"vf",resources)
+ end if
+
+ ; Check if we need to force the X or Y axis to be linear or log.
+ ; If so, then we have to overlay it on a LogLin Plot.
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ overlay_plot_object = plot_object
+ delete(plot_object)
+
+ plot_object = overlay_irregular(wks,wksname,overlay_plot_object,
+ data_object,force_x_linear,
+ force_y_linear,force_x_log,
+ force_y_log,"streamline",llres)
+ end if
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ plot_object at data = data_object
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_streamline_map ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a streamline plot over a map plot to ;
+ ; the workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "u" and "v" are the 2-dimensional arrays to be ;
+ ; streamlined, and "resources" is an optional list of resources. The id ;
+ ; of the map plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_streamline_map")
+ function gsn_streamline_map(wks:graphic,u[*][*]:numeric,
+ v[*][*]:numeric,resources:logical)
+ local i, data_object, contour_object, res, vf_res_index,
+ st_res_index, mp_res_index, map_object, res2, stres2
+ begin
+ res2 = get_resources(resources)
+
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,new(1,float),"gsn_streamline_map",res2,2)
+ end if
+
+ ; Create the data object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ data_object = vector_field(wksname+"_data",u,v,res2)
+
+ ; Create plot object.
+
+ stream_object = create wksname + "_stream" streamlinePlotClass wks
+ "stVectorFieldData" : data_object
+ end create
+
+ ; Create map object.
+
+ map_object = create wksname + "_map" mapPlotClass wks
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"stSpanLevelPalette")) then
+ res2 at stSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ mpres = get_res_eq(res2,(/"mp","vp","pmA","pmO","pmT","tm"/))
+ stres = get_res_ne(res2,(/"vf","mp","vp"/))
+
+ attsetvalues_check(data_object,vfres)
+ attsetvalues_check(stream_object,stres)
+ attsetvalues_check(map_object,mpres)
+
+ if(.not.isatt(res2,"stLevelColors")) then
+ stres2 = True
+ set_attr(stres2,"stLevelColors",
+ spread_colors(wks,stream_object,min_index,max_index,res2))
+ attsetvalues(stream_object,stres2)
+ end if
+
+ overlay(map_object,stream_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(stream_object,"vf",resources)
+ end if
+
+ draw_and_frame(wks,map_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ map_object at data = data_object
+ map_object at streamline = stream_object
+ return(map_object)
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_draw_colormap ;
+ ; wks: workstation object ;
+ ; ;
+ ; This procedure retrieves the current colormap and draws it. ;
+ ; wks is a variable returned from a previous call to "gsn_open_wks". ;
+ ;***********************************************************************;
+ undef("gsn_draw_colormap")
+ procedure gsn_draw_colormap(wks)
+ local nrows, ncols, ncolors, maxcols, ntotal, offset, width, height,
+ xpos, ypos, xbox, ybox, cmap, cmapnew
+ begin
+ nrows = 16 ; # of rows of colors per page.
+ maxcols = 256 ; max # of colors per color table.
+
+ getvalues wks
+ "wkColorMapLen" : ncolors ; Get # of colors in color map.
+ end getvalues
+
+ ;
+ ; Figure out ncols such that the columns will span across the page.
+ ; Or, just set ncols to 16, which is big enough to cover the largest
+ ; possible color map.
+ ;
+ ncols = floattoint(ncolors/nrows)
+ if(ncols*nrows.lt.ncolors)
+ ncols = ncols+1
+ end if
+
+ ntotal = nrows * ncols ; # of colors per page.
+ ;
+ ; If the number of colors in our color map is less than the allowed
+ ; maximum, then this gives us room to add a white background and/or a
+ ; black foreground.
+ ;
+ reset_colormap = False
+ if(ncolors.lt.maxcols) then
+ reset_colormap = True
+ ;
+ ; Get current color map.
+ ;
+ getvalues wks
+ "wkColorMap" : cmap
+ end getvalues
+
+ if(ncolors.lt.maxcols-1) then
+ offset = 2
+ cmapnew = new((/ncolors+2,3/),float)
+ cmapnew(0,:) = (/1.,1.,1./) ; white background
+ cmapnew(1,:) = (/0.,0.,0./) ; black background
+ cmapnew(2:,:) = cmap
+ else
+ offset = 1
+ cmapnew = new((/ncolors+1,3/),float)
+ cmapnew(0,:) = (/1.,1.,1./) ; white background
+ cmapnew(1:,:) = cmap
+ end if
+ ;
+ ; Set new color map.
+ ;
+ setvalues wks
+ "wkColorMap" : cmapnew
+ end setvalues
+
+ delete(cmapnew)
+ else
+ offset = 0
+ end if
+ ;
+ ; X and Y positions of text and box in the view port.
+ ;
+ width = 1./ncols
+ height = 1./nrows
+ if(ncols.gt.1) then
+ xpos = fspan(0,1-width,ncols)
+ else
+ xpos = 0.
+ end if
+ if(nrows.gt.1) then
+ ypos = fspan(1-height,0,nrows)
+ else
+ ypos = 1.-height
+ end if
+ ;
+ ; Box coordinates.
+ ;
+ xbox = (/0,width, width, 0,0/)
+ ybox = (/0, 0,height,height,0/)
+
+ font_height = 0.015
+ font_space = font_height/2.
+
+ gonres = True ; variables to hold list of resources
+ lineres = True
+ txres = True
+
+ txres at txFontHeightF = font_height
+ txres at txFont = "helvetica-bold"
+ txres at txJust = "BottomLeft"
+ txres at txPerimOn = True
+ txres at txPerimColor = "black" ; Or close to black if
+ txres at txFontColor = "black" ; black is not in color map.
+ txres at txBackgroundFillColor = "white" ; Or close to white.
+
+ lineres at gsLineColor = "black"
+
+ ;
+ ; ntotal colors per page.
+ ;
+ do k = 1,ncolors,ntotal
+ jj = 0
+ do j=k,min((/k+ntotal-1,ncolors/)),nrows
+ ii = 0
+ do i=j,min((/j+nrows-1,ncolors/))
+ ;
+ ; Draw box and fill in the appropriate color.
+ ;
+ gonres at gsFillColor = offset + (i-1)
+ gsn_polygon_ndc(wks,xbox+xpos(jj),ybox+ypos(ii),gonres) ; Draw box.
+ ;
+ ; Outline box in black.
+ ;
+ gsn_polyline_ndc(wks,xbox+xpos(jj),ybox+ypos(ii),lineres)
+ ;
+ ; Draw color label.
+ ;
+ gsn_text_ndc(wks,i-1,font_space+xpos(jj),ypos(ii)+font_space,txres)
+ ii = ii + 1
+ end do
+ jj = jj +1
+ end do
+ frame(wks) ; Advance the frame.
+ end do
+
+ if(reset_colormap) then
+ ;
+ ; Put the original color map back.
+ ;
+ setvalues wks
+ "wkColorMap" : cmap
+ end setvalues
+ delete(cmap)
+ end if
+ return
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_draw_named_colors ;
+ ; wks: workstation object ;
+ ; colors: colors array ;
+ ; box: array defining number of rows and columns ;
+ ; ;
+ ; This procedure takes a named color array and draws it. ;
+ ; wks is a variable returned from a previous call to "gsn_open_wks". ;
+ ;***********************************************************************;
+ undef("gsn_draw_named_colors")
+ procedure gsn_draw_named_colors(wks:graphic,colors[*]:string, box[2]:integer)
+ local ncolors, ntotal, nrows, ncols, offset, width, height,
+ xpos, ypos, xbox, ybox
+
+ begin
+ nrows = box(0) ; # of rows of colors per page.
+ ncols = box(1) ; # of columns of colors per page.
+
+ if(typeof(colors).ne."string".or.dimsizes(dimsizes(colors)).ne.1)
+ print("The input array is not a one dimensional array of named color strings")
+ exit
+ end if
+
+ if((nrows.gt.16).or.(ncols.gt.8))
+ print("Number of rows should be less than 16 and Number of columns should be less than 8.")
+ exit
+ end if
+
+ ncolors = dimsizes(colors) ; # of colors given
+
+ getvalues wks
+ "wkColorMap" : oldcmap ; Get current color map.
+ end getvalues
+
+ ;
+ ; Find out the rgb values of each color and put it into
+ ; an array
+ ;
+ rgb_values = namedcolor2rgb(colors)
+ rgb_val = new(ncolors, string)
+ do l =0, ncolors-1, 1
+ rgb_val(l) = sprintf("%.2f", rgb_values(l,0)) + "," +
+ sprintf("%.2f", rgb_values(l,1)) + "," +
+ sprintf("%.2f", rgb_values(l,2))
+ end do
+
+ ;
+ ; npages number of frames.
+ ;
+ ntotal = ncols * nrows
+
+ npages = floattoint(ncolors/ntotal)
+ if(npages*ntotal.lt.ncolors)
+ npages = npages+1
+ end if
+
+ ;
+ ; X and Y positions of text and box in the view port.
+ ;
+ width = 1./ncols
+ height = 1./nrows
+
+ if(ncols.gt.1) then
+ xpos = fspan(0,1-width,ncols)
+ else
+ xpos = 0.
+ end if
+ if(nrows.gt.1) then
+ ypos = fspan(1-height,0,nrows)
+ else
+ ypos = 1.-height
+ end if
+ ;
+ ; Box coordinates.
+ ;
+ xbox = (/0,width, width, 0,0/)
+ ybox = (/0, 0,height,height,0/)
+
+ ;
+ ; Calculate font height.
+ ;
+ font_heights = (/.0143, .0143, .0143, .0141, .013, .011, .0093, .0085/)
+ font_height = font_heights(ncols-1)
+ font_space = font_height/2.
+
+ gonres = True ; variables to hold list of resources
+ lineres = True
+ txres = True
+
+ txres at gsnDraw = True
+ txres at txFontHeightF = font_height
+ txres at txFont = "helvetica-bold"
+ txres at txPerimOn = True
+ txres at txPerimColor = "black" ; Or close to black if
+ txres at txFontColor = "black" ; black is not in color map.
+ txres at txBackgroundFillColor = "white" ; Or close to white.
+
+ lineres at gsLineColor = "black"
+
+ kk = 0
+ offset = 2
+ do k = 1,ncolors,ntotal
+ start = kk*ntotal
+ colorindex = 0
+ ;
+ ; Set the colormap
+ ;
+ if(npages.eq.1)
+ cmapnew = new(ncolors-start+2,string)
+ cmapnew(0) = "White" ; white background
+ cmapnew(1) = "Black" ; black background
+ cmapnew(2:) = colors(start:ncolors-1)
+ else
+ cmapnew = new(ntotal+2,string)
+ cmapnew(0) = "White" ; white background
+ cmapnew(1) = "Black" ; black background
+ cmapnew(2:) = colors(start:start+ntotal-1)
+ end if
+
+ setvalues wks
+ "wkColorMap" : cmapnew
+ end setvalues
+ delete(cmapnew)
+
+ jj = 0
+ do j=k,min((/k+ntotal-1,ncolors/)),nrows
+ ii = 0
+ do i=j,min((/j+nrows-1,ncolors/))
+
+ ; Draw box and fill in the appropriate color.
+ gonres at gsFillColor = offset + colorindex
+ gsn_polygon_ndc(wks,xbox+xpos(jj),ybox+ypos(ii),gonres) ; Draw box.
+
+ ; Outline box in black.
+ gsn_polyline_ndc(wks,xbox+xpos(jj),ybox+ypos(ii),lineres)
+
+ ; Draw color label.
+ txres at txJust = "BottomLeft"
+ text = gsn_create_text_ndc(wks,colors(i-1),font_space+xpos(jj),
+ ypos(ii)+font_space,txres)
+ txres at txJust = "TopLeft"
+ gsn_text_ndc(wks,rgb_val(i-1),font_space+xpos(jj),
+ height+ypos(ii)-font_space,txres)
+
+ ii = ii + 1
+ colorindex = colorindex + 1
+ end do
+ jj = jj +1
+ end do
+ kk = kk + 1
+ npages = npages - 1
+ frame(wks) ; Advance the frame.
+ end do
+
+ ;
+ ; Put the original color map back.
+ ;
+ setvalues wks
+ "wkColorMap" : oldcmap
+ end setvalues
+ delete(oldcmap)
+
+ end
+
+
+ ;***********************************************************************;
+ ; Function : gsn_vector ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U array ;
+ ; v: 2-dimensional V array ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a vector plot to the workstation "wks";
+ ; (the variable returned from a previous call to "gsn_open_wks"). "u" ;
+ ; and "v" are the 2-dimensional arrays to be vectorized, and "resources";
+ ; is an optional list of resources. The id of the vector plot is ;
+ ; returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_vector")
+ function gsn_vector(wks:graphic, u[*][*]:numeric, v[*][*]:numeric,
+ resources:logical )
+ local i,data_object,plot_object,res,vf_res_index,vc_res_index,
+ force_x_linear, force_y_linear, force_x_log, force_y_log, sprdcols,
+ trxmin, trxmax, trymin, trymax, ll_res_index, llres, res2
+ begin
+ llres = False
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,new(1,float),"gsn_vector",res2,2)
+ end if
+
+ force_x_linear = False
+ force_y_linear = False
+ force_x_log = False
+ force_y_log = False
+
+ ; Create the data object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ data_object = vector_field(wksname+"_data",u,v,res2)
+
+ ; Create plot object.
+
+ plot_object = create wksname + "_vector" vectorPlotClass wks
+ "vcVectorFieldData" : data_object
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"vcSpanLevelPalette")) then
+ res2 at vcSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ check_for_irreg2loglin(res2,force_x_linear,force_y_linear,
+ force_x_log,force_y_log)
+ check_for_tickmarks_off(res2)
+
+ vfres = get_res_eq(res2,"vf")
+ vcres = get_res_ne(res2,"vf")
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ llres = get_res_eq(res2,(/"tr","vp"/))
+ end if
+
+ attsetvalues_check(data_object,vfres)
+ attsetvalues_check(plot_object,vcres)
+ if(sprdcols.and..not.isatt(res2,"vcLevelColors")) then
+ vcres2 = True
+ set_attr(vcres2,"vcLevelColors",
+ spread_colors(wks,plot_object,min_index,max_index,res2))
+ attsetvalues(plot_object,vcres2)
+ end if
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(plot_object)
+ end if
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(plot_object,"vf",resources)
+ end if
+
+ ; Check if we need to force the X or Y axis to be linear or log.
+ ; If so, then we have to overlay it on a LogLin Plot.
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ overlay_plot_object = plot_object
+ delete(plot_object)
+
+ plot_object = overlay_irregular(wks,wksname,overlay_plot_object,
+ data_object,force_x_linear,
+ force_y_linear,force_x_log,
+ force_y_log,"vector",llres)
+ end if
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ plot_object at data = data_object
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_vector_contour ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws vectors and contours to the ;
+ ; workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "u" and "v" are the 2-dimensional arrays to be ;
+ ; vectorized, and "data" is the scalar field to be contoured. ;
+ ; "resources" is an optional list of resources. The id of the vector ;
+ ; plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_vector_contour")
+ function gsn_vector_contour(wks:graphic,u[*][*]:numeric,
+ v[*][*]:numeric,data:numeric,
+ resources:logical)
+ local i, vfdata_object, sfdata_object, contour_object, res,
+ vf_res_index, vc_res_index, sf_res_index, res2
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_vector_contour: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_vector_contour",res2,3)
+ end if
+ ;
+ ; Create the scalar and vector field object.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create vector plot object.
+
+ vector_object = create wksname + "_vector" vectorPlotClass wks
+ "vcVectorFieldData" : vfdata_object
+ end create
+
+ ; Create contour plot object.
+
+ contour_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : sfdata_object
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"cnSpanFillPalette")) then
+ res2 at cnSpanFillPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourZeroLineThicknessF")) then
+ zthickness = res2 at gsnContourZeroLineThicknessF
+ if(.not.get_res_value_keep(res2,"cnMonoLineThickness",True).and.
+ isatt(res2,"cnLineThicknesses")) then
+ cthickness = get_res_value(res2,"cnLineThicknesses",1.)
+ else
+ cthickness = get_res_value(res2,"cnLineThicknessF",1.)
+ end if
+ delete(res2 at gsnContourZeroLineThicknessF)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourLineThicknessesScale")) then
+ linescale = res2 at gsnContourLineThicknessesScale
+ delete(res2 at gsnContourLineThicknessesScale)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourNegLineDashPattern")) then
+ npattern = res2 at gsnContourNegLineDashPattern
+ delete(res2 at gsnContourNegLineDashPattern)
+ else
+ npattern = new(1,integer) ; Set to missing
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourPosLineDashPattern")) then
+ ppattern = res2 at gsnContourPosLineDashPattern
+ delete(res2 at gsnContourPosLineDashPattern)
+ else
+ ppattern = new(1,integer) ; Set to missing
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ ;
+ ; Make sure that the labelbar resources get passed to the
+ ; correct object.
+ ;
+ if(res2.and.isatt(res2,"cnFillOn").and.res2 at cnFillOn) then
+ cnres = get_res_eq(res2,(/"cn","tf","lb","pmLabel"/))
+ vcres = get_res_ne(res2,(/"vf","sf","cn","lb","pmLabel"/))
+ else
+ cnres = get_res_eq(res2,(/"cn","tf"/))
+ vcres = get_res_ne(res2,(/"vf","sf","cn"/))
+ end if
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(contour_object,cnres)
+ attsetvalues_check(vector_object,vcres)
+
+ if(isvar("zthickness")) then
+ contour_object = set_zero_line_thickness(contour_object,zthickness,cthickness)
+ delete(zthickness)
+ end if
+
+ if(isvar("linescale")) then
+ contour_object = set_line_thickness_scale(contour_object,linescale)
+ delete(linescale)
+ end if
+
+ if(.not.ismissing(npattern).or..not.ismissing(ppattern)) then
+ contour_object = set_pos_neg_line_pattern(contour_object,
+ ppattern,npattern)
+ end if
+
+ if(sprdcols)
+ if(.not.isatt(res2,"cnFillColors")) then
+ cnres2 = True
+ set_attr(cnres2,"cnFillColors",
+ spread_colors(wks,contour_object,min_index,max_index,res2))
+ attsetvalues(contour_object,cnres2)
+ end if
+ if(.not.isatt(res2,"vcLevelColors")) then
+ vcres2 = True
+ set_attr(vcres2,"vcLevelColors",
+ spread_colors(wks,vector_object,min_index,max_index,res2))
+ attsetvalues(vector_object,vcres2)
+ end if
+ end if
+
+ overlay(contour_object,vector_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(contour_object,"vf",resources)
+ end if
+
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(contour_object)
+ end if
+
+ draw_and_frame(wks,contour_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ contour_object at vfdata = vfdata_object
+ contour_object at sfdata = sfdata_object
+ contour_object at contour = contour_object
+ return(contour_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_streamline_contour ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws streamlines and contours to the ;
+ ; workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "u" and "v" are the 2-dimensional arrays to be ;
+ ; streamlines, and "data" is the scalar field to be contoured. ;
+ ; "resources" is an optional list of resources. The id of the streamline;
+ ; plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_streamline_contour")
+ function gsn_streamline_contour(wks:graphic,u[*][*]:numeric,
+ v[*][*]:numeric,data:numeric,
+ resources:logical)
+ local i, vfdata_object, sfdata_object, contour_object, res,
+ vf_res_index, st_res_index, sf_res_index, res2
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_streamline_contour: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_streamline_contour",res2,3)
+ end if
+ ;
+ ; Create the vector and scalar fields.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create streamline plot object.
+
+ stream_object = create wksname + "_stream" streamlinePlotClass wks
+ "stVectorFieldData" : vfdata_object
+ end create
+
+ ; Create contour plot object.
+
+ contour_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : sfdata_object
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"cnSpanFillPalette")) then
+ res2 at cnSpanFillPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourZeroLineThicknessF")) then
+ zthickness = res2 at gsnContourZeroLineThicknessF
+ if(.not.get_res_value_keep(res2,"cnMonoLineThickness",True).and.
+ isatt(res2,"cnLineThicknesses")) then
+ cthickness = get_res_value(res2,"cnLineThicknesses",1.)
+ else
+ cthickness = get_res_value(res2,"cnLineThicknessF",1.)
+ end if
+ delete(res2 at gsnContourZeroLineThicknessF)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourLineThicknessesScale")) then
+ linescale = res2 at gsnContourLineThicknessesScale
+ delete(res2 at gsnContourLineThicknessesScale)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourNegLineDashPattern")) then
+ npattern = res2 at gsnContourNegLineDashPattern
+ delete(res2 at gsnContourNegLineDashPattern)
+ else
+ npattern = new(1,integer) ; Set to missing
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourPosLineDashPattern")) then
+ ppattern = res2 at gsnContourPosLineDashPattern
+ delete(res2 at gsnContourPosLineDashPattern)
+ else
+ ppattern = new(1,integer) ; Set to missing
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ cnres = get_res_eq(res2,(/"cn"/))
+ stres = get_res_ne(res2,(/"vf","sf","cn"/))
+
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(contour_object,cnres)
+ attsetvalues_check(stream_object,stres)
+
+ if(isvar("zthickness")) then
+ contour_object = set_zero_line_thickness(contour_object,zthickness,cthickness)
+ delete(zthickness)
+ end if
+
+ if(isvar("linescale")) then
+ contour_object = set_line_thickness_scale(contour_object,linescale)
+ delete(linescale)
+ end if
+
+ if(.not.ismissing(npattern).or..not.ismissing(ppattern)) then
+ contour_object = set_pos_neg_line_pattern(contour_object,
+ ppattern,npattern)
+ end if
+
+ if(.not.isatt(res2,"cnFillColors")) then
+ cnres2 = True
+
+ set_attr(cnres2,"cnFillColors",
+ spread_colors(wks,contour_object,min_index,max_index,res2))
+
+ attsetvalues(contour_object,cnres2)
+ end if
+
+ overlay(stream_object,contour_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(stream_object,"vf",resources)
+ end if
+
+ draw_and_frame(wks,stream_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ stream_object at vfdata = vfdata_object
+ stream_object at sfdata = sfdata_object
+ stream_object at contour = contour_object
+ return(stream_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_vector_contour_map ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws vectors and contours over a map plot ;
+ ; to the workstation "wks" (the variable returned from a previous call ;
+ ; to "gsn_open_wks"). "u" and "v" are the 2-dimensional arrays to be ;
+ ; vectorized, and "data" is the scalar field to be contoured. ;
+ ; "resources" is an optional list of resources. The id of the map plot ;
+ ; is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_vector_contour_map")
+ function gsn_vector_contour_map(wks:graphic,u[*][*]:numeric,
+ v[*][*]:numeric,data:numeric,
+ resources:logical)
+ local i, vfdata_object, sfdata_object, contour_object, res,
+ vf_res_index, vc_res_index, sf_res_index, mp_res_index, map_object, res2
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_vector_contour_map: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_vector_contour_map",res2,3)
+ end if
+ ;
+ ; Create the vector and scalar field objects.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create vector plot object.
+
+ vector_object = create wksname + "_vector" vectorPlotClass wks
+ "vcVectorFieldData" : vfdata_object
+ end create
+
+ ; Create contour plot object.
+
+ contour_object = create wksname + "_contour" contourPlotClass wks
+ "cnScalarFieldData" : sfdata_object
+ end create
+
+ ; Create map object.
+
+ map_object = create wksname + "_map" mapPlotClass wks end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"cnSpanFillPalette")) then
+ res2 at cnSpanFillPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourZeroLineThicknessF")) then
+ zthickness = res2 at gsnContourZeroLineThicknessF
+ if(.not.get_res_value_keep(res2,"cnMonoLineThickness",True).and.
+ isatt(res2,"cnLineThicknesses")) then
+ cthickness = get_res_value(res2,"cnLineThicknesses",1.)
+ else
+ cthickness = get_res_value(res2,"cnLineThicknessF",1.)
+ end if
+ delete(res2 at gsnContourZeroLineThicknessF)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourLineThicknessesScale")) then
+ linescale = res2 at gsnContourLineThicknessesScale
+ delete(res2 at gsnContourLineThicknessesScale)
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourNegLineDashPattern")) then
+ npattern = res2 at gsnContourNegLineDashPattern
+ delete(res2 at gsnContourNegLineDashPattern)
+ else
+ npattern = new(1,integer) ; Set to missing
+ end if
+
+ if(res2.and.isatt(res2,"gsnContourPosLineDashPattern")) then
+ ppattern = res2 at gsnContourPosLineDashPattern
+ delete(res2 at gsnContourPosLineDashPattern)
+ else
+ ppattern = new(1,integer) ; Set to missing
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ cnres = get_res_eq(res2,(/"cn","tf"/))
+ mpres = get_res_eq(res2,(/"mp","vp","pmA","pmO","pmT","tm"/))
+ vcres = get_res_ne(res2,(/"cn","mp","sf","vf","vp"/))
+
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(map_object,mpres)
+ attsetvalues_check(contour_object,cnres)
+ attsetvalues_check(vector_object,vcres)
+
+ if(isvar("zthickness")) then
+ contour_object = set_zero_line_thickness(contour_object,zthickness,cthickness)
+ delete(zthickness)
+ end if
+
+ if(isvar("linescale")) then
+ contour_object = set_line_thickness_scale(contour_object,linescale)
+ delete(linescale)
+ end if
+
+ if(.not.ismissing(npattern).or..not.ismissing(ppattern)) then
+ contour_object = set_pos_neg_line_pattern(contour_object,
+ ppattern,npattern)
+ end if
+
+ if(sprdcols) then
+ if(.not.isatt(res2,"cnFillColors")) then
+ cnres2 = True
+ set_attr(cnres2,"cnFillColors",
+ spread_colors(wks,contour_object,min_index,max_index,res2))
+ attsetvalues(contour_object,cnres2)
+ end if
+ if(.not.isatt(res2,"vcLevelColors")) then
+ vcres2 = True
+
+ set_attr(vcres2,"vcLevelColors",
+ spread_colors(wks,vector_object,min_index,max_index,res2))
+
+ attsetvalues(vector_object,vcres2)
+ end if
+ end if
+
+ overlay(map_object,contour_object)
+ overlay(map_object,vector_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(vector_object,"vf",resources)
+ end if
+
+ draw_and_frame(wks,map_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ map_object at vfdata = vfdata_object
+ map_object at sfdata = sfdata_object
+ map_object at vector = vector_object
+ map_object at contour = contour_object
+ return(map_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_vector_map ;
+ ; wks: workstation object ;
+ ; : 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a vector plot over a map plot to the ;
+ ; workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "u" and "v" are the 2-dimensional arrays to be ;
+ ; vectorized, and "resources" is an optional list of resources. The id ;
+ ; of the map plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_vector_map")
+ function gsn_vector_map(wks:graphic, u[*][*]:numeric, v[*][*]:numeric,
+ resources:logical )
+ local i, data_object, contour_object, res, vf_res_index,
+ vc_res_index, mp_res_index, map_object, res2, sprdcols
+ begin
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,new(1,float),"gsn_vector_map",res2,2)
+ end if
+
+ ; Create the data object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ data_object = vector_field(wksname+"_data",u,v,res2)
+
+ ; Create plot object.
+
+ vector_object = create wksname + "_vector" vectorPlotClass wks
+ "vcVectorFieldData" : data_object
+ end create
+
+ ; Create map object.
+
+ map_object = create wksname + "_map" mapPlotClass wks
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"vcSpanLevelPalette")) then
+ res2 at vcSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ mpres = get_res_eq(res2,(/"mp","vp","pmA","pmO","pmT","tm"/))
+ vcres = get_res_ne(res2,(/"mp","vf","vp"/))
+
+ attsetvalues_check(data_object,vfres)
+ attsetvalues_check(map_object,mpres)
+ attsetvalues_check(vector_object,vcres)
+
+ if(.not.isatt(res2,"vcLevelColors")) then
+ vcres2 = True
+ set_attr(vcres2,"vcLevelColors",
+ spread_colors(wks,vector_object,min_index,max_index,res2))
+ attsetvalues(vector_object,vcres2)
+ end if
+
+ overlay(map_object,vector_object)
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(vector_object,"vf",resources)
+ end if
+
+ draw_and_frame(wks,map_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ map_object at data = data_object
+ map_object at vector = vector_object
+ return(map_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_vector_scalar ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U array ;
+ ; v: 2-dimensional V array ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a vector plot to the workstation "wks";
+ ; (the variable returned from a previous call to "gsn_open_wks"). "u" ;
+ ; and "v" are the 2-dimensional arrays to be vectorized, and "data" is ;
+ ; the scalar field that the vectors are colored by. "resources" is an ;
+ ; optional list of resources. The id of the vector plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_vector_scalar")
+ function gsn_vector_scalar(wks:graphic,u[*][*]:numeric,v[*][*]:numeric,
+ data:numeric, resources:logical )
+ local i, vfdata_object, sfdata_object, plot_object, res,
+ force_x_linear, force_y_linear, force_x_log, force_y_log,
+ trxmin, trxmax, trymin, trymax, ll_res_index, llres, vf_res_index,
+ vc_res_index, sf_res_index, res2, sprdcols
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_vector_scalar: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ llres = False
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_vector_scalar",res2,3)
+ end if
+
+ force_x_linear = False
+ force_y_linear = False
+ force_x_log = False
+ force_y_log = False
+
+ ; Create the scalar and vector field data object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create plot object.
+
+ plot_object = create wksname + "_vector" vectorPlotClass wks
+ "vcVectorFieldData" : vfdata_object
+ "vcScalarFieldData" : sfdata_object
+ "vcUseScalarArray" : True
+ "vcMonoLineArrowColor" : False
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"vcSpanLevelPalette")) then
+ res2 at vcSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ check_for_irreg2loglin(res2,force_x_linear,force_y_linear,
+ force_x_log,force_y_log)
+ check_for_tickmarks_off(res2)
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ vcres = get_res_ne(res2,(/"sf","vf"/))
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ llres = get_res_eq(res2,(/"tr","vp"/))
+ end if
+
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(plot_object,vcres)
+ if(sprdcols.and..not.isatt(res2,"vcLevelColors")) then
+ vcres2 = True
+ set_attr(vcres2,"vcLevelColors",
+ spread_colors(wks,plot_object,min_index,max_index,res2))
+ attsetvalues(plot_object,vcres2)
+ end if
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(plot_object)
+ end if
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(plot_object,"vf",resources)
+ end if
+
+ ; Check if we need to force the X or Y axis to be linear or log.
+ ; If so, then we have to overlay it on a LogLin Plot.
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ overlay_plot_object = plot_object
+ delete(plot_object)
+
+ plot_object = overlay_irregular(wks,wksname,overlay_plot_object,
+ data_object,force_x_linear,
+ force_y_linear,force_x_log,
+ force_y_log,"vector",llres)
+ end if
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ plot_object at vfdata = vfdata_object
+ plot_object at sfdata = sfdata_object
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_streamline_scalar ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U array ;
+ ; v: 2-dimensional V array ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a streamline plot to the workstation ;
+ ; "wks"; (the variable returned from a previous call to "gsn_open_wks").;
+ ; "u" and "v" are the 2-dimensional vector arrays, and "data" is the ;
+ ; scalar field that the streamlines are colored by. "resources" is an ;
+ ; optional list of resources. The id of the streamline plot is returned.;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_streamline_scalar")
+ function gsn_streamline_scalar(wks:graphic,u[*][*]:numeric,v[*][*]:numeric,
+ data:numeric, resources:logical )
+ local i, vfdata_object, sfdata_object, plot_object, res,
+ force_x_linear, force_y_linear, force_x_log, force_y_log,
+ trxmin, trxmax, trymin, trymax, ll_res_index, llres, vf_res_index,
+ st_res_index, sf_res_index, res2, sprdcols
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_streamline_scalar: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ llres = False
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_streamline_scalar",res2,3)
+ end if
+
+ force_x_linear = False
+ force_y_linear = False
+ force_x_log = False
+ force_y_log = False
+
+ ; Create the scalar and vector field data object.
+
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create plot object.
+
+ plot_object = create wksname + "_streamline" streamlinePlotClass wks
+ "stVectorFieldData" : vfdata_object
+ "stScalarFieldData" : sfdata_object
+ "stUseScalarArray" : True
+ "stMonoLineColor" : False
+ end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"stSpanLevelPalette")) then
+ res2 at stSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ check_for_irreg2loglin(res2,force_x_linear,force_y_linear,
+ force_x_log,force_y_log)
+ check_for_tickmarks_off(res2)
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ stres = get_res_ne(res2,(/"sf","vf"/))
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ llres = get_res_eq(res2,(/"tr","vp"/))
+ end if
+
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(plot_object,stres)
+ if(sprdcols.and..not.isatt(res2,"stLevelColors")) then
+ stres2 = True
+ set_attr(stres2,"stLevelColors",
+ spread_colors(wks,plot_object,min_index,max_index,res2))
+ attsetvalues(plot_object,stres2)
+ end if
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(plot_object)
+ end if
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(plot_object,"vf",resources)
+ end if
+
+ ; Check if we need to force the X or Y axis to be linear or log.
+ ; If so, then we have to overlay it on a LogLin Plot.
+
+ if(force_x_linear.or.force_x_log.or.force_y_linear.or.force_y_log)
+ overlay_plot_object = plot_object
+ delete(plot_object)
+
+ plot_object = overlay_irregular(wks,wksname,overlay_plot_object,
+ data_object,force_x_linear,
+ force_y_linear,force_x_log,
+ force_y_log,"vector",llres)
+ end if
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ plot_object at vfdata = vfdata_object
+ plot_object at sfdata = sfdata_object
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_vector_scalar_map ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a vector plot over a map plot to the ;
+ ; workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "u" and "v" are the 2-dimensional arrays to be ;
+ ; vectorized, and "data" is the scalar field that the vectors are ;
+ ; colored by. "resources" is an optional list of resources. The id of ;
+ ; the map plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_vector_scalar_map")
+ function gsn_vector_scalar_map(wks:graphic,u[*][*]:numeric,
+ v[*][*]:numeric,data:numeric,
+ resources:logical)
+ local i, vfdata_object, sfdata_object, contour_object, res,
+ vf_res_index, vc_res_index, sf_res_index, mp_res_index, map_object, res2,
+ sprdcols
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_vector_scalar_map: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_vector_scalar_map",res2,3)
+ end if
+
+ ;
+ ; Create the vector and scalar field object.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create plot object.
+
+ vector_object = create wksname + "_vector" vectorPlotClass wks
+ "vcVectorFieldData" : vfdata_object
+ "vcScalarFieldData" : sfdata_object
+ "vcUseScalarArray" : True
+ "vcMonoLineArrowColor" : False
+ end create
+
+ ; Create map object.
+
+ map_object = create wksname + "_map" mapPlotClass wks end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"vcSpanLevelPalette")) then
+ res2 at vcSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ mpres = get_res_eq(res2,(/"mp","vp","pmA","pmO","pmT","tm"/))
+ vcres = get_res_ne(res2,(/"mp","sf","vf","vp"/))
+
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(map_object,mpres)
+ attsetvalues_check(vector_object,vcres)
+
+ if(sprdcols.and..not.isatt(res2,"vcLevelColors")) then
+ vcres2 = True
+ set_attr(vcres2,"vcLevelColors",
+ spread_colors(wks,vector_object,min_index,max_index,res2))
+ attsetvalues(vector_object,vcres2)
+ end if
+
+ overlay(map_object,vector_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(vector_object,"vf",resources)
+ end if
+
+ draw_and_frame(wks,map_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ map_object at vfdata = vfdata_object
+ map_object at sfdata = sfdata_object
+ map_object at vector = vector_object
+ return(map_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_streamline_scalar_map ;
+ ; wks: workstation object ;
+ ; u: 2-dimensional U data ;
+ ; v: 2-dimensional V data ;
+ ; data: 2-dimensional scalar field ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws a streamline plot over a map plot to ;
+ ; the workstation "wks" (the variable returned from a previous call to ;
+ ; "gsn_open_wks"). "u" and "v" are the 2-dimensional streamline arrays,;
+ ; and "data" is the scalar field that the streamlines are colored by. ;
+ ; "resources" is an optional list of resources. The id of the map plot ;
+ ; is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; gsnSpreadColors - deprecated as of NCL V6.1.0. Only used if ;
+ ; gsnSpreadColorStart and/or gsnSpreadColorEnd are set to something ;
+ ; other than 2 and -1. ;
+ ; gsnSpreadColorStart ;
+ ; gsnSpreadColorEnd ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_streamline_scalar_map")
+ function gsn_streamline_scalar_map(wks:graphic,u[*][*]:numeric,
+ v[*][*]:numeric,data:numeric,
+ resources:logical)
+ local i, vfdata_object, sfdata_object, contour_object, res,
+ vf_res_index, st_res_index, sf_res_index, mp_res_index, map_object, res2,
+ sprdcols
+ begin
+ ;
+ ; Make sure input data is 1D or 2D
+ ;
+ if(.not.is_data_1d_or_2d(data)) then
+ print("gsn_streamline_scalar_map: Fatal: the input data array must be 1D or 2D")
+ return
+ end if
+
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(u,v,data,"gsn_streamline_scalar_map",res2,3)
+ end if
+
+ ;
+ ; Create the streamline and scalar field object.
+ ;
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ vfdata_object = vector_field(wksname+"_vfdata",u,v,res2)
+ sfdata_object = scalar_field(wksname+"_sfdata",data,res2);
+
+ ; Create plot object.
+
+ streamline_object = create wksname + "_streamline" streamlinePlotClass wks
+ "stVectorFieldData" : vfdata_object
+ "stScalarFieldData" : sfdata_object
+ "stUseScalarArray" : True
+ "stMonoLineColor" : False
+ end create
+
+ ; Create map object.
+
+ map_object = create wksname + "_map" mapPlotClass wks end create
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+ min_index = get_res_value(res2,"gsnSpreadColorStart",2)
+ max_index = get_res_value(res2,"gsnSpreadColorEnd",-1)
+ if(min_index.ne.2.or.max_index.ne.-1.) then
+ sprdcols = get_res_value(res2,"gsnSpreadColors",True)
+ else
+ if(check_attr(res2,"gsnSpreadColors",False,True).and..not.
+ isatt(res2,"stSpanLevelPalette")) then
+ res2 at stSpanLevelPalette = False
+ end if
+ sprdcols = get_res_value(res2,"gsnSpreadColors",False)
+ end if
+
+ vfres = get_res_eq(res2,"vf")
+ sfres = get_res_eq(res2,"sf")
+ mpres = get_res_eq(res2,(/"mp","vp","pmA","pmO","pmT","tm"/))
+ stres = get_res_ne(res2,(/"mp","sf","vf","vp"/))
+
+ attsetvalues_check(vfdata_object,vfres)
+ attsetvalues_check(sfdata_object,sfres)
+ attsetvalues_check(map_object,mpres)
+ attsetvalues_check(streamline_object,stres)
+
+ if(sprdcols.and..not.isatt(res2,"stLevelColors")) then
+ stres2 = True
+ set_attr(stres2,"stLevelColors",
+ spread_colors(wks,streamline_object,min_index,max_index,res2))
+ attsetvalues(streamline_object,stres2)
+ end if
+
+ overlay(map_object,streamline_object)
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(streamline_object,"vf",resources)
+ end if
+
+ draw_and_frame(wks,map_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ map_object at vfdata = vfdata_object
+ map_object at sfdata = sfdata_object
+ map_object at streamline = streamline_object
+ return(map_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_xy ;
+ ; wks: workstation object ;
+ ; x: n-dimensional array of X arrays ;
+ ; y: n-dimensional array of Y array ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function creates and draws an xy plot to the workstation "wks" ;
+ ; (the variable returned from a previous call to "gsn_open_wks"). "x" ;
+ ; and "y" are either 1 or 2-dimensional arrays containing the X and Y ;
+ ; data points and "resources" is an optional list of resources. The id ;
+ ; of the xy plot is returned. ;
+ ; ;
+ ; Special resources ("gsn" prefix) allowed: ;
+ ; ;
+ ; gsnDraw ;
+ ; gsnFrame ;
+ ; gsnShape ;
+ ; gsnScale ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_xy")
+ function gsn_xy(wks:graphic, x:numeric, y:numeric, resources:logical )
+ local i, attnames, data_object, plot_object, res, ca_res_index,
+ xy_res_index, xydp_res_index, dspec, res2, set_dash
+ begin
+ set_dash = True ; Default is to set some dash patterns.
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(x,y,new(1,float),"gsn_xy",res2,2)
+ end if
+
+ ; Determine if we have multiple lines or just one line.
+
+ nxdims = dimsizes(dimsizes(x))
+ xdims = dimsizes(x)
+ wksname = get_res_value_keep(wks,"name","gsnapp")
+
+ data_object = create wksname + "_data" coordArraysClass noparent
+ "caXArray" : x
+ "caYArray" : y
+ end create
+
+ ; Check for missing values.
+
+ if(isatt(x,"_FillValue")) then
+ setvalues data_object
+ "caXMissingV" : x at _FillValue
+ end setvalues
+ end if
+ if(isatt(y,"_FillValue")) then
+ setvalues data_object
+ "caYMissingV" : y at _FillValue
+ end setvalues
+ end if
+
+ ; Create plot object.
+
+ plot_object = create wksname + "_xy" xyPlotClass wks
+ "xyCoordData" : data_object
+ end create
+ ;
+ ; I'm guessing that we can't set the tr* resources when we create
+ ; the XY plot because it probably affects other resources. So, we go ahead
+ ; and create the full plot, and *then* we set the tr* resources, if any.
+ ;
+ getvalues plot_object
+ "trXMinF" : trxmin2
+ "trXMaxF" : trxmax2
+ "trYMinF" : trymin2
+ "trYMaxF" : trymax2
+ end getvalues
+
+ trxmin = get_res_value_keep(res2,"trXMinF",trxmin2)
+ trxmax = get_res_value_keep(res2,"trXMaxF",trxmax2)
+ trymin = get_res_value_keep(res2,"trYMinF",trymin2)
+ trymax = get_res_value_keep(res2,"trYMaxF",trymax2)
+
+ plot_object = create wksname + "_xy" xyPlotClass wks
+ "xyCoordData" : data_object
+ "trXMinF" : trxmin
+ "trXMaxF" : trxmax
+ "trYMinF" : trymin
+ "trYMaxF" : trymax
+ end create
+
+ ; Check for existence of x/y at long_name/units and use them to
+ ; label X and Y axes.
+
+ xaxis_string = get_long_name_units_string(x)
+ yaxis_string = get_long_name_units_string(y)
+
+ if(.not.ismissing(xaxis_string)) then
+ set_attr(res2,"tiXAxisString",xaxis_string)
+ end if
+ if(.not.ismissing(yaxis_string)) then
+ set_attr(res2,"tiYAxisString",yaxis_string)
+ end if
+
+ ; By default, only solid lines get drawn if there are multiple lines, so
+ ; set some dash patterns to use instead. Also set different marker styles.
+
+ getvalues plot_object
+ "xyCoordDataSpec" : dspec
+ end getvalues
+
+ if(res2.and..not.any(ismissing(getvaratts(res2))))
+ if(isatt(res2,"xyDashPattern").or.isatt(res2,"xyDashPatterns"))
+ set_dash = False
+ end if
+ end if
+
+ if(set_dash)
+ setvalues dspec
+ "xyDashPatterns" : (/0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
+ 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,
+ 0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16/)
+ end setvalues
+ end if
+
+ calldraw = get_res_value(res2,"gsnDraw", True)
+ callframe = get_res_value(res2,"gsnFrame",True)
+ maxbb = get_bb_res(res2)
+ shape = get_res_value(res2,"gsnShape",False)
+ scale = get_res_value(res2,"gsnScale",shape)
+
+ check_for_tickmarks_off(res2)
+
+ cares = get_res_eq(res2,"ca")
+ attsetvalues_check(data_object,cares)
+
+ if(res2.and..not.any(ismissing(getvaratts(res2))))
+ ; Get list of resources.
+
+ attnames = getvaratts(res2)
+ res = stringtocharacter(attnames(ind(attnames.ne."_FillValue")))
+
+ ;***********************************************************************;
+ ; Check to see if any xy plot resources were set. There are two kinds ;
+ ; of xy plot resources, the regular kind, and the data spec kind. If ;
+ ; the resource starts with an "xy", it could be either kind, so we need ;
+ ; to have some tests to see which object it belongs to. Any "xy" ;
+ ; resources that start with "xyC", "xyX", or "xyY" are regular ;
+ ; resources (meaning, it belongs to the XyPlot object). The remaining ;
+ ; "xy" resources belong to the data spec object. Any resources that do ;
+ ; not start with "xy" or "ca" are assumed to also go with the XyPlot ;
+ ; object. ;
+ ;***********************************************************************;
+ if(dimsizes(dimsizes(res)).eq.1)
+ if((charactertostring(res(0:1)).ne."ca".and.
+ charactertostring(res(0:1)).ne."xy").or.
+ (charactertostring(res(0:1)).eq."xy".and.
+ (charactertostring(res(0:2)).eq."xyC".or.
+ charactertostring(res(0:2)).eq."xyX".or.
+ charactertostring(res(0:2)).eq."xyY")))
+ setvalues plot_object
+ attnames : res2@$attnames$
+ end setvalues
+ end if
+ if(charactertostring(res(0:1)).eq."xy".and.
+ (charactertostring(res(0:2)).ne."xyC".and.
+ charactertostring(res(0:2)).ne."xyX".and.
+ charactertostring(res(0:2)).ne."xyY"))
+ setvalues dspec
+ attnames : res2@$attnames$
+ end setvalues
+ end if
+ else
+ xy_res_index = ind((charactertostring(res(:,0:1)).ne."ca".and.
+ charactertostring(res(:,0:1)).ne."xy").or.
+ (charactertostring(res(:,0:1)).eq."xy".and.
+ (charactertostring(res(:,0:2)).eq."xyC".or.
+ charactertostring(res(:,0:2)).eq."xyX".or.
+ charactertostring(res(:,0:2)).eq."xyY")))
+ xydp_res_index = ind(charactertostring(res(:,0:1)).eq."xy".and.
+ (charactertostring(res(:,0:2)).ne."xyC".and.
+ charactertostring(res(:,0:2)).ne."xyX".and.
+ charactertostring(res(:,0:2)).ne."xyY"))
+ if(.not.all(ismissing(xy_res_index)))
+ xyres = True
+ do i = 0,dimsizes(xy_res_index)-1
+ xyres@$attnames(xy_res_index(i))$ = res2@$attnames(xy_res_index(i))$
+ end do
+ attsetvalues_check(plot_object,xyres)
+ end if
+ if(.not.all(ismissing(xydp_res_index)))
+ getvalues plot_object
+ "xyCoordDataSpec" : dspec
+ end getvalues
+ xydpres = True
+ do i = 0,dimsizes(xydp_res_index)-1
+ xydpres@$attnames(xydp_res_index(i))$ = res2@$attnames(xydp_res_index(i))$
+ end do
+ attsetvalues_check(dspec,xydpres)
+ end if
+ end if
+
+ end if
+ ;
+ ; If gsnShape was set to True, then resize the X or Y axis so that
+ ; the scales are proportionally correct.
+ ;
+ if(shape)
+ gsnp_shape_plot(plot_object)
+ end if
+
+ ;
+ ; If gsnScale was set to True, then make sure the X and Y axis labels
+ ; and tick marks are the same size.
+ ;
+ if(scale)
+ gsnp_scale_plot(plot_object,"",False)
+ end if
+
+ draw_and_frame(wks,plot_object,calldraw,callframe,0,maxbb)
+
+ ; Return plot object and data object (as attribute of plot object).
+
+ plot_object at data = data_object
+ plot_object at dataspec = dspec
+ return(plot_object)
+ end
+
+ ;***********************************************************************;
+ ; Function : gsn_y ;
+ ; wks: workstation object ;
+ ; y: n-dimensional array of Y array ;
+ ; resources: optional resources ;
+ ; ;
+ ; This function is similar to gsn_xy, except instead of a specific X ;
+ ; array, index values are used. ;
+ ; ;
+ ;***********************************************************************;
+ undef("gsn_y")
+ function gsn_y(wks:graphic, y:numeric, resources:logical )
+ local dsizes_y, npts, x, rank_y, xy
+ begin
+ res2 = get_resources(resources)
+ ;
+ ; Write data and plot resource information to a file so we can
+ ; reconstruct plot if desired, without all the computational
+ ; code beforehand.
+ ;
+ if(isatt(res2,"gsnDebugWriteFileName")) then
+ gsnp_write_debug_info(y,new(1,float),new(1,float),"gsn_y",res2,1)
+ end if
+ ;
+ ; Get dimension sizes of Y array.
+ ;
+ dsizes_y = dimsizes(y)
+ rank_y = dimsizes(dsizes_y)
+ if(rank_y.eq.1) then
+ npts = dsizes_y
+ else
+ if(rank_y.ne.2) then
+ print("Error: gsn_y: The input Y array must either be 1-dimensional, or 2-dimensional, where the leftmost dimension represents the number of curves and the rightmost dimension the number of points in each curve.")
+ exit
+ end if
+ npts = dsizes_y(1)
+ end if
+
+ ;
+ ; Create the indexed X array.
+ ;
+ x = ispan(0,npts-1,1)
+ x at long_name = ""
+
+ ;
+ ; Call gsn_xy.
+ ;
+ xy = gsn_xy(wks,x,y,res2)
+ return(xy)
+ end
+
+
+ ;***********************************************************************;
+ ; Function : gsn_contour_shade ;
+ ; ;
+ ; This function shades contour regions given low and/or high values ;
+ ; using colors or patterns. ;
+ ; ;
+ ; This function was written by Adam Phillips, 2006 ;
+ ; ;
+ ; This function was updated July 2013 to allow any combination of ;
+ ; gsnShadeLow, gsnShadeMid, and gsnShadeHigh to be set. ;
+ ; ;
+ ; This function was updated July 2014 to allow RGB and RGBA values for ;
+ ; color. The following are now valid for colors: ;
+ ; ;
+ ; Color index value: opt at gsnShadeLow = 5 ;
+ ; Named color: opt at gsnShadeHigh = "blue" ;
+ ; RGB color: opt at gsnShadeHigh = (/1.,0.,0.5/) ;
+ ; RGBA color: opt at gsnShadeHigh = (/1.,0.,0.5,0.5/) ;
+ ;***********************************************************************;
+ undef("gsn_contour_shade")
+ function gsn_contour_shade(plot:graphic,lowval:numeric,highval:numeric,
+ opt:logical)
+ local shaden_set, shadem_set, shadep_set, shaden, shadep, shadem, ovrly_ids,
+ idstringcnlvls, colist, i, N, tmp_wks
+ begin
+ if (.not.opt) then
+ print("gsn_contour_shade: Options list must be used as one of the following option resources must be set: opt at gsnShadeLow, opt at gsnShadeHigh, opt at gsnShadeMid.")
+ print(" Returning without making any changes to plot.")
+ return(plot)
+ end if
+
+ shade_type = str_lower(get_res_value_keep(opt,"gsnShadeFillType","color")) ; "pattern"
+
+ if(.not.any(shade_type.eq.(/"color","pattern"/))) then
+ print("gsn_contour_shade: gsnShadeFillType can only be 'pattern' or 'color'.")
+ print(" Returning without making any changes to plot.")
+ return(plot)
+ end if
+
+ ;----------------------------------------------------------------------
+ ; This section is used to retrieve the gsnShadeLow/Mid/High resources
+ ; and make sure they are valid.
+ ;
+ ; If doing color fill, you can mix and match color types (index color,
+ ; named color, rgb, rgba).
+ ;
+ ; If doing pattern fill, only pattern indexes can be used.
+ ;----------------------------------------------------------------------
+ tmp_wks = NhlGetParentWorkstation(plot)
+ if (isatt(opt,"gsnShadeLow")) then
+ shaden_set = True
+ if(shade_type.eq."color") then
+ shaden = convert_color_to_rgba(tmp_wks,opt at gsnShadeLow)
+ else
+ shaden = opt at gsnShadeLow
+ shaden_type = typeof(shaden)
+ end if
+ else
+ shaden_set = False
+ if(shade_type.eq."color") then
+ shaden = (/0.,0.,0.,0./) ; transparent
+ shaden_type = "rgba"
+ else
+ shaden = -1 ; no fill
+ shaden_type = "integer"
+ end if
+ end if
+ if (isatt(opt,"gsnShadeMid")) then
+ shadem_set = True
+ if(shade_type.eq."color") then
+ shadem = convert_color_to_rgba(tmp_wks,opt at gsnShadeMid)
+ shadem_type = "rgba"
+ else
+ shadem = opt at gsnShadeMid
+ shadem_type = typeof(shadem)
+ end if
+ else
+ shadem_set = False
+ if(shade_type.eq."color") then
+ shadem = (/0.,0.,0.,0./) ; transparent
+ shadem_type = "rgba"
+ else
+ shadem = -1 ; no fill
+ shadem_type = "integer"
+ end if
+ end if
+ if (isatt(opt,"gsnShadeHigh")) then
+ shadep_set = True
+ if(shade_type.eq."color") then
+ shadep = convert_color_to_rgba(tmp_wks,opt at gsnShadeHigh)
+ shadep_type = "rgba"
+ else
+ shadep = opt at gsnShadeHigh
+ shadep_type = typeof(shadep)
+ end if
+ else
+ shadep_set = False
+ if(shade_type.eq."color") then
+ shadep = (/0.,0.,0.,0./) ; transparent
+ shadep_type = "rgba"
+ else
+ shadep = -1 ; no fill
+ shadep_type = "integer"
+ end if
+ end if
+
+ ;---Error checking on the gsnShadeLow/Mid/High resources
+ if(.not.any((/shaden_set,shadem_set,shadep_set/))) then
+ print("gsn_contour_shade: one of the following resources must be set: opt at gsnShadeLow, opt at gsnShadeHigh, opt at gsnShadeMid.")
+ print(" Returning without making any changes to plot.")
+ return(plot)
+ end if
+
+ ;---Error checking if we have pattern fill.
+ if(shade_type.eq."pattern".and.
+ any((/shaden_type,shadem_type,shadep_type/).ne."integer")) then
+ print("gsn_contour_shade: You must use integer values when doing pattern fill.")
+ print(" Returning without making any changes to plot.")
+ return(plot)
+ end if
+
+ if(shade_type.eq."color".and.any((/all(ismissing(shaden)),
+ all(ismissing(shadem)),all(ismissing(shadep))/))) then
+ print("gsn_contour_shade: One of your gsnShadeLow/Mid/High resources is set to an invalid color.")
+ print(" Returning without making any changes to plot.")
+ return(plot)
+ end if
+
+ getvalues plot
+ "pmOverlaySequenceIds" : ovrly_ids
+ end getvalues
+ if (.not.any(ismissing(ovrly_ids))) then
+ do i=0,dimsizes(ovrly_ids)-1
+ if (NhlClassName(ovrly_ids(i)).eq."contourPlotClass")
+ idstring = ovrly_ids(i)
+ end if
+ end do
+ end if
+ getvalues idstring
+ "cnLevels" : cnlvls
+ end getvalues
+
+ if ((isatt(opt,"printcnlevels"))) then
+ if (opt at printcnlevels) then
+ print(cnlvls)
+ end if
+ end if
+
+ ;---Make sure we have contour levels
+ N = dimsizes(cnlvls)
+ if (ismissing(N) .or. N.le.0) then
+ print ("gsn_contour_shade: dimsizes(cnlvls)="+N+" return (non-fatal)")
+ return (plot)
+ end if
+
+ ;---Create array for fill, set all to transparent or white
+ if(shade_type.eq."color") then
+ colist = new((/N+1,4/),double)
+ colist(:,3) = 0.
+ else
+ colist = new(N+1,integer)
+ colist = -1
+ end if
+
+ ;---Start filling colist
+ if (shaden_set.and.any(cnlvls.le.lowval)) then
+ ii := ind(cnlvls.le.lowval)
+ ii_dims = dimsizes(ii)
+ if(shade_type.eq."pattern") then
+ colist(ii) = shaden
+ else if(ii_dims.eq.1) then
+ colist(ii,:) = shaden
+ else
+ colist(ii,:) = conform(colist(ii,:),shaden,1)
+ end if
+ end if
+ end if
+
+ if (shadep_set.and.any(cnlvls.ge.highval)) then
+ ii := ind(cnlvls.ge.highval)+1
+ ii_dims = dimsizes(ii)
+ if(shade_type.eq."pattern") then
+ colist(ii) = shadep
+ else if(ii_dims.eq.1) then
+ colist(ii,:) = shadep
+ else
+ colist(ii,:) = conform(colist(ii,:),shadep,1)
+ end if
+ end if
+ end if
+
+ if (shadem_set.and.any(cnlvls.ge.lowval.and.cnlvls.le.highval)) then
+ ii := ind(cnlvls.ge.lowval.and.cnlvls.le.highval)
+ ii_dims = dimsizes(ii)
+ if(shade_type.eq."pattern") then
+ colist(ii) = shadem
+ else if (ii_dims.ge.2) then
+ colist(ii(1:),:) = conform(colist(ii(1:),:),shadem,1)
+ else
+ print("gsn_contour_shade: 1 contour level or less found between "+lowval+" and "+highval+", not color filling")
+ end if
+ end if
+ end if
+
+ if (shade_type.eq."color") then
+ setvalues idstring
+ "cnFillOn" : True
+ "cnMonoFillPattern" : True
+ "cnMonoFillColor" : False
+ "cnFillColors" : colist
+ end setvalues
+ else
+ setvalues idstring
+ "cnFillOn" : True
+ "cnMonoFillColor" : True
+ "cnMonoFillPattern" : False
+ "cnFillPatterns" : colist
+ end setvalues
+ end if
+ return (plot)
+ end
+ undef("fill_res")
+ procedure fill_res(res1:logical,res2:logical,ncr[2]:integer,attnames[*]:string)
+ local natts, i, dsizes, rank, success, nrows, ncols
+ begin
+ nrows = ncr(0)
+ ncols = ncr(1)
+ natts = dimsizes(attnames)
+
+ if(res1.and.natts.ge.1) then
+ res2 = True
+ ;
+ ; Loop through each attribute, check its size, and copy it to new
+ ; 2D variable if needed. We have to do this so that later we don't
+ ; have to check each attribute for the right size.
+ ;
+ do i=0,natts-1
+ if(isatt(res1,attnames(i))) then
+ ;
+ ; Get the dimension size and rank of this attribute.
+ ;
+ dsizes = dimsizes(res1@$attnames(i)$)
+ rank = dimsizes(dsizes)
+ success = False
+ ;
+ ; We need elseif here!!
+ ;
+ if(rank.eq.1) then
+ if(dsizes.eq.1) then
+ ;
+ ; Scalar attribute.
+ ;
+ res2@$attnames(i)$ = new(nrows*ncols,typeof(res1@$attnames(i)$))
+ res2@$attnames(i)$(:) = res1@$attnames(i)$
+ success = True
+ else
+ ;
+ ; 1D attribute of length nrows (ncols must be 1).
+ ;
+ if(dsizes.eq.nrows.and.ncols.eq.1) then
+ res2@$attnames(i)$ = new(nrows*ncols,typeof(res1@$attnames(i)$))
+ res2@$attnames(i)$(:) = res1@$attnames(i)$
+ success = True
+ else
+ ;
+ ; 1D attribute of length ncols (nrows must be 1).
+ ;
+ if(dsizes.eq.ncols.and.nrows.eq.1) then
+ res2@$attnames(i)$ = new(nrows*ncols,typeof(res1@$attnames(i)$))
+ res2@$attnames(i)$(:) = res1@$attnames(i)$
+ success = True
+ end if
+ end if
+ end if
+ else
+ if(rank.eq.2.and.dsizes(0).eq.nrows.and.dsizes(1).eq.ncols) then
+ ;
+ ; 2D attribute of size nrows x ncols.
+ ;
+ res2@$attnames(i)$ = ndtooned(res1@$attnames(i)$)
+ success = True
+ end if
+ end if
+ if(.not.success) then
+ print("fill_res: attribute '" + attnames(i) + "' is the wrong size.")
+ print(" Not using it.")
+ end if
+ delete(dsizes)
+ end if
+ end do
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Procedure : gsn_table ;
+ ; This procedure draws a grid given the workstation ;
+ ; to draw to, the beginning X and ending Y values (in NDC coords), ;
+ ; and the number of rows and columns. Text strings are drawn ;
+ ; in the center of each cell, if specified. ;
+ ; ;
+ ; draw_grid( ;
+ ; wks - workstation value returned from gsn_open_wks. ;
+ ; ncr[2] - integers, number of rows and columns ;
+ ; x - begin and end values of x position of table ;
+ ; y - begin and end values of y position of table ;
+ ; text - optional list of text strings. Use: ;
+ ; text = new(1,string) ;
+ ; if you don't want any text strings. ;
+ ; res - optional list of "gs" (for the table lines) ;
+ ; or "tx" (for the text) resources. ;
+ ; ) ;
+ ;***********************************************************************;
+ undef("gsn_table")
+ procedure gsn_table(wks:graphic,ncr[2]:integer,x[2]:numeric,
+ y[2]:numeric,text:string,res:logical)
+ local nrows, ncols, i, ii, txres, txres2, lnres, attnames, natts, text2d
+ begin
+ debug = get_res_value(res,"gsnDebug",False)
+
+ nrows = ncr(0)
+ ncols = ncr(1)
+ ;
+ ; Error checking.
+ ;
+ if(nrows.lt.1.or.ncols.lt.1) then
+ print("gsn_table: nrows and ncols must be >= 1.")
+ exit
+ end if
+ if(any(x.lt.0.or.x.gt.1.or.y.lt.0.or.y.gt.1)) then
+ print("gsn_table: the begin and end x and y values must")
+ print(" be in the range [0,1].")
+ exit
+ end if
+
+ if(x(1).le.x(0).or.y(1).le.y(0)) then
+ print("gsn_table: the begin x,y points must be less")
+ print(" than the end x,y points.")
+ exit
+ end if
+
+ ;
+ ; Check if text desired.
+ ;
+ if(.not.all(ismissing(text))) then
+ text_avail = True
+ else
+ text_avail = False
+ end if
+
+ if(text_avail) then
+ ;
+ ; Check that the text dimens are correct. If you have nrows x ncols,
+ ; then the text can either be (nrows x ncols) strings, a scalar string,
+ ; or (ncols) if nrows=1, or (nrows) if ncols=1.
+ ;
+ dsizes_text = dimsizes(text)
+ rank_text = dimsizes(dsizes_text)
+ if( (rank_text.ne.2.and.rank_text.ne.1).or.
+ (rank_text.eq.1.and.(nrows.ne.1.and.ncols.ne.1)).or.
+ (rank_text.eq.1.and.(nrows.eq.1.and.ncols.ne.dsizes_text)).or.
+ (rank_text.eq.1.and.(ncols.eq.1.and.nrows.ne.dsizes_text)).or.
+ (rank_text.ne.2.and.(nrows.gt.1.and.ncols.gt.1)) ) then
+ print("gsn_table: the dimensionality of the text must be ")
+ print(" " + nrows + " row(s) x " + ncols + " column(s).")
+ exit
+ end if
+ end if
+
+ ;
+ ; Check all resource values. They must either be scalars, or
+ ; arrays of same size as nrows x ncols.
+ ;
+ res2 = False
+ attnames = getvaratts(res)
+ fill_res(res,res2,ncr,attnames)
+ delete(attnames) ; We're going to use this later.
+
+ ;
+ ; Get ready to draw table.
+ ;
+ xsize = (x(1) - x(0))/ncols ; width of grid cell
+ ysize = (y(1) - y(0))/nrows ; height of grid cell
+
+ lnres = get_res_eq(res2,"gs") ; Resource list for lines.
+
+ ;
+ ; Check for a box fill color.
+ ;
+ fill_on = False
+ if(isatt(res2,"gsFillColor").or.isatt(res2,"gsFillIndex")) then
+ fill_on = True
+ end if
+
+ ;
+ ; Check for desired filling of each grid cell. Do this before drawing
+ ; grid lines, because we want lines drawn on top of filled boxes.
+ ;
+ if(fill_on) then
+ gonres = get_res_eq(res2,"gsFill") ; Get fill resources.
+ gonres2 = True
+ attnames = getvaratts(gonres)
+ natts = dimsizes(attnames)
+ do nr = 0,nrows-1
+ ypos = y(1) - ((nr+1) * ysize)
+ do nc = 0,ncols-1
+ ii = nr*ncols+nc
+ ;
+ ; Copy all resources over to temporary array.
+ ;
+ do i=0,natts-1
+ gonres2@$attnames(i)$ = gonres@$attnames(i)$(ii)
+ end do
+ xpos = x(0) + (nc * xsize)
+ gsn_polygon_ndc(wks,(/xpos,xpos+xsize,xpos+xsize,xpos,xpos/),
+ (/ypos,ypos,ypos+ysize,ypos+ysize,ypos/),gonres2)
+ end do
+ end do
+ delete(attnames) ; We're going to use this later.
+ end if
+
+ ; Draw horizontal lines, top to bottom.
+ do nr = 0,nrows
+ ypos = y(1) - (nr * ysize)
+ gsn_polyline_ndc(wks,(/x(0),x(1)/),(/ypos,ypos/),lnres)
+
+ if(debug) then
+ print("Horizontal line from (" + x(0) + "," + ypos + ") to (" +
+ x(1) + "," + ypos + ")")
+ end if
+ end do
+
+ ; Draw vertical lines, left to right.
+ do nc = 0,ncols
+ xpos = x(0) + (nc * xsize)
+ gsn_polyline_ndc(wks,(/xpos,xpos/),(/y(0),y(1)/),lnres)
+
+ if(debug) then
+ print("Vertical line from (" + xpos + "," + y(0) + ") to (" +
+ xpos + "," + y(1) + ")")
+ end if
+ end do
+
+ ;
+ ; Draw text, if any. The text will be drawn left to right,
+ ; top to bottom.
+ ;
+ if(text_avail) then
+ txres = get_res_eq(res2,"tx") ; Get text resources.
+ ;
+ ; Conform text to nrows x ncols if it is 1D.
+ ;
+ if(rank_text.eq.1) then
+ text2d = new((/nrows,ncols/),string)
+ if(nrows.eq.1) then
+ text2d(0,:) = text
+ else
+ text2d(:,0) = text
+ end if
+ else
+ text2d = text ; Already 2D.
+ end if
+
+ xsize2 = xsize/2. ; Half width of box.
+ ysize2 = ysize/2. ; Half height of box.
+
+ ;
+ ; All text resources should be nrows x ncols at this point. Now,
+ ; for each individual text string, we need to grab the appropriate
+ ; resource value, and attach it to a new resource list.
+ ;
+ txres2 = True ; True no matter what, because we have to at least set
+ ; txJust.
+ ;
+ ; If txJust is not being set, use "CenterCenter" for each one.
+ ; Note that if txres is set to False and it is setting txJust,
+ ; it will be ignored. that's because setting txres=False means
+ ; ignore all attributes set to this logical variable.
+ ;
+ if(.not.txres.or.(txres.and..not.isatt(txres,"txJust"))) then
+ txres = True
+ txres at txJust = new(nrows*ncols,string)
+ txres at txJust(:) = "CenterCenter"
+ end if
+
+ attnames = getvaratts(txres)
+ natts = dimsizes(attnames)
+
+ do nr = 0,nrows-1
+ do nc = 0,ncols-1
+
+ if(.not.ismissing(text2d(nr,nc))) then
+ ii = nr*ncols+nc
+ ;
+ ; Copy all resources over to temporary array.
+ ;
+ do i=0,natts-1
+ txres2@$attnames(i)$ = txres@$attnames(i)$(ii)
+ end do
+ ;
+ ; Check the text justification.
+ ;
+ txjust = txres2 at txJust
+
+ if(any(lower_case(txjust).eq.
+ (/"bottomleft","bottomcenter","bottomright"/))) then
+ ypos = y(1) - ((nr+1) * ysize)
+ end if
+ if(any(lower_case(txjust).eq.
+ (/"centerleft","centercenter","centerright"/))) then
+ ypos = (y(1) - ((nr+1) * ysize)) + ysize2
+ end if
+ if(any(lower_case(txjust).eq.
+ (/"topleft","topcenter","topright"/))) then
+ ypos = y(1) - (nr * ysize)
+ end if
+ if(any(lower_case(txjust).eq.
+ (/"bottomleft","centerleft","topleft"/))) then
+ xpos = x(0) + (nc * xsize)
+ end if
+ if(any(lower_case(txjust).eq.
+ (/"bottomcenter","centercenter","topcenter"/))) then
+ xpos = (x(0) + (nc * xsize)) + xsize2
+ end if
+ if(any(lower_case(txjust).eq.
+ (/"bottomright","centerright","topright"/))) then
+ xpos = x(0) + ((nc+1) * xsize)
+ end if
+ ; Draw text.
+ gsn_text_ndc(wks,text2d(nr,nc),xpos,ypos,txres2)
+ end if
+ end do
+ end do
+ end if
+ end
+ ;--------------------------------------------------------------------------------
+ ; This function convert input variable x to type specified by type.
+ ; Wei Huang
+ ; May 21, 2012
+ ;--------------------------------------------------------------------------------
+
+ undef("totype")
+ function totype( varin, type:string )
+ local varout
+
+ begin
+ ;printVarSummary(varin)
+ ;print(type)
+
+ ;Convert to float
+ if(type .eq. "float") then
+ varout = tofloat(varin)
+ return(varout)
+ end if
+
+ ;Convert to double
+ if(type .eq. "double") then
+ varout = todouble(varin)
+ return(varout)
+ end if
+
+ ;Convert to uint
+ if(type .eq. "uint") then
+ varout = touint(varin)
+ return(varout)
+ end if
+
+ ;Convert to integer
+ if(type .eq. "int" .or. type .eq. "integer") then
+ varout = toint(varin)
+ return(varout)
+ end if
+
+ ;Convert to char
+ if(type .eq. "char" .or. type .eq. "character") then
+ varout = tochar(varin)
+ return(varout)
+ end if
+
+ ;Convert to byte
+ if(type .eq. "byte") then
+ varout = tobyte(varin)
+ return(varout)
+ end if
+
+ ;Convert to short
+ if(type .eq. "short") then
+ varout = toshort(varin)
+ return(varout)
+ end if
+
+ ;Convert to ushort
+ if(type .eq. "ushort") then
+ varout = toushort(varin)
+ return(varout)
+ end if
+
+ ;Convert to long
+ if(type .eq. "long") then
+ varout = tolong(varin)
+ return(varout)
+ end if
+
+ ;Convert to ulong
+ if(type .eq. "ulong") then
+ varout = toulong(varin)
+ return(varout)
+ end if
+
+ ;Convert to int64
+ if(type .eq. "int64") then
+ varout = toint64(varin)
+ return(varout)
+ end if
+
+ ;Convert to uint64
+ if(type .eq. "uint64") then
+ varout = touint64(varin)
+ return(varout)
+ end if
+
+ ;Convert to string
+ if(type .eq. "string") then
+ varout = tostring(varin)
+ return(varout)
+ end if
+
+ print("")
+ print("WARNING:")
+ print("CANNOT convert input variable type: <" + typeof(varin) + "> to type: <" + type + ">")
+ print("The original type: <" + typeof(varin) + "> is returned.")
+ print("")
+
+ varout = varin
+ return(varout)
+ end
+
+ ;***********************************************************************;
+ ; Function : read_colormap_file ;
+ ; colorMapName : either the name of an NCL-standard ;
+ ; colormap, or the filename of a ;
+ ; user-supplied colormap. ;
+ ; ;
+ ; This function either reads an NCL-standard colormap, given is name, ;
+ ; or expects to read a colormap from a given file. It supports reading ;
+ ; either RGB-tuples or RGBA-tuples (or a mixture); it always returns a ;
+ ; colormap comprised of RGBA-tuples. ;
+ ; ;
+ ; This function was moved to utilities.ncl (from gsn_code.ncl) to make ;
+ ; it more accessible (say by functions in contributed.ncl). ;
+ ;***********************************************************************;
+ undef("read_colormap_file")
+ function read_colormap_file(colorMapName:string)
+ local pathname, lines, tokens, cmap, tmpCmap, i, numColors,
+ red, green, blue, alpha, maxValue, MAXCOLORS
+ begin
+ MAXCOLORS = 256 ; symbolic constant, used below
+
+ ; ----------------------------------------------------------
+ ; Inner convenience function to test string as suitable for
+ ; conversion to numeric.
+ undef("isNumerical")
+ function isNumerical(s:string)
+ local seenDecimal, charS, len, i
+ begin
+ seenDecimal = False
+ charS = stringtocharacter(s)
+ len = strlen(s)
+ do i=0, len-1
+ if (charS(i).eq.".") then
+ if (seenDecimal) then
+ return False
+ else
+ seenDecimal = True
+ end if
+ else
+ if (charS(i).lt."0" .or. charS(i).gt."9") then
+ return False
+ end if
+ end if
+ end do
+ return True
+ end
+
+ ; ------------------------------------------------------------
+ ; Inner convenience function to find appropriate pathname for
+ ; the given filename.
+ undef("getFilePath")
+ function getFilePath(colorMapName:string)
+ local suffixes, paths, path1, path2, i, j, tmp
+ begin
+
+ ; Is this one of our standard named colormaps? There are several well-defined
+ ; locations and suffixes to try...
+ tmp = getenv("NCARG_COLORMAPS")
+ if (.not.ismissing(tmp)) then
+ paths = str_split(tmp, ":")
+ else
+ paths = (/ ncargpath("ncarg") + "/colormaps" /)
+ end if
+
+ suffixes = (/ ".rgb", ".gp", ".ncmap" /)
+
+ ; loop over the product of possible paths and possible suffixes...
+ do i=0, dimsizes(paths)-1
+ path1 = paths(i) + "/" + colorMapName
+ do j=0, dimsizes(suffixes)-1
+ path2 = path1 + suffixes(j)
+ if (fileexists(path2)) then
+ return path2
+ end if
+ end do
+ end do
+
+ ; if still here, just return colorMapName literally; presumably is a
+ ; filename for a user-managed colormap...
+ return colorMapName
+ end
+
+ ; get an appropriate pathname for the given colortable name and load it..
+ pathname = getFilePath(colorMapName)
+ lines = asciiread(pathname, -1, "string")
+ lines = str_squeeze(lines)
+
+ ; parse upto MAXCOLORS rgba tuples from the file just read...
+ tmpCmap = new((/ MAXCOLORS, 4 /), "float")
+ numColors = 0
+ maxValue = -1.0
+ i = 0
+ do while (i.lt.dimsizes(lines) .and. numColors.lt.MAXCOLORS)
+ if (ismissing(strlen(lines(i))) .or. strlen(lines(i)).eq.0) then
+ lines(i) = "#" ; zero-lengthed lines cause us grief...
+ end if
+ tokens = str_split(lines(i), " ")
+ if (dimsizes(tokens).ge.3) then
+ red = -1.0
+ green = -1.0
+ blue = -1.0
+ if (isNumerical(tokens(0))) then
+ red = stringtofloat(tokens(0))
+ end if
+ if (isNumerical(tokens(1))) then
+ green = stringtofloat(tokens(1))
+ end if
+ if (isNumerical(tokens(2))) then
+ blue = stringtofloat(tokens(2))
+ end if
+ if (dimsizes(tokens).gt.3 .and. isNumerical(tokens(3))) then
+ alpha = stringtofloat(tokens(3))
+ else
+ alpha = -1.0 ; used a marker, replaced appropriately below...
+ end if
+
+ ; were we able to get a rgba-tuple?
+ ;
+ if (red.ge.0 .and. green.ge.0 .and. blue.ge.0) then
+ ; yes, add it to our colormap...
+ tmpCmap(numColors,0) = red
+ tmpCmap(numColors,1) = green
+ tmpCmap(numColors,2) = blue
+ tmpCmap(numColors,3) = alpha
+ numColors = numColors + 1
+ ; keep track of the magnitude of these values; used to rescale below...
+ if (red.gt.maxValue) then
+ maxValue = red
+ end if
+ if (green.gt.maxValue) then
+ maxValue = green
+ end if
+ if (blue.gt.maxValue) then
+ maxValue = blue
+ end if
+ end if
+ end if
+ i = i + 1
+ delete(tokens)
+ end do
+
+ ; copy tmpCmap into appropriately sized array
+ cmap = new((/numColors, 4/), float)
+ cmap = tmpCmap(0:numColors-1,:)
+
+ ; normalize the values...(oh for true if-elseif!)
+ ; this logical taken directly from HLU code in "Palette.c"
+ if (maxValue.le.1) then
+ cmap(:,3) = where(cmap(:,3).lt.0, 1., cmap(:,3))
+ else if (maxValue.lt.256) then
+ cmap(:,3) = where(cmap(:,3).lt.0, 255., cmap(:,3))
+ cmap = cmap / 255.
+ else if (maxValue.eq.256) then
+ cmap(:,3) = where(cmap(:,3).lt.0, 256., cmap(:,3))
+ cmap = cmap / 256.
+ else if (maxValue.eq.65536) then
+ cmap(:,3) = where(cmap(:,3).lt.0, 65535., cmap(:,3))
+ cmap = cmap / 65535.
+ else if (maxValue.eq.65536) then
+ cmap(:,3) = where(cmap(:,3).lt.0, 65536., cmap(:,3))
+ cmap = cmap / 65536.
+ else
+ cmap(:,3) = where(cmap(:,3).lt.0, maxValue, cmap(:,3))
+ cmap = cmap / maxValue
+ end if
+ end if
+ end if
+ end if
+ end if
+
+ return cmap
+ end
+
+ ;***********************************************************************;
+ ; Function : read_colormap_files ;
+ ; colorMapNames : an array of names of an NCL-standard ;
+ ; colormap, or the filenames of ;
+ ; user-supplied colormaps. ;
+ ; ;
+ ; This function behaves exactly like read_colormap_file, except it ;
+ ; handles an array of color maps rather than just a single color map. ;
+ ;***********************************************************************;
+ undef("read_colormap_files")
+ function read_colormap_files(colorMapNames[*]:string)
+ local ncmaps, ncolors, i, cmap, nc
+ begin
+ ncmaps = dimsizes(colorMapNames)
+ ncolors = new(ncmaps,integer)
+
+ do i=0,ncmaps-1
+ cmap := read_colormap_file(colorMapNames(i))
+ if(any(ismissing(cmap))) then
+ print("read_colormap_files: Error: invalid color map name")
+ return(new((/1,4/),float))
+ end if
+ ncolors(i) = dimsizes(cmap(:,0))
+ end do
+
+ rgba_array = new((/sum(ncolors),4/),float)
+ nc = 0
+ do i=0,ncmaps-1
+ rgba_array(nc:nc+ncolors(i)-1,:) = read_colormap_file(colorMapNames(i))
+ nc = nc + ncolors(i)
+ end do
+
+ return(rgba_array)
+ end
+
+ ;***********************************************************************;
+ ; Given a color map and the number of desired colors, this function
+ ; returns an array of color indexes that nicely span the full colormap.
+ ;
+ ; For a named colormap, the first two color values are not used,
+ ; because these are the foreground/background colors.
+ ;
+ ; This function is very similar to the span_color_rgba function,
+ ; which returns RGBA values.
+ ;
+ ; The colormap can be a named colormap, like "rainbow", or an array
+ ; of RGB (n,3) or RGBA (n,4).
+ ;***********************************************************************
+ undef("span_color_indexes")
+ function span_color_indexes(cmapt,ncolors)
+ local ncols, fmin, fmax, fcols, icols, cmap
+ begin
+ if(isstring(cmapt)) then
+ cmap = read_colormap_file(cmapt)
+ else if(isnumeric(cmapt)) then
+ dims = dimsizes(cmapt)
+ if(dimsizes(dims).ne.2.or.dims(0).lt.3.or.dims(0).gt.256.or.
+ .not.any(dims(1).ne.(/3,4/))) then
+ print ("Error: span_color_indexes: cmap must be an n x 3 or n x 4 array of RGB or RGBA values, or a valid color map name")
+ return(new(1,integer)) ; return missing
+ end if
+ cmap = cmapt
+ else
+ print ("Error: span_color_indexes: cmap must be an n x 3 or n x 4 array of RGB or RGBA values, or a valid color map name")
+ end if
+ end if
+
+ ncols = dimsizes(cmap(:,0))
+ ;
+ ; Start at index 0 and end at ncols-1 (the full range of the
+ ; color map.
+ ;
+ minix = 0
+ maxix = ncols-1
+
+ fmin = new(1,float) ; to make sure we get a missing value (?)
+ fmax = new(1,float)
+ fmin = minix
+ fmax = maxix
+ fcols = fspan(fmin,fmax,ncolors)
+ icols = tointeger(fcols + 0.5)
+ if(isstring(cmapt)) then
+ return(icols+2)
+ else
+ return(icols)
+ end if
+ end
+
+ ;***********************************************************************;
+ ; Given a color map and the number of desired colors, this function
+ ; returns an array of RGB[A] values that nicely span the full colormap.
+ ;
+ ; For a named colormap, the first two color values are not used,
+ ; because these are the foreground/background colors.
+ ;
+ ; This function is very similar to the span_color_indexes function,
+ ; except it returns RGBA values rather than index values. This
+ ; function actually uses span_color_indexes.
+ ;
+ ; The colormap can be a named colormap, like "rainbow", or an array
+ ; of RGB (n,3) or RGBA (n,4).
+ ;***********************************************************************
+ undef("span_color_rgba")
+ function span_color_rgba(cmapt,ncolors)
+ local icols, cmap, fmsg
+ begin
+ icols = span_color_indexes(cmapt,ncolors)
+ fmsg = new(4,float) ; missing value
+ if(any(ismissing(icols)))
+ return(fmsg)
+ end if
+
+ if(isstring(cmapt)) then
+ cmap = read_colormap_file(cmapt)
+ icols = icols - 2 ; read_colormap_file returns array
+ ; with indexes 0 and 1 dropped off
+ else
+ cmap = cmapt
+ end if
+
+ return(cmap(icols,:))
+ end
+
+ ;***********************************************************************
+ ; Given an array of contour levels, a color map, and a single
+ ; value, this function returns an index value into the colormap
+ ; to use for representing the single value
+ ;
+ ; This function is very similar to the get_color_rgb function,
+ ; except it returns the index value into the color map, rather
+ ; than an RGBA value.
+ ;
+ ; The colormap can be a named colormap, like "rainbow", or an array
+ ; of RGB (n,3) or RGBA (n,4).
+ ;
+ ; This function replaces the deprecated GetFillColor.
+ ;***********************************************************************
+ undef("get_color_index")
+ function get_color_index(cmapt,cnlvls[*]:numeric,value[1]:numeric)
+ local cmap, dims, ncn, nclr, color, n, col_indexes, ncoli
+ begin
+
+ if(isstring(cmapt)) then
+ cmap = read_colormap_file(cmapt)
+ else if(isnumeric(cmapt)) then
+ dims = dimsizes(cmapt)
+ if(dimsizes(dims).ne.2.or.dims(0).lt.3.or.dims(0).gt.256.or.
+ .not.any(dims(1).ne.(/3,4/))) then
+ print ("Error: get_color_index: cmap must be an n x 3 or n x 4 array of RGB or RGBA values, or a valid color map name")
+ return(new(3,"float")) ; return a missing value
+ end if
+ cmap = cmapt
+ else
+ print ("Error: get_color_index: cmap must be an n x 3 or n x 4 array of RGB or RGBA values, or a valid color map name")
+ end if
+ end if
+
+ ncn = dimsizes (cnlvls)
+ nclr = dimsizes (cmap(:,0))
+ imsg = new(1,integer) ; missing value
+
+ if (nclr-2 .lt. ncn+1) then
+ print ("Warning: get_color_index: Not enough colors in colormap for number of contour levels")
+ print (" Colors will be repeated")
+ end if
+ if (ismissing(value)) then
+ print ("Error: get_color_index: Input value is missing")
+ return (imsg)
+ end if
+ if (any(ismissing(cnlvls))) then
+ print ("Error: get_color_index: One or more input contour levels are missing")
+ return (imsg)
+ end if
+
+ ;---Get nice span of indexes throughout the color map
+ col_indexes = span_color_indexes(cmap,dimsizes(cnlvls)+1)
+ ncoli = dimsizes(col_indexes) ; should be ncn+1
+
+ do n = 0, ncn-1
+ if (value .lt. cnlvls(n)) then
+ break
+ end if
+ end do
+ if(isstring(cmapt)) then
+ return(col_indexes(n)+2) ; Account for 0/1 index being dropped
+ else
+ return(col_indexes(n))
+ end if
+ end
+
+ ;***********************************************************************
+ ; Given an array of contour levels, a color map, and a single
+ ; value, this function returns an RGB[A] value in the colormap
+ ; to use for representing the single value
+ ;
+ ; This function uses get_color_index, and is very similar to this
+ ; function except it returns the actual RGB[A] value, rather
+ ; than an index value.
+ ;
+ ; The colormap can be a named colormap, like "rainbow", or an array
+ ; of RGB (n,3) or RGBA (n,4).
+ ;***********************************************************************
+ undef("get_color_rgba")
+ function get_color_rgba(cmapt,cnlvls[*]:numeric,value[1]:numeric)
+ local fmsg, icol, cmap
+ begin
+ fmsg = new(4,float) ; missing value
+ icol = get_color_index(cmapt,cnlvls,value)
+
+ if (ismissing(icol)) then
+ return (fmsg)
+ end if
+
+ if(isstring(cmapt)) then
+ cmap = read_colormap_file(cmapt)
+ return(cmap(icol-2,:)) ; Indexes start at 2
+ else
+ cmap = cmapt
+ return(cmap(icol,:))
+ end if
+ end
+
+
+ ;***********************************************************************;
+ ; Procedure : draw_color_palette ;
+ ; wks[1] : graphic ;
+ ; colors : ;
+ ; opt[1] : logical ;
+ ; ;
+ ; This procedure draws the given colors as a series of boxes in the ;
+ ; same fashion as the old gsn_draw_colormap procedure. ;
+ ; ;
+ ; "wks" is the workstation to draw the colors to. ;
+ ; ;
+ ; "colors" can be a color map name ("rainbow"), a list of named colors ;
+ ; (/"red","blue"/), an RGB array (n x 3), an RGBA array (n x 4), or a ;
+ ; list of color indexes (/2,5,3,8/). ;
+ ; ;
+ ; "opt" If set to True, then you can optionally attach attributes to ;
+ ; control behavior of this procedure. ;
+ ; ;
+ ;***********************************************************************;
+ undef("draw_color_palette")
+ procedure draw_color_palette(wks,colors,opt)
+ local label_boxes, call_frame, labels_on, label_strings, across,
+ color_type, rgba_colors, ncolors, nrows, ncols,width,height
+ begin
+ ;---Retrieve values for attributes
+ call_frame = get_res_value_keep(opt,"Frame",True)
+ labels_on = get_res_value_keep(opt,"LabelsOn",True)
+ if(opt.and.isatt(opt,"LabelStrings")) then
+ set_label_strings = True
+ label_strings = opt at LabelStrings
+ else
+ set_label_strings = False
+ end if
+ font_height = get_res_value_keep(opt,"LabelFontHeight",0.015)
+ across = get_res_value_keep(opt,"Across",True)
+
+ ;---Check for valid colors
+ color_type = get_color_type(colors)
+
+ if(ismissing(color_type).or.color_type.eq."unknown")
+ print("Error: draw_color_palette: invalid color specification.")
+ return
+ end if
+
+ if(color_type.eq."rgba") then
+ rgba_colors = colors
+ end if
+ if(color_type.eq."index") then
+ rgba_colors = indexcolor2rgba(wks,colors)
+ end if
+ if(color_type.eq."colormap") then
+ rgba_colors = read_colormap_files(colors)
+ end if
+ if(color_type.eq."named") then
+ rgba_colors = namedcolor2rgba(colors)
+ end if
+ if(color_type.eq."rgb") then
+ rgba_colors = rgb2rgba(colors)
+ end if
+
+ ncolors = dimsizes(rgba_colors(:,0))
+ nrows = toint(sqrt(ncolors))
+
+ ;---Figure out ncols such that the columns will span across the page.
+ ncols = floattoint(ncolors/nrows)
+ if((ncols*nrows).lt.ncolors)
+ ncols = ncols+1
+ end if
+
+ ntotal = nrows * ncols ; # of colors per page.
+
+ ;---If drawing labels, test that we have valid number of labels
+ if(labels_on) then
+ if(.not.set_label_strings) then
+ label_strings = "" + ispan(0,ncolors-1,1)
+ else
+ if(dimsizes(label_strings).ne.ncolors) then
+ print("Error: draw_color_palette: invalid number of labels for boxes")
+ return
+ end if
+ end if
+ end if
+ ;---Calculate X and Y positions of text and box in the view port.
+ width = 1./ncols
+ height = 1./nrows
+
+ if(ncols.gt.1) then
+ if(across) then
+ xpos = ndtooned(conform_dims((/nrows,ncols/),fspan(0,1-width,ncols),1))
+ else
+ xpos = ndtooned(conform_dims((/ncols,nrows/),fspan(0,1-width,ncols),0))
+ end if
+ else
+ xpos = new(ntotal,float)
+ xpos = 0.
+ end if
+ if(nrows.gt.1) then
+ if(across) then
+ ypos = ndtooned(conform_dims((/nrows,ncols/),fspan(1-height,0,nrows),0))
+ else
+ ypos = ndtooned(conform_dims((/ncols,nrows/),fspan(1-height,0,nrows),1))
+ end if
+ else
+ ypos = new(ntotal,float)
+ ypos = 1.-height
+ end if
+
+ ;---Calculate box coordinates.
+ xbox = (/0,width, width, 0,0/)
+ ybox = (/0, 0,height,height,0/)
+
+ gnres = True ; variables to hold list of resources
+ lnres = True
+
+ if(labels_on) then
+ font_space = font_height/2.
+ txres = True
+ txres at txFontHeightF = font_height
+ txres at txFont = "helvetica-bold"
+ txres at txJust = "BottomLeft"
+ txres at txPerimOn = True
+ txres at txPerimColor = "black"
+ txres at txFontColor = "black"
+ txres at txBackgroundFillColor = "white"
+ end if
+
+ lnres at gsLineColor = "black"
+
+ ;---ntotal colors per page.
+ do i = 0,ncolors-1
+ ;---Draw box and fill in the appropriate color.
+ gnres at gsFillColor = rgba_colors(i,:)
+ gsn_polygon_ndc(wks,xbox+xpos(i),ybox+ypos(i),gnres) ; Draw box.
+
+ ;---Outline box in black.
+ gsn_polyline_ndc(wks,xbox+xpos(i),ybox+ypos(i),lnres)
+
+ ;---Draw color label.
+ if(labels_on) then
+ gsn_text_ndc(wks,label_strings(i),font_space+xpos(i),ypos(i)+font_space,txres)
+ end if
+ end do
+ if(call_frame) then
+ frame(wks) ; Advance the frame.
+ end if
+ return
+ end
+
+ ;----------------------------------------------------------------------
+ ; This function takes an array of anything and depending on "opt",
+ ; it does one of two things:
+ ;
+ ; - Returns the unique values as a 1D array (opt=0)
+ ; - Returns the number of unique values (opt=1)
+ ;
+ ; Some notes:
+ ; - THIS FUNCTION IS NOT INTENDED TO BE MADE PUBLIC.
+ ; See "get_unique_values" and "count_unique_values" below.
+ ;
+ ; - We did some timing tests and confirmed that sorting the values
+ ; first made for a faster algorithm, including with string arrays.
+ ;
+ ; - We decided to create a separate "count_unique_values" function,
+ ; instead of making the user do "dimsizes(get_unique_values(x))"
+ ; because the count function is less memory intensive.
+ ;----------------------------------------------------------------------
+ undef("unique_values_opt")
+ function unique_values_opt(vals,opt)
+ local vals1d, i, ii, vals_nomsg, nvals, nuniq_vals, count_only
+ begin
+ if(opt.eq.0) then
+ count_only = False
+ else if(opt.eq.1) then
+ count_only = True
+ else
+ print("unique_values_opt: Error: Don't recognize opt=" + opt)
+ print("This is an internal function and may change")
+ exit
+ end if
+ end if
+
+ if(isatt(vals,"_FillValue")) then
+ vals1d = ndtooned(vals)
+ ii = ind(.not.ismissing(vals1d))
+ if(ismissing(ii(0))) then
+ ; Input array is all missing
+ if(count_only) then
+ return(0)
+ else
+ return(new(1,typeof(vals)))
+ end if
+ end if
+ vals_nomsg = vals1d(ii)
+ delete(vals_nomsg at _FillValue) ; This is important, otherwise a _FillValue
+ ; will get added to return value.
+ delete([/vals1d,ii/])
+ else
+ vals_nomsg = ndtooned(vals)
+ end if
+
+ ;---Sort the array first
+ if(typeof(vals_nomsg).eq."string") then
+ sqsort(vals_nomsg)
+ else
+ qsort(vals_nomsg)
+ end if
+
+ nvals = dimsizes(vals_nomsg)
+
+ ;---This is the array to be returned, if returning unique values.
+ if(.not.count_only) then
+ vals_uniq = new(nvals,typeof(vals_nomsg),"No_FillValue")
+ vals_uniq(0) = vals_nomsg(0) ; The first unique value
+ end if
+ ;
+ ; Doing two different loops here, so we don't have an extra
+ ; "if" test inside the do loop.
+ ;
+ nuniq_vals = 1
+ if(count_only) then
+ do i=1,nvals-1
+ if(vals_nomsg(i).eq.vals_nomsg(i-1)) then
+ continue
+ end if
+ nuniq_vals = nuniq_vals+1
+ end do
+ return(nuniq_vals)
+ else
+ do i=1,nvals-1
+ if(vals_nomsg(i).eq.vals_nomsg(i-1)) then
+ continue
+ end if
+ vals_uniq(nuniq_vals) = vals_nomsg(i)
+ nuniq_vals = nuniq_vals+1
+ end do
+ return(vals_uniq(0:nuniq_vals-1))
+ end if
+ end
+
+ ;----------------------------------------------------------------------
+ ; This function takes an array of anything and returns the
+ ; unique values as a 1D array.
+ ;----------------------------------------------------------------------
+ undef("get_unique_values")
+ function get_unique_values(vals)
+ begin
+ return(unique_values_opt(vals,0))
+ end
+
+
+ ;----------------------------------------------------------------------
+ ; This function takes an array of anything and returns the
+ ; # of unique values. If the array
+ ;----------------------------------------------------------------------
+ undef("count_unique_values")
+ function count_unique_values(vals)
+ begin
+ return(unique_values_opt(vals,1))
+ end
+ ;
+ ; $Id: contributed.ncl,v 1.273 2010-05-07 17:38:12 haley Exp $
+ ;
+ ;
+ ; -------------- added Feb 14 2002
+ ; copy_VarMeta
+ ; cssgrid_Wrap
+ ; epzZero
+ ; flt2dble
+ ; getVarDimNames
+ ; numAsciiRow
+ ; numAsciiCol
+ ; month_to_season
+ ; month_to_seasonN
+ ; month_to_season12
+ ; wave_number_spc
+ ; uv2dvG_Wrap
+ ; uv2vrG_Wrap
+ ; uv2dvF_Wrap
+ ; uv2vrF_Wrap
+ ; dv2uvG_Wrap
+ ; vr2uvG_Wrap
+ ; dv2uvF_Wrap
+ ; vr2uvF_Wrap
+ ; ilapsG_Wrap
+ ; ilapsF_Wrap
+ ; dim_standardize_Wrap
+ ; msrcp_mss2local
+
+ ; -------------- changed 13 May 2002
+ ; eofMeta: changed a dimension name from "eval" to "evn"
+ ; -------------- added 13 May 2002
+ ; eofcor_pcmsg_Wrap
+ ; eofcov_pcmsg_Wrap
+
+ ; -------------- changed June 2002
+ ; short2flt: added extra names
+ ;
+ ; -------------- replaced June 2002
+ ; NewCosWeight
+ ; SqrtCosWeight
+ ;
+ ; -------------- added July 3 2002
+ ; GetFillColorIndex
+ ; yyyymmdd2yyyyFrac
+ ;
+ ; -------------- bug fix 30 Aug 2002
+ ; closest_val: mult "closest" values Murphy
+ ;
+ ; -------------- added 13 Sept 2002
+ ; grib_stime2itime: convert initial_time (string) to time (integer)
+ ; wgt_areaave_Wrap
+ ;
+ ; -------------- 19 Sept 2002
+ ; NormCosWgtGlobe: make lat wgts sum to 2.0 like gaussian whts
+ ; namDimCheck : makes sure all dimensions are named
+ ; calcMonStandardizeAnomTLL : calculated standardized anomalies for each month
+ ;
+ ; -------------- Oct 2002
+ ; cat2var: Concatenate 2 (or more) variables to create one variable
+ ; byte2float
+ ; svdHomHet2LatLon: convert SVD output arrays to lat/lon for plotting
+ ; svdAkBk2time : convert SVD output attributes to timefor plotting
+ ; trimBlankRight ; trim trailing (rightmost) blanks from strings
+ ;
+ ; -------------- Nov 2002
+ ; All routines had local variables explicitly declared.
+ ; All 'undef' statements were activated.
+ ; Numerous regridding routines had changes made to them. [lat/lon stuff]
+ ;
+ ; ------------- Feb-Mar 2003
+ ; added clmMonTLLL, stdMonTLLL
+ ; namelist
+ ; merge_VarAtts
+ ; timeCoads2YYYYMM
+ ; -------------
+ ; Now using CVS .... no longer will I manually maintain the change log
+ ; -------------
+ ;
+ ; Contributed.ncl
+ ;
+ ; The codes in this script were contributed by various NCL'ers. They are
+ ; designed to be completely self contained so that if a user desires, the
+ ; code can be extracted without loss of functionality.
+ ;
+
+ ;************************************************************
+ ; D. Shea
+ ; return number of elements of an array [scalar==> size=1]
+ ;************************************************************
+ undef("size_array")
+ function size_array(x)
+ begin
+ return( product(dimsizes(x)) )
+ end
+ ; D. Shea
+ ; return True if "x" has one of several synonyms for "long_name"
+
+ undef ("isatt_LongName")
+ function isatt_LongName(x)
+ local LongName, xAtts, nAtts, n
+ begin
+ LongName = (/"long_name","description","standard_name"
+ ,"DESCRIPTION","DataFieldName" /)
+ xAtts = getvaratts(x)
+ nAtts = dimsizes(xAtts)
+ do n=0,nAtts-1
+ if (any(LongName.eq.xAtts(n))) then
+ return( True )
+ end if
+ end do
+ return( False )
+ end
+
+ ;************************************************************
+ ; D. Shea
+ ; return the "long_name" attribute of a variable
+ ; Check for various synonyms
+
+ undef ("getLongName")
+ function getLongName(x)
+ ; return long_name: check for various synonyms
+ begin
+ if (isatt(x,"long_name")) then ; COARDS, CSM, CF
+ return(x at long_name)
+ end if
+
+ if (isatt(x,"description")) then ; WRF
+ return(x at description)
+ end if
+
+ if (isatt(x,"DESCRIPTION")) then
+ return(x at DESCRIPTION)
+ end if
+
+ if (isatt(x,"standard_name")) then ; CF
+ return(x at standard_name)
+ end if
+
+ if (isatt(x,"DataFieldName")) then ; HDF [some]
+ return(x at DataFieldName)
+ end if
+ ;return("") ; return
+ return(new(1,string))
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; error check: called internally by a number of functions
+ ; make sure all dimension are named
+ ; sample: dNam = namDimCheck ("clmMonLLT", x)
+
+ undef("namDimCheck")
+ function namDimCheck (name:string, x)
+ local rank, dNam, i
+ begin
+ rank = dimsizes( dimsizes(x) )
+ dNam = new ( rank, "string") ; save input dim names
+ do i=0,rank-1
+ if (.not.ismissing(x!i)) then
+ dNam(i) = x!i
+ else
+ print(name+": All dimensions should be named")
+ print(" dimension "+i+" is missing" )
+ ;exit
+ dNam(i) = "bogus_"+i ; assign arbitrary name
+ end if
+ end do
+ return (dNam)
+ end
+
+ ;************************************************************
+ ; D. Shea
+ ; Copy all of the coordinate variables from one variable to another.
+
+ undef("copy_VarCoords")
+ procedure copy_VarCoords(var_from,var_to)
+ local dfrom, dto, rfrom, rto, i, dName
+ begin
+ dfrom = dimsizes(var_from)
+ dto = dimsizes(var_to)
+
+ rfrom = dimsizes(dfrom)
+ rto = dimsizes(dto)
+ ; coordinates must have names
+ dName = getvardims(var_from) ; Oct 18, 2005
+
+ if (.not.all(ismissing(dName))) then
+
+ if (all(dfrom(0:rto-1).eq.dto)) then
+ do i = 0,rto-1
+ if (.not.ismissing(dName(i))) then ; Oct 18, 2005
+ var_to!i = var_from!i
+ if(iscoord(var_from,var_from!i))
+ var_to&$var_to!i$ = var_from&$var_from!i$
+ end if
+ end if
+ end do
+ else
+ print("ERROR: copy_VarCoords: dimension sizes do not match")
+ print(dto)
+ print(dfrom)
+ end if
+
+ end if
+ end
+ ;************************************************************
+ ; D. Shea
+ ; Copy the coordinate variables from one variable to another,
+ ; except for last dimension.
+ ; Used internally
+
+ undef ("copy_VarCoords_1")
+ procedure copy_VarCoords_1(var_from,var_to)
+ local dimt, dimf, rfrom, rto, i, dName
+ begin
+
+ dimf = dimsizes(var_from)
+ dimt = dimsizes(var_to)
+ rfrom = dimsizes(dimf) ; rank of var_from
+ rto = dimsizes(dimt) ; rank of var_to
+
+ dName = getvardims(var_from) ; Oct 18, 2005
+
+ if (.not.all(ismissing(dName))) then
+ ;if (rto.eq.(rfrom-1)) then
+ do i = 0,rfrom-2 ; do not use last dimension
+ if (.not.ismissing(dName(i)).and.dimf(i).eq.dimt(i)) then
+ var_to!i = var_from!i
+ if(iscoord(var_from,var_from!i))
+ var_to&$var_to!i$ = var_from&$var_from!i$
+ end if
+ end if
+ end do
+ ;else
+ ; print("ERROR: copy_VarCoords_1: rank problem")
+ ;end if
+ end if
+ end
+ ; *****************************************************************
+ ; D. Shea
+ ; Copy the coordinate variables from one variable to another,
+ ; except for last two dimensions.
+ ; Used internally
+
+ undef ("copy_VarCoords_2")
+ procedure copy_VarCoords_2(var_from,var_to)
+ local dimt, dimf, rfrom, rto, i, dName
+ begin
+ dimf = dimsizes(var_from)
+ rfrom = dimsizes(dimf) ; rank of var_from
+
+ if (rfrom.le.2) then
+ return
+ end if
+
+ dName = getvardims(var_from) ; Oct 18, 2005
+
+ if (.not.all(ismissing(dName))) then
+ if (rfrom.gt.2) then
+ dimt = dimsizes(var_to)
+ rto = dimsizes(dimt) ; rank of var_to
+ do i = 0,rfrom-3 ; do not use last two dimensions
+ if (.not.ismissing(dName(i)) .and. dimf(i).eq.dimt(i) ) then
+ var_to!i = var_from!i
+ if(iscoord(var_from,var_from!i))
+ var_to&$var_to!i$ = var_from&$var_from!i$
+ end if
+ end if
+ end do
+ end if
+ end if
+ end
+
+ ;************************************************************
+ ; M. Haley
+ ; Return a list of dimension indexes that correspond with
+ ; the dimension names.
+ ;
+ ; Used internally.
+
+ undef("dimnames_to_indexes")
+ function dimnames_to_indexes(var_from,dim_args[*])
+ local vdims_from, ndims, dims, i, imsg
+ begin
+ ndims = dimsizes(dim_args)
+ imsg = new(ndims,"integer")
+
+ if(.not.any(typeof(dim_args).eq.(/"string","integer"/))) then
+ print("dimnames_to_indexes: error: invalid type for last argument")
+ return(imsg)
+ end if
+
+ if(typeof(dim_args).eq."string") then
+ vdims_from = getvardims(var_from)
+ dims = new(ndims,integer)
+ do i=0,dimsizes(dim_args)-1
+ ii = ind(dim_args(i).eq.vdims_from)
+ if(.not.any(ismissing(ii))) then
+ dims(i) = ii(0)
+ else
+ print("dimnames_to_indexes: error: invalid dimension name")
+ return(imsg)
+ end if
+ delete(ii)
+ end do
+ else
+ dims = dim_args
+ end if
+ return(dims)
+ end
+
+ ;************************************************************
+ ; M. Haley
+ ;
+ ; Dec 30 2001
+ ; Copy the coordinate arrays of the given dimensions from
+ ; one array to another.
+ ;
+ ; This function makes the assumption that the "dims"
+ ; dimensions represent dimensions in the "var_from"
+ ; array. They do not have to be monotonic.
+ ;
+ ; Note: in the special case where the rank of the two arrays are
+ ; the same, then the assumption that the dimensions to copy are
+ ; in the same dimension locations in both arrays. Otherwise,
+ ; coordinates are copied to the "var_to" variable starting
+ ; with the leftmost dimension and going to the next one, etc.
+ ;
+ undef ("copy_VarCoords_n")
+ procedure copy_VarCoords_n(var_from,var_to,dims_to_copy)
+ local dimt, dimf, rfrom, rto, ifrom, ito, dName, ndims
+ begin
+ dimf = dimsizes(var_from)
+ dimt = dimsizes(var_to)
+ rfrom = dimsizes(dimf) ; rank of var_from
+ rto = dimsizes(dimt) ; rank of var_to
+ ndims = dimsizes(dims_to_copy)
+
+ ;---Error checking for "dims_to_copy"
+ if(any(dims_to_copy.lt.0.or.dims_to_copy.gt.dimsizes(dimf))) then
+ print("Error: copy_VarCoords_n: invalid dimensions to copy from")
+ return
+ end if
+
+ ;---Error checking for rank
+ ;; if(rto.gt.rfrom) then
+ ;; print("Error: copy_VarCoords_n: arrays must be same rank, or second array must be subset in size of first array.")
+ ;; return
+ ;; end if
+
+ dName = getvardims(var_from)
+
+ ito = 0 ; leftmost dimension of var_to array
+ if (.not.all(ismissing(dName))) then
+ do i = 0,rfrom-1
+ if(any(i.eq.dims_to_copy)) then
+ ifrom = i
+ if (.not.ismissing(dName(ifrom)).and.dimf(ifrom).eq.dimt(ito)) then
+ var_to!ito = var_from!ifrom
+ if(iscoord(var_from,var_from!ifrom)) then
+ if(dimf(ifrom).eq.dimt(ito)) then
+ var_to&$var_to!ito$ = var_from&$var_from!ifrom$
+ else
+ print("Error: copy_VarCoords_n: dimension being copied must be the same size")
+ end if
+ end if
+ end if
+ ito = ito + 1
+ else
+ if(rfrom.eq.rto) then
+ ito = ito + 1
+ end if
+ end if
+ end do
+ end if
+ end
+
+ ;************************************************************
+ ; M. Haley
+ ; Copy all but indicated coordinate variables from two arrays
+ ; of the same size, or from a larger array to a smaller
+ ; array that is a subset in size.
+ ;
+ ; Dec 30 2001:
+ ; This function used to be two different functions:
+ ; "copy_VarCoords_n" and "copy_VarCoords_not_n". I
+ ; decided to combine them into one function called
+ ; "copy_VarCoords_not_n".
+ ;
+ ; This function *used* to make the assumption that the
+ ; "dims_to_skip" dimensions were consecutive and
+ ; increasing. This is no longer necessary. The
+ ; "dims_to_copy" must represent valid dimensions in
+ ; the "var_from" array.
+ ;
+ ; Note: in the special case where the rank of the two arrays are
+ ; the same, then the assumption that the dimensions to skip are
+ ; in the same dimension locations in both arrays. Otherwise,
+ ; coordinates are copied to the "var_to" variable starting
+ ; with the leftmost dimension and going to the next one, etc.
+ ;
+ undef ("copy_VarCoords_not_n")
+ procedure copy_VarCoords_not_n(var_from,var_to,dims_to_skip)
+ local dimt, dimf, rfrom, rto, i, ifrom, ito, dName, ndims, dims
+ begin
+ dimf = dimsizes(var_from)
+ dimt = dimsizes(var_to)
+ rfrom = dimsizes(dimf) ; rank of var_from
+ rto = dimsizes(dimt) ; rank of var_to
+ ndims = dimsizes(dims_to_skip)
+
+ ;---Error checking for "dims_to_skip"
+ if(any(dims_to_skip.lt.0.or.dims_to_skip.gt.dimsizes(dimf))) then
+ print("Error: copy_VarCoords_not_n: invalid dimensions to skip")
+ return
+ end if
+
+ ;---Error checking for rank
+ if((rfrom-ndims).gt.rto) then
+ print("Error: copy_VarCoords_not_n: you are not skipping enough dimensions.")
+ return
+ end if
+
+ dName = getvardims(var_from)
+
+ ito = 0 ; leftmost dimension of var_to array
+ if (.not.all(ismissing(dName))) then
+ do i = 0,rfrom-1
+ if(.not.any(i.eq.dims_to_skip)) then
+ ifrom = i
+ if (.not.ismissing(dName(ifrom)).and.dimf(ifrom).eq.dimt(ito)) then
+ var_to!ito = var_from!ifrom
+ if(iscoord(var_from,var_from!ifrom))
+ var_to&$var_to!ito$ = var_from&$var_from!ifrom$
+ end if
+ end if
+ ito = ito + 1
+ else
+ if(rfrom.eq.rto) then
+ ito = ito + 1
+ end if
+ end if
+ end do
+ end if
+ end
+
+ ;==============================
+ undef("copy_VarAtts")
+ procedure copy_VarAtts(var_from,var_to)
+ local att_names, i, toType, fromFillValue, fromFillType
+ begin
+ att_names =getvaratts(var_from);
+
+ if(.not.all(ismissing(att_names))) then
+
+ ; copy all attributes except _FillValue and missing_value
+ ; use := cuz shape/type may differ if var_to had previous attributes
+
+ do i = 0,dimsizes(att_names)-1
+ if (.not.(att_names(i).eq."_FillValue" .or. att_names(i).eq."missing_value")) then
+ var_to@$att_names(i)$ := var_from@$att_names(i)$
+ end if
+ end do
+
+ ; handle _FillValue and missing_value
+
+ toType = typeof(var_to)
+
+ if (any(att_names.eq."_FillValue")) then ; associated with 'var_from'
+ fromFillValue = var_from at _FillValue
+ fromFillType = typeof(var_from at _FillValue)
+
+ if (fromFillType.eq.toType) then
+ var_to at _FillValue = fromFillValue
+ else
+ var_to at _FillValue_original := fromFillValue
+ var_to at _FillValue := totype(fromFillValue, toType)
+ end if
+ end if
+
+ if (any(att_names.eq."missing_value")) then ; associated with 'var_from'
+ fromMissValue = var_from at missing_value
+ fromMissType = typeof(var_from at missing_value)
+
+ if (fromMissType.eq.toType) then
+ var_to at missing_value = fromMissValue
+ else
+ var_to at missing_value_original := fromMissValue
+ var_to at missing_value := totype(fromMissValue, toType)
+ end if
+ end if
+ end if
+ end
+ ;======================================================================
+ ; This is the modified version of copy_VarAtts originaly developed by
+ ; Dennis Shea.
+ ;
+ ; Jan 12, 2012
+ ; This function was originally developed for use in the ESMF software,
+ ; and moved to contributed.ncl.
+ ;======================================================================
+ undef("copy_VarAtts_except")
+ procedure copy_VarAtts_except(var_from,var_to, Except [*]:string)
+ local att_names, i
+ begin
+ att_names = getvaratts(var_from);
+ if(.not.all(ismissing(att_names)))
+ do i = 0,dimsizes(att_names)-1
+ if (.not.any(att_names(i).eq.Except)) then
+ if (isatt(var_to,att_names(i))) then
+ delete(var_to@$att_names(i)$) ; var_from att may be diff size/type
+ end if
+ var_to@$att_names(i)$ = var_from@$att_names(i)$
+ end if
+ end do
+ end if
+ end ; of copy_VarAtts_except
+
+ ;***********************************************
+ ; D. Shea
+ ; delete one or more attributes of a variable
+ ; This checks to see if the attribute exists and
+ ; if it does, it deletes it.
+ ;
+ ; Sample usage:
+ ; x = 0
+ ; x at apple = 5
+ ; x at orange = 81.
+ ; x at peach = (/ "a", "b"/)
+ ;
+ ; delete_VarAtts(x, "apple") )
+ ; delete_VarAtts(x, (/ "apple", "peach"/) )
+ ;
+ ; x at orange remains
+ ;***********************************************
+ undef("delete_VarAtts")
+ procedure delete_VarAtts (x, ATTS)
+ local n, atts, nAtts
+ begin
+ typeATTS = typeof(ATTS)
+ if (.not.(typeATTS.eq."string" .or. typeATTS.eq."integer")) then
+ print("delete_VarAtts: argument must be string or integer: type="+typeATTS)
+ print("delete_VarAtts: nothing deleted")
+ return
+ end if
+
+ if (typeATTS.eq."integer") then
+ atts = getvaratts(x)
+ end if
+
+ if (typeof(ATTS).eq."string") then
+ atts = ATTS
+ end if
+
+ nAtts = dimsizes(atts)
+ do n=0,nAtts-1
+ if (isatt(x, atts(n)) ) then
+ delete(x@$atts(n)$)
+ else
+ print("delete_VarAtts: attribute="+atts(n)+" does not exist")
+ end if
+ end do
+ end
+
+ ;****************************************
+ ; D. Shea
+ ; Basically a function version of copy_VarAtts which is a procedure
+ ; copy attributes associated with "var_from" to "var_to" and
+ ; return as a new variable.
+
+ ; xNew = merge_VarAtts( x2, x1)
+ ; will result in attributes associated with x2 to be
+ ; added to those associated with x1. If duplictae
+ ; attributes exist those associated with x2 will
+ ; replace those associated with x1.
+
+ undef("merge_VarAtts")
+ function merge_VarAtts(var_from,var_to)
+ local att_names, i, vNew
+
+ begin
+ vNew = var_to
+ att_names =getvaratts(var_from);
+ if(.not.all(ismissing(att_names)))
+ do i = 0,dimsizes(att_names)-1
+ if (isatt(vNew,att_names(i))) then
+ delete(vNew@$att_names(i)$) ; var_from att may be diff size/type
+ end if
+ vNew@$att_names(i)$ = var_from@$att_names(i)$
+ end do
+ end if
+ return(vNew)
+ end
+
+ ;***************************************************************
+ ; S. Murphy
+ ; copyatt is very similar to the above two functions, except that
+ ; the the variables do not have to be the same dimension. This can be
+ ; used on variables that have been operated on by a dim_* function.
+ ; It also copies both the attributes and the coordinate variables.
+
+ undef("copyatt")
+ procedure copyatt(var_to,var_from)
+ local n, att_names, i, dName, rankto, natts
+ begin
+
+ dName = getvardims(var_from) ; Oct 18, 2005
+ rankto= dimsizes(dimsizes(var_to))
+ ; coordinates must have names
+ if (.not.all(ismissing(dName))) then
+ do n=0,rankto-1
+ if (.not.ismissing(dName(n))) then ; Oct 18, 2005
+ var_to!n = var_from!n
+ if (iscoord(var_from,var_from!n))then
+ var_to&$var_to!n$ = var_from&$var_from!n$
+ end if
+ end if
+ end do
+ end if
+ ;
+ ; copy variable attributes
+ ;
+
+ copy_VarAtts(var_from,var_to) ; DJS 20 Jan 2005
+
+ ;;att_names = getvaratts(var_from) ; This was not quite right
+ ;;natts = dimsizes(att_names)
+ ;;if(.not.all(ismissing(att_names)))
+ ;; do i=0,natts-1
+ ;; if(isatt(var_from,"_FillValue"))then
+ ;; if(typeof(var_from at _FillValue).eq."double" .and.\
+ ;; typeof(var_to).eq."float")then
+ ;; var_to at _FillValue = doubletofloat(var_from at _FillValue)
+ ;; else
+ ;; if (isatt(var_to,att_names(i))) then ; added 10 Mar 2003 [DJS]
+ ;; delete(var_to@$att_names(i)$)
+ ;; end if
+ ;; var_to@$att_names(i)$ = var_from@$att_names(i)$
+ ;; end if
+ ;; end if
+ ;; end do
+ ;;end if
+
+ end
+ ;****************************************
+ ; D. Shea
+ ; New entry: better name than "copyatt"
+ ; also input arguments are the same as other routines
+ undef ("copy_VarMeta" )
+ procedure copy_VarMeta (var_from,var_to)
+ begin
+ copyatt(var_to, var_from)
+ end
+ ;************************************************************
+ ; D. Shea
+ ; called internally: add coordinate variables to a variable
+ ; which has had an extra left dimension added.
+
+ undef("component_copy_VarCoords")
+ procedure component_copy_VarCoords (x, y)
+ local rankx, dimy, i, dName
+ begin
+ rankx = dimsizes(dimsizes(x))
+ dimy = dimsizes(y)
+
+ y!0 = "component"
+ y&component = ispan(0, dimy(0)-1, 1)
+
+ dName = getvardims( x )
+
+ do i=0,rankx-1
+ if (.not.ismissing(dName(i))) then
+ y!(i+1) = x!i
+ if(iscoord(x,x!i)) then
+ y&$x!i$ = x&$x!i$
+ end if
+ end if
+ end do
+ end
+
+ ;***************************************************************
+ ; D. Shea
+ ; Determine the number of rows (ie, number of records, lines)
+ ; in an ascii file
+ ; This approach was suggested by:
+ ; From: "Lunde, Bruce N CIV NAVOCEANO, NP1" <bruce.lunde at navy.mil>
+ ;
+ ; Usage: nrow = numAsciiRow ("/my/path/ascii_file")
+
+ undef ("numAsciiRow")
+ function numAsciiRow (fNam:string)
+
+ local filString, nrow, nrow_s
+ begin
+ ;filString = asciiread ( fNam, -1, "string")
+ ;nrow = dimsizes(filString)
+
+ nrow_s = systemfunc("'wc' -l " + fNam +" | awk '{print $1}'" )
+
+ nrow = tointeger( nrow_s )
+ return (nrow)
+ end
+
+ ;***************************************************************
+ ; D. Shea
+ ; Determine the number of columns in an ascii file
+ ; This assumes that all rows have the same number of columns
+ ; and the columns are separated by spaces.
+ ;
+ ; This approach was suggested by:
+ ; Date: Thu, 7 Dec 2006 11:39:37 -0800
+ ; From: "Lunde, Bruce N CIV NAVOCEANO, NP1" <bruce.lunde at navy.mil>
+ ;
+ ; It replaced the original version which read the entire file.
+ ;
+ ; Usage: ncol = numAsciiCol ("/my/path/ascii_file")
+
+ undef ("numAsciiCol")
+ function numAsciiCol (fNam:string)
+ begin
+ ncol = stringtointeger( systemfunc("head -1 "+fNam+" | wc -w") )
+ return(ncol)
+ end
+ ;*******************************************************************************
+ ; HISTORY:
+ ; 08-02-05 Bruce Lunde.
+ ; 08-02-06 Bruce Lunde. Generalized to awk versus gawk. Added option "start"
+ ; for the "every" option, to allow starting the selecting of every Nth
+ ; line starting with line 1 (opt at start=1). Otherwise, the first line
+ ; selected is the Nth line in the file.
+ ; NOTES:
+ ; * Set opt=True and add the following attributes:
+ ; * opt at every=N ... To return every Nth line.
+ ; * opt at line1,opt at line2 ... To print a range of lines (opt at line2 optional,
+ ; defaults to End-of-File).
+ ; *opt at list ... To print a list of line numbers. First line of file is
+ ; numbered line 1. Input list is a 1D integer array.
+ ; * Option priority is (1) line1,line2 (2) every (3) list
+ ;*******************************************************************************
+
+ undef("extractAsciiRows")
+ function extractAsciiRows(fName:string,OPT:logical)
+ local AOK, command, DBLQT, ii, ilist, numline, opt
+ begin
+
+ if (OPT) then
+ opt = OPT
+ else
+ return( asciiread(fName, -1, "string") )
+ end if
+
+ DBLQT = inttochar(34)
+ AOK = False
+ if( opt )then
+ if( isatt(opt,"list") )then
+ AOK = True
+ ;;; print(1)
+ command = "awk -v LIST=" + DBLQT
+ ilist = opt at list
+ numline = dimsizes(ilist)
+ do ii=0,numline-1
+ command = command + ilist(ii) + " "
+ end do
+ command = command + DBLQT + " 'BEGIN{split(LIST,INDX); II=1}"
+ command = command + "{if( NR == INDX[II] ){print $0; II=II+1}}' "
+ command = command + fName
+ end if
+
+ if( isatt(opt,"every") )then
+ AOK = True
+ START = "0"
+ if( isatt(opt,"start") )then
+ if( opt at start .eq. 1 )then
+ START = "1"
+ end if
+ end if
+ ;;; print(2)
+ command = "awk '(NR % " + opt at every + ") == " + START + "' " + fName
+ end if
+
+ ;.. NOTE: Should check for line1 <= line2
+ if( isatt(opt,"line1") )then
+ AOK = True
+ ;;; print(3)
+ if( isatt(opt,"line2") )then
+ command = "awk 'NR==" + opt at line1 + ",NR==" + opt at line2
+ else
+ command = "awk 'NR>=" + opt at line1
+ end if
+ command = command + "' " + fName
+ end if
+ ;;; print("command = "+command)
+ end if
+
+ if( AOK )then
+ return( systemfunc(command) )
+ else
+ return( "ERROR" )
+ end if
+ end ; END extractAsciiRows
+
+ ;***************************************************************
+ ; D. Shea
+ ; There is no NCL built-in function to get the dimension names
+ ; +++++++ THIS HAS CHANGED ++++++++++++
+ ; getvardims replaces this function
+ ; +++++++++++++++++++++++++++++++++++++
+ ; of a variable in memory. There is one for file variables
+ ; [getfilevardims] but not for a variable in memory. Dunno why!
+ ; Usage: dimNames = getVarDimNames (x)
+
+ undef ("getVarDimNames")
+ function getVarDimNames (x)
+
+ ;local dimx, rank, n, dimNames
+ begin
+ ;dimx = dimsizes(x)
+ ;rank = dimsizes(dimx)
+
+ ;dimNames = new ( rank, "string", "missing")
+
+ ;do n=0,rank-1
+ ; if (.not.ismissing(x!n)) then
+ ; dimNames(n) = x!n
+ ; end if
+ ;end do
+
+ ;return (dimNames)
+
+ return (getvardims(x))
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; print Min and Max of a numeric variable using long_name [if present]
+ ;
+ undef("printMinMax")
+ procedure printMinMax (x:numeric,optSpace:logical)
+ ; Usage: printMinMax (T,True)
+ begin
+ ; attribute names to check
+ vLongName = (/"long_name", "description", "standard_name" /)
+ long_name = ""
+ do n=0,dimsizes(vLongName)-1
+ if (isatt(x,vLongName(n))) then
+ long_name = x@$vLongName(n)$
+ break
+ end if
+ end do
+
+ if (optSpace) then
+ print (" ")
+ end if
+
+ if (long_name.ne."") then
+ print (long_name+ ": min="+min(x)+" max="+max(x))
+ else
+ print ("min="+min(x)+" max="+max(x))
+ end if
+ end
+
+ ; *****************************************************************
+ ; D. Shea
+ ; Generate gaussian latitudes and meta data
+ ; nlat = 64
+ ; lat = latGau (nlat, "lat", "latitude", "degrees_north")
+ ;
+ ; set nlat at double = True if double precision is desired
+
+ undef ("latGau")
+ function latGau (nlat, dimName:string, longName:string, units:string)
+ local gau_info, lat
+ begin
+ if (isatt(nlat,"double") .and. nlat at double) then
+ gau_info = gaus(nlat/2)
+ else
+ gau_info = doubletofloat(gaus(nlat/2))
+ end if
+
+ lat = gau_info(:,0) ; lat values
+ lat!0 = dimName ; name the dimension
+ lat at long_name = longName
+ lat at units = units
+ lat&$dimName$ = lat ; coordinate variable
+ return (lat)
+ end
+
+ ; *****************************************************************
+ ; D. Shea
+ ; Generate gaussian weights and meta data
+ ; nlat = 64
+ ; gwt = latGauWgt (nlat, "lat", "gaussian weights", "dimension_less")
+ ; gwt = latGauWgt (nlat, "lat", "gaussian weights", "")
+ ;
+ ; set nlat at double = True if double precision is desired
+
+ undef ("latGauWgt")
+ function latGauWgt(nlat,dimName:string,longName:string,units:string)
+ local gau_info, gwt
+ begin
+ if (isatt(nlat,"double") .and. nlat at double) then
+ gau_info = gaus(nlat/2)
+ else
+ gau_info = doubletofloat(gaus(nlat/2))
+ end if
+
+ gwt = gau_info(:,1) ; gaussian wgt values
+ gwt!0 = dimName ; name the dimension
+ gwt at long_name = longName
+ if (units.ne."")then
+ gwt at units = units
+ end if
+ gwt&$dimName$ = gau_info(:,0) ; lat to named dimension
+ return (gwt)
+ end
+
+ ; *****************************************************************
+ ; Mark Stevens
+ ; normalize the cosine wgts so that the sum is 2.0
+ ; just like gaussian wgts
+
+ undef("NormCosWgtGlobe")
+ function NormCosWgtGlobe (lat:numeric)
+ local deg_to_rad, wgt, tsum, nwgt
+ begin
+
+ if (typeof(lat).eq."double") then
+ one = 1.0d
+ two = 2.0d
+ con = 180.0d
+ else
+ one = 1.0
+ two = 2.0
+ con = 180.0
+ end if
+
+ deg_to_rad = acos(-one)/con
+ wgt = lat
+ wgt = cos(lat*deg_to_rad)
+ tsum = sum(wgt)
+ nwgt = wgt ; copy coordinates
+ nwgt = (/two*wgt/tsum/)
+ nwgt at long_name = "normalized cosine weights"
+ nwgt at units = "dimensionless"
+ return(nwgt)
+ end
+
+ ; *****************************************************************
+ ; D. Shea
+ ; Generate longitudes for a Fixed global grid
+ ; mlon = 128
+ ; lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; lon will run from 0->"whatever"
+ ;
+ ; If u want the initial lon to be -180., then upon return
+ ; lon = (/ lon - 180. /) ; subtract 180 from all values
+ ; lon&lon = lon ; make coord
+ ;
+ ; set mlon at double = True if double precision is desired
+
+ undef ("lonGlobeF")
+ function lonGlobeF(mlon,dimName:string,longName:string,units:string)
+ local dlon, lon
+ begin
+ if (isatt(mlon,"double") .and. mlon at double) then
+ dlon = new ( 1, "double")
+ else
+ dlon = new ( 1, "float")
+ end if
+ delete (dlon at _FillValue)
+
+ dlon = 360./mlon ; output lon
+ lon = ispan ( 0,mlon-1,1 )*dlon
+ lon!0 = dimName
+ lon at long_name = longName
+ lon at units = units
+ lon&$dimName$ = lon
+ return (lon)
+ end
+
+ ; *****************************************************************
+ ; D. Shea
+ ; Generate longitudes for a Fixed-Offset global grid
+ ; Example: lon = lonGlobeFo (72, "lon", "longitude", "degrees_east")
+ ; lon will run from -> 2.5 to 357.5 in the above example
+ ;
+ ; If u want the initial lon to be, say, -177.5,, then upon return
+ ; lon = (/ lon - 180. /) ; subtract 180 from all values
+ ; lon&lon = lon ; make coord
+ ;
+ ; set mlon at double = True if double precision is desired
+
+ undef ("lonGlobeFo")
+ function lonGlobeFo(mlon,dimName:string,longName:string,units:string)
+ local dlon, offset, lon
+ begin
+ if (isatt(mlon,"double") .and. mlon at double) then
+ dlon = new ( 1, "double")
+ else
+ dlon = new ( 1, "float")
+ end if
+ delete (dlon at _FillValue)
+
+ dlon = 360./mlon ; output lon
+ offset = dlon*0.5
+ lon = ispan ( 0,mlon-1,1 )*dlon + offset
+ lon!0 = dimName
+ lon at long_name = longName
+ lon at units = units
+ lon&$dimName$ = lon
+ return (lon)
+ end
+
+ ; *****************************************************************
+ ; D. Shea
+ ; Internal: made for regridding routines with _Wrap
+ ; Will cause 0=>360 to return -180-to-180 via
+ ; lon = (/ lon - 180. /) ; subtract 180 from all values
+ ; lon&lon = lon ; make coord
+ ; check the initial LON location: if lon(0) < 0 assume
+ ; start is at Date Line
+ ; note: x&lon is different from lonNew
+
+ undef ("lonGM2DateLine")
+ procedure lonGM2DateLine (xOld, lonNew)
+ local namDim, dim_x, nDim
+ begin
+ dim_x = dimsizes(xOld)
+ nDim = dimsizes(dim_x)
+ if (.not.ismissing(xOld!(nDim-1)) .and. iscoord(xOld,xOld!(nDim-1))) then
+ namDim = xOld!(nDim-1)
+ if (xOld&$namDim$(0).lt.0.) then ; is 1st value < 0.0
+ lonNew = (/ lonNew-180. /) ; start lonNew at Date Line
+ end if
+ end if
+ end
+ ; *****************************************************************
+ ; D.Shea
+ ; Change case of each character in a string to the opposite case
+
+ ; This function was deprecated in V5.1.1 and replaced with
+ ; the built-in function "str_switch".
+
+ ; input strings may be scalar [sample="An apple a day"]
+ ; or 1D [sample=new( 10, string) ]
+ ; sample(0)="apple", (1)="ARTICHOKE", ...
+ ; Usage: sample = changeCaseChar (sample)
+ ; sample = changeCaseChar ("apple") ==> APPLE
+ ; sample = changeCaseChar ("APPLE") ==> apple
+ ; sample = changeCaseChar ("ApplE") ==> aPPLe
+
+ undef ("changeCaseChar")
+ function changeCaseChar (x:string)
+
+ begin
+ ; print("changeCaseChar: this function has been deprecated.")
+ ; print(" Will use str_switch.")
+ return(str_switch(x))
+ end
+ ; *****************************************************************
+ ; D.Shea
+ ; Change case: (1) "low" [change all to lower case]
+ ; (2) "up" [change all to upper case]
+
+ ; This function was deprecated in V5.1.1 and replaced with
+ ; the built-in functions "str_lower" and "str_upper".
+
+ ; input strings may be scalar [sample="An apple a day"]
+ ; or 1D [sample=new( 10, string) ]
+ ; sample(0)="apple", (1)="ARTICHOKE", ...
+ ; Usage: sample = changeCase (sample, "up") ; all upper case
+ ; sample = changeCase (sample, "low") ; all lower case
+
+ undef ("changeCase")
+ function changeCase (x:string, opt:string)
+
+ begin
+ print("changeCase: this function has been deprecated.")
+ print(" Will use str_lower or str_upper.")
+ if (opt.eq."low") then
+ return (str_lower(x))
+ else
+ return (str_upper(x))
+ end if
+ end
+ ; *****************************************************
+ ; D. Shea
+ ; trim trailing (rightmost) blanks from one or more strings
+
+ ; This function was deprecated in V5.1.1 and replaced with
+ ; the built-in function "str_right_strip".
+
+ ;
+ undef("trimBlankRight")
+ function trimBlankRight (s[*]:string)
+ begin
+ print("trimBlankRight: this function has been deprecated.")
+ print(" Will use str_right_strip.")
+ return(str_right_strip(s))
+ end
+ ; *****************************************************************
+ ; D. Shea
+ ; Generate latitudes for a Fixed global grid
+ ; nlat= 73
+ ; lat = latGlobeF (nlat, "lat", "latitude", "degrees_north")
+ ; lat will run from -90 -> +90
+ ;
+ ; set nlat at double = True if double precision is desired
+ ;
+ undef ("latGlobeF")
+ function latGlobeF(nlat,dimName:string,longName:string,units:string)
+ local dlat, lat
+ begin
+ if (isatt(nlat,"double") .and. nlat at double) then
+ dlat = new ( 1, "double" )
+ else
+ dlat = new ( 1, "float" )
+ end if
+ delete (dlat at _FillValue)
+
+ dlat = 180./(nlat-1) ; output lat
+ lat = ispan ( 0,nlat-1,1 )*dlat - 90.
+ lat!0 = dimName
+ lat at long_name = longName
+ lat at units = units
+ lat&$dimName$ = lat
+ return (lat)
+ end
+ ; *****************************************************************
+ ; D. Shea
+ ; Generate latitudes for a Fixed-Offset global grid
+ ; Example: nlat= 72
+ ; lat = latGlobeFo (nlat, "lat", "latitude", "degrees_north")
+ ; lat will run from -> -87.5 to 87.5 in the above example
+ ;
+ ; set nlat at double = True if double precision is desired
+ ;
+ undef ("latGlobeFo")
+ function latGlobeFo(nlat,dimName:string,longName:string,units:string)
+ local dlat, offset, lat
+ begin
+ if (isatt(nlat,"double") .and. nlat at double) then
+ dlat = new ( 1, "double" )
+ else
+ dlat = new ( 1, "float" )
+ end if
+ delete (dlat at _FillValue)
+
+ dlat = 180./nlat ; output lat
+ offset = dlat*0.5
+ lat = ispan ( 0,nlat-1,1 )*dlat - 90. + offset
+ lat!0 = dimName
+ lat at long_name = longName
+ lat at units = units
+ lat&$dimName$ = lat
+ return (lat)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Assign all named dimensions to a variable along with the longname
+ ; and units. It will not assigne coordinate variables.
+
+ undef("nameDim")
+ function nameDim(x,dimNames[*]:string,longName:string,units:string)
+
+ ;usage: z = nameDim (z, (/a string name for each dim/), longName, units)
+ ;usage: 4D: u = nameDim (u, (/"time","lat","lev","lon"/), "zonal wind", "m/s")
+ ;usage: 4D: u = nameDim (u, (/"time","lev","lat","lon"/), "zonal wind", "m/s")
+ ;usage: 3D: t = nameDim (x, (/"time","lat","lon"/) , "temperature", "K")
+ ;usage: 1D: lat = nameDim (lat, "lat" , "latitude", "degrees_north")
+ ;usage: 1D: gw = nameDim ( gw, "lat" , "gaussian weights", "")
+
+ local dimN, rank, n
+ begin
+ dimN = dimsizes(dimNames) ; number of names in dimNames
+ rank = dimsizes(dimsizes(x)) ; number of dimension of "x"
+
+ if (dimN.eq.rank) then
+ do n=0,dimN-1
+ x!n = dimNames(n) ; eg: x!0 = "time"
+ end do
+
+ x at long_name = longName
+ x at units = units
+ else
+ print ("NCL: nameDim: #of dimension names (="+dimN+
+ ") does not equal the rank of the input array ("+rank+")")
+ end if
+
+ return (x)
+ end
+ ; *****************************************************************
+ ; Calculate meteorological wind direction
+ ; *****************************************************************
+ undef ("wind_direction")
+ function wind_direction(u:numeric, v:numeric, opt:integer)
+ ; meteorological wind direction.
+ ; This is over-kill. Only need: wdir=atan2(u,v)*radi + 180
+ local wdir, radi, con, wcrit, wmsg, zero, dimu
+ begin
+ if (.not.(typeof(u).eq."double" .or.
+ typeof(u).eq."float" .or.
+ typeof(u).eq."integer" )) then
+ print("wind_direction: illegal numeric type: "+typeof(u))
+ exit
+ end if
+
+ dimu = dimsizes(u)
+
+ if (typeof(u).eq."double") then
+ zero = 0.0d
+ wmsg = 1d20
+ con = 180.0d
+ wcrit= 360d0-0.00002d0
+ radi = 1.0d0/0.0174532925199433d0
+ wdir = new (dimu, typeof(u), wmsg)
+ else
+ zero = 0.0
+ wmsg = 1e20
+ con = 180.0
+ wcrit= 360-0.00002
+ radi = 1.0/0.01745329
+ wdir = new (dimu, "float", wmsg)
+ end if
+
+ wdir = (/ atan2(u,v)*radi + con /)
+ wdir = where(wdir.ge.wcrit, zero, wdir) ; force 360 "north winds" to 0
+
+ if (typeof(opt).eq."integer" .and. opt.eq.0) then
+ cdir = zero ; calm 0.0->_FillValue
+ wdir = where (u.eq.zero .and. v.eq.zero, cdir, wdir)
+ end if
+
+ if (typeof(opt).eq."integer" .and. opt.eq.1) then
+ cdir = wdir at _FillValue ; calm 0.0->_FillValue
+ wdir = where (u.eq.zero .and. v.eq.zero, cdir, wdir)
+ end if
+
+ if (typeof(opt).eq."float" .or. typeof(opt).eq."double") then
+ ; calm 0.0->user_value
+ wdir = where (u.eq.zero .and. v.eq.zero, opt, wdir)
+ end if
+
+ wdir at long_name = "wind direction (meteorological)"
+ if (isatt(wdir,"units")) then
+ delete(wdir at units)
+ end if
+ return(wdir)
+ end
+ ; *****************************************************************
+ ; Calculate meteorological wind components
+ ; *****************************************************************
+ undef ("wind_component")
+ function wind_component(wspd:numeric, wdir:numeric, opt:integer)
+ local wdir, rad , ivmsg, uveps, uvzero, dimw, rankw, dimuv, uv
+ begin
+ if (typeof(wspd).eq."double" .or. typeof(wspd).eq."double") then
+ rad = 0.0174532925199433d0
+ uvmsg = 1d20
+ uveps = 1.0d-5
+ uvzero= 0.0d0
+ else
+ rad = 0.01745329
+ uvmsg = 1e20
+ uveps = 1.0e-5
+ uvzero= 0.0
+ end if
+
+ dimw = dimsizes(wspd)
+ rankw= dimsizes(dimw)
+
+ dimuv= new ( rankw+1, "integer", "No_FillValue")
+ dimuv(0) = 2
+ dimuv(1:) = dimw
+ uv = new (dimuv, typeof(wspd), uvmsg)
+
+ if (rankw.eq.1 .and. dimw(0).eq.1) then
+ uv(0) = -wspd*sin(wdir*rad)
+ uv(1) = -wspd*cos(wdir*rad)
+ copy_VarMeta(wspd, uv)
+ else if (rankw.eq.1) then
+ uv(0,:) = -wspd*sin(wdir*rad)
+ uv(1,:) = -wspd*cos(wdir*rad)
+ copy_VarMeta(wspd, uv(0,:))
+ else if (rankw.eq.2) then
+ uv(0,:,:) = -wspd*sin(wdir*rad)
+ uv(1,:,:) = -wspd*cos(wdir*rad)
+ copy_VarMeta(wspd, uv(0,:,:))
+ else if (rankw.eq.3) then
+ uv(0,:,:,:) = -wspd*sin(wdir*rad)
+ uv(1,:,:,:) = -wspd*cos(wdir*rad)
+ copy_VarMeta(wspd, uv(0,:,:,:))
+ else if (rankw.eq.4) then
+ uv(0,:,:,:,:) = -wspd*sin(wdir*rad)
+ uv(1,:,:,:,:) = -wspd*cos(wdir*rad)
+ copy_VarMeta(wspd, uv(0,:,:,:,:))
+ else if (rankw.eq.5) then
+ uv(0,:,:,:,:,:) = -wspd*sin(wdir*rad)
+ uv(1,:,:,:,:,:) = -wspd*cos(wdir*rad)
+ copy_VarMeta(wspd, uv(0,:,:,:,:,:))
+ end if ; 5
+ end if ; 4
+ end if ; 3
+ end if ; 2
+ end if ; 1
+ end if ; scalar
+
+ uv = where(abs(uv).le.uveps, uvzero, uv) ; make near zero => 0
+
+ uv!0 = "uv"
+ uv at long_name = "zonal and meridional wind components"
+
+ return(uv)
+ end
+
+ ; **************************************************************
+ ; D. Shea
+ ; Loops thru a 1D variable [eg, time] and finds
+ ; the indices which match up with the values of the cvWant 1D array
+ ; e.g. time_want = (/1948, 1957, 1964, 1965, 1989/)
+ ; indWant = get1Dindex (time, time_want)
+ ; note that the values of cvWant must EXIST in cv
+
+ undef("get1Dindex")
+ function get1Dindex (cv[*], cvWant[*])
+ local nWant, indWant, n, indcv, nMult
+
+ begin
+ nWant = dimsizes (cvWant)
+ indWant = new (nWant, "integer")
+ nMult = 0
+
+ do n=0,nWant-1
+ indcv := ind( cv.eq.cvWant(n) ) ; could be multiple values
+ indWant(n) = indcv(0) ; return the 1st if multiple indcv
+ if (dimsizes(indcv).gt.1) then
+ nMult = nMult + 1
+ end if
+ end do
+
+ indWant at index_info = "Out of nWant="+nWant+" : multiple index occurrences="+nMult
+ indWant at nMultInd = nMult
+
+ return (indWant)
+ end
+
+ ; *******************************************************************
+ ; u.utku.turuncoglu at be.itu.edu.tr
+ ; The following procedure to sorts x,y coordinate pair based on
+ ; selected one. The opt controls the behavior of the sort procedure. If the
+ ; value is equal to 1 then, it sorts the x values and match the correct y
+ ; with it.
+
+ undef("sort_xy")
+ procedure sort_xy(x:numeric, y:numeric, eps:numeric, opt:numeric)
+
+ local x_old, y_old, x_ind, y_ind, x_eps, y_eps, i
+ begin
+ ;--- sort x ---
+ if (opt .eq. 1) then
+ ;--- fix, the arguments of the get1Dindex must unique ---
+ x_eps = new(dimsizes(x), typeof(x))
+ do i = 0, dimsizes(x)-1
+ x_eps(i) = (i+1)*eps
+ end do
+
+ ;--- add artifical small number to get unique array ---
+ x = x+x_eps
+
+ ;--- sort arrays ---
+ x_old = x
+ qsort(x)
+ x_ind = get1Dindex(x_old, x)
+ y = y(x_ind)
+ ;--- sort y ---
+ else
+ ;--- fix, the arguments of the get1Dindex must unique ---
+ y_eps = new(dimsizes(y), typeof(y))
+ do i = 0, dimsizes(y)-1
+ y_eps(i) = (i+1)*eps
+ end do
+
+ ;--- add artifical small number to get unique array ---
+ y = y+y_eps
+
+ ;--- sort arrays ---
+ y_old = y
+ qsort(y)
+ y_ind = get1Dindex(y_old, y)
+ x = x(y_ind)
+ end if
+ end
+
+ ;********************************************************************
+ ; D. Shea
+ ; set a _FillValue "automatically"
+ ; If a variable has a "_FillValue" use it, if not "missing_value" etc.
+ ; if none on file, then return "No_FillValue"
+ ; This function should be used within the "new" statement.
+ ; example of inline use: var = new(dimsizes(x),typeof(x),getFillValue(x))
+
+ undef("getFillValue")
+ function getFillValue (x)
+ local FillValue
+ begin
+ if (isatt(x,"_FillValue")) then
+ FillValue = x at _FillValue
+ else
+ if (isatt(x,"missing_value")) then
+ FillValue = x at missing_value
+ else
+ FillValue = "No_FillValue"
+ end if
+ end if
+
+ return (FillValue)
+ end
+ ;********************************************************************
+ ; D. Shea
+ ; set a numeric _FillValue "automatically"
+ ; If a variable has a "_FillValue" use it, if not "missing_value" etc.
+ ; if none on file, then set default by variable type
+ ; example of inline use: var = new(dimsizes(x),typeof(x),getFillValue(x))
+
+ undef("getVarFillValue")
+ function getVarFillValue (x)
+ local FillValue
+ begin
+ if (isatt(x,"_FillValue")) then
+ return( x at _FillValue )
+ else
+ if (isatt(x,"missing_value")) then
+ return( x at missing_value )
+ else
+ return( default_fillvalue(typeof(x)) )
+ end if
+ end if
+ end
+ ; **************************************************************
+ ; D. Shea
+ ; Loops thru a 1D variable [eg, time] and finds
+ ; the indices which do *not* match up with the values of the cvExclude
+
+ undef("get1Dindex_Exclude")
+ function get1Dindex_Exclude (cv[*]:numeric,cvExclude[*]:numeric)
+ local nCv, nExclude, cvLocal,n, indTemp
+ begin
+
+ nExclude = dimsizes (cvExclude)
+ nCv = dimsizes (cv)
+
+ cvLocal = new( nCv, typeof(cv), getFillValue(cv) )
+ cvLocal = (/ cv /)
+
+ do n=0,nExclude-1
+ indTemp = ind( cvExclude(n).eq.cv)
+ if (.not.any(ismissing(indTemp)) ) then
+ cvLocal(indTemp) = cvLocal at _FillValue
+ end if
+ delete(indTemp)
+ end do
+
+ return(ind(.not.ismissing(cvLocal)))
+ end
+ ; **************************************************************
+ ; D. Shea
+ ; 19 Feb 2006
+ ; This was wrong. For historical reasons keep the function but
+ ; invoke get1Dindex_Exclude
+
+ undef("get1Dindex_Collapse")
+ function get1Dindex_Collapse (cv[*]:numeric,cvWant[*]:numeric)
+ begin
+ return( get1Dindex_Exclude(cv, cvWant) )
+ end
+
+ ;*************************************************************
+ ; From: Dave Allured
+ ; Date: Thu, 15 Mar 2007 14:00:43 -0600
+ ; "The following is much simpler and more robust" ... than 'closest_val'
+ ; DA's original name was 'closest_val_AnyOrder'
+ undef("closest_val")
+ function closest_val(xVal[1]:snumeric, x:snumeric)
+ local xAbsDif, xMinVal, iClose
+ begin
+ xAbsDif = abs(xVal-x)
+ iClose = minind(xAbsDif)
+ return(iClose) ; original doc says "first occurence"
+ end
+
+ ;****************************************************************
+ ; S. Murphy
+ ; Finds the index of the array point closest to the desired value
+ ; e.g. var2ck = 18.382
+ ; values in array2ck = 17.0 17.5 18.0 18.5
+ ; this function would return 3.
+
+ undef("closest_val_original")
+ function closest_val_original(var2ck:numeric,array2ck[*])
+ local size, narray,loc, test1,test2
+ begin
+ size = dimsizes(array2ck) ; get size of original array
+
+ ; make sure array is monotonically increasing
+
+ if (.not.all(array2ck(1:size-1).gt.array2ck(0:size-2)) ) then
+ print("closest_val: input array is not monotonically increasing")
+ exit
+ end if
+
+
+ ; first check to see if the value exists in the array
+
+ if(any(var2ck.eq.array2ck))then
+ return(ind(var2ck.eq.array2ck))
+ print(var2ck +"equals a value in the array")
+ exit
+ end if
+
+ ; value does not exist in array, so we insert it
+
+ narray = new( (/size + 1/),typeof(array2ck)) ; create new array
+
+ narray(0:size-1) = array2ck(:)
+ narray(size) = var2ck ; add value to new array
+ qsort(narray) ; sort the new array
+
+ loc = ind(narray.eq.var2ck) ; determine the index
+ ;
+ ; var2ck is last value
+ ;
+ if(loc.ge.size)then
+ return(size)
+ exit
+ end if
+ ;
+ ; var2ck is first value
+ ;
+ if(loc.eq.0)then
+ return(loc)
+ exit
+ end if
+ ;
+ ; somewhere in the middle
+ ;
+ test1 = narray(loc) - narray(loc-1)
+ test2 = narray(loc+1) - narray(loc)
+ if(test1.lt.test2)then
+ return(loc-1)
+ else
+ return(loc)
+ end if
+ end
+ ; **************************************************************
+ ; D. Shea
+ ; Convert a 1D array to a single string
+ ; e.g. maxYrs = (/1960,1969,1980,1989/)
+ ; yrString = oneDtostring (maxYrs)
+ ; yrString = "1960,1969,1980,1989"
+
+ undef("oneDtostring")
+ function oneDtostring (x[*])
+ local nx, n, newString
+ begin
+ newString = new ( 1 , string)
+
+ nx = dimsizes(x)
+ if (nx.gt.1) then
+ newString = x(0) + ","
+ do n=1,nx-2
+ newString = newString + x(n) + ","
+ end do
+ newString = newString + x(nx-1)
+ else
+ newString = x(0)
+ end if
+ return (newString)
+ end
+ ;********************************************************
+ ; S. Murphy
+ ; converts a list of comma deliminated variables passed from
+ ; csh to NCL to an actual array of strings.
+ ; e.g. set vars = ,T,U,V,TS,PRECC, (in csh)
+ ; setenv nclvars $vars (to pass to NCL must be and env)
+ ; vs = getenv("nclvars") (reads csh variable into NCL)
+ ; vars = cshstringtolist(vs) (does conversion)
+ ; vars = (/"T","U","V","TS","PRECC"/)
+
+ ; note the string "list" is now an NCL keyword, so "list" has been
+ ; shortened to "lst"
+
+ undef("cshstringtolist")
+ function cshstringtolist(cshlist:string)
+ local lst, breaks, nwords, str, i
+ begin
+
+ lst=stringtochar(cshlist) ;convert the string to characters
+ breaks = ind(lst .eq. inttochar(44)) ;locate the deliminators (a space is 32)
+ nwords=dimsizes(breaks) ;count the deliminators
+
+ str=new((/nwords-1/),string)
+ do i=0,nwords-2 ;pull out the separate strings
+ str(i) = chartostring (lst(breaks(i)+1:breaks(i+1)-1))
+ end do
+ return(str)
+ end
+
+
+ ;*************************************************************
+ ; D. Shea
+ ; use coersion for integer to float
+ ; get around *irritating* lack of conversion function
+
+ undef ("int2flt")
+ function int2flt(i:integer)
+ local dimi, fi
+ begin
+ dimi = dimsizes(i)
+ if (isatt(i,"_FillValue")) then
+ fi = new( dimi, "float", i at _FillValue)
+ else
+ fi = new( dimi, "float","No_FillValue")
+ end if
+
+ fi = i ; values + meta data
+ return (fi)
+ end
+
+
+ ;*************************************************************
+ ; D. Shea
+ ; use coersion for integer to float
+ ; get around *irritating* lack of conversion function
+
+ undef ("int2dble")
+ function int2dble(i:integer)
+ local dimi, di
+ begin
+ dimi = dimsizes(i)
+ di = new( dimi, "double")
+ di = i ; values + meta data
+ if (isatt(i,"_FillValue")) then
+ di at _FillValue = i at _FillValue
+ else
+ delete(di at _FillValue)
+ end if
+ return (di)
+
+ end
+
+
+ ; *************************************************************
+ ; D. Shea
+ ; use coersion for float to double
+ ; but also make sure that _FillValue is assigned
+ ; when missing_value is present
+ undef("flt2dble")
+ function flt2dble (xF:float)
+ local xD
+ begin
+ xD = new (dimsizes(xF), double, getFillValue(xF))
+ ;if (.not.isatt(xF,"_FillValue") .and. \
+ ; .not.isatt(xF,"missing_value")) then
+ ; delete(xD at _FillValue) ; no _FillValue or missing_value on input
+ ;end if
+ xD = xF ; variable-to-variable transfer [all meta data copied]
+
+ if (isatt(xD,"missing_value") .and.
+ typeof(xD at missing_value).ne."double") then
+ delete(xD at missing_value)
+ xD at missing_value = xD at _FillValue ; add missing_value
+ end if
+
+ return(xD)
+ end
+
+ ; *************************************************************
+ ; D. Shea
+ ; Wrapper for NCL function: doubletofloat
+ ; This does the conversion and copies all the attributes
+ ; and coordinate variables [CV] and attributes of the CV.
+ ; This is more complicated than usual beacuse I want
+ ; to convert any double attributes and CVs to float.
+
+ undef("dble2flt")
+ function dble2flt (xD)
+ local dimx, ndimx, xF, xD_atts, i, j, cv, cvD, cvF, cvD_atts
+ begin
+ if (typeof(xD).eq."float") then
+ if (isatt(xD,"long_name")) then
+ print("dble2flt: input variable is already type float: "+xD at long_name)
+ else
+ print("dble2flt: input variable is already type float")
+ end if
+ return(xD)
+ end if
+
+ dimx = dimsizes(xD)
+
+ if (isatt(xD,"_FillValue")) then
+ xF = new (dimx, float, doubletofloat(xD at _FillValue ) )
+ else
+ if (isatt(xD,"missing_value")) then
+ xF = new (dimx(xD), float, doubletofloat(xD at missing_value) )
+ end if
+ end if
+
+ xF = doubletofloat (xD) ; convert values
+
+ xD_atts = getvaratts(xD) ; copy attributes of input variable
+ if (.not.all(ismissing(xD_atts))) then
+ do i=0,dimsizes(xD_atts)-1
+ if (xD_atts(i).ne."_FillValue") then ; done above
+ if(typeof(xD@$xD_atts(i)$) .ne. "double" ) then
+ xF@$xD_atts(i)$ = xD@$xD_atts(i)$
+ else
+ xF@$xD_atts(i)$ = doubletofloat(xD@$xD_atts(i)$)
+ end if
+ end if
+ end do
+ end if
+ delete (xD_atts)
+ ; add info on operation performed
+ xF at typeConversion_op_ncl = "double converted to float"
+
+ ndimx = dimsizes(dimx) ; number of dimensions
+ do i=0,ndimx-1 ; loop over all dimensions
+ if (.not.ismissing(xD!i)) then
+ xF!i = xD!i ; copy dimension name
+ if(iscoord(xD,xD!i)) then ; copy coordinate variable [if present]
+ cvD = xD&$xD!i$ ; coordinate variable [for convenience]
+ if (typeof(cvD).ne."double") then
+ xF&$xF!i$ = cvD ; straight copy
+ else
+ cvF = doubletofloat(cvD) ; no attributes copied
+ cvD_atts = getvaratts(cvD) ; coord var atts
+ if (.not.all(ismissing(cvD_atts))) then
+ do j=0,dimsizes(cvD_atts)-1
+ if (typeof(cvD@$cvD_atts(j)$) .ne. "double" ) then
+ cvF@$cvD_atts(j)$ = cvD@$cvD_atts(j)$
+ else ; must be double
+ cvF@$cvD_atts(j)$ = doubletofloat( cvD@$cvD_atts(j)$)
+ end if
+ end do
+ end if
+ xF&$xF!i$ = cvF ; assign float coord variable
+ delete (cvF)
+ delete (cvD_atts)
+ end if
+ delete (cvD)
+ end if
+ end if
+ end do
+
+ return (xF)
+
+ end
+ ;******************************************************************
+ ; D. Shea
+ ; converts shorts to floats using the "scale" and "offset" attributes (if present)
+ ; Note: the CF and COARDS conventions require that
+ ; "if both scale_factor and add_offset
+ ; attributes are present, the data are first scaled before the offset is added"
+ ; This follows these conventions.
+
+ undef("short2flt")
+ function short2flt (xS)
+ local xF, oNames, sNames, offset, scale, xAtts, nAtts, n
+ begin
+ if (typeof(xS).eq."float") then
+ if (isatt(xS,"long_name")) then
+ print("short2flt: input variable is already type float: "+xS at long_name)
+ else
+ print("short2flt: input variable is already type float")
+ end if
+ print("short2flt: no conversion performed")
+ return(xS)
+ end if
+
+ if (.not.(typeof(xS).eq."short" .or. typeof(xS).eq."ushort")) then
+ if (isatt(xS,"long_name")) then
+ print("short2flt: input variable is not type short or ushort: "+xS at long_name)
+ else
+ print("short2flt: input variable is not type short or ushort")
+ end if
+ exit
+ end if
+
+ ;xF = new ( dimsizes(xS), float)
+ xF = new ( dimsizes(xS), float, 1.e20) ; 20 Nov 2002
+ ; added 19 Dec 2002
+ ; the type stuff added Sept 2003
+ if (isatt(xS,"missing_value") .and. .not.isatt(xS,"_FillValue")) then
+ type_missing_value = typeof(xS at missing_value)
+ if (typeof(xS).eq."short") then
+ if (type_missing_value.eq."short") then
+ xS at _FillValue = xS at missing_value
+ end if
+ if (type_missing_value.eq."ushort") then
+ xS at _FillValue = toshort(xS at missing_value)
+ end if
+ if (type_missing_value.eq."integer") then
+ xS at _FillValue = toshort(xS at missing_value)
+ end if
+ end if
+
+ if (typeof(xS).eq."ushort") then
+ if (type_missing_value.eq."ushort") then
+ xS at _FillValue = xS at missing_value
+ end if
+ if (type_missing_value.eq."short") then
+ xS at _FillValue = toushort(xS at missing_value)
+ end if
+ if (type_missing_value.eq."integer") then
+ xS at _FillValue = toushort(xS at missing_value)
+ end if
+ end if
+ end if ; end of assigning _FillValue
+
+ copy_VarAtts (xS, xF)
+ copy_VarCoords (xS, xF)
+
+ ; should data be 'scaled' and/or 'offset' ?
+
+ ; names to check
+ oNames = (/"add_offset", "offset", "OFFSET", "Offset", "_offset"
+ ,"Intercept", "intercept", "add_off", "ADD_OFF"/)
+ sNames = (/"scale", "SCALE", "Scale", "_scale", "scale_factor", "factor"
+ ,"Scale_factor", "Slope" , "slope", "ScaleFactor", "Scale_Factor"
+ ,"SCALING_FACTOR" /)
+
+ offset = 0.0 ; establish as type float
+ scale = 1.0
+
+ xAtts = getvaratts(xS)
+ nAtts = dimsizes(xAtts)
+
+ do n=0,nAtts-1
+ if (any(oNames.eq.xAtts(n))) then
+ if (typeof(xS@$xAtts(n)$).eq."float") then
+ offset = xS@$xAtts(n)$
+ else
+ if (typeof(xS@$xAtts(n)$).eq."double") then
+ offset = doubletofloat(xS@$xAtts(n)$)
+ end if
+ if (typeof(xS@$xAtts(n)$).eq."string") then
+ offset = stringtofloat(xS@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have offset att
+ break
+ end if
+ end do
+
+ do n=0,nAtts-1
+ if (any(sNames.eq.xAtts(n))) then
+ if (typeof(xS@$xAtts(n)$).eq."float") then
+ scale = xS@$xAtts(n)$
+ else
+ if (typeof(xS@$xAtts(n)$).eq."double") then
+ scale = doubletofloat(xS@$xAtts(n)$)
+ end if
+ if (typeof(xS@$xAtts(n)$).eq."string") then
+ scale = stringtofloat(xS@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have scale att
+ break
+ end if
+ end do
+
+ if (scale.eq.1.0 .and. offset.eq.0.) then
+ xF = (/ xS /)
+ else
+ xF = xS*scale + offset
+ end if
+
+ if (isatt(xS,"valid_range") .and. typeof(xS at valid_range).eq."short") then
+ vrS = xS at valid_range
+ vrF = new ( dimsizes(vrS), float)
+ vrF = vrS*scale + offset
+ delete(xF at valid_range) ; delete the "short" valid_range
+ xF at valid_range = vrF ; recreate with float
+ end if
+
+ if (isatt(xF,"missing_value")) then
+ delete(xF at missing_value)
+ xF at missing_value = xF at _FillValue
+ end if
+
+ return (xF)
+
+ end
+ ;******************************************************************
+ ; D. Shea
+ ; converts bytes to floats using the "scale" and "offset" attributes (if present)
+ ; Note: the CF and COARDS conventions require that
+ ; "if both scale_factor and add_offset
+ ; attributes are present, the data are first scaled before the offset is added"
+ ; This follows these conventions.
+
+ undef("byte2flt")
+ function byte2flt (xB)
+ local xF, oNames, sNames, offset, scale, xAtts, nAtts, n
+ begin
+ xF = new ( dimsizes(xB), float)
+
+ copy_VarAtts (xB, xF)
+ copy_VarCoords (xB, xF)
+
+ ; should data be 'scaled' and/or 'offset' ?
+
+ ; names to check
+ oNames = (/"add_offset", "offset", "OFFSET", "Offset", "_offset"
+ ,"Intercept", "intercept", "add_off", "ADD_OFF"/)
+ sNames = (/"scale", "SCALE", "Scale", "_scale", "scale_factor" , "factor"
+ ,"Scale_factor", "Slope" , "slope", "ScaleFactor", "Scale_Factor"
+ ,"SCALING_FACTOR" /)
+
+
+ offset = 0.0 ; establish as type float
+ scale = 1.0
+
+ xAtts = getvaratts(xB)
+ nAtts = dimsizes(xAtts)
+
+ do n=0,nAtts-1
+ if (any(oNames.eq.xAtts(n))) then
+ if (typeof(xB@$xAtts(n)$).eq."float") then
+ offset = xB@$xAtts(n)$
+ else
+ if (typeof(xB@$xAtts(n)$).eq."double") then
+ offset = doubletofloat(xB@$xAtts(n)$)
+ end if
+ if (typeof(xB@$xAtts(n)$).eq."string") then
+ offset = stringtofloat(xB@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have offset att
+ break
+ end if
+ end do
+
+ do n=0,nAtts-1
+ if (any(sNames.eq.xAtts(n))) then
+ if (typeof(xB@$xAtts(n)$).eq."float") then
+ scale = xB@$xAtts(n)$
+ else
+ if (typeof(xB@$xAtts(n)$).eq."double") then
+ scale = doubletofloat(xB@$xAtts(n)$)
+ end if
+ if (typeof(xB@$xAtts(n)$).eq."string") then
+ scale = stringtofloat(xB@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have scale att
+ break
+ end if
+ end do
+
+ if (scale.eq.1.0 .and. offset.eq.0.) then
+ xF = (/ xB /)
+ else
+ xF = xB*scale + offset
+ end if
+
+ if (isatt(xB,"valid_range") .and.
+ (typeof(xB at valid_range).eq."byte" .or.
+ typeof(xB at valid_range).eq."ubyte") ) then
+ vrB = xB at valid_range
+ vrF = new ( dimsizes(vrB), float)
+ vrF = vrB*scale + offset
+ delete(xF at valid_range) ; delete the "byte" valid_range
+ xF at valid_range = vrF ; recreate with float
+ end if
+
+ return (xF)
+
+ end
+ ;******************************************************************
+ ; D. Shea
+ ; converts shorts to floats using the "scale" and "offset" attributes (if present)
+
+ ; Note: Conventional HDF usage require that
+ ; if both scale_factor and add_offset attributes are present,
+ ; the following implementation should be used:
+ ; result = scale_factor*(stored_integer-add_offset)
+ ; This is different than the COARDS and CF Conventions.
+ ;
+ ; Usage:
+ ; x = short2flt_hdf(xS) where xS is a short
+ ; also directly convert to float
+ ; x = short2flt_hdf(f->xS)
+ ;
+ undef("short2flt_hdf")
+ function short2flt_hdf (xS:short)
+ local xF, oNames, sNames, offset, scale, xAtts, nAtts, n
+ begin
+ ;xF = new ( dimsizes(xS), float)
+ xF = new ( dimsizes(xS), float, 1.e20) ; 20 Nov 2002
+
+ copy_VarAtts (xS, xF)
+ copy_VarCoords (xS, xF)
+ ; added 19 Dec 2002
+ if (isatt(xS,"missing_value") .and. .not.isatt(xS,"_FillValue")) then
+ xS at _FillValue = xS at missing_value
+ end if
+
+ ; should data be 'scaled' and/or 'offset' ?
+
+ ; names to check
+ oNames = (/"add_offset", "offset", "OFFSET", "Offset", "_offset"
+ ,"Intercept", "intercept", "scalingIntercept" /)
+ sNames = (/"scale", "SCALE", "Scale", "_scale", "scale_factor"
+ ,"Scale_factor", "Slope" , "slope", "ScaleFactor"
+ ,"Scale_Factor", "scalingSlope", "SCALING_FACTOR" /)
+
+
+ offset = 0.0 ; establish as type float
+ scale = 1.0
+
+ xAtts = getvaratts(xS)
+ nAtts = dimsizes(xAtts)
+
+ do n=0,nAtts-1
+ if (any(oNames.eq.xAtts(n))) then
+ if (typeof(xS@$xAtts(n)$).eq."float") then
+ offset = xS@$xAtts(n)$
+ else
+ if (typeof(xS@$xAtts(n)$).eq."double") then
+ offset = doubletofloat(xS@$xAtts(n)$)
+ end if
+ if (typeof(xS@$xAtts(n)$).eq."string") then
+ offset = stringtofloat(xS@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have offset att
+ break
+ end if
+ end do
+
+ do n=0,nAtts-1
+ if (any(sNames.eq.xAtts(n))) then
+ if (typeof(xS@$xAtts(n)$).eq."float") then
+ scale = xS@$xAtts(n)$
+ else
+ if (typeof(xS@$xAtts(n)$).eq."double") then
+ scale = doubletofloat(xS@$xAtts(n)$)
+ end if
+ if (typeof(xS@$xAtts(n)$).eq."string") then
+ scale = stringtofloat(xS@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have scale att
+ break
+ end if
+ end do
+
+ if (scale.eq.1.0 .and. offset.eq.0.) then
+ xF = (/ xS /)
+ else
+ xF = scale*(xS - offset)
+ end if
+
+ if (isatt(xS,"valid_range") .and. typeof(xS at valid_range).eq."short") then
+ vrS = xS at valid_range
+ vrF = new ( dimsizes(vrS), float)
+ vrF = vrS*scale + offset
+ delete(xF at valid_range) ; delete the "short" valid_range
+ xF at valid_range = vrF ; recreate with float
+ end if
+
+ if (isatt(xF,"missing_value")) then
+ delete(xF at missing_value)
+ xF at missing_value = xF at _FillValue
+ end if
+
+ return (xF)
+
+ end
+ ;******************************************************************
+ ; D. Shea
+ ; converts bytes to floats using the "scale" and "offset"
+ ; attributes (if present)
+
+ ; Note: Conventional HDF usage [HDF Users Guide] require that
+ ; if both scale_factor and add_offset attributes are present,
+ ; the following implementation should be used:
+ ; Usage: x = byte2flt_hdf(xB) where xB is a short
+
+ undef("byte2flt_hdf")
+ function byte2flt_hdf (xB:byte)
+ local xF, oNames, sNames, offset, scale, xAtts, nAtts, n
+ begin
+ xF = new ( dimsizes(xB), float)
+
+ copy_VarAtts (xB, xF)
+ copy_VarCoords (xB, xF)
+
+ ; should data be 'scaled' and/or 'offset' ?
+
+ ; names to check
+ oNames = (/"add_offset", "offset", "OFFSET", "Offset", "_offset"
+ ,"Intercept", "intercept"/)
+ sNames = (/"scale", "SCALE", "Scale", "_scale", "scale_factor"
+ ,"Scale_factor", "Slope" , "slope", "ScaleFactor"
+ ,"Scale_Factor", "SCALING_FACTOR" /)
+
+
+ offset = 0.0 ; establish as type float
+ scale = 1.0
+
+ xAtts = getvaratts(xB)
+ nAtts = dimsizes(xAtts)
+
+ do n=0,nAtts-1
+ if (any(oNames.eq.xAtts(n))) then
+ if (typeof(xB@$xAtts(n)$).eq."float") then
+ offset = xB@$xAtts(n)$
+ else
+ if (typeof(xB@$xAtts(n)$).eq."double") then
+ offset = doubletofloat(xB@$xAtts(n)$)
+ end if
+ if (typeof(xB@$xAtts(n)$).eq."string") then
+ offset = stringtofloat(xB@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have offset att
+ break
+ end if
+ end do
+
+ do n=0,nAtts-1
+ if (any(sNames.eq.xAtts(n))) then
+ if (typeof(xB@$xAtts(n)$).eq."float") then
+ scale = xB@$xAtts(n)$
+ else
+ if (typeof(xB@$xAtts(n)$).eq."double") then
+ scale = doubletofloat(xB@$xAtts(n)$)
+ end if
+ if (typeof(xB@$xAtts(n)$).eq."string") then
+ scale = stringtofloat(xB@$xAtts(n)$)
+ end if
+ end if
+ delete(xF@$xAtts(n)$) ; xF will no longer have scale att
+ break
+ end if
+ end do
+
+ if (scale.eq.1.0 .and. offset.eq.0.) then
+ xF = (/ xB /)
+ else
+ xF = scale*(xB - offset)
+ end if
+
+ if (isatt(xB,"valid_range") .and. typeof(xB at valid_range).eq."byte") then
+ vrB = xB at valid_range
+ vrF = new ( dimsizes(vrB), float)
+ vrF = vrB*scale + offset
+ delete(xF at valid_range) ; delete the "byte" valid_range
+ xF at valid_range = vrF ; recreate with float
+ end if
+
+ return (xF)
+
+ end
+ ; ********************************************************************
+ ; D. Shea
+ ; There is no built-in "floattostring"
+ ; Convert float values to type string
+
+ undef("flt2string")
+ function flt2string ( x:float )
+ local x_str
+ begin
+ ;x_str = x + "" ; trick
+ ;copy_VarMeta (x, x_str) ; contributed.ncl
+
+ x_str = new (dimsizes(x), "string")
+ delete(x_str at _FillValue)
+ x_str = x
+ return(x_str)
+ end
+
+ ; ********************************************************************
+ ; D. Shea
+ ; Convert *any* numeric type to integer with option for rounding
+
+ undef("numeric2int")
+ function numeric2int( x:numeric, opt[1]:integer)
+ local t, i
+ begin
+ t = typeof( x )
+ if (t.eq."integer") then
+ return( x )
+ end if
+ if (t.eq."float") then
+ if (opt.eq.0) then
+ return( toint(x) ) ; truncate
+ else
+ return( round(x,3) )
+ end if
+ end if
+ if (t.eq."double") then
+ if (opt.eq.0) then
+ return( toint(x) ) ; truncate
+ else
+ return( round(x,3) )
+ end if
+ end if
+ if (t.eq."short" .or. t.eq."byte") then
+ i = new( dimsizes(x), "integer", getFillValue(x))
+ i = x ; promote to integer
+ return( i )
+ end if
+ end
+ ; ********************************************************************
+ ; D. Shea
+ ; Truncate or Round "x" to the number of decimal places [nDec]
+ ; This will [I hope] operate on any arbitrary array of float/double
+ ; numbers. However, originally it was designed to work on a scalar for
+ ; plotting or printing purposes.
+
+ ; ==> The NCL function "sprintf" has much of the same functionality
+ ; ==> as this function. "decimalPlaces" is kept for backward
+ ; ==> compatibility reasons.
+ ;
+ ; It was upgraded by D Shea in Dec 2009 to use "round" and to
+ ; return metadata.
+ ;
+ ; x - float or double only
+ ; nDec - number of decimal places to the right of decimal point
+ ; Round - round or truncate
+ ;
+ ; usage:
+ ; x is a scalar
+ ; xRound = decimalPlaces(x, 2, True) ; x=12.345678 => 12.35
+ ; xRound = decimalPlaces(x, 2, False) ; x=12.345678 => 12.34
+ ; title = "EOF: PerCent Variance="+decimalPlaces(pcvar(0), 2, True)
+
+ undef("decimalPlaces")
+ function decimalPlaces(x:numeric, nDec:integer, Round:logical)
+ local xType, shift, xTmp, _FillValue
+ begin
+ xType = typeof(x)
+
+ if (xType.eq."float" .or. xType.eq."double") then
+ if (xType.eq."double") then
+ shift = 10.0d^nDec
+ else
+ shift = 10.0^nDec
+ end if
+
+ xTmp = x
+ if (isatt(xTmp,"_FillValue")) then
+ FillValue = xTmp at _FillValue
+ delete(xTmp at _FillValue)
+ xTmp at _FillValue = FillValue*shift ; shifted _FillValue
+ end if
+
+ xTmp = xTmp*shift
+ xTmp = round(xTmp, 0)
+ xTmp = xTmp/shift
+ ;xTmp = (/ round(x*shift)/shift /)
+
+ if (isvar("FillValue")) then
+ xTmp at _FillValue = FillValue ; original _FillValue
+ end if
+
+ return(xTmp)
+ else
+ print ("decimalPlaces: input is of type "+xType )
+ print (" only float or double is allowed")
+ return (x)
+ end if
+ end
+
+ ; *******************************************************************
+ ; M. Haley
+ ; Constructs a string with dim names to return with the _Wrap fcns
+ ; str - name of function being used
+ ; val - variable containing possible dimension names
+ ; dims - dimensions whose dim names we want to use (if they exist)
+
+ undef("dimWrapString")
+ function dimWrapString(str[1]:string,val:numeric,dims[*]:integer)
+ local any_valid_dims, i, strcat, dnames
+ begin
+ dnames = getvardims(val)
+ any_valid_dims = False
+ if(.not.all(ismissing(dnames))) then
+ strcat = str + " over dimension(s): "
+ do i=0,dimsizes(dims)-1
+ if(.not.ismissing(val!dims(i))) then
+ if(.not.any_valid_dims) then
+ strcat = strcat + val!dims(i)
+ any_valid_dims = True
+ else
+ strcat = strcat + "," + val!dims(i)
+ end if
+ end if
+ end do
+ end if
+ if(any_valid_dims) then
+ return(strcat)
+ else
+ return(str + " function was applied")
+ end if
+ end
+
+ ; *******************************************************************
+ ; D. Shea
+ ; Compute a dimension average of "x" [x may have many dimensions]
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+
+ undef ("dim_avg_Wrap")
+ function dim_avg_Wrap (x:numeric)
+ local xave, dimx, Ndx, Ndx1
+ begin
+
+ xave = dim_avg(x) ; arithmetic ave [no meta data]
+
+ copy_VarAtts (x, xave) ; copy attributes
+
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xave) ; one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xave at average_op_ncl = dimWrapString("dim_avg",x,Ndx1)
+
+ return (xave)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension average of "x" [x may have many dimensions]
+ ; return with one less dimension. Based on dim_avg_Wrap.
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do average across
+
+ undef ("dim_avg_n_Wrap")
+ function dim_avg_n_Wrap (x:numeric,dim_args[*])
+ local xave, dims
+ begin
+
+ dims = dimnames_to_indexes(x,dim_args)
+ xave = dim_avg_n(x,dims) ; arithmetic ave [no meta data]
+
+ copy_VarAtts (x, xave) ; copy attributes
+ ; copy dim names and coord variables
+
+ copy_VarCoords_not_n (x, xave, dims)
+ ; add an extra attribute
+ xave at average_op_ncl = dimWrapString("dim_avg_n",x,dims)
+
+ return (xave)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Compute a wgted average of the rightmost dimension of "x"
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+ undef ("dim_avg_wgt_Wrap")
+ function dim_avg_wgt_Wrap (x:numeric, w[*]:numeric, opt[1]:integer)
+ local xave, dimx, Ndx, Ndx1
+ begin
+
+ xave = dim_avg_wgt(x,w,opt); weighted ave [no meta data]
+
+ copy_VarAtts (x, xave) ; copy attributes
+ ; copy dim names and coord variables
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xave) ; one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xave at average_op_ncl = dimWrapString("dim_avg_wgt",x,Ndx1)
+
+ return (xave)
+ end
+
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a wgted average of the dims' dimensions of "x"
+ ; return with one less dimension. Based on dim_avg_wgt_Wrap.
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do wgted average across
+
+ undef ("dim_avg_wgt_n_Wrap")
+ function dim_avg_wgt_n_Wrap (x:numeric, w[*]:numeric, opt[1]:integer,
+ dims[*]:integer)
+ local xave
+ begin
+
+ xave = dim_avg_wgt_n(x,w,opt,dims); weighted ave [no meta data]
+
+ copy_VarAtts (x, xave) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xave, dims)
+ ; add an extra attribute
+ xave at average_op_ncl = dimWrapString("dim_avg_wgt_n",x,dims)
+
+ return (xave)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Compute a dimension variance of "x" [x may have many dimensions]
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+
+ undef ("dim_variance_Wrap")
+ function dim_variance_Wrap (x:numeric)
+ local xvar, dimx, Ndx, Ndx1
+ begin
+
+ xvar = dim_variance(x) ; arithmetic ave [no meta data]
+
+ copy_VarAtts (x, xvar) ; copy attributes
+ ; copy dim names and coord variables
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xvar) ; one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xvar at variance_op_ncl = dimWrapString("dim_variance",x,Ndx1)
+
+ return (xvar)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension variance of "x" [x may have many dimensions]
+ ; return with one less dimension. Based on dim_variance_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do variance across
+
+ undef ("dim_variance_n_Wrap")
+ function dim_variance_n_Wrap (x:numeric, dims[*]:integer)
+ local xvar
+ begin
+
+ xvar = dim_variance_n(x,dims) ; arithmetic ave [no meta data]
+
+ copy_VarAtts (x, xvar) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xvar, dims)
+ ; add an extra attribute
+ xvar at variance_op_ncl = dimWrapString("dim_variance_n",x,dims)
+
+ return (xvar)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Compute a dimension standard dev of "x" [x may have many dimensions]
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+
+ undef ("dim_stddev_Wrap")
+ function dim_stddev_Wrap (x:numeric)
+ local xstd, dimx, Ndx, Ndx1
+ begin
+
+ xstd = dim_stddev(x) ; arithmetic ave [no meta data]
+
+ copy_VarAtts (x, xstd) ; copy attributes
+ ; copy dim names and coord variables
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xstd) ; one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xstd at stddev_op_ncl = dimWrapString("dim_stddev",x,Ndx1)
+
+ return (xstd)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension standard dev of "x" [x may have many dimensions]
+ ; return with one less dimension. Based on dim_stddev_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do sum across
+
+ undef ("dim_stddev_n_Wrap")
+ function dim_stddev_n_Wrap (x:numeric,dims[*]:integer)
+ local xstd
+ begin
+
+ xstd = dim_stddev_n(x,dims); arithmetic ave [no meta data]
+
+ copy_VarAtts (x, xstd) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xstd, dims)
+ ; add an extra attribute
+ xstd at stddev_op_ncl = dimWrapString("dim_stddev_n",x,dims)
+
+ return (xstd)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Compute a dimension sum of "x" [x may have many dimensions]
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+
+ undef ("dim_sum_Wrap")
+ function dim_sum_Wrap (x:numeric)
+ local xsum, dimx, Ndx, Ndx1
+ begin
+
+ xsum = dim_sum(x) ; arithmetic sum [no meta data]
+
+ copy_VarAtts (x, xsum) ; copy attributes
+ ; copy dim names and coord variables
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xsum) ; one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xsum at sum_op_ncl = dimWrapString("dim_sum",x,Ndx1)
+
+ return (xsum)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension sum of "x" [x may have many dimensions]
+ ; return with one less dimension. Based on dim_sum_Wrap.
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do sum across
+
+ undef ("dim_sum_n_Wrap")
+ function dim_sum_n_Wrap (x:numeric,dims[*]:integer)
+ local xsum
+ begin
+
+ xsum = dim_sum_n(x,dims) ; arithmetic sum [no meta data]
+
+ copy_VarAtts (x, xsum) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xsum, dims)
+ ; add an extra attribute
+ xsum at sum_op_ncl = dimWrapString("dim_sum_n",x,dims)
+
+ return (xsum)
+ end
+
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension min of "x" [x may have many dimensions]
+ ; return with one less dimension. There is no dim_min_Wrap.
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do min across
+
+ undef ("dim_min_n_Wrap")
+ function dim_min_n_Wrap (x:numeric,dims[*]:integer)
+ local xmin
+ begin
+
+ xmin = dim_min_n(x,dims) ; min of data [no meta data]
+
+ copy_VarAtts (x, xmin) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xmin, dims)
+ ; add an extra attribute
+ xmin at min_op_ncl = dimWrapString("dim_min_n",x,dims)
+
+ return (xmin)
+ end
+
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension max of "x" [x may have many dimensions]
+ ; return with one less dimension. There is no dim_max_Wrap.
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do max across
+
+ undef ("dim_max_n_Wrap")
+ function dim_max_n_Wrap (x:numeric,dims[*]:integer)
+ local xmax
+ begin
+
+ xmax = dim_max_n(x,dims) ; max of data [no meta data]
+
+ copy_VarAtts (x, xmax) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xmax, dims)
+ ; add an extra attribute
+ xmax at max_op_ncl = dimWrapString("dim_max_n",x,dims)
+
+ return (xmax)
+ end
+
+ ; *******************************************************************
+ ; D. Shea
+ ; Compute a dimension sum of "x" [x may have many dimensions]
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+
+ undef ("dim_sum_wgt_Wrap")
+ function dim_sum_wgt_Wrap (x:numeric, w[*]:numeric, opt[1]:integer )
+ local xsum, dimx, Ndx, Ndx1
+ begin
+
+ xsum = dim_sum_wgt(x, w, opt) ; arithmetic weighted sum
+
+ copy_VarAtts (x, xsum) ; copy attributes
+ ; copy dim names and coord variables
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xsum) ; one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xsum at sum_op_ncl = dimWrapString("dim_sum_wgt",x,Ndx1)
+
+ return (xsum)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Compute a dimension wgted sum of "x" [x may have many dimensions]
+ ; return with one less dimension. Based on dim_sum_wgt_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do calculation on
+
+ undef ("dim_sum_wgt_n_Wrap")
+ function dim_sum_wgt_n_Wrap (x:numeric, w[*]:numeric, opt[1]:integer,
+ dims[*]:numeric )
+ local xsum
+ begin
+
+ xsum = dim_sum_wgt_n(x, w, opt, dims) ; arithmetic weighted sum
+
+ copy_VarAtts (x, xsum) ; copy attributes
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xsum, dims)
+ ; add an extra attribute
+ xsum at sum_op_ncl = dimWrapString("dim_sum_wgt_n",x,dims)
+
+ return (xsum)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Remove means of each rightmost dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ;
+ undef ("dim_rmvmean_Wrap")
+ function dim_rmvmean_Wrap (x:numeric)
+ local xAnom, dimx, Ndx
+ begin
+
+ xAnom = dim_rmvmean(x)
+ copy_VarAtts(x, xAnom)
+ copy_VarCoords(x, xAnom)
+
+ if (isatt(x,"long_name")) then
+ xAnom at long_name = "Anomalies: "+getLongName(x)
+ else
+ xAnom at long_name = "Deviation from mean"
+ end if
+
+ dimx = dimsizes(x)
+ Ndx = dimsizes(dimx) ; number of dimensions
+ xAnom at rmvmean_op_NCL = dimWrapString("dim_rmvmean",x,Ndx-1)
+
+ return (xAnom)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Remove means of all but the dims' dimensions.
+ ; Based on dim_rmvmean_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do calculation on
+
+ undef ("dim_rmvmean_n_Wrap")
+ function dim_rmvmean_n_Wrap (x:numeric,dims[*]:integer)
+ local xAnom
+ begin
+
+ xAnom = dim_rmvmean_n(x,dims)
+ copy_VarAtts(x, xAnom)
+ copy_VarCoords(x, xAnom)
+
+ if (isatt(x,"long_name")) then
+ xAnom at long_name = "Anomalies: "+getLongName(x)
+ else
+ xAnom at long_name = "Deviation from mean"
+ end if
+
+ xAnom at rmvmean_op_NCL = dimWrapString("dim_rmvmean_n",x,dims)
+
+ return (xAnom)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Remove median of all but the dims' dimensions.
+ ; Based on dim_rmvmean_Wrap
+ ; Remove median of each rightmost dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ;
+ undef ("dim_rmvmed_Wrap")
+ function dim_rmvmed_Wrap (x:numeric)
+ local xRmvMed, dimx, Ndx
+ begin
+
+ xRmvMed = x ; copy metadata
+ xRmvMed = dim_rmvmed(x)
+
+ dimx = dimsizes(x)
+ Ndx = dimsizes(dimx) ; number of dimensions
+ xRmvMed at rmvmed_op_NCL = dimWrapString("dim_rmvmed",x,Ndx-1)
+
+ return (xRmvMed)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; Remove median of all but the dims' dimensions.
+ ; Based on dim_rmvmed_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do calculation on
+ undef ("dim_rmvmed_n_Wrap")
+ function dim_rmvmed_n_Wrap (x:numeric,dims[*]:integer)
+ local xRmvMed
+ begin
+
+ xRmvMed = x ; copy metadata
+ xRmvMed = dim_rmvmed_n(x,dims)
+
+ xRmvMed at rmvmed_op_NCL = dimWrapString("dim_rmvmed_n",x,dims)
+
+ return (xRmvMed)
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; Standardize by the st. dev of each rightmost dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+
+
+ undef ("dim_standardize_Wrap")
+ function dim_standardize_Wrap (x:numeric, opt:integer)
+ local xStd, dimx, Ndx, Ndx1
+ begin
+
+ xStd = x ; copy metadata
+ xStd = dim_standardize(x, opt)
+
+ dimx = dimsizes(x) ; size of each dimension
+ Ndx = dimsizes(dimx) ; number of dimensions
+ Ndx1 = Ndx-1 ; last dimension
+ xStd at standardize_op_ncl = dimWrapString("dim_standardize",x,Ndx1)
+
+ return (xStd)
+ end
+
+ ; *******************************************************************
+ ; M. Haley
+ ; Standardize by the st. dev of each dims' dimensions
+ ; Based on dim_standardize_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; dims - dimension(s) to do calculation on
+
+
+ undef ("dim_standardize_n_Wrap")
+ function dim_standardize_n_Wrap (x:numeric, opt:integer, dims[*]:integer)
+ local xStd
+ begin
+
+ xStd = x ; copy metadata
+ xStd = dim_standardize_n(x, opt, dims)
+
+ ; add an extra attribute
+ xStd at standardize_op_ncl= dimWrapString("dim_standardize_n",x,dims)
+
+ return (xStd)
+ end
+
+ ;**********************************************************
+ ; D. Shea
+ ; Compute average root-mean-square-difference between "x" and "y"
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x,y - 1D or multidimensional variables (must have same size)
+
+ undef ("dim_rmsd_Wrap")
+ function dim_rmsd_Wrap (x:numeric, y:numeric)
+ local xrmsd, dimx, dimy, Ndx, Ndx1
+ begin
+ dimx = dimsizes(x)
+ dimy = dimsizes(y)
+ if (all(dimx.eq.dimy)) then
+
+ xrmsd = dim_rmsd(x,y) ; rmsd values only [no meta data]
+
+ copy_VarAtts (x, xrmsd) ; copy attributes
+ if (isatt(xrmsd,"long_name")) then
+ xrmsd at long_name = "RMSD: "+getLongName(x)
+ end if
+ ; copy dim names and coord variables
+ Ndx = dimsizes(dimx) ; number of dimensions
+ copy_VarCoords_1 (x, xrmsd); one less dimension
+ ; add an extra attribute
+ Ndx1 = Ndx-1 ; last dimension
+ xrmsd at rmsd_op_ncl = dimWrapString("dim_rmsd",x,Ndx1)
+
+ return (xrmsd)
+ else
+ print ("------------------------------------------------------")
+ print ("---> dim_rmsd_Wrap: error: x,y dimension mismatch <---")
+ print ("------------------------------------------------------")
+ exit
+ end if
+
+ end
+ ;**********************************************************
+ ; M. Haley
+ ; Compute average root-mean-square-difference between "x" and "y"
+ ; Based on dim_rmsd_Wrap
+ ; return with one less dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x,y - 1D or multidimensional variables (must have same size)
+ ; dims - dimension(s) to do calculation on
+
+ undef ("dim_rmsd_n_Wrap")
+ function dim_rmsd_n_Wrap (x:numeric, y:numeric, dims[*]:integer)
+ local xrmsd, dimx, dimy
+ begin
+ dimx = dimsizes(x)
+ dimy = dimsizes(y)
+ if (all(dimx.eq.dimy)) then
+
+ xrmsd = dim_rmsd_n(x,y,dims) ; rmsd values only [no meta data]
+
+ copy_VarAtts (x, xrmsd) ; copy attributes
+ if (isatt(xrmsd,"long_name")) then
+ xrmsd at long_name = "RMSD: "+getLongName(x)
+ end if
+ ; copy dim names and coord variables
+ copy_VarCoords_not_n (x, xrmsd, dims)
+ ; add an extra attribute
+ xrmsd at rmsd_op_ncl = dimWrapString("dim_rmsd_n",x,dims)
+
+ return (xrmsd)
+ else
+ print ("--------------------------------------------------------")
+ print ("---> dim_rmsd_n_Wrap: error: x,y dimension mismatch <---")
+ print ("--------------------------------------------------------")
+ exit
+ end if
+
+ end
+ ; *******************************************************************
+ ; D. Shea
+ ; returns cumulative sum of each rightmost dimension
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; opt - option argument, must be 0, 1, or 2
+ ;
+ undef ("dim_cumsum_Wrap")
+ function dim_cumsum_Wrap (x:numeric,opt:integer)
+ local xCumSum
+ begin
+
+ xCumSum = dim_cumsum(x,opt)
+ copy_VarAtts(x, xCumSum)
+ copy_VarCoords(x, xCumSum)
+
+ if (isatt(x,"long_name")) then
+ xCumSum at long_name = "Cumulative Sum: "+getLongName(x)
+ else
+ xCumSum at long_name = "Cumulative Sum"
+ end if
+
+ return (xCumSum)
+ end
+ ; *******************************************************************
+ ; M. Haley
+ ; returns cumulative sum at the given dimension
+ ; Based on dim_cumsum_Wrap
+ ; Copies over all the attributes and coordinate variables
+ ; x - multidimensional variable
+ ; opt - option argument, must be 0, 1, or 2
+ ; dims - dimensions to do calculations on
+
+ undef ("dim_cumsum_n_Wrap")
+ function dim_cumsum_n_Wrap (x:numeric,opt:integer,dims[1]:integer)
+ local xCumSum
+ begin
+
+ xCumSum = dim_cumsum_n(x,opt,dims)
+ copy_VarAtts(x, xCumSum)
+ copy_VarCoords(x, xCumSum)
+
+ if (isatt(x,"long_name")) then
+ xCumSum at long_name = "Cumulative Sum: "+getLongName(x)
+ else
+ xCumSum at long_name = "Cumulative Sum"
+ end if
+
+ return (xCumSum)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute divergence on a fixed grid
+
+ undef("uv2dvF_Wrap")
+ function uv2dvF_Wrap (u:numeric, v:numeric)
+ local div
+ begin
+ div = uv2dvF (u,v)
+ copy_VarMeta (u, div)
+ div at long_name = "divergence"
+ div at units = "1/s" ; assume u,v are m/s
+ return (div)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute divergence on a gaussian grid
+
+ undef("uv2dvG_Wrap")
+ function uv2dvG_Wrap (u:numeric, v:numeric)
+ local div
+ begin
+ div = uv2dvG (u,v)
+ copy_VarMeta (u, div)
+ div at long_name = "divergence"
+ div at units = "1/s" ; assume u,v are m/s
+ return (div)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute relative vorticity on a fixed grid
+
+ undef("uv2vrF_Wrap")
+ function uv2vrF_Wrap (u:numeric, v:numeric)
+ local vrt
+ begin
+ vrt = uv2vrF (u,v)
+ copy_VarMeta (u, vrt)
+ vrt at long_name = "vorticity"
+ vrt at units = "1/s" ; assume u,v are m/s
+ return (vrt)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute relative vorticity on a gaussian grid
+
+ undef("uv2vrG_Wrap")
+ function uv2vrG_Wrap (u:numeric, v:numeric)
+ local vrt
+ begin
+ vrt = uv2vrG (u,v)
+ copy_VarMeta (u, vrt)
+ vrt at long_name = "vorticity"
+ vrt at units = "1/s" ; assume u,v are m/s
+ return (vrt)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute inverse laplacian on a gaussian grid
+
+ undef("ilapsG_Wrap")
+ function ilapsG_Wrap (zlap:numeric, zlmbda:numeric)
+ local answer
+ begin
+ answer = ilapsG (zlap,zlmbda)
+ copy_VarMeta (zlap, answer)
+ answer at long_name = "inverse laplacian"
+ answer at units = "" ; assume u,v are m/s
+ return (answer)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute inverse laplacian on a fixed grid
+
+ undef("ilapsF_Wrap")
+ function ilapsF_Wrap (zlap:numeric, zlmbda:numeric)
+ local answer
+ begin
+ answer = ilapsF (zlap,zlmbda)
+ copy_VarMeta (zlap, answer)
+ answer at long_name = "inverse laplacian"
+ answer at units = "" ; assume u,v are m/s
+ return (answer)
+ end
+
+ ;************************************************************
+ ; D. Shea
+ ; Wrappers for the dv2uv[G/F] and vr2uv[G/F] functions
+
+ undef("dv2uvG_Wrap")
+ function dv2uvG_Wrap (dv)
+ local uv
+ begin
+ uv = dv2uvG(dv)
+ copy_VarAtts (dv, uv)
+ ; override long_name and units
+ uv at long_name = "divergent zonal [0] and meridional [1] winds"
+ uv at units = "m/s"
+ ; coordinate variables
+ component_copy_VarCoords (dv, uv)
+ return(uv)
+ end
+
+ undef("dv2uvF_Wrap")
+ function dv2uvF_Wrap (dv)
+ local uv
+ begin
+ uv = dv2uvF(dv)
+ copy_VarAtts (dv, uv)
+ ; override long_name and units
+ uv at long_name = "divergent zonal [0] and meridional [1] winds"
+ uv at units = "m/s"
+ ; coordinate variables
+ component_copy_VarCoords (dv, uv)
+ return(uv)
+ end
+
+ undef("vr2uvG_Wrap")
+ function vr2uvG_Wrap (vr)
+ local uv
+ begin
+ uv = vr2uvG(vr)
+ copy_VarAtts (vr, uv)
+ ; override long_name and units
+ uv at long_name = "rotational zonal [0] and meridional [1] winds"
+ uv at units = "m/s"
+ ; coordinate variables
+ component_copy_VarCoords (vr, uv)
+ return(uv)
+ end
+
+ undef("vr2uvF_Wrap")
+ function vr2uvF_Wrap (vr)
+ local uv
+ begin
+ uv = vr2uvF(vr)
+ copy_VarAtts (vr, uv)
+ ; override long_name and units
+ uv at long_name = "rotational zonal [0] and meridional [1] winds"
+ uv at units = "m/s"
+ ; coordinate variables
+ component_copy_VarCoords (vr, uv)
+ return(uv)
+ end
+
+ ;**********************************************************
+ ;D. Shea
+ ; Compute a zonal average of "x" [x may have many dimensions]
+ ; return with one less dimension
+
+ undef("zonalAve")
+ function zonalAve (x:numeric)
+ local xzon
+ begin
+ xzon = dim_avg_Wrap (x)
+ ; ----DJS personal---- over ride above
+ if (isatt(xzon,"long_name") .or. isatt(xzon,"description") .or.
+ isatt(xzon,"standard_name") ) then
+ xzon at long_name = "Zonal Ave ["+ getLongName(xzon)+"]"
+ else
+ xzon at long_name = "Zonal Average"
+ end if
+
+ if (isatt(xzon,"short_name")) then
+ xzon at short_name = "Zonal Ave ["+ xzon at short_name+"]"
+ else
+ xzon at short_name = "ZonAve"
+ end if
+ ; ----end DJS personal
+ return (xzon)
+ end
+
+
+ ; **********************************************************
+ ; D. Shea
+ ; same arguments as NCL function smth9
+ ; usually: p=0.50 and q={-0.25 [light], 0 [5-pt], 0.25[heavy]}
+
+ ; This is a "wrapper" for smth9. It copies all attributes
+ ; coordinate dimensions etc to the smoothed variable.
+ ; Also it adds an attribute or two.
+
+ ; Basically it ensures that the return variable will have all the
+ ; corrects meta info with it.
+ ; [eg: xSmth = smth9_Wrap (x,p,q,False) then xSmth will be "correct"]
+
+
+ undef("smth9_Wrap")
+ function smth9_Wrap(var:numeric, p[1]:numeric, q[1]:numeric, cyclic:logical)
+ local var_out
+ begin
+ if (isatt(var,"missing_value") .and. .not.isatt(var,"_FillValue")) then
+ var at _FillValue = var at missing_value
+ end if
+ var_out = var ; transfer all coordinate variables, attributes etc
+ var_out = smth9 (var, p, q, cyclic) ; add info on operation performed
+ var_out at spatial_op_ncl = "smth9; nine-pt smoother applied; " +
+ "p="+p+" q="+q+" cyclic="+cyclic
+ return(var_out)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; error check: called internally by a number of functions
+ ; sample: modCheck ("clmMonLLT", ntim, nmos) ; error check
+
+
+ undef("modCheck")
+ procedure modCheck (name:string, N, n)
+ local valid_types
+ begin
+ valid_types = (/"integer","long"/)
+
+ if(.not.any(typeof(N).eq.valid_types).or.
+ .not.any(typeof(n).eq.valid_types)) then
+ print ("modCheck: n and N must be integers or longs")
+ exit
+ end if
+ if ((N%n).ne.0) then
+ print ("contributed.ncl: "+name+": dimension must be a multiple of "+n)
+ exit
+ end if
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; error check: called internally by a number of functions
+ ; sample: rankCheck ("routine_name", x, 3) ; rank check
+
+ undef("rankCheck")
+ procedure rankCheck (name:string, x, n:integer)
+ begin
+ rank = dimsizes(dimsizes(x))
+ if (rank.ne.n) then
+ print("contributed.ncl: "+name+":: rank +n+ required: rank="+rank)
+ exit
+ end if
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate long term monthly means (monthly climatology)
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lat,lon,time) <==== INPUT DIMENSION ORDER
+ ; x!0 = "lat"
+ ; x!1 = "lon"
+ ; x!2 = "time"
+ ;
+ ; Usage: moClm = clmMonLLT (x)
+
+ undef("clmMonLLT")
+ function clmMonLLT (x[*][*][*]:numeric)
+ local dimx, nlat, mlon, ntim, i, nmo, nmos, aveMonth
+ begin
+
+ dimx = dimsizes (x)
+ nlat = dimx(0)
+ mlon = dimx(1)
+ ntim = dimx(2)
+
+ nmos = 12
+ modCheck ("clmMonLLT", ntim, nmos) ; error check
+ ;
+ ; Compute all 12 monthly averages first.
+ ;
+ aveMonth = new((/nlat,mlon,nmos/),typeof(x)
+ ,getFillValue(x))
+
+ do nmo=0,nmos-1
+ aveMonth(:,:,nmo) = dim_avg( x(:,:,nmo:ntim-1:nmos) )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,aveMonth)
+ aveMonth at time_op_ncl = "Climatology: "+ (ntim/nmos) +" years"
+ aveMonth at info = "function clmMonLLT: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=0,1
+ if (.not.ismissing(x!i)) then
+ aveMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ aveMonth&$aveMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ aveMonth!2 = "month" ; create a "month" named dim
+ aveMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (aveMonth)
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate standard deviations of monthly means
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lat,lon,time) <==== INPUT DIMENSION ORDER
+ ; x!0 = "lat"
+ ; x!1 = "lon"
+ ; x!2 = "time"
+ ;
+ ; Usage: moStd = stdMonLLT (x)
+
+
+ undef("stdMonLLT")
+ function stdMonLLT (x[*][*][*]:numeric)
+ local dimx, nlat, mlon, ntim, i, nmo, nmos, stdMonth
+ begin
+
+ dimx = dimsizes (x)
+ nlat = dimx(0)
+ mlon = dimx(1)
+ ntim = dimx(2)
+
+ nmos = 12
+ modCheck ("stdMonLLT", ntim, nmos) ; error check
+ ;
+ ; Compute all 12 monthly standard deviations first.
+ ;
+ stdMonth = new((/nlat,mlon,nmos/),typeof(x)
+ ,getFillValue(x))
+
+ do nmo=0,nmos-1
+ stdMonth(:,:,nmo) = dim_stddev( x(:,:,nmo:ntim-1:nmos) )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,stdMonth)
+
+ stdMonth at time_op_ncl = " Monthly Standard Deviation: "+ (ntim/nmos) +" years"
+ stdMonth at info = "function stdMonLLT: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=0,1
+ if (.not.ismissing(x!i)) then
+ stdMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ stdMonth&$stdMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ stdMonth!2 = "month" ; create a "month" named dim
+ stdMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (stdMonth)
+ end
+
+ ; ------------------------------------------------------------------
+ ; D. Shea
+ ; Calculate anomalies from climatology
+ ; returned array is same as from "rmMonthAnnualCycleLLT (x, yr1, yr2)
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lat,lon,time) <==== INPUT DIMENSION ORDER
+ ; x!0 = "lat"
+ ; x!1 = "lon"
+ ; x!2 = "time"
+ ;
+ ; Usage: x = calcMonAnomLLT (x,xAve) ; overwrites "x"
+ ; xAnom = calcMonAnomLLT (x,xAve) ; creates xAnom
+ ; where xAve = clmMonLLT (x) ; see previous function
+
+
+ undef("calcMonAnomLLT")
+ function calcMonAnomLLT (x[*][*][*]:numeric, xAve[*][*][12]:numeric)
+ local dimx, ntim, yr, nmos, xAnom
+ begin
+ dimx = dimsizes (x)
+ ntim = dimx(2)
+
+ nmos = 12
+ modCheck ("calcMonAnomLLT", ntim, nmos) ; error check
+
+ ; Now loop on every year and compute difference.
+ ; The [yr:yr+nmos-1] strips out 12 months for each year.
+
+ xAnom = x ; variable to variable copy [meta data]
+ do yr=0,ntim-1,nmos
+ xAnom(:,:,yr:yr+nmos-1) = (/ x(:,:,yr:yr+nmos-1)- xAve /)
+ end do
+
+ ; Create an informational attribute:
+
+ xAnom at anomaly_op_ncl = "function calcMonAnomLLT: contributed.ncl"
+ return (xAnom)
+ end
+
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Remove that remove Annual Cycle from "monthly" (nmos=12) data.
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lat,lon,time) <==== INPUT DIMENSION ORDER
+ ; x!0 = "lat"
+ ; x!1 = "lon"
+ ; x!2 = "time"
+ ;
+ ; Usage: x = rmMonAnnCyLLT (x)
+
+ undef("rmMonAnnCycLLT")
+ function rmMonAnnCycLLT (x[*][*][*]:numeric)
+ local dimx, ntim, nmos, xAve, xAnom
+ begin
+ dimx = dimsizes(x)
+ ntim = dimx(2)
+
+ nmos = 12
+ modCheck ("rmMonAnnCycLLT", ntim, nmos) ; error check
+
+ xAve = clmMonLLT (x) ; Compute all 12 monthly averages first.
+ xAnom = calcMonAnomLLT (x,xAve) ; Remove the mean from each year-month grid
+
+ ; Create an informational attribute
+
+ xAnom at anomaly_op_ncl = "Annual Cycle Removed:function rmMonAnnCycLLT:contributed.ncl"
+ xAnom at reference = "function rmMonAnnCycLLT in contrib.ncl"
+ return (xAnom)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate long term monthly means (monthly climatology)
+ ; requires named dimensions
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lat,lon) <==== INPUT DIMENSION ORDER
+ ; x!1 = "time"
+ ; x!2 = "lat"
+ ; x!3 = "lon"
+ ;
+ ; Usage: moClm = clmMonTLL (x)
+
+
+ undef("clmMonTLL")
+ function clmMonTLL (x[*][*][*]:numeric)
+ local dimx, ntim, nlat, mlon, i, nmo, nmos, monAveLLT
+ begin
+ dimx = dimsizes(x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("clmMonTLL", ntim, nmos) ; error check
+ ;rankCheck("clmMonTLL", x, 3) ; not needed due to prototyping
+
+ nlat = dimx(1)
+ mlon = dimx(2)
+ ;
+ ; Compute all 12 monthly averages first.
+ ;
+ aveMonth = new((/nmos,nlat,mlon/),typeof(x)
+ ,getFillValue(x))
+ do nmo=0,nmos-1
+ aveMonth(nmo,:,:) = dim_avg_n( x(nmo:ntim-1:nmos,:,:), 0 )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,aveMonth)
+ aveMonth at time_op_ncl = "Climatology: "+ (ntim/nmos) +" years"
+ aveMonth at info = "function clmMonLLT: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=1,2
+ if (.not.ismissing(x!i)) then
+ aveMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ aveMonth&$aveMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ aveMonth!0 = "month" ; create a "month" named dim
+ aveMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (aveMonth)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate standard deviations of monthly means (interannual var)
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lat,lon) <==== INPUT DIMENSION ORDER
+ ; x!1 = "time"
+ ; x!2 = "lat"
+ ; x!3 = "lon"
+ ;
+ ; Usage: moStd = stdMonTLL (x)
+
+ undef("stdMonTLL")
+ function stdMonTLL (x[*][*][*]:numeric)
+ local dimx, ntim, nlat, mlon, i, nmo, nmos, stdMonth
+ begin
+ dimx = dimsizes(x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("stdMonTLL", ntim, nmos) ; error check
+ ;rankCheck("stdMonTLL", x, 3) ; not needed due to prototyping
+
+ nlat = dimx(1)
+ mlon = dimx(2)
+ ;
+ ; Compute all 12 std deviations.
+ ;
+ stdMonth = new((/nmos,nlat,mlon/),typeof(x)
+ ,getFillValue(x))
+ do nmo=0,nmos-1
+ stdMonth(nmo,:,:) = dim_stddev_n( x(nmo:ntim-1:nmos,:,:), 0 )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,stdMonth)
+ stdMonth at time_op_ncl = "Monthly Standard Deviation: "+ (ntim/nmos) +" years"
+ stdMonth at info = "function stdMonTLL: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=1,2
+ if (.not.ismissing(x!i)) then
+ stdMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ stdMonth&$stdMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ stdMonth!0 = "month" ; create a "month" named dim
+ stdMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (stdMonth)
+ end
+
+ ;**********************************************************************
+ ; D. Shea
+ ; Calculate standardized anomalies from monthly data
+ ;
+ ; Subtract the the long term means from each Month.
+ ; divide by the standard deviation for that month
+ ; On return x will consist of anomalies from each month's long term mean.
+ ;
+ ; opt
+ ; opt=1 use population standard deviation to normalize.
+ ; opt.ne.1, use sample standard deviation.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lat,lon) <==== INPUT DIMENSION ORDER
+ ; x!0 = "time"
+ ; x!1 = "lat"
+ ; x!2 = "lon"
+ ;
+ ; Usage: x = calcMonStandardizeAnomTLL (x, opt) ; overwrites "x"
+ ; xStiz = calcMonStandardizeAnomTLL (x, opt) ; creates xStiz as new variable
+
+ undef("calcMonStandardizeAnomTLL")
+ function calcMonStandardizeAnomTLL (x[*][*][*]:numeric, opt:integer)
+ local dimx, ntim, nmo, nmos, dNam, namd0, namd1, namd2, xStiz
+ begin
+ dimx = dimsizes (x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("calcMonStandardizeAnomTLL", ntim, nmos) ; error check
+ dNam = dimNamCheck ("calcMonStandardizeAnomTLL", x) ; error check
+
+ nyrs = ntim/nmos
+
+ namd0 = dNam(0)
+ namd1 = dNam(1)
+ namd2 = dNam(2)
+
+ xStiz = x ; variable to variable copy [meta data]
+ do nmo=0,ntim-1,nmos
+ ;xStiz(nmo:ntim-1:nmos,:,:) = dim_standardize(x(namd1|:,namd2|:,namd0|nmo:ntim-1:nmos), opt)
+ xStiz(nmo:ntim-1:nmos,:,:) = dim_standardize_n(x(nmo:ntim-1:nmos,:,:), opt, 0 ) ; Nov 9, 2009
+ end do
+ if (isatt(x,"long_name") .or. isatt(x,"description") .or.
+ isatt(x,"standard_name") ) then
+ xStiz at long_name = "Standardized Anomalies: "+getLongName(x)
+ end if
+ xStiz at units = "dimensionless"
+
+ ; Create an informational attribute:
+
+ xStiz at standardized_op_ncl = "calcMonStandardizeAnomTLL: contributed.ncl"
+
+ return (xStiz)
+ end
+
+ ;*******************************************************************
+ ; Adam Phillips
+ ; remove annual cycle from 1d monthly time series
+ ;
+ ; The time dimension must be a multiple of 12
+ ; Usage:
+ ; xAnom = rmAnnCycle1D (x)
+ ; x = rmAnnCycle1D (x)
+
+ undef ("rmAnnCycle1D")
+ function rmAnnCycle1D (x[*]:numeric)
+ local ntim, nmo, nmos, aveMonth, xAnom, yr
+ begin
+ ntim = dimsizes(x)
+
+ nmos = 12
+ modCheck ("rmAnnCycle1D", ntim, nmos) ; error check
+ ;
+ ; Compute all 12 monthly averages first.
+ ;
+ aveMonth = new(nmos,typeof(x),getFillValue(x))
+ do nmo=0,nmos-1
+ aveMonth(nmo) = dim_avg( x(nmo:ntim-1:nmos) )
+ end do
+ ;
+ ; remove the monthly means from each year
+ ;
+ xAnom = x ; variable to variable copy [meta data]
+ do yr=0,ntim-1,nmos
+ xAnom(yr:yr+nmos-1) = (/ x(yr:yr+nmos-1)- aveMonth /)
+ end do
+ xAnom at anomaly_op_ncl = "Annual Cycle Removed: rmAnnCycle1D: contributed.ncl"
+ return (xAnom)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate long term monthly means (monthly climatology)
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lev,lat,lon,time) <==== INPUT DIMENSION ORDER
+ ;
+ ; Usage: moClm = clmMonLLLT (x)
+ ; moClm(lev,lat,lon,12)
+
+
+ undef("clmMonLLLT")
+ function clmMonLLLT (x[*][*][*][*]:numeric)
+ local dimx, klvl, nlat, mlon, ntim, i, nmo, nmos, aveMonth
+ begin
+
+ dimx = dimsizes (x)
+ klvl = dimx(0)
+ nlat = dimx(1)
+ mlon = dimx(2)
+ ntim = dimx(3)
+
+ nmos = 12
+ modCheck ("clmMonLLLT", ntim, nmos) ; error check
+ ;
+ ; Compute all 12 monthly averages first.
+ ;
+ aveMonth = new((/klvl,nlat,mlon,nmos/),typeof(x)
+ ,getFillValue(x))
+
+ do nmo=0,nmos-1
+ aveMonth(:,:,:,nmo) = dim_avg( x(:,:,:,nmo:ntim-1:nmos) )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,aveMonth)
+
+ aveMonth at time_op_ncl = "Climatology: "+ (ntim/nmos) +" years"
+ aveMonth at info = "function clmMonLLLT: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=0,2
+ if (.not.ismissing(x!i)) then
+ aveMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ aveMonth&$aveMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ aveMonth!3 = "month" ; create a "month" named dim
+ aveMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (aveMonth)
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate standard deviations of monthly means
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lev,lat,lon,time) <==== INPUT DIMENSION ORDER
+ ;
+ ; Usage: moStd = stdMonLLLT (x)
+ ; moStd(lev,lat,lon,12)
+
+
+ undef("stdMonLLLT")
+ function stdMonLLLT (x[*][*][*][*]:numeric)
+ local dimx, klvl, nlat, mlon, ntim, i, nmo, nmos, stdMonth
+ begin
+
+ dimx = dimsizes (x)
+ klvl = dimx(0)
+ nlat = dimx(1)
+ mlon = dimx(2)
+ ntim = dimx(3)
+
+ nmos = 12
+ modCheck ("stdMonLLLT", ntim, nmos) ; error check
+ ;
+ ; Compute all 12 monthly standard deviations first.
+ ;
+ stdMonth = new((/klvl,nlat,mlon,nmos/),typeof(x)
+ ,getFillValue(x))
+
+ do nmo=0,nmos-1
+ stdMonth(:,:,:,nmo) = dim_stddev( x(:,:,:,nmo:ntim-1:nmos) )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,stdMonth)
+
+ stdMonth at time_op_ncl = " Monthly Standard Deviation: "+ (ntim/nmos) +" years"
+ stdMonth at info = "function stdMonLLLT: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=0,2
+ if (.not.ismissing(x!i)) then
+ stdMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ stdMonth&$stdMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ stdMonth!3 = "month" ; create a "month" named dim
+ stdMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (stdMonth)
+ end
+
+ ; ------------------------------------------------------------------
+ ; D. Shea
+ ; Calculate anomalies from climatology
+ ; returned array is same as from "rmMonthAnnualCycleLLLT (x, yr1, yr2)
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(,lev,lat,lon,time) <==== INPUT DIMENSION ORDER
+ ;
+ ; Usage: x = calcMonAnomLLLT (x,xAve) ; overwrites "x"
+ ; xAnom = calcMonAnomLLLT (x,xAve) ; creates xAnom
+ ; where xAve = clmMonLLLT (x) ; see previous function
+
+
+ undef("calcMonAnomLLLT")
+ function calcMonAnomLLLT (x[*][*][*][*]:numeric, xAve[*][*][*][12]:numeric)
+ local dimx, ntim, yr, nmos, xAnom
+ begin
+
+ dimx = dimsizes (x)
+ ntim = dimx(3)
+
+ nmos = 12
+ modCheck ("calcMonAnomLLLT", ntim, nmos) ; error check
+
+ ; Now loop on every year and compute difference.
+ ; The [yr:yr+nmos-1] strips out 12 months for each year.
+
+ xAnom = x ; variable to variable copy [meta data]
+ do yr=0,ntim-1,nmos
+ xAnom(:,:,:,yr:yr+nmos-1) = (/ x(:,:,:,yr:yr+nmos-1)- xAve /)
+ end do
+
+ ; Create an informational attribute:
+
+ xAnom at anomaly_op_ncl = "function calcMonAnomLLLT: contributed.ncl"
+ return (xAnom)
+ end
+
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Remove that Annual Cycle from "monthly" (nmos=12) data.
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(lat,lon,time) <==== INPUT DIMENSION ORDER
+ ;
+ ; Usage: x = rmMonAnnCyLLLT (x)
+
+ undef("rmMonAnnCycLLLT")
+ function rmMonAnnCycLLLT (x[*][*][*][*]:numeric)
+ local dimx, ntim, xAve, xAnom, nmos
+ begin
+ dimx = dimsizes(x)
+ ntim = dimx(3)
+
+ nmos = 12
+ modCheck ("rmMonAnnCycLLLT", ntim, nmos) ; error check
+
+ xAve = clmMonLLLT (x) ; Compute all 12 monthly averages first.
+ xAnom = calcMonAnomLLLT (x,xAve) ; Remove the mean from each year-month grid
+
+ ; Create an informational attribute
+
+ xAnom at anomaly_op_ncl = "Annual Cycle Removed:function rmMonAnnCycLLLT:contributed.ncl"
+ xAnom at reference = "function rmMonAnnCycLLLT in contrib.ncl"
+ return (xAnom)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate long term monthly means (monthly climatology)
+ ; requires named dimensions
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lev,lat,lon) <==== INPUT DIMENSION ORDER
+ ;
+ ; Usage: moClm = clmMonTLLL (x)
+ ; Output: moClm(12,lev,lat,lon)
+
+ undef("clmMonTLLL")
+ function clmMonTLLL (x[*][*][*][*]:numeric)
+ local dimx, klvl, ntim, nlat, mlon, i, nmo, nmos, monAveLLT
+ begin
+ dimx = dimsizes(x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("clmMonTLLL", ntim, nmos) ; error check
+ ;rankCheck("clmMonTLLL", x, 3) ; not needed due to prototyping
+
+ klvl = dimx(1)
+ nlat = dimx(2)
+ mlon = dimx(3)
+ ;
+ ; Compute all 12 monthly averages first.
+ ;
+ aveMonth = new((/nmos,klvl,nlat,mlon/),typeof(x)
+ ,getFillValue(x))
+ do nmo=0,nmos-1
+ aveMonth(nmo,:,:,:) = dim_avg_n( x(nmo:ntim-1:nmos,:,:,:), 0 )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,aveMonth)
+ aveMonth at time_op_ncl = "Climatology: "+ (ntim/nmos) +" years"
+ aveMonth at info = "function clmMonLLLT: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=1,3
+ if (.not.ismissing(x!i)) then
+ aveMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ aveMonth&$aveMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ aveMonth!0 = "month" ; create a "month" named dim
+ aveMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (aveMonth)
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Calculate standard deviations of monthly means (interannual var)
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,klvl,lat,lon) <==== INPUT DIMENSION ORDER
+ ;
+ ; Usage: moStd = stdMonTLLL (x)
+ ; Output: moStd(12,lev,lat,lon)
+
+ undef("stdMonTLLL")
+ function stdMonTLLL (x[*][*][*][*]:numeric)
+ local dimx, klvl, ntim, nlat, mlon, i, nmo, nmos, stdMonth
+ begin
+ dimx = dimsizes(x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("stdMonTLLL", ntim, nmos) ; error check
+ ;rankCheck("stdMonTLLL", x, 3) ; not needed due to prototyping
+
+ klvl = dimx(1)
+ nlat = dimx(2)
+ mlon = dimx(3)
+ ;
+ ; Compute all 12 standard deviations first.
+ ;
+ stdMonth = new((/nmos,klvl,nlat,mlon/),typeof(x)
+ ,getFillValue(x))
+ do nmo=0,nmos-1
+ stdMonth(nmo,:,:,:) = dim_stddev_n( x(nmo:ntim-1:nmos,:,:,:), 0 )
+ end do
+
+ ; copy attributes and add a couple of informational attributes
+ ; only need to do this if plotting or writing to netCDF file
+
+ copy_VarAtts (x,stdMonth)
+ stdMonth at time_op_ncl = "Monthly Standard Deviation: "+ (ntim/nmos) +" years"
+ stdMonth at info = "function stdMonTLLL: contributed.ncl"
+
+ ; copy spatial (eg, lat/lon) coordinate variables
+
+ do i=1,3
+ if (.not.ismissing(x!i)) then
+ stdMonth!i = x!i
+ if (iscoord(x,x!i)) then
+ stdMonth&$stdMonth!i$ = x&$x!i$
+ end if
+ end if
+ end do
+
+ stdMonth!0 = "month" ; create a "month" named dim
+ stdMonth&month = ispan(0,nmos-1,1) ; create a month coord var
+
+ return (stdMonth)
+ end
+ ;**********************************************************************
+ ; D. Shea
+ ; Calculate anomalies from climatology [Remove annual cycle]
+ ;
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lat,lon) <==== INPUT DIMENSION ORDER
+ ; x!0 = "time"
+ ; x!1 = "lat"
+ ; x!2 = "lon"
+ ; xAve(12,lat,lon) <==== THE 12 is Jan, Feb, .., Dec
+ ;
+ ; Usage: x = calcMonAnomTLL (x,xAve) ; overwrites "x"
+ ; xAnom = calcMonAnomTLL (x,xAve) ; creates xAnom as new variable
+ ; where xAve = clmMonTLL (x)
+
+ undef("calcMonAnomTLL")
+ function calcMonAnomTLL (x[*][*][*]:numeric, xAve[12][*][*]:numeric)
+ local dimx, ntim, yr, nmos, xAnom
+ begin
+ dimx = dimsizes (x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("calcMonAnomTLL", ntim, nmos) ; error check
+ ;rankCheck("calcMonAnomTLL", x, 3) ; not needed due to prototyping
+
+ ; Now loop on every year and compute difference.
+ ; The [yr:yr+nmos-1] strips out 12 months for each year. [array notation]
+
+ xAnom = x ; variable to variable copy [meta data]
+ do yr=0,ntim-1,nmos
+ xAnom(yr:yr+nmos-1,:,:) = (/ x(yr:yr+nmos-1,:,:)- xAve /)
+ end do
+
+ ; Create an informational attribute:
+
+ xAnom at anomaly_op_ncl = "Anomalies from Annual Cycle: calcMonAnomTLL: contributed.ncl"
+
+ return (xAnom)
+ end
+ ;**********************************************************************
+ ; D. Shea
+ ; Calculate anomalies from climatology [Remove annual cycle]
+ ;
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lev,lat,lon) <==== INPUT DIMENSION ORDER
+ ; x!0 = "time"
+ ; x!1 = "lev"
+ ; x!2 = "lat"
+ ; x!3 = "lon"
+ ; xAve(12,lev,lat,lon) <==== THE 12 is Jan, Feb, .., Dec
+ ;
+ ; Usage: x = calcMonAnomTLLL (x,xAve) ; overwrites "x"
+ ; xAnom = calcMonAnomTLLL (x,xAve) ; creates xAnom as new variable
+ ; where xAve = clmMonTLLL (x)
+
+ undef("calcMonAnomTLLL")
+ function calcMonAnomTLLL (x[*][*][*][*]:numeric, xAve[12][*][*][*]:numeric)
+ local dimx, ntim, yr, nmos, xAnom
+ begin
+ dimx = dimsizes (x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("calcMonAnomTLLL", ntim, nmos) ; error check
+ ;rankCheck("calcMonAnomTLLL", x, 3) ; not needed due to prototyping
+
+ ; Now loop on every year and compute difference.
+ ; The [yr:yr+nmos-1] strips out 12 months for each year. [array notation]
+
+ xAnom = x ; variable to variable copy [meta data]
+ do yr=0,ntim-1,nmos
+ xAnom(yr:yr+nmos-1,:,:,:) = (/ x(yr:yr+nmos-1,:,:,:)- xAve /)
+ end do
+
+ ; Create an informational attribute:
+
+ xAnom at anomaly_op_ncl = "Anomalies from Annual Cycle: calcMonAnomTLLL: contributed.ncl"
+
+ return (xAnom)
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; Remove the Annual Cycle from "monthly" (nmos=12) data.
+ ; Subtract the the long term means from each "month".
+ ; On return x will consist of deviations from each "month's" long term mean.
+ ;
+ ; The time dimension must be a multiple of 12
+ ;
+ ; x(time,lat,lon) <==== INPUT DIMENSION ORDER
+ ; x!0 = "time"
+ ; x!1 = "lat"
+ ; x!2 = "lon"
+ ;
+ ; Usage: x = rmMonAnnCycTLL (x)
+
+ undef("rmMonAnnCycTLL")
+ function rmMonAnnCycTLL (x[*][*][*]:numeric)
+ local dimx, ntim, nmos, xAve, xAnom
+ begin
+ dimx = dimsizes (x)
+ ntim = dimx(0)
+
+ nmos = 12
+ modCheck ("rmMonAnnCycTLL", ntim, nmos) ; error check
+
+ xAve = clmMonTLL (x) ; Compute all 12 monthly averages first. [12,lat,lon]
+ xAnom = calcMonAnomTLL (x,xAve) ; Remove the mean from each year-month grid
+
+ ; Create an informational attribute
+
+ xAnom at anomaly_op_ncl = "Annual Cycle Removed: rmMonAnnCycTLL: contributed.ncl"
+ return (xAnom)
+ end
+
+ ; =====================================
+ undef("clmDayTLL")
+ function clmDayTLL (x[*][*][*]:numeric, yyyyddd:integer)
+ ;
+ ; calculate the mean Annual Cycle from daily data.
+ ; The return array will gave the raw climatology at each grid point
+ ;
+ ; x(time,lat,lon) <==== input dimension order
+ ; x!0 = "time" <==== time is in days
+ ; x!1 = "lat"
+ ; x!2 = "lon"
+ ;
+ ; non-Leap yyyyddd
+ ; 1905001 => Jan 1, 1905
+ ; 1905032 => Feb 1, 1905
+ ; 1905059 => Feb 28, 1905
+ ; 1905060 => Mar 1, 1905
+ ; 1905365 => Dec 31, 1905
+ ;
+ ; Leap
+ ; 1908001 => Jan 1, 1908]
+ ; 1908032 => Feb 1, 1908]
+ ; 1908059 => Feb 28, 1908]
+ ; 1908060 => Feb 29, 1908]
+ ; 1908061 => Mar 1, 1908]
+ ; 1908366 => Dec 31, 1908]
+ ;
+ ; Usage: xClmDay = clmDAY_TLL (x, yyyyddd)
+ ; -------
+
+ local dimx, ntim, nlat, mlon, ndys, days, clmDay, ndy, indx, year_day, nFill
+ begin
+
+ dimx = dimsizes (x)
+
+ ntim = dimx(0)
+ nlat = dimx(1)
+ mlon = dimx(2)
+ if (isatt(yyyyddd,"calendar")) then
+ if (yyyyddd at calendar.eq."360_day" .or. yyyyddd at calendar.eq."360") then
+ ndys = 360
+ end if
+ if (yyyyddd at calendar.eq."365_day" .or. yyyyddd at calendar.eq."365" .or.
+ yyyyddd at calendar.eq."noleap" .or. yyyyddd at calendar.eq."no_leap") then
+ ndys = 365
+ end if
+ if (yyyyddd at calendar.eq."366_day" .or. yyyyddd at calendar.eq."366" .or.
+ yyyyddd at calendar.eq."allleap" .or. yyyyddd at calendar.eq."all_leap") then
+ ndys = 366
+ end if
+ if (yyyyddd at calendar.eq."standard" .or. yyyyddd at calendar.eq."gregorian") then
+ ndys = 366
+ end if
+ else
+ ndys = 366 ; default
+ end if
+
+ days = yyyyddd - (yyyyddd/1000)*1000 ; strip year info [ddd]
+ clmDay= new((/ndys,nlat,mlon/),typeof(x), getFillValue(x) ) ; daily climatology
+
+ ;
+ ; Compute averages for each sequential day of the year.
+ ;
+ do ndy=0,ndys-1
+ indx = ind( days.eq.(ndy+1) )
+ if (.not.ismissing(indx(0))) then
+ nindx = dimsizes(indx)
+ if (nindx.eq.1) then ; force 3rd dimension
+ clmDay(ndy,:,:) = dim_avg_n(x(indx:indx,:,:), 0)
+ else
+ clmDay(ndy,:,:) = dim_avg_n(x(indx,:,:), 0)
+ end if
+ end if
+ delete(indx)
+ end do
+
+ if (.not.isatt(yyyyddd,"calendar") .or.
+ isatt(yyyyddd,"calendar") .and. yyyyddd at calendar.eq."standard" .or.
+ yyyyddd at calendar.eq."gregorian") then
+ ; nominal day 366
+ ; ave(31 Dec + 1 Jan)=leap
+ clmDay(ndys-1,:,:) = (clmDay(0,:,:) + clmDay(ndys-2,:,:))*0.5
+ end if
+
+ nFill = num(ismissing(clmDay))
+ if (nFill.eq.0) then
+ delete(clmDay at _FillValue)
+ end if
+
+ clmDay at long_name = "Daily Climatology"
+ if (isatt(x,"long_name")) then
+ clmDay at long_name = clmDay at long_name +": "+x at long_name
+ end if
+ if (isatt(x,"units")) then
+ clmDay at units = x at units
+ end if
+ clmDay at information = "Raw daily averages across all years"
+ clmDay at smoothing = "None"
+
+ year_day = ispan(1,ndys,1)
+ year_day at long_name = "day of year"
+ year_day at units = "ddd"
+
+ clmDay!0 = "year_day"
+ clmDay&year_day = year_day
+
+ copy_VarCoords(x(0,:,:), clmDay(0,:,:)) ; trick
+ delete(clmDay at year_day) ; clean up
+
+ if (isatt(yyyyddd,"calendar")) then
+ clmDay at calendar = yyyyddd at calendar
+ end if
+
+ return (clmDay)
+ end
+
+ ; =====================================
+ undef("clmDayTLLL")
+ function clmDayTLLL (x[*][*][*][*]:numeric, yyyyddd:integer)
+ ;
+ ; calculate the mean Annual Cycle from daily data.
+ ; The return array will gave the raw climatology at each grid point
+ ;
+ ; x(time,lev,lat,lon) <==== input dimension order
+ ; x!0 = "time" <==== time is in days
+ ; x!1 = "lev"
+ ; x!2 = "lat"
+ ; x!3 = "lon"
+ ;
+ ; non-Leap yyyyddd
+ ; 1905001 => Jan 1, 1905
+ ; 1905032 => Feb 1, 1905
+ ; 1905059 => Feb 28, 1905
+ ; 1905060 => Mar 1, 1905
+ ; 1905365 => Dec 31, 1905
+ ;
+ ; Leap
+ ; 1908001 => Jan 1, 1908]
+ ; 1908032 => Feb 1, 1908]
+ ; 1908059 => Feb 28, 1908]
+ ; 1908060 => Feb 29, 1908]
+ ; 1908061 => Mar 1, 1908]
+ ; 1908366 => Dec 31, 1908]
+ ;
+ ; Usage: xClmDay = clmDAYTLLL (x, yyyyddd)
+ ; -------
+
+ local dimx, ntim, klev, nlat, mlon, ndys, days, clmDay, ndy, indx, year_day, nFill
+ begin
+
+ dimx = dimsizes (x)
+
+ ntim = dimx(0)
+ klev = dimx(1)
+ nlat = dimx(2)
+ mlon = dimx(3)
+ if (isatt(yyyyddd,"calendar")) then
+ if (yyyyddd at calendar.eq."360_day" .or. yyyyddd at calendar.eq."360") then
+ ndys = 360
+ end if
+ if (yyyy at calendar.eq."365_day" .or. yyyy at calendar.eq."365" .or.
+ yyyy at calendar.eq."noleap" .or. yyyy at calendar.eq."no_leap") then
+ ndys = 365
+ end if
+ if (yyyy at calendar.eq."366_day" .or. yyyy at calendar.eq."366" .or.
+ yyyy at calendar.eq."allleap" .or. yyyy at calendar.eq."all_leap") then
+ ndys = 366
+ end if
+ if (yyyy at calendar.eq."standard" .or. yyyy at calendar.eq."gregorian") then
+ ndys = 366
+ end if
+ else
+ ndys = 366 ; default
+ end if
+
+ days = yyyyddd - (yyyyddd/1000)*1000 ; strip year info [yyyy]
+
+ clmDay= new((/ndys,klev,nlat,mlon/),typeof(x), getFillValue(x) ) ; daily climatology
+ ;
+ ; Compute averages for each sequential day of the year.
+ ; This uses dimension swapping.
+ ;
+ do ndy=0,ndys-2 ; ndy=0->364 ==> day of year 1->365
+ indx = ind( days.eq.(ndy+1) ) ; indx:indx Mar 2012, handle 1 element
+ if (.not.ismissing(indx(0))) then
+ nindx = dimsizes(indx)
+ if (nindx.eq.1) then ; force 3rd dimension
+ clmDay(ndy,:,:,:) = dim_avg_n(x(indx:indx,:,:,:), 0)
+ else
+ clmDay(ndy,:,:,:) = dim_avg_n(x(indx,:,:,:), 0)
+ end if
+ end if
+ delete(indx)
+ end do
+
+ if (.not.isatt(yyyyddd,"calendar") .or.
+ isatt(yyyyddd,"calendar") .and. yyyyddd at calendar.eq."standard" .or.
+ yyyyddd at calendar.eq."gregorian") then
+ ; nominal day 366
+ ; ave(31 Dec + 1 Jan)=leap
+ clmDay(ndys-1,:,:,:) = (clmDay(0,:,:,:) + clmDay(ndys-2,:,:,:))*0.5
+ end if
+
+ nFill = num(ismissing(clmDay))
+ if (nFill.eq.0) then
+ delete(clmDay at _FillValue)
+ end if
+
+ clmDay at long_name = "Daily Climatology"
+ if (isatt(x,"long_name")) then
+ clmDay at long_name = clmDay at long_name +": "+x at long_name
+ end if
+ if (isatt(x,"units")) then
+ clmDay at units = x at units
+ end if
+ clmDay at information = "Raw daily averages across all years"
+ clmDay at smoothing = "None"
+
+ year_day = ispan(1,ndys,1)
+ year_day at long_name = "day of year"
+ year_day at units = "ddd"
+
+ clmDay!0 = "year_day"
+ clmDay&year_day = year_day
+
+ copy_VarCoords(x(0,:,:,:), clmDay(0,:,:,:)) ; trick
+ delete(clmDay at year_day) ; clean up
+
+ if (isatt(yyyyddd,"calendar")) then
+ clmDay at calendar = yyyyddd at calendar
+ end if
+
+ return (clmDay)
+ end
+
+ ; =====================================
+ undef("smthClmDayTLL")
+ function smthClmDayTLL (clmDay[*][*][*]:numeric, nHarm:integer)
+ ;
+ local nFill, dn, z, cf, clmDaySmth
+ begin
+
+ ; The following was commented out (post 6.2.0) when people started using
+ ; this on daily SSTs which, of course, have _FillValue over land.
+
+ ;if (isatt(clmDay, "_FillValue")) then
+ ; nFill = num(ismissing(clmDay))
+ ; if (nFill.gt.0) then
+ ; print("smthClmDayTLL: No missing values allowed: ezfftf does not allow")
+ ; print("smthClmDayTLL: nFill="+nFill)
+ ; exit
+ ; end if
+ ;end if
+
+ dn = getvardims(clmDay) ; get dimension names
+ if (dn(0).ne."year_day") then
+ print("smthClmDayTLL: Warning: Usually expect year_day to be the dimension name")
+ end if
+
+ z = clmDay($dn(1)$|:,$dn(2)$|:,$dn(0)$|:); reorder make time fastest varying dimension
+ cf = ezfftf( z ) ; [2] x [nlat] x [mlon] x [nday/2+1]
+
+ ; remember NCL is 0-based
+ ; cf(:,0:nHarm-1) are retained unaltered
+ cf(:,:,:,nHarm ) = 0.5*cf(:,:,:,nHarm) ; mini-taper
+ cf(:,:,:,nHarm+1:) = 0.0 ; set all higher coef to 0.0
+
+ z = ezfftb( cf, cf at xbar) ; reconstructed series
+
+ clmDaySmth = z($dn(0)$|:,$dn(1)$|:,$dn(2)$|:)
+ clmDaySmth at information = "Smoothed daily climatological averages"
+ clmDaySmth at smoothing = "FFT: "+nHarm+" harmonics were retained."
+
+ return(clmDaySmth)
+ end
+
+ ; =====================================
+ undef("smthClmDayTLLL")
+ function smthClmDayTLLL (clmDay[*][*][*][*]:numeric, nHarm:integer)
+ ; lxf: Li 2011-05-15
+ local nFill, dn, z, cf, clmDaySmth
+ begin
+
+ ; The following was commented out (post 6.2.0) when people started using
+ ; this on daily ocean which, of course, have _FillValue over land.
+
+ if (isatt(clmDay, "_FillValue")) then
+ nFill = num(ismissing(clmDay))
+ if (nFill.gt.0) then
+ print("smthClmDayTLLL: No missing values allowed: ezfftf does not allow")
+ print("smthClmDayTLLL: nFill="+nFill)
+ exit
+ end if
+ end if
+
+ dn = getvardims(clmDay) ; get dimension names
+ if (dn(0).ne."year_day") then
+ print("smthClmDayTLLL: Warning: Usually expect year_day to be the dimension name")
+ end if
+
+ z = clmDay($dn(1)$|:,$dn(2)$|:,$dn(3)$|:,$dn(0)$|:); reorder make time fastest varying dimension
+ cf = ezfftf( z ) ; [2] x [klev] x [nlat] x [mlon] x [183]
+
+ ; remember NCL is 0-based
+ ; cf(:,0:nHarm-1) are retained unaltered
+ cf(:,:,:,:,nHarm ) = 0.5*cf(:,:,:,:,nHarm) ; mini-taper
+ cf(:,:,:,:,nHarm+1:) = 0.0 ; set all higher coef to 0.0
+
+ z = ezfftb( cf, cf at xbar) ; reconstructed series
+
+ clmDaySmth = z($dn(0)$|:,$dn(1)$|:,$dn(2)$|:,$dn(3)$|:)
+ clmDaySmth at information = "Smoothed daily climatological averages"
+ clmDaySmth at smoothing = "FFT: "+nHarm+" harmonics were retained."
+
+ return(clmDaySmth)
+ end
+
+ ; =====================================
+ undef("clmDayHr")
+ ;
+ ; Calculate daily temporal means.
+ ; This is a more general form of clmDayTLL
+ ; It works on any dimension array and allows for multiple
+ ; samples per day.
+ ;
+ ; It has not been extensively tested and it is not documented.
+ ; Consider this unsupported at this time.
+ ;
+ function clmDayHr(z:numeric, yyyymmddhh[*]:integer)
+ begin
+ yyyy = yyyymmddhh/1000000
+ mdh = yyyymmddhh%1000000
+ mm = mdh/10000
+ dh = mdh%10000
+ dd = dh/100
+ hh = dh-dd*100
+
+ if (isatt(yyyymmddhh,"calendar")) then
+ yyyy at calendar = yyyymmddhh at calendar ; needed for 'day_of_year'
+ end if
+
+ NTIM = dimsizes(yyyymmddhh) ; all time steps
+
+ dddhh = day_of_year(yyyy, mm, dd)*100 + hh
+ yyyydddhh = yyyy*100000 + dddhh
+
+ if (isatt(yyyy,"calendar")) then
+ yyyydddhh at calendar = yyyy at calendar
+ end if
+
+ dhh = hh(1)-hh(0) ; assume constant
+ nsmp = 24/dhh ; # samples/day
+
+ if (.not.isatt(yyyy,"calendar") .or.
+ isatt(yyyy,"calendar") .and. yyyy at calendar.eq."standard" .or.
+ yyyy at calendar.eq."gregorian") then
+ nday = 365
+ ndayx = 366 ; including leap year
+ end if
+ if (isatt(yyyy,"calendar")) then
+ if (yyyy at calendar.eq."none") then
+ print("clmDayHr: yyyy at calendar=none: I have no idea what to do")
+ exit
+ end if
+ if (yyyy at calendar.eq."360_day" .or. yyyy at calendar.eq."360") then
+ nday = 360
+ ndayx = 360
+ end if
+ if (yyyy at calendar.eq."365_day" .or. yyyy at calendar.eq."365" .or.
+ yyyy at calendar.eq."noleap" .or. yyyy at calendar.eq."no_leap") then
+ nday = 365
+ ndayx = 365
+ end if
+ if (yyyy at calendar.eq."366_day" .or. yyyy at calendar.eq."366" .or.
+ yyyy at calendar.eq."allleap" .or. yyyy at calendar.eq."all_leap") then
+ nday = 366
+ ndayx = 366
+ end if
+ end if
+
+ ntimx = nsmp*ndayx
+
+ dimz = dimsizes(z)
+ rankz = dimsizes(dimz)
+
+ ;---------------------------------------------------------------
+ ; Create array to hold climatology and counts.
+ ;---------------------------------------------------------------
+ if (typeof(z).eq."double") then
+ zType = "double"
+ zFill = 1d20
+ else
+ zType = "float"
+ zFill = 1e20
+ end if
+
+ if (rankz.eq.4) then
+ klev = dimz(1)
+ nlat = dimz(2)
+ mlon = dimz(3)
+ zClm = new ( (/ntimx,klev,nlat,mlon/), zType, zFill)
+ end if
+ if (rankz.eq.3) then
+ nlat = dimz(1)
+ mlon = dimz(2)
+ zClm = new ( (/ntimx,nlat,mlon/), zType, zFill)
+ end if
+ if (rankz.eq.2) then
+ npts = dimz(1)
+ zClm = new ( (/ntimx,npts/), zType, zFill)
+ end if
+ if (rankz.eq.1) then
+ zClm = new ( (/ntimx/), zType, zFill)
+ end if
+
+ yrStrt = yyyy(0)
+ yrLast = yyyy(NTIM-1)
+ nyrs = yrLast-yrStrt+1
+ ;---------------------------------------------------------------
+ ; Climatologies: Loop over each climate day and hour
+ ;---------------------------------------------------------------
+ nt = -1
+ do ndy=1,nday
+ do nhr=hh(0),hh(nsmp-1),dhh
+ nt = nt+1
+ indx = ind(dddhh.eq.(ndy*100+nhr))
+
+ if (rankz.eq.4) then
+ zClm(nt:nt,:,:,:) = dim_avg_n(z(indx,:,:,:), 0)
+ end if
+ if (rankz.eq.3) then
+ zClm(nt:nt,:,:) = dim_avg_n(z(indx,:,:), 0)
+ end if
+ if (rankz.eq.2) then
+ zClm(nt:nt,:) = dim_avg_n(z(indx,:), 0)
+ end if
+ if (rankz.eq.1) then
+ zClm(nt:nt) = dim_avg_n(z(indx), 0)
+ end if
+
+ delete(indx)
+ end do
+ end do
+
+ ;---------------------------------------------------------------
+ ; Fill in climatological day 366 with the average
+ ; of Jan 1 (day 1) and 31 Dec (day 365)
+ ; greorian, standard or no calendar attribute
+ ;---------------------------------------------------------------
+ if (nday.eq.365 .and. ndayx.eq.366) then
+ do ns=0,nsmp-1
+
+ if (rankz.eq.4) then
+ zClm(ntim+ns,:,:,:) = 0.5*(zClm(ns,:,:,:)+zClm(ntim-(nsmp-ns),:,:,:))
+ end if
+ if (rankz.eq.3) then
+ zClm(ntim+ns,:,:) = 0.5*(zClm(ns,:,:)+zClm(ntim-(nsmp-ns),:,:))
+ end if
+ if (rankz.eq.2) then
+ zClm(ntim+ns,:) = 0.5*(zClm(ns,:)+zClm(ntim-(nsmp-ns),:))
+ end if
+ if (rankz.eq.1) then
+ zClm(ntim+ns) = 0.5*(zClm(ns)+zClm(ntim-(nsmp-ns)))
+ end if
+
+ end do
+ end if
+
+ ;---------------------------------------------------------------
+ ; Meta data
+ ;---------------------------------------------------------------
+ dt = 1.0/nsmp
+ day = fspan(1.00, ndayx+1-dt, ntimx)
+ day at long_name = "day and fraction of day"
+ day!0 = "day"
+ day&day = day
+
+ zClm!0 = "day"
+ zClm&day = day
+
+ if (rankz.eq.4) then
+ copy_VarCoords(z(0,:,:,:), zClm(0,:,:,:))
+ end if
+ if (rankz.eq.3) then
+ copy_VarCoords(z(0,:,:), zClm(0,:,:))
+ end if
+ if (rankz.eq.2) then
+ copy_VarCoords(z(0,:), zClm(0,:))
+ end if
+
+ if (isatt(z,"long_name")) then
+ zClm at long_name = z at long_name
+ end if
+ if (isatt(z,"units")) then
+ zClm at units = z at units
+ end if
+
+ return(zClm)
+ end
+
+
+ ; =====================================
+ undef("calcDayAnomTLL")
+ function calcDayAnomTLL (x[*][*][*]:numeric, yyyyddd:integer, clmDay[*][*][*]:numeric)
+
+ ; Remove the Annual Cycle from daily data.
+ ; On return x will consist of deviations from each day's long term mean.
+ ;
+ ; x(time,lat,lon) <==== input dimension order
+ ; x!0 = "time" <==== time is in days
+ ; x!1 = "lat"
+ ; x!2 = "lon"
+ ;
+ ;
+ ; non-Leap yyyyddd
+ ; 1905001 => Jan 1, 1905
+ ; 1905032 => Feb 1, 1905
+ ; 1905059 => Feb 28, 1905
+ ; 1905060 => Mar 1, 1905
+ ; 1905365 => Dec 31, 1905
+ ;
+ ; Leap
+ ; 1908001 => Jan 1, 1908]
+ ; 1908032 => Feb 1, 1908]
+ ; 1908059 => Feb 28, 1908]
+ ; 1908060 => Feb 29, 1908]
+ ; 1908061 => Mar 1, 1908]
+ ; 1908366 => Dec 31, 1908]
+
+ ; Usage: xAnom = calcDayAnomTLL (x, yyyyddd, clmDay)
+
+ local dimx, ntim, nlat, mlon, days, xAnom, nt
+ begin
+ if (isatt(yyyyddd,"calendar") .and. isatt(clmDay,"calendar")) then
+ if (yyyyddd at calendar .ne. clmDay at calendar) then
+ print("calcDayAnomTLL: calendar mismatch")
+ print(" yyyyddd at calendar = "+yyyyddd at calendar)
+ print(" clmday at calendar = "+ clmDay at calendar)
+ exit
+ end if
+ end if
+
+ dimx = dimsizes (x)
+
+ ntim = dimx(0)
+ nlat = dimx(1)
+ mlon = dimx(2)
+
+ days = yyyyddd - (yyyyddd/1000)*1000 ; strip year info [yyyy]
+
+ ; loop on every day and compute difference.
+
+ xAnom = (/ x /) ; create xAnom
+ do nt=0,ntim-1
+ xAnom(nt,:,:) = x(nt,:,:) - clmDay(days(nt)-1,:,:) ; -1 for 0-based subscript
+ end do
+
+ if (isatt(x,"long_name")) then
+ xAnom at long_name = "Anomalies: "+x at long_name
+ else
+ xAnom at long_name = "Anomalies from Daily Climatology"
+ end if
+ if (isatt(x,"units")) then
+ xAnom at units = x at units
+ end if
+ if (isatt(yyyyddd,"calendar")) then
+ xAnom at calendar = yyyyddd at calendar
+ end if
+
+ copy_VarCoords(x, xAnom)
+
+ return(xAnom)
+ end
+
+ ; *******************************************************************
+ undef("calcDayAnomTLLL")
+ function calcDayAnomTLLL (x[*][*][*][*]:numeric, yyyyddd:integer, clmDay[*][*][*][*]:numeric)
+
+ ; Remove the Annual Cycle from daily data.
+ ; On return x will consist of deviations from each day's long term mean.
+ ;
+ ; x(time,lev,lat,lon) <==== input dimension order
+ ; x!0 = "time" <==== time is in days
+ ; x!1 = "lev"
+ ; x!2 = "lat"
+ ; x!3 = "lon"
+ ;
+ ;
+ ; non-Leap yyyyddd
+ ; 1905001 => Jan 1, 1905
+ ; 1905032 => Feb 1, 1905
+ ; 1905059 => Feb 28, 1905
+ ; 1905060 => Mar 1, 1905
+ ; 1905365 => Dec 31, 1905
+ ;
+ ; Leap
+ ; 1908001 => Jan 1, 1908]
+ ; 1908032 => Feb 1, 1908]
+ ; 1908059 => Feb 28, 1908]
+ ; 1908060 => Feb 29, 1908]
+ ; 1908061 => Mar 1, 1908]
+ ; 1908366 => Dec 31, 1908]
+
+ ; Usage: xAnom = calcDayAnomTLLL (x, yyyyddd, clmDay)
+
+ local dimx, ntim, klev,nlat, mlon, ndys, days, xAnom, nt
+ begin
+ if (isatt(yyyyddd,"calendar") .and. isatt(clmDay,"calendar")) then
+ if (yyyyddd at calendar .ne. clmDay at calendar) then
+ print("calcDayAnomTLL: calendar mismatch")
+ print(" yyyyddd at calendar = "+yyyyddd at calendar)
+ print(" clmday at calendar = "+ clmDay at calendar)
+ exit
+ end if
+ end if
+
+ dimx = dimsizes (x)
+
+ ntim = dimx(0)
+ klev = dimx(1)
+ nlat = dimx(2)
+ mlon = dimx(3)
+
+ days = yyyyddd - (yyyyddd/1000)*1000 ; strip year info [yyyy]
+
+ ; loop on every day and compute difference.
+
+ xAnom = (/ x /) ; create xAnom
+ do nt=0,ntim-1
+ xAnom(nt,:,:,:) = x(nt,:,:,:) - clmDay(days(nt)-1,:,:,:) ; -1 for 0-based subscript
+ end do
+
+ if (isatt(x,"long_name")) then
+ xAnom at long_name = "Anomalies: "+x at long_name
+ else
+ xAnom at long_name = "Anomalies from Daily Climatology"
+ end if
+ if (isatt(x,"units")) then
+ xAnom at units = x at units
+ end if
+
+ if (isatt(yyyyddd,"calendar")) then
+ xAnom at calendar = yyyyddd at calendar
+ end if
+
+ copy_VarCoords(x, xAnom)
+ return(xAnom)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; create different view of variable
+ ; v6.2.0: calendar attribute recognized
+
+ undef("yyyymmdd_to_yyyyddd")
+ function yyyymmdd_to_yyyyddd (yyyymmdd[*]:integer)
+ local ntim, yyyy, mmdd, mm, dd, yyyyddd
+ begin
+ ntim = dimsizes(yyyymmdd)
+
+ ;;if (isatt(yyyymmdd,"calendar") .and. yyyymmdd at calendar.eq."proleptic_gregorian") then
+ ;; print("yyyymmdd_to_yyyyddd: proleptic_gregorian calendar not supported")
+ ;; yyyyddd = new(ntim, "integer", -9999)
+ ;; yyyyddd at long_name = "yyyymmdd_to_yyyyddd: proleptic_gregorian calendar not supported"
+ ;; return(yyyyddd)
+ ;;end if
+
+ yyyy = yyyymmdd/10000
+ mmdd = yyyymmdd - (yyyy*10000)
+ mm = mmdd/100
+ dd = mmdd - (mm*100)
+
+ if (isatt(yyyymmdd,"calendar")) then ; needed for day_of_year
+ yyyy at calendar = yyyymmdd at calendar
+ end if
+
+ yyyyddd = yyyy*1000 +day_of_year(yyyy, mm, dd)
+ copy_VarMeta(yyyymmdd, yyyyddd)
+ yyyyddd at long_name = "yyyy and day_of_year"
+ yyyyddd at units = "yyyyddd"
+
+ return(yyyyddd)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; v6.2.0: calendar attribute recognized
+
+ undef("yyyyddd_to_yyyymmdd")
+ function yyyyddd_to_yyyymmdd ( yyyyddd[*]:integer )
+ ; convert yyyyddd (year|day_of_year) to yyyymmdd
+
+ local nTime, yyyy, ddd, days, yyyymmdd, nt, iyr
+ , ndyr, skip, nmo, ndy, ndymo, foo
+ begin
+ nTime = dimsizes( yyyyddd )
+
+ ;;if (isatt(yyyyddd,"calendar") .and. yyyyddd at calendar.eq."proleptic_gregorian") then
+ ;; print("yyyyddd_to_yyyymmdd: proleptic_gregorian calendar not supported")
+ ;; yyyymmdd = new(nTime, "integer", -9999)
+ ;; yyyymmdd at long_name = "yyyyddd_to_yyyymmdd: proleptic_gregorian calendar not supported"
+ ;; return(yyyymmdd)
+ ;;end if
+
+ yyyy = yyyyddd/1000
+ ddd = yyyyddd - yyyy*1000
+ ; non leap and leap [greorian, standard, or no 'calendar' attribute
+ days = (/ (/31,28,31,30,31,30,31,31,30,31,30,31/)
+ , (/31,29,31,30,31,30,31,31,30,31,30,31/) /)
+
+ if (isatt(yyyyddd,"calendar")) then ; retrofit to existing code
+ yyyy at calendar = yyyyddd at calendar ; needed for day_of_year
+
+ if (yyyyddd at calendar.eq."365_day" .or. yyyyddd at calendar.eq."365" .or.
+ yyyyddd at calendar.eq."noleap" .or. yyyyddd at calendar.eq."no_leap") then
+ days(1,:) = days(0,:) ; make all non-leap year
+ end if
+ if (yyyyddd at calendar.eq."366_day" .or. yyyyddd at calendar.eq."366" .or.
+ yyyyddd at calendar.eq."allleap" .or. yyyyddd at calendar.eq."all_leap") then
+ days(0,:) = days(1,:) ; make all leap yeary
+ end if
+ if (yyyyddd at calendar.eq."360_day" .or. yyyyddd at calendar.eq."360") then
+ days = 30 ; make all 30
+ end if
+ end if
+
+ yyyymmdd = new (nTime, integer)
+
+ do nt=0,nTime-1
+ iyr = 0
+ if (isleapyear(yyyy(nt))) then ; only has effect for standard, gregorian
+ iyr = 1
+ end if
+
+ ndyr = 0 ; day of year
+ skip = False ; use to bounce out of loops
+
+ do nmo=1,12
+ do ndymo=1,days(iyr,(nmo-1))
+ ndyr = ndyr+1 ; increment day of year
+ if (ndyr.eq.ddd(nt)) then
+ yyyymmdd(nt) = yyyy(nt)*10000 + nmo*100 + ndymo
+ skip = True
+ break ; bounce out of ndy loop
+ end if
+ end do
+ foo = 1
+ if (skip) then
+ break ; bounce out of nmo loop
+ end if
+ end do
+
+ end do
+
+ if (.not.any(ismissing(yyyymmdd))) then
+ delete(yyyymmdd at _FillValue)
+ end if
+
+ yyyymmdd!0 = "time"
+ yyyymmdd at long_name = "current date"
+ yyyymmdd at units = "YYYYMMDD"
+ yyyymmdd at info = "converted from YYYYDDD"
+
+ if (isatt(yyyyddd,"calendar")) then
+ yyyymmdd at calendar = yyyyddd at calendar
+ end if
+
+ return(yyyymmdd)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "linint1" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef("linint1_Wrap")
+ function linint1_Wrap (xi:numeric, fi:numeric, wrapX:logical
+ ,xo[*]:numeric, Opt)
+
+ ; wrapper for NCL function "linint1" that copies attributes and coordinate vars.
+ local fo, dimfi, nDim, n, nD
+ begin
+
+ fo = linint1 (xi,fi, wrapX, xo, Opt) ; perform interpolation
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fo)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ copy_VarCoords_1 (fi, fo) ; copy coord variables
+ ; except for rightmost
+
+ nD = nDim-1 ; last dimension
+ ; create a new coord for
+ if (isdimnamed(xo,0)) then
+ fo!nD = xo!0 ; if present, use xo name
+ else
+ if (isdimnamed(fi,nD)) then
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ else ; but change case [contributed]
+ fo!nD = "X" ; default dimension name
+ end if
+ end if
+ ; assign coordinates
+ fo&$fo!nD$ = xo ; rightmost dim
+
+ return (fo)
+ end
+
+ ; **********************************************************************
+ ; M. Haley
+ ; wrapper for NCL procedure "linint1_n" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef("linint1_n_Wrap")
+ function linint1_n_Wrap (xi:numeric, fi:numeric, wrapX:logical
+ ,xo[*]:numeric, Opt, dim[1]:integer)
+
+ ; wrapper for NCL function "linint1_n" that copies attributes and coordinate vars.
+ local fo, dimfi, nDim, n, nD
+ begin
+
+ fo = linint1_n (xi,fi, wrapX, xo, Opt, dim) ; perform interpolation
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fo)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ copy_VarCoords_not_n (fi, fo, dim) ; copy coord variables
+ ; except for dim-th
+
+ ; create a new coord for
+ nD = dim ; "dim"-th dimension
+ if (isdimnamed(xo,0)) then
+ fo!nD = xo!0 ; if present, use xo name
+ else
+ if (isdimnamed(fi,nD)) then
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ else ; but change case [contributed]
+ fo!nD = "X" ; default dimension name
+ end if
+ end if
+ ; assign coordinates
+ fo&$fo!nD$ = xo ; "dim"-th dimension
+
+ return (fo)
+ end
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "linint2" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef ("linint2_Wrap")
+ function linint2_Wrap (xi[*]:numeric,yi[*]:numeric, fi:numeric, wrapX:logical
+ ,xo[*]:numeric,yo[*]:numeric, Opt)
+
+ ; wrapper for NCL function "linint2" that copies attributes and coordinate vars
+
+ local fo, dimfi, nDim, nD
+ begin
+ fo = linint2 (xi,yi,fi, wrapX, xo,yo, Opt) ; perform interpolation
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (nDim.gt.2) then
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+ end if
+
+ fo!(nDim-2) = "Y" ; default named dimensions
+ fo!(nDim-1) = "X"
+ ; override if possible
+ if (isdimnamed(xo,0) .and. isdimnamed(yo,0) ) then
+ fo!(nDim-2) = yo!0 ; if present, use xo name
+ fo!(nDim-1) = xo!0 ; if present, use xo name
+ else
+ do nD=nDim-2,nDim-1 ; two rightmost dimensions
+ if (.not.ismissing(fi!nD)) then
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ end if ; but change case
+ end do
+ end if
+
+ fo&$fo!(nDim-2)$ = yo ; create coordinate var
+ fo&$fo!(nDim-1)$ = xo ; two rightmost dimensions
+
+ return (fo)
+ end
+
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "linint2_points" that copies attributes+coordinates
+ ; vars. It creates a "pts" coord variable and creates two 1D
+ ; attributes that indicate the lat/lon associated with each point.
+ undef ("linint2_points_Wrap")
+ function linint2_points_Wrap
+ (xi[*]:numeric,yi[*]:numeric, fi:numeric, wrapX:logical
+ ,xo[*]:numeric,yo[*]:numeric, Opt)
+
+ ; wrapper for NCL function "linint2_points" that copies attributes and coordinate vars
+ local fo, dimfi, nDim, pts
+ begin
+ fo = linint2_points (xi,yi,fi, wrapX, xo,yo, Opt) ; perform interpolation
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (nDim.gt.2) then
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+ end if
+ ; except for 2 rightmost
+
+ nDim = dimsizes(dimsizes(fo)) ; # output dimensions
+
+ pts = ispan(0,dimsizes(xo)-1,1) ; linear
+ pts at long_name = "Points"
+
+ fo!(nDim-1) = "pts" ; default named dimensions
+ fo&pts = pts
+ fo at xcoord = xo ; x/longitude points
+ fo at ycoord = yo ; y/latitude points
+
+ return (fo)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "rcm2rgrid" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef ("rcm2rgrid_Wrap")
+ function rcm2rgrid_Wrap (yi[*][*]:numeric,xi[*][*]:numeric, fi:numeric
+ ,yo[*]:numeric,xo[*]:numeric, Opt)
+
+ ; wrapper for NCL function "rcm2rgrid" that copies attributes and coordinate vars
+
+ local fo, dimfi, nDim, nD
+ begin
+ fo = rcm2rgrid (yi,xi,fi, yo,xo, Opt) ; perform interpolation
+
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (isatt(fo,"lat2d")) then
+ delete(fo at lat2d)
+ end if
+ if (isatt(fo,"lon2d")) then
+ delete(fo at lon2d)
+ end if
+
+ if (nDim.gt.2) then
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+ end if
+
+ fo!(nDim-2) = "Y" ; default named dimensions
+ fo!(nDim-1) = "X"
+ ; override if possible
+ if (isdimnamed(xo,0) .and. isdimnamed(yo,0) ) then
+ fo!(nDim-1) = xo!0 ; if present, use xo name
+ fo!(nDim-2) = yo!0 ; if present, use xo name
+ else
+ do nD=nDim-2,nDim-1 ; two rightmost dimensions
+ if (.not.ismissing(fi!nD)) then
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ end if ; but change case
+ end do
+ end if
+
+ fo&$fo!(nDim-1)$ = xo ; create coordinate var
+ fo&$fo!(nDim-2)$ = yo ; two rightmost dimensions
+
+ fo at ncl = "rcm2rgrid used for interpolation"
+
+ return (fo)
+ end
+ ;-------------------------
+ undef ("rcm2points_Wrap")
+ function rcm2points_Wrap
+ (yi[*][*]:numeric,xi[*][*]:numeric, fi:numeric
+ ,yo[*]:numeric,xo[*]:numeric, Opt)
+
+ local fo, dimfi, nDim, pts
+ begin
+ fo = rcm2points (yi,xi,fi, yo,xo, Opt) ; perform interpolation
+
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (nDim.gt.2) then
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+ end if ; except for 2 rightmost
+
+ nDim = dimsizes(dimsizes(fo)) ; # output dimensions
+
+ pts = ispan(0,dimsizes(xo)-1,1) ; linear
+ pts at long_name = "Points"
+
+ fo!(nDim-1) = "pts" ; default named dimensions
+ fo&pts = pts
+ fo at xcoord = xo ; x/longitude points
+ fo at ycoord = yo ; y/latitude points
+ fo at ncl = "rcm2points used for interpolation"
+
+ return (fo)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "rgrid2rcm" that copies attributes and coordinate
+ ; vars.
+
+ undef ("rgrid2rcm_Wrap")
+ function rgrid2rcm_Wrap (yi[*]:numeric,xi[*]:numeric, fi:numeric
+ ,yo[*][*]:numeric,xo[*][*]:numeric, Opt)
+
+ ; wrapper for NCL function "rgrid2rcm" that copies attributes and coordinate vars
+
+ local fo, dimfi, nDim, nD
+ begin
+ fo = rgrid2rcm (yi,xi,fi, yo,xo, Opt) ; perform interpolation
+
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (nDim.gt.2) then
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+ end if ; except for 2 rightmost
+
+ fo!(nDim-2) = "Y" ; default named dimensions
+ fo!(nDim-1) = "X"
+ ; override if possible
+ if (isdimnamed(xo,0) ) then
+ fo!(nDim-2) = xo!0 ; if present, use xo name
+ end if
+ if (isdimnamed(xo,1) ) then
+ fo!(nDim-1) = xo!1 ; if present, use xo name
+ end if
+ fo at ncl = "rgrid2rcm used for interpolation"
+ ;fo at coordinates = fo!(nDim-2) +" "+fo!(nDim-1)
+
+ return (fo)
+ end
+
+ ;****************************************************
+ ; D. Shea
+ ; Take a monthly climatology and make a daily climatology
+ ; Current for gregorian / standard year.
+ ;
+ ; Supported: leftmost dimension must be 12
+ ; x(12), x(12,N), x(12,N1,N2), x(12,N1,N2,N3)
+ ; x must have named dimensions on entry
+ ; opt - not used set to zero [0]
+ ;
+ undef("clmMon2clmDay")
+ function clmMon2clmDay( x:numeric, retOrder:integer, opt:integer )
+ local dNames, dimx, rank, X, midMon, day
+ begin
+ if (.not.(retOrder.eq.0 .or. retOrder.eq.1)) then
+ print("clmMon2clmDay: retOrder must be 0 or 1, retOrder=" +retOrder)
+ exit
+ end if
+
+ dNames = getvardims( x )
+ if (any(ismissing(dNames))) then
+ print("clmMon2clmDay: named dimensions required:" +dNames)
+ exit
+ end if
+
+ dimx = dimsizes(x)
+ if (dimx(0).ne.12) then
+ print("clmMon2clmDay: leftmost dimension must be size=12: SIZE="+dimx(0))
+ exit
+ end if
+
+ rank = dimsizes( dimx )
+ if (rank.gt.4) then
+ print("clmMon2clmDay: currently max of 4 dimension supported: rank="+rank)
+ exit
+ end if
+
+ ;if (isatt(x,"_FillValue")) then
+ ; nFill = num(ismissing(x))
+ ; if (nFill.gt.0) then
+ ; print("clmMon2clmDay: input is assumed to have no missing values, nFill="+nFill)
+ ; exit
+ ; end if
+ ;end if
+ ; transfer to work arrsy,if necessary, reorder array
+ if (rank.eq.2) then
+ X = x
+ end if
+ if (rank.eq.2) then
+ X = x($dNames(1)$|:, $dNames(0)$|:)
+ end if
+ if (rank.eq.3)
+ X = x($dNames(1)$|:, $dNames(2)$|:, $dNames(0)$|:)
+ end if
+ if (rank.eq.4)
+ X = x($dNames(1)$|:, $dNames(2)$|:, $dNames(3)$|:, $dNames(0)$|:)
+ end if
+ ; mid day of each month
+ if (isatt(opt,"midmon")) then
+ if (dimsizes(opt at midMon).eq.12) then
+ midMon = opt at midMon
+ else
+ print("clmMon2clmDay: midMon required to be size 12: size="+dimsizes(opt at midMon))
+ exit
+ end if
+ else
+ midMon = (/ 15.5, 45 , 74.5,105 ,135.5,166
+ ,196.5,227.5,258 ,288.5,319 ,349.5/)
+ end if
+ midMon at long_name = "middle of month"
+
+ day = ispan(0,364,1) ; use 0 => 364 for interpolation
+ day!0 = "day"
+
+ Z = linint1_Wrap (midMon, X, True, day, 0)
+ Z at info = "NCL: clmMon2clmDay"
+
+ day = ispan(1,365,1) ; use 1 => 365 for coord variable
+ day at long_name = "day of year: no leap"
+ day at units = "1=Jan 1, 32=Feb 1, ..., 365-Dec 31"
+ Z!(rank-1) = "day"
+ Z&day = day
+
+ if (retOrder.eq.1) then
+ return( Z )
+ end if
+
+ if (retOrder.eq.0) then
+ if (rank.eq.1) then
+ return(Z)
+ end if
+ if (rank.eq.2) then
+ return( Z(day
+ end if
+ if (rank.eq.3) then
+ return( Z(day
+ end if
+ if (rank.eq.4) then
+ return( Z(day
+ end if
+ end if
+ end
+
+
+ ;********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "cssgrid" that copies attributes
+ ; It adds the longitude and latitude coordinates.
+
+ undef("cssgrid_Wrap")
+ function cssgrid_Wrap (lati[*]:numeric,loni[*]:numeric, fi:numeric
+ ,lato[*]:numeric,lono[*]:numeric)
+ local fo
+ begin
+ fo = cssgrid (lati,loni, fi, lato, lono) ; perform interpolation
+ fo!0 = "lat"
+ fo!1 = "lon"
+
+ fo&lat = lato
+ fo&lon = lono
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ fo at NCL_function = "cssgrid_Wrap"
+
+ if (isatt(fo,"time")) then
+ delete (fo at time) ; special case since this does not work
+ end if ; on arrays
+
+ return (fo)
+ end
+
+ ;********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "g2gsh" that copies attributes and coordinate vars.
+ ; It adds the longitude and gaussian latitude coordinates.
+
+ undef("g2gsh_Wrap")
+ function g2gsh_Wrap (x:numeric, newDims, twave:numeric)
+ local nlat, mlon, xNew, lat, lon, nDim, gwt
+ begin
+ nlat = newDims(0) ; specify output grid
+ mlon = newDims(1)
+ if (typeof(x).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ xNew = g2gsh(x, (/nlat,mlon/), twave) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (x, xNew) ; copy variable attributes
+ copy_VarCoords_2 (x, xNew) ; copy coord variables except lat and lon
+
+ lat = latGau (nlat, "lat", "latitude" , "degrees_north")
+ gwt = latGauWgt (nlat, "lat", "gaussian weights", "")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (x, lon) ; [lon(0)=-180] init location
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat ; add new coord var
+ xNew&lon = lon
+
+ if (isatt(xNew,"gwt")) then
+ delete(xNew at gwt)
+ end if
+ xNew at gwt = gwt ; attach as attribute
+
+ return (xNew)
+ end
+
+ ;******************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "g2fsh" that copies attributes and coordinate vars.
+ ; It adds the longitude and gaussian latitude coordinates.
+
+ undef("g2fsh_Wrap")
+ function g2fsh_Wrap (x:numeric, newDims)
+ local nlat, mlon, xNew, lat, lon, nDim
+ begin
+ nlat = newDims(0) ; specify output grid
+ mlon = newDims(1)
+ if (typeof(x).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ xNew = g2fsh(x, (/nlat,mlon/) ) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (x, xNew) ; copy variable attributes
+ copy_VarCoords_2 (x, xNew) ; copy coord variables except lat and lon
+
+ lat = latGlobeF (nlat, "lat", "latitude" , "degrees_north")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (x, lon) ; [lon(0)=-180] init location
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat ; add new coord var
+ xNew&lon = lon
+
+ return (xNew)
+ end
+
+
+ ; **************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "f2gsh" that copies attributes and coordinate vars.
+ ; It adds the longitude and gaussian latitude coordinates.
+
+ undef("f2gsh_Wrap")
+ function f2gsh_Wrap (x:numeric, newDims, twave:numeric)
+ local nlat, mlon, xNew, lat, lon, nDim
+ begin
+ nlat = newDims(0) ; specify output grid
+ mlon = newDims(1)
+ if (typeof(x).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ xNew = f2gsh(x, newDims, twave) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (x, xNew) ; copy variable attributes
+ copy_VarCoords_2 (x, xNew) ; copy coord variables except lat and lon
+
+ lat = latGau (nlat, "lat", "latitude" , "degrees_north")
+ gwt = latGauWgt (nlat, "lat", "gaussian weights", "")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (x, lon) ; [lon(0)=-180] init location
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat ; add new coord var
+ xNew&lon = lon
+
+ if (isatt(xNew,"gwt")) then
+ delete(xNew at gwt)
+ end if
+ xNew at gwt = gwt ; attach gaussian weights
+
+ return (xNew)
+ end
+
+
+
+ ;********************************************************
+ ; D. Shea
+ ; wrapper for NCL function "f2fsh" that copies attributes and coordinate vars.
+ ; It adds the longitude and latitude coordinates.
+
+ undef("f2fsh_Wrap")
+ function f2fsh_Wrap (x:numeric, newDims)
+ local nlat, mlon, xNew, lat, lon, nDim
+ begin
+ nlat = newDims(0) ; specify output grid
+ mlon = newDims(1)
+ if (typeof(x).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ xNew = f2fsh(x, newDims ) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (x, xNew) ; copy variable attributes
+ copy_VarCoords_2 (x, xNew) ; copy coord variables except lat and lon
+
+ lat = latGlobeF (nlat, "lat", "latitude" , "degrees_north")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (x, lon) ; [lon(0)=-180] init location
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat ; add new coord var
+ xNew&lon = lon
+
+ return (xNew)
+ end
+
+
+ ;****************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "f2fosh" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef("f2fosh_Wrap")
+ function f2fosh_Wrap (x:numeric)
+ local nlat, mlon, xNew, lat, lon, dimx, nDim, nlat1
+ begin
+ xNew = f2fosh(x) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (x, xNew) ; copy variable attributes
+ copy_VarCoords_2 (x, xNew) ; copy coord variables
+ ; except lat and lon
+ dimx = dimsizes (x)
+ nDim = dimsizes (dimx) ; rank of matrix
+ nlat = dimx(nDim-2) ; dim of INPUT grid
+ mlon = dimx(nDim-1)
+ nlat1= nlat-1 ; fo has one less lat
+
+ if (typeof(x).eq."double") then
+ nlat at double = True
+ nlat1 at double= True
+ mlon at double = True
+ end if
+
+ lat = latGlobeFo (nlat1, "lat", "latitude", "degrees_north")
+ lon = lonGlobeFo (mlon , "lon", "longitude","degrees_east")
+ ; possibly make near Date Line
+ lonGM2DateLine (x, lon) ; init location
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat ; add new coord var
+ xNew&lon = lon
+
+ return (xNew)
+ end
+
+ ;****************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "fo2fsh" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef("fo2fsh_Wrap")
+ function fo2fsh_Wrap (x:numeric)
+ local nlat, mlon, xNew, lat, lon, dimx, nDim, nlat1
+ begin
+ xNew = fo2fsh(x) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (x, xNew) ; copy variable attributes
+ copy_VarCoords_2 (x, xNew) ; copy coord variables
+ ; except lat and lon
+ dimx = dimsizes (x)
+ nDim = dimsizes (dimx) ; rank of matrix
+ nlat = dimx(nDim-2) ; dim of INPUT grid
+ mlon = dimx(nDim-1)
+ nlat1= nlat+1 ; f has one additional lat
+
+ if (typeof(x).eq."double") then
+ nlat at double = True
+ nlat1 at double= True
+ mlon at double = True
+ end if
+
+ lat = latGlobeF (nlat1, "lat", "latitude", "degrees_north")
+ lon = lonGlobeF (mlon , "lon", "longitude","degrees_east")
+ ; possibly make near Date Line
+ lonGM2DateLine (x, lon) ; init location
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat ; add new coord var
+ xNew&lon = lon
+
+ return (xNew)
+ end
+
+
+ ; **********************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "g2gshv" that copies attributes and coordinate
+ ; vars. It adds the longitude and gaussian latitude coordinates.
+
+ undef("g2gshv_Wrap")
+ procedure g2gshv_Wrap (u:numeric, v:numeric, uNew:numeric, vNew:numeric,
+ twave:numeric)
+ local dim_uNew, nDim, nlat, mlon, lat, lon, gwt
+ begin
+ g2gshv (u, v, uNew, vNew,twave)
+ ; contributed functions
+ copy_VarAtts (u, uNew) ; copy variable attributes
+ copy_VarCoords_2 (u, uNew) ; copy coord variables
+ ; except lat and lon
+ copy_VarAtts (v, vNew) ; copy variable attributes
+ copy_VarCoords_2 (v, vNew) ; copy coord variables
+
+ ; except lat and lon
+ dim_uNew= dimsizes(uNew) ; dim sizes of each dimension
+ nDim = dimsizes(dim_uNew) ; number of dimensions [rank]
+ nlat = dim_uNew(nDim-2) ; number of latitudes
+ mlon = dim_uNew(nDim-1) ; number of longitudes
+ if (typeof(u).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ lat = latGau (nlat, "lat", "latitude" , "degrees_north")
+ gwt = latGauWgt (nlat, "lat", "gaussian weights", "")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (u, lon) ; [lon(0)=-180] init location
+
+ uNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ uNew!(nDim-1) = "lon" ; rightmost dimension
+ uNew&lat = lat ; add new coord var
+ uNew&lon = lon
+
+ vNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ vNew!(nDim-1) = "lon" ; rightmost dimension
+ vNew&lat = lat ; add new coord var
+ vNew&lon = lon
+
+ if (isatt(uNew,"gwt")) then
+ delete(uNew at gwt)
+ end if
+ uNew at gwt = gwt ; attach gaussian weights
+
+ if (isatt(vNew,"gwt")) then
+ delete(vNew at gwt)
+ end if
+ vNew at gwt = gwt ; attach gaussian weights
+ end
+
+ ; ********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "g2fshv" that copies attributes and coordinate
+ ; vars. It adds the longitude and gaussian latitude coordinates.
+
+ undef("g2fshv_Wrap")
+ procedure g2fshv_Wrap (u:numeric, v:numeric, uNew:numeric, vNew:numeric)
+ local dim_uNew, nDim, nlat, mlon, lon, lat
+ begin
+ g2fshv (u, v, uNew, vNew)
+ ; contributed functions
+ copy_VarAtts (u, uNew) ; copy variable attributes
+ copy_VarCoords_2 (u, uNew) ; copy coord variables
+ ; except lat and lon
+ copy_VarAtts (v, vNew) ; copy variable attributes
+ copy_VarCoords_2 (v, vNew) ; copy coord variables
+ ; except lat and lon
+ dim_uNew= dimsizes(uNew) ; dim sizes of each dimension
+ nDim = dimsizes(dim_uNew) ; number of dimensions [rank]
+ nlat = dim_uNew(nDim-2) ; number of latitudes
+ mlon = dim_uNew(nDim-1) ; number of longitudes
+
+ if (typeof(u).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ lat = latGlobeF (nlat, "lat", "latitude" , "degrees_north")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (u, lon) ; [lon(0)=-180] init location
+
+ uNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ uNew!(nDim-1) = "lon" ; rightmost dimension
+ uNew&lat = lat ; add new coord var
+ uNew&lon = lon
+
+ vNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ vNew!(nDim-1) = "lon" ; rightmost dimension
+ vNew&lat = lat ; add new coord var
+ vNew&lon = lon
+ end
+
+
+ ; ***********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "f2gshv" that copies attributes and coordinate
+ ; vars. It adds the longitude and gaussian latitude coordinates.
+
+ undef("f2gshv_Wrap")
+ procedure f2gshv_Wrap (u:numeric, v:numeric, uNew:numeric, vNew:numeric,
+ twave:numeric)
+ local dim_uNew, nDim, nlat, mlon, lon, lat, gwt
+ begin
+ f2gshv (u, v, uNew, vNew, twave)
+ ; contributed functions
+ copy_VarAtts (u, uNew) ; copy variable attributes
+ copy_VarCoords_2 (u, uNew) ; copy coord variables
+ ; except lat and lon
+ copy_VarAtts (v, vNew) ; copy variable attributes
+ copy_VarCoords_2 (v, vNew) ; copy coord variables
+ ; except lat and lon
+ dim_uNew= dimsizes(uNew) ; dim sizes of each dimension
+ nDim = dimsizes(dim_uNew) ; number of dimensions [rank]
+ nlat = dim_uNew(nDim-2) ; number of latitudes
+ mlon = dim_uNew(nDim-1) ; number of longitudes
+
+ if (typeof(u).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ lat = latGau (nlat, "lat", "latitude" , "degrees_north")
+ gwt = latGauWgt (nlat, "lat", "gaussian weights", "")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (u, lon) ; [lon(0)=-180] init location
+
+ uNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ uNew!(nDim-1) = "lon" ; rightmost dimension
+ uNew&lat = lat ; add new coord var
+ uNew&lon = lon
+
+ vNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ vNew!(nDim-1) = "lon" ; rightmost dimension
+ vNew&lat = lat ; add new coord var
+ vNew&lon = lon
+
+ if (isatt(uNew,"gwt")) then
+ delete(uNew at gwt)
+ end if
+ uNew at gwt = gwt ; attach gaussian weights
+
+ if (isatt(vNew,"gwt")) then
+ delete(vNew at gwt)
+ end if
+ vNew at gwt = gwt ; attach gaussian weights
+ end
+
+ ; *************************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "f2fshv" that copies attributes and coordinate
+ ; vars. It adds the longitude and gaussian latitude coordinates.
+
+ undef("f2fshv_Wrap")
+ procedure f2fshv_Wrap (u:numeric, v:numeric, uNew:numeric, vNew:numeric)
+ local dim_uNew, nDim, nlat, mlon, lon, lat
+ begin
+ f2fshv (u, v, uNew, vNew)
+ ; contributed functions
+ copy_VarAtts (u, uNew) ; copy variable attributes
+ copy_VarCoords_2 (u, uNew) ; copy coord variables
+ ; except lat and lon
+ copy_VarAtts (v, vNew) ; copy variable attributes
+ copy_VarCoords_2 (v, vNew) ; copy coord variables
+ ; except lat and lon
+ dim_uNew= dimsizes(uNew) ; dim sizes of each dimension
+ nDim = dimsizes(dim_uNew) ; number of dimensions [rank]
+ nlat = dim_uNew(nDim-2) ; number of latitudes
+ mlon = dim_uNew(nDim-1) ; number of longitudes
+
+ if (typeof(u).eq."double") then
+ nlat at double = True
+ mlon at double = True
+ end if
+
+ lat = latGlobeF (nlat, "lat", "latitude" , "degrees_north")
+ lon = lonGlobeF (mlon, "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (u, lon) ; [lon(0)=-180] init location
+
+ uNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ uNew!(nDim-1) = "lon" ; rightmost dimension
+ uNew&lat = lat ; add new coord var
+ uNew&lon = lon
+
+ vNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ vNew!(nDim-1) = "lon" ; rightmost dimension
+ vNew&lat = lat ; add new coord var
+ vNew&lon = lon
+ end
+
+
+
+ ; ********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "f2fosh" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef("f2foshv_Wrap")
+ procedure f2foshv_Wrap (u:numeric, v:numeric, uNew:numeric, vNew:numeric)
+ local dim_uNew, nDim, nlat, mlon, lon, lat
+ begin
+ f2foshv(u, v, uNew, vNew) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (u, uNew) ; copy variable attributes
+ copy_VarCoords_2 (u, uNew) ; copy coord variables
+ ; except lat and lon
+ copy_VarAtts (v, vNew) ; copy variable attributes
+ copy_VarCoords_2 (v, vNew) ; copy coord variables
+ ; except lat and lon
+ dim_uNew= dimsizes(uNew) ; dim sizes of each dimension
+ nDim = dimsizes(dim_uNew) ; number of dimensions [rank]
+ nlat = dim_uNew(nDim-2) ; number of latitudes [fo grid]
+ mlon = dim_uNew(nDim-1) ; number of longitudes [fo grid]
+ nlat1= nlat-1 ; fo has one less lat
+
+ if (typeof(u).eq."double") then
+ nlat at double = True
+ nlat1 at double= True
+ mlon at double = True
+ end if
+
+ lat = latGlobeFo (nlat1, "lat", "latitude", "degrees_north")
+ lon = lonGlobeFo (mlon , "lon", "longitude","degrees_east")
+ ; possibly make near Date Line
+ lonGM2DateLine (u, lon) ; init location
+
+ uNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ uNew!(nDim-1) = "lon" ; rightmost dimension
+ uNew&lat = lat ; add new coord var
+ uNew&lon = lon
+
+ vNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ vNew!(nDim-1) = "lon" ; rightmost dimension
+ vNew&lat = lat ; add new coord var
+ vNew&lon = lon
+ end
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "fo2fsh" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef("fo2fshv_Wrap")
+ procedure fo2fshv_Wrap (u:numeric, v:numeric, uNew:numeric, vNew:numeric)
+ local dim_uNew, nDim, nlat, mlon, lon, lat
+ begin
+ fo2fshv(u, v, uNew, vNew) ; interpolate to new grid
+ ; contributed functions
+ copy_VarAtts (u, uNew) ; copy variable attributes
+ copy_VarCoords_2 (u, uNew) ; copy coord variables
+ ; except lat and lon
+ copy_VarAtts (v, vNew) ; copy variable attributes
+ copy_VarCoords_2 (v, vNew) ; copy coord variables
+ ; except lat and lon
+ dim_uNew= dimsizes(uNew) ; dim sizes of each dimension
+ nDim = dimsizes(dim_uNew) ; number of dimensions [rank]
+ nlat = dim_uNew(nDim-2) ; number of latitudes [fo grid]
+ mlon = dim_uNew(nDim-1) ; number of longitudes [fo grid]
+ nlat1 = nlat+1 ; f has one more lat
+
+ if (typeof(u).eq."double") then
+ nlat at double = True
+ nlat1 at double= True
+ mlon at double = True
+ end if
+
+ lat = latGlobeF (nlat1, "lat", "latitude" , "degrees_north")
+ lon = lonGlobeF (mlon , "lon", "longitude", "degrees_east")
+ ; possibly make Date Line
+ lonGM2DateLine (u, lon) ; [lon(0)=-180] init location
+
+ uNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ uNew!(nDim-1) = "lon" ; rightmost dimension
+ uNew&lat = lat ; add new coord var
+ uNew&lon = lon
+
+ vNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ vNew!(nDim-1) = "lon" ; rightmost dimension
+ vNew&lat = lat ; add new coord var
+ vNew&lon = lon
+ end
+
+ ;*********************************************************************
+ ; Mark Stevens
+ ; Read RGB file format of n rows by 3 columns (R,G,B)
+ ; values are integers from 0 to 255
+ ; first triplet is the background
+ ; second triplet is the foreground
+ ; normalize RGB values (=RGB/255) for cmap format
+
+ undef("RGBtoCmap")
+ function RGBtoCmap (fName:string)
+ local rgb, size, n, norm, cmap
+ begin
+ rgb = asciiread (fName, -1, "integer")
+ size = dimsizes(rgb)
+ n = size/3 ; number of rows
+ norm = rgb/255.0 ; divide all elements
+ cmap = onedtond (norm, (/n,3/)) ; back to triplets
+ return (cmap)
+ end
+ ;************************************************************
+ ; Mark Stevens
+ ; will choose a color to fill in a poly(line/gon/marker) based upon
+ ; secondary scalar field.
+ ;
+ ; This function was updated 6/10/2013 to allow n x 3 or
+ ; n x 4 (RGBA) arrays.
+ ;
+ undef("GetFillColor")
+ function GetFillColor(cnlvls[*]:numeric,cmapt,data:numeric)
+ local dims, ncn, nclr, color, n
+ begin
+
+ if(isstring(cmapt)) then
+ cmap = read_colormap_file(cmapt)
+ else if(isnumeric(cmapt)) then
+ dims = dimsizes(cmapt)
+ if(dims(0).lt.3.or.dims(0).gt.256.or..not.any(dims(1).ne.(/3,4/))) then
+ print ("Error: GetFillColors: cmap must be an n x 3 or n x 4 array of RGB or RGBA values, or a valid color map name")
+ return(new(3,"float")) ; return a missing value
+ end if
+ cmap = cmapt
+ else
+ print ("Error: GetFillColors: cmap must be an n x 3 or n x 4 array of RGB or RGBA values, or a valid color map name")
+ end if
+ end if
+
+ ncn = dimsizes (cnlvls)
+ nclr = dimsizes (cmap(:,0))
+ if (nclr-2 .lt. ncn+1) then
+ print ("Error: GetFillColors: Not enough colors in colormap for number of contour levels")
+ return (new(3,float)) ; return missing
+ end if
+
+ if (data .le. cnlvls(0)) then
+ color = cmap(2,:)
+ else
+ if (data .gt. cnlvls(ncn-1)) then
+ color = cmap(nclr-1,:)
+ else
+ do n = 1, ncn-1
+ if (data .le. cnlvls(n)) then
+ color = cmap(n+2,:)
+ break
+ end if
+ end do
+ end if
+ end if
+ return (color)
+ end
+ ;************************************************************
+ ; Mark Stevens
+ ; function returns the correct colormap index for the input data value
+ ;
+ undef ("GetFillColorIndex")
+ function GetFillColorIndex(cnlvls[*]:numeric,indices[*]:integer,data:numeric)
+
+ ; cnlvls - input contour levels
+ ; indices - input indices to colormap
+ ; data - input data value
+ local ncn, nclr, index, n
+ begin
+
+ ncn = dimsizes (cnlvls)
+ nclr = dimsizes (indices)
+
+ if (nclr .lt. ncn+1) then
+ print ("Not enough colors in colormap for number of contour levels")
+ return (default_fillvalue("integer"))
+ end if
+
+ if (data .le. cnlvls(0)) then
+ index = indices(0)
+ else
+ if (data .gt. cnlvls(ncn-1)) then
+ index = indices(nclr-1)
+ else
+ do n = 1, ncn-1
+ if (data .le. cnlvls(n)) then
+ index = indices(n)
+ break
+ end if
+ end do
+ end if
+ end if
+ return (index)
+ end
+ ;*****************************************************************
+ ; S. Murphy
+ ; goes and determines the appropriate value for the missing value from
+ ; getFillValue, and then assigns the _FillValue and the missing_value
+ ; to this number. This is useful when creating derivations and outputting
+ ; data to netcdf, or dealing with netcdf data that has no attributes.
+
+ undef("assignFillValue")
+ procedure assignFillValue(var_from:numeric, var_to:numeric)
+ local value
+ begin
+
+ if (isatt(var_from,"_FillValue")) then
+ var_to at _FillValue = var_from at _FillValue
+ var_to at missing_value = var_from at _FillValue
+ end if
+
+ end
+ ;*****************************************************************
+ ; A Phillips
+ ; Sets a data point array to missing if a percentage of good points
+ ; is not met.
+
+ ; Time is assumed to be on the rightmost side of y
+ ;
+ ; dataperc is the percentage of data which is necessary to use
+ ; in forthcoming calculations in your program. For instance,
+ ; if dataperc is .75, 75% of the data for a data point must
+ ; be present. If not, all data values for that particular data
+ ; point will be set to missing in this fxn.
+ ;
+ ; USAGE:
+ ; y = rmInsufData(y,.75) ;will replace "y" with filtered array
+ ; Y = rmInsufData(y,.75) ;"Y" will be filtered, "y" will be unchanged
+
+ undef("rmInsufData")
+ function rmInsufData (y:numeric, dataperc:float)
+ local x, dims, numdims, i,j,k,l, dim0,dim1,dim2,dim3,dim4
+ begin
+ x=y
+ dims=dimsizes(x)
+ numdims=dimsizes(dims)
+
+ if (numdims.eq.1) then
+ dim0=dims(0)
+ if (((num(.not.ismissing(x(:)))*100)/dim0).lt.dataperc*100) then
+ x = x at _FillValue
+ end if
+ end if
+
+ if (numdims.eq.2) then
+ dim0=dims(0)
+ dim1=dims(1)
+ do i=0,dim0-1
+ if (((num(.not.ismissing(x(i,:)))*100)/dim1).lt.dataperc*100) then
+ x(i,:) = x at _FillValue
+ end if
+ end do
+ end if
+
+ if (numdims.eq.3) then
+ dim0=dims(0)
+ dim1=dims(1)
+ dim2=dims(2)
+ do i=0,dim0-1
+ do j=0,dim1-1
+ if (((num(.not.ismissing(x(i,j,:)))*100)/dim2).lt.dataperc*100) then
+ x(i,j,:) = x at _FillValue
+ end if
+ end do
+ end do
+ end if
+
+ if (numdims.eq.4) then
+ dim0=dims(0)
+ dim1=dims(1)
+ dim2=dims(2)
+ dim3=dims(3)
+ do i=0,dim0-1
+ do j=0,dim1-1
+ do k=0,dim2-1
+ if(((num(.not.ismissing(x(i,j,k,:)))*100)/dim3).lt.dataperc*100)then
+ x(i,j,k,:) = x at _FillValue
+ end if
+ end do
+ end do
+ end do
+ end if
+
+ if (numdims.eq.5) then
+ dim0=dims(0)
+ dim1=dims(1)
+ dim2=dims(2)
+ dim3=dims(3)
+ dim4=dims(4)
+ do i=0,dim0-1
+ do j=0,dim1-1
+ do k=0,dim2-1
+ do l=0,dim3-1
+ if(((num(.not.ismissing(x(i,j,k,l,:)))*100)/dim4).lt.
+ dataperc*100) then
+ x(i,j,k,l,:) = x at _FillValue
+ end if
+ end do
+ end do
+ end do
+ end do
+ end if
+ return(x)
+ end
+ ;; -------------------------------------------------------
+ undef("SqrtCosWeight")
+ function SqrtCosWeight (y:numeric)
+ ;; Created by Adam Phillips
+ ;;
+ ;; The name of the latitude dimension is assumed to be "lat"
+ ;; The rightmost dimension is assumed to be longitude
+ ;;
+ ;; Acceptable dimension orders:
+ ;; (lat,lon), (time,lat,lon), (time,???,lat,lon), (time,???,???,lat,lon)
+ ;;
+ ;; This function will perform square-root of the cosine weighting on the
+ ;; given array.
+ ;;
+ ;;
+ ;; USAGE:
+ ;; y = SqrtCosWeight(y) ;will replace "y" with weighted array
+ ;; Y = SqrtCosWeight(y) ;"Y" will be weighted, "y" will be unchanged
+
+ local x, qwlat, dims, numdims, nlat, pi, rad, coslat, z, sqrtcos, a,b,c,d
+ begin
+ x = y
+ if (typeof(x&lat).eq."double") then
+ qwlat = doubletofloat(x&lat)
+ else
+ qwlat = x&lat
+ end if
+
+ dims=dimsizes(x)
+ numdims=dimsizes(dims)
+ nlat = dims(numdims-2)
+ pi = 4.*atan(1.0)
+ rad = (pi/180.)
+ coslat = cos(qwlat*rad)
+ do z = 0,nlat-1
+ if (coslat(z).lt.0) then
+ coslat(z) = 0. ;sets the cos(90) = 0
+ end if
+ end do
+ sqrtcos = sqrt(coslat)
+
+ if (numdims.eq.2) then
+ do a = 0,nlat-1
+ x(a,:) = x(a,:)*sqrtcos(a)
+ end do
+ end if
+ if (numdims.eq.3) then
+ do b = 0,nlat-1
+ x(:,b,:) = x(:,b,:)*sqrtcos(b)
+ end do
+ end if
+ if (numdims.eq.4) then
+ do c = 0,nlat-1
+ x(:,:,c,:) = x(:,:,c,:)*sqrtcos(c)
+ end do
+ end if
+ if (numdims.eq.5) then
+ do d = 0,nlat-1
+ x(:,:,:,d,:) = x(:,:,:,d,:)*sqrtcos(d)
+ end do
+ end if
+ if (numdims.ge.6) then
+ print("SqrtCosWeight accepts an array with 5 dimensions or less, array has "+numdims+" dimensions, exiting")
+ exit
+ end if
+ if (isatt(x,"long_name")) then
+ x at long_name = x at long_name + " (sqrt cosine weighted)"
+ end if
+ return(x)
+ end
+ ;; -------------------------------------------------------
+ undef ("NewCosWeight")
+ function NewCosWeight (y:numeric)
+ ;;
+ ;; created by Adam Phillips
+ ;;
+ ;; The name of the latitude dimension is assumed to be "lat"
+ ;; The rightmost dimension is assumed to be longitude
+ ;;
+ ;; Acceptable dimension orders:
+ ;; (lat,lon), (time,lat,lon), (time,???,lat,lon), (time,???,???,lat,lon)
+ ;;
+ ;; This function will perform cosine weighting on the given array.
+ ;;
+ ;; USAGE:
+ ;; y = NewCosWeight(y) ;will replace "y" with weighted array
+ ;; Y = NewCosWeight(y) ;"Y" will be weighted, "y" will be unchanged
+
+ local x, qwlat, dims, numdims, pi, rad, coslat, nlat, a,b,c,d
+ begin
+ x = y
+ if (typeof(x&lat).eq."double") then
+ qwlat = doubletofloat(x&lat)
+ else
+ qwlat = x&lat
+ end if
+
+ dims=dimsizes(x)
+ numdims=dimsizes(dims)
+ pi = 4.*atan(1.0)
+ rad = (pi/180.)
+ coslat = cos(qwlat*rad)
+ nlat = dims(numdims-2)
+ if (numdims.eq.2) then
+ do a = 0,nlat-1
+ x(a,:) = x(a,:)*coslat(a)
+ end do
+ end if
+ if (numdims.eq.3) then
+ do b = 0,nlat-1
+ x(:,b,:) = x(:,b,:)*coslat(b)
+ end do
+ end if
+ if (numdims.eq.4) then
+ do c = 0,nlat-1
+ x(:,:,c,:) = x(:,:,c,:)*coslat(c)
+ end do
+ end if
+ if (numdims.eq.5) then
+ do d = 0,nlat-1
+ x(:,:,:,d,:) = x(:,:,:,d,:)*coslat(d)
+ end do
+ end if
+ if (numdims.ge.6) then
+ print("NewCosWeight accepts an array with 5 dimensions or less, array has "+numdims+" dimensions, exiting")
+ exit
+ end if
+ if (isatt(x,"long_name")) then
+ x at long_name = x at long_name + " (cosine weighted)"
+ end if
+ return(x)
+ end
+ ;*************************************************************************
+ ; D. Shea
+
+ ; Unfortunately, NCL's built-in function, "addfiles" does not act like
+ ; the "addfile". It does not return any meta information.
+
+ ; This function will return all the attributes and coordinate
+ ; variables of a variable returned by "addfiles". This does make
+ ; an assumption in the case of "join" that the leftmost dimension
+ ; is the coordinate variable that must be treated 'specially'
+ ;
+
+ ; sample usage:
+ ; diri = "/fs/cgd/data0/shea/"
+ ; fili = "annual*.nc"
+ ; fils = systemfunc ("ls "+diri+fili)
+ ;
+ ; f = addfiles (fils, "r")
+ ;
+ ; ListSetType (f, "cat") ; default
+ ; or
+ ; ListSetType (f, "join") ; [extra dimension]
+ ;
+ ; T = addfiles_GetVar (f, fils, "T" )
+ undef("addfiles_GetVar")
+ function addfiles_GetVar (f:list, fils[*]:string, varName:string)
+ local x, dimx, rankx, g, X, dimX, rankX, i
+ begin
+ x = f[:]->$varName$ ; returned variable [vlaues ONLY]
+ dimx = dimsizes(x)
+ rankx = dimsizes(dimx) ; # dimensions [rank]
+
+ g = addfile (fils(0), "r") ; read in one variable
+ X = g->$varName$ ; with original atts + coord vars
+ dimX = dimsizes(X)
+ rankX = dimsizes(dimX) ; # dimensions [rank]
+
+ copy_VarAtts (X,x) ; copy attributes
+ ; copy/create coordinate variables
+ if (rankx.eq.(rankX+1) ) then ; must be "join"
+ do i=0,rankX-1
+ if (.not.ismissing(X!i)) then
+ x!(i+1) = X!i ; dimensions are offset by one
+ if (iscoord(X,X!i) ) then
+ x&$x!(i+1)$ = X&$X!i$
+ end if
+ end if
+ end do
+ ; add the extra dim stuff
+ x!0 = "case" ; arbitrary dimension name
+ x&$x!0$ = ispan(0,dimx(0)-1,1) ; sequential sequence
+
+ else ; should be "cat"
+
+ if (rankx.eq.rankX ) then
+ do i=0,rankX-1
+ if (.not.ismissing(X!i)) then
+ x!i = X!i ; name all dimensions
+ if (iscoord(X,X!i) ) then
+ if (i.eq.0 ) then
+ x&$x!0$ = f[:]->$x!0$ ; leftmost dimension
+ else
+ x&$x!i$ = X&$X!i$ ; rightmost dimensions
+ end if
+ end if
+ end if
+ end do
+ else
+ print ("function addfiles_GetVar: ERROR: dimension problem")
+ end if
+ end if
+
+ return (x)
+ end
+ ;************************************************************************
+ ; D. Shea
+ ; called internally by eofcov_Wrap, eofcor_Wrap, eof_pcmsg_Wrap, eof_pcmsg_Wrap
+ ; wrapper for NCL function "eofcov" that copies coordiante variables
+
+ undef ("eofMeta")
+ procedure eofMeta (data:numeric, neval:integer, eof:numeric)
+ local evn, dimd, dime, nDimd, nDime, i
+ begin
+ if (isatt(data,"long_name") .or. isatt(data,"description") .or.
+ isatt(data,"standard_name") ) then
+ eof at long_name = "EOF: "+getLongName(data)
+ end if
+ if (isatt(data,"lev") ) then
+ eof at lev = data at lev
+ end if
+
+ evn = ispan(1,neval,1) ; built-in function
+ evn at long_name = "eigenvalue number"
+ evn at units = ""
+ evn!0 = "evn" ; name dimension
+ evn&evn = evn ; make coord variable
+
+ eof!0 = "evn" ; name eof leftmost dimension
+ eof&evn = evn ; assign coord var
+
+ dimd = dimsizes(data)
+ dime = dimsizes(eof)
+ nDimd= dimsizes(dimsizes(data)) ; rank
+ nDime= dimsizes(dimsizes(eof))
+
+ do i=0,nDimd-2 ; do not use last dimension
+ if (.not.ismissing(data!i)) then
+ eof!(i+1) = data!i
+ if (iscoord(data,data!i) ) then
+ eof&$eof!(i+1)$ = data&$data!i$
+ end if
+ end if
+ end do
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrappers for NCL functions "eofcov"/"eofcor" that copies coord variables
+
+ ; usage: eof = eofcov_Wrap (data, neval)
+ ; eof = eofcor_Wrap (data, neval)
+
+ undef ("eofcov_Wrap")
+ function eofcov_Wrap (data:numeric, neval:integer)
+ ; wrapper for NCL function "eofcov" that copies attributes and coordinate vars
+ local eof
+ begin
+ eof = eofcov(data, neval) ; invoke built-in function
+ eofMeta (data, neval, eof) ; add meta information
+ eof at matrix = "covariance"
+ return (eof) ; return
+ end
+
+ undef ("eofcor_Wrap")
+ function eofcor_Wrap (data:numeric, neval:integer)
+ ; wrapper for NCL function "eofcor" that copies attributes and coordinate vars
+ local eof
+ begin
+ eof = eofcor(data, neval)
+ eofMeta (data, neval, eof)
+ eof at matrix = "correlation"
+ return (eof)
+ end
+
+ undef ("eofcov_pcmsg_Wrap")
+ function eofcov_pcmsg_Wrap (data:numeric, neval:integer, pcrit:numeric)
+ ; wrapper for NCL function "eofcov_pcmsg" that copies attributes and coordinate vars
+ local eof
+ begin
+ eof = eofcov_pcmsg(data, neval, pcrit) ; invoke built-in function
+ eofMeta (data, neval, eof) ; add meta information
+ eof at matrix = "covariance"
+ eof at pcrit = pcrit
+ return (eof) ; return
+ end
+
+ undef ("eofcor_pcmsg_Wrap")
+ function eofcor_pcmsg_Wrap (data:numeric, neval:integer, pcrit:numeric)
+ ; wrapper for NCL function "eofcor_pcmsg" that copies attributes and coordinate vars
+ local eof
+ begin
+ eof = eofcor_pcmsg(data, neval, pcrit)
+ eofMeta (data, neval, eof)
+ eof at matrix = "correlation"
+ eof at pcrit = pcrit
+ return (eof)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; called internally by eofcov_ts_Wrap and eofcor_ts_Wrap
+ ; wrapper for NCL functions "eofcov_ts" "eofcor_ts"
+ ; that copies coordiante variables
+
+ undef ("eofTsMeta")
+ procedure eofTsMeta (data:numeric, eof:numeric, eofTs:numeric)
+ local dimd, dime, nDimd, nDime, i, j
+ begin
+ dimd = dimsizes(data)
+ dime = dimsizes(eofTs)
+ nDimd= dimsizes(dimsizes(data)) ; rank
+ nDime= dimsizes(dimsizes(eofTs))
+
+ if (isatt(data,"long_name") .or. isatt(data,"description") .or.
+ isatt(data,"standard_name") ) then
+ eofTs at long_name = "EOF: Amplitude: "+getLongName(data)
+ end if
+
+ if (.not.ismissing(eof!0)) then
+ eofTs!0 = eof!0
+ if (iscoord(eof,eof!0) ) then
+ eofTs&$eofTs!0$ = eof&$eof!0$
+ end if
+ end if
+
+ i = nDimd-1 ; rightmost dimension of data
+ j = nDime-1 ; rightmost dimension of eofTs
+ if (.not.ismissing(data!i)) then
+ eofTs!j = data!i
+ if (iscoord(data,data!i) ) then
+ eofTs&$eofTs!j$ = data&$data!i$
+ end if
+ end if
+
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrappers for NCL functions "eofcov_ts"/"eofcor_ts" that copies coord variables
+
+ ; usage: eof = eofcov_ts_Wrap (data, eof)
+ ; eof = eofcor_ts_Wrap (data, eof)
+
+ undef ("eofcov_ts_Wrap")
+ function eofcov_ts_Wrap (data:numeric, eof:numeric)
+ local eofTS
+ begin
+ eofTs = eofcov_ts(data, eof) ; invoke built-in function
+ eofTsMeta (data, eof, eofTs) ; add meta information
+ return (eofTs) ; return
+ end
+
+ undef ("eofcor_ts_Wrap")
+ function eofcor_ts_Wrap (data:numeric, eof:numeric)
+ local eofTS
+ begin
+ eofTs = eofcor_ts(data, eof) ; invoke built-in function
+ eofTsMeta (data, eof, eofTs) ; add meta information
+ return (eofTs) ; return
+ end
+
+
+ ; **********************************************************************
+ ; D Shea
+ ;
+ ; Project the eofts onto the Data and return an 'eof' pattern.
+ ; No normalization is performed.
+ ;
+ ; usage: eof = eofcov (x,neval)
+ ; eofts = eofcov_ts (x,eof) ; where 'deof' is the data used
+ ; EOF = eoftsData2eof(eof_ts, deof, False)
+ ;
+ ; currently: the option argument is not used.
+ ;
+ undef("eoftsData2eof")
+ function eoftsData2eof (eof_ts[*][*], data:numeric, option:logical )
+ local dimd, rank, dimts, neval, ntim, npts, eof, nev
+ , np, opt, n, mx, MX, ny, NY
+ begin
+ dimd = dimsizes(data)
+ rank = dimsizes(dimd)
+ if (rank.lt.2 .or. rank.gt.3) then
+ print("-----")
+ print("contributed: eoftsData2eof: only works with arrays of2 or 3")
+ exit
+ end if
+
+ dimts = dimsizes(eof_ts)
+ neval = dimts(0)
+ ntim = dimts(1)
+
+ if (rank.eq.2) then
+ npts = dimd(0)
+
+ eof = new ( (/neval,npts/), typeof(data),getFillValue(data) )
+ do nev=0,neval-1
+ do np=0,npts-1
+ eof(nev,np) = sum(eof_ts(nev,:)*data(np,:))
+ end do
+ end do
+
+ eof!0 = "evn"
+ if (isdimnamed(data,0)) then
+ eof!1 = data!0
+ if (iscoord(data,data!0) ) then
+ eof&$eof!0$ = data&$data!0$
+ end if
+ else
+ eof!1 = "npts"
+ end if
+ end if
+
+ if (rank.eq.3) then
+ NY = dimd(0)
+ MX = dimd(1)
+
+ eof = new ( (/neval,NY,MX/), typeof(data),getFillValue(data) )
+ do nev=0,neval-1
+ do ny=0,NY-1
+ do mx=0,MX-1
+ eof(nev,ny,mx) = sum(eof_ts(nev,:)*data(ny,mx,:))
+ end do
+ end do
+ end do
+
+ eof!0 = "evn"
+ do n=1,2
+ nm1 = n-1
+ if (isdimnamed(data,n)) then
+ eof!n = data!nm1
+ if (iscoord(data,data!nm1) ) then
+ eof&$eof!n$ = data&$data!nm1$
+ end if
+ end if
+ end do
+ end if
+
+ return(eof)
+ end
+
+ undef ("eofunc_Wrap")
+ function eofunc_Wrap (data:numeric, neval:integer, optEOF:logical)
+ ; wrapper for NCL function "eofunc" that copies attributes and coordinate vars
+ local eofx
+ begin
+ eofx = eofunc(data, neval, optEOF) ; invoke built-in function
+ eofMeta (data, neval, eofx) ; add meta information
+ return (eofx) ; return
+ end
+
+ undef ("eofunc_ts_Wrap")
+ function eofunc_ts_Wrap (data:numeric, eof:numeric, optETS:logical)
+ local eofTS
+ begin
+ eofTs = eofunc_ts(data, eof, optETS) ; invoke built-in function
+ eofTsMeta (data, eof, eofTs) ; add meta information
+ return (eofTs) ; return
+ end
+
+ undef ("eofunc_varimax_Wrap")
+ function eofunc_varimax_Wrap (eof:numeric, optEVX:integer)
+ local eofEVX
+ begin
+ eofEVX = eofunc_varimax(eof, optEVX) ; invoke built-in function
+ eofEVX at op = "Kaiser Varimax Rotation: opt="+optEVX
+ copy_VarCoords(eof, eofEVX)
+
+ return (eofEVX) ; return
+ end
+
+ ;*******************************************************************
+ ; Returns the varimax rotated EOFs in descending order.
+ ;*******************************************************************
+ undef("eof_varimax_reorder")
+ procedure eof_varimax_reorder ( eofr )
+ local dime, rank, neof, ip, EOFR
+ begin
+ dime = dimsizes( eofr )
+ rank = dimsizes( dime )
+ if (rank.lt.2 .or. rank.gt.3) then
+ print("eof_varimax_reorder: Currently eofr must be 2D or 3D.")
+ print("eof_varimax_reorder: ***** Return original array ****")
+ end if
+ neofr= dime(0)
+
+ ip = dim_pqsort( eofr at pcvar_varimax, -1 ) ; descending order
+
+ EOFR = eofr ; temp and copt meta
+ do ne=0,neofr-1
+ if (rank.eq.2) then
+ eofr(ne,:) = (/ EOFR(ip(ne),:) /)
+ end if
+ if (rank.eq.3) then
+ eofr(ne,:,:) = (/ EOFR(ip(ne),:,:) /)
+ end if
+ eofr at pcvar_varimax(ne) = (/ EOFR at pcvar_varimax(ip(ne)) /)
+ eofr at variance_varimax(ne) = (/ EOFR at variance_varimax(ip(ne)) /)
+ end do
+
+ end
+ ; **************************************************************
+ ; D. Shea
+ ; different entry name ....
+ ; **************************************************************
+
+ undef("eofunc_varimax_reorder")
+ procedure eofunc_varimax_reorder ( eofr )
+ begin
+ eof_varimax_reorder( eofr )
+ end
+
+
+ ; **************************************************************
+ ; D. Shea
+ ; reorder [flip] the longitude coordinate variable
+ ; NOTE:
+ ; (1) coordinate "lon" is assumed to be the rightmost dim
+ ; (2) the longitude is assume to be "global"
+ ; (3) cyclic pt NOT allowed here
+
+ ; change to the return variable: Feb 9 2001
+ ; instead of returning "x" I return "temp"
+
+ undef("lonFlip")
+ function lonFlip (x:numeric)
+ local dimx, nDim, mon, mlon2, temp, i
+ begin
+
+ dimx = dimsizes(x)
+ nDim = dimsizes(dimx)
+ if (nDim.gt.5) then
+ print ("lonflip: too many dimensions: nDim="+nDim)
+ return (x)
+ end if
+
+ mlon = dimx(nDim-1)
+ if (mlon%2 .ne. 0) then
+ print ("lonflip: longitude dimension size must be even: mlon="+mlon)
+ exit
+ end if
+ mlon2 = mlon/2
+
+ if (mlon%2.ne.0) then
+ print("=======================")
+ print("Currently, lonFlip requires that the number")
+ print("of longitudes be even. mlon="+mlon )
+ print("=======================")
+ exit
+ end if
+
+ temp = x
+ if (nDim.eq.1) then
+ temp(0:mlon2-1) = (/ x(mlon2:) /)
+ temp(mlon2:) = (/ x(0:mlon2-1) /)
+ end if
+ if (nDim.eq.2) then
+ temp(:,0:mlon2-1) = (/ x(:,mlon2:) /)
+ temp(:,mlon2:) = (/ x(:,0:mlon2-1) /)
+ end if
+ if (nDim.eq.3) then
+ temp(:,:,0:mlon2-1) = (/ x(:,:,mlon2:) /)
+ temp(:,:,mlon2:) = (/ x(:,:,0:mlon2-1) /)
+ end if
+ if (nDim.eq.4) then
+ temp(:,:,:,0:mlon2-1) = (/ x(:,:,:,mlon2:) /)
+ temp(:,:,:,mlon2:) = (/ x(:,:,:,0:mlon2-1) /)
+ end if
+ if (nDim.eq.5) then
+ temp(:,:,:,:,0:mlon2-1) = (/ x(:,:,:,:,mlon2:) /)
+ temp(:,:,:,:,mlon2:) = (/ x(:,:,:,:,0:mlon2-1) /)
+ end if
+
+ i = nDim-1 ; last dimension
+ if (.not.ismissing(x!i)) then
+ if (iscoord(x,x!i)) then
+ xlon = x&$x!i$ ; original coord variable
+ tlon = (/ xlon /)
+
+ xlon(0:mlon2-1) = (/ tlon(mlon2:) /)
+ xlon(mlon2:) = (/ tlon(0:mlon2-1)/)
+
+ if (tlon(0).ge.0.) then ; (say) 0=>355
+ xlon(0:mlon2-1) = (/ tlon(mlon2:) - 360 /)
+ xlon(mlon2:) = (/ tlon(0:mlon2-1) /)
+ else ; (say) -180=>175
+ xlon(0:mlon2-1) = (/ tlon(mlon2:) /)
+ xlon(mlon2:) = (/ tlon(0:mlon2-1) + 360 /)
+ end if
+
+ temp&$x!i$ = xlon ; new coord variable
+ end if
+ else
+ print ("lonFlip: warning: last dimension is not named")
+ end if
+
+ temp at lonFlip = "longitude coordinate variable " +
+ "has been reordered via lonFlip"
+ return (temp)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; pivot (flip) the contents of array "x" about some arbitrary
+ ; user specified longitude. The effect is similar to "lonFlip"
+ ; However, lonFlip will pivot about the mid point [whatever that is]
+ ; while thus function allows the user to specify what lon to pivot about.
+
+ ; grid must be "global" [no cyclic point] and it assumes that the
+ ; rightmost dimension of "x" is a coordinate variable corresponding
+ ; to longitude.
+
+ ; change to the return variable: Feb 9 2001
+
+ ; usage xNew = lonPivot (x, 20.) ; pivot about 20E
+ ; x = lonPivot (x, 20.) ; can overwrite
+ undef("lonPivot")
+ function lonPivot (x:numeric, pivotLon:numeric)
+ local dimx, nDim, lonName, temp, xlon, indP, mlon, indL, n
+ , temp, tlon, indt
+ begin
+ dimx = dimsizes(x)
+ nDim = dimsizes(dimx)
+ if (nDim.gt.5) then
+ print ("contributed.ncl: lonflip: too many dims: nDim="+nDim)
+ return (x)
+ end if
+
+ if (.not.ismissing(x!(nDim-1)) ) then
+ lonName = x!(nDim-1)
+ else
+ print ("contributed.ncl: lonPivot: lon coord var is msg")
+ exit
+ end if
+
+ temp = x
+ xlon = x&$lonName$ ; original coord variable
+ xlon!0 = "lon"
+ xlon&lon = (/ xlon /)
+ indP = ind(xlon.eq.xlon({pivotLon})) ; must be exact
+ if (ismissing(indP)) then
+ print ("contributed.ncl: lonPivot: bad pivot value")
+ exit
+ end if
+
+ mlon = dimx(nDim-1) ; # of longitudes
+ indL = mlon-1 ; last index
+ n = indL-indP
+
+ if (nDim.eq.1) then
+ temp(0:n) = (/ x(indP:indL)/)
+ temp(n+1:) = (/ x(0:indP-1) /)
+ end if
+ if (nDim.eq.2) then
+ temp(:,0:n) = (/ x(:,indP:indL)/)
+ temp(:,n+1:) = (/ x(:,0:indP-1) /)
+ end if
+ if (nDim.eq.3) then
+ temp(:,:,0:n) = (/ x(:,:,indP:indL)/)
+ temp(:,:,n+1:) = (/ x(:,:,0:indP-1) /)
+ end if
+ if (nDim.eq.4) then
+ temp(:,:,:,0:n) = (/ x(:,:,:,indP:indL)/)
+ temp(:,:,:,n+1:) = (/ x(:,:,:,0:indP-1) /)
+ end if
+ if (nDim.eq.5) then
+ temp(:,:,:,:,0:n) = (/ x(:,:,:,:,indP:indL)/)
+ temp(:,:,:,:,n+1:)= (/ x(:,:,:,:,0:indP-1) /)
+ end if
+
+ tlon = new ( mlon, typeof(xlon) )
+ tlon(0:n) = (/ xlon(indP:indL) /)
+ tlon(n+1:) = (/ xlon(0:indP-1)/)
+ delete (tlon at _FillValue)
+
+ if (tlon(0).ge.0.) then ; (say) 20,25,...,350,355,0,5,..
+ indt = ind(tlon.lt.tlon(0))
+ if (.not.all(ismissing(indt))) then
+ tlon(indt) = (/ tlon(indt) + 360. /)
+ end if
+ end if
+ if (tlon(0).ge.180. .or. tlon(0).eq.360.) then
+ tlon = (/ tlon -360. /)
+ end if
+ copy_VarAtts (xlon,tlon)
+
+ temp&$lonName$ = tlon ; new coord variable
+
+ temp at lonPivot = "reordered via lonPivot [NCL]: pivotLon="+pivotLon
+ return (temp)
+ end
+
+ ; ******************************************************************
+ ; Dennis Shea
+
+ undef("natgrid_Wrap")
+ function natgrid_Wrap (xi[*]:numeric,yi[*]:numeric, fi:numeric
+ ,xo[*]:numeric,yo[*]:numeric)
+
+ local fo, dimfi, nDimi, nDimo
+ begin
+ fo = natgrid (xi,yi,fi, xo,yo) ; perform interpolation
+
+ dimfi= dimsizes(fi)
+ nDimi= dimsizes(dimsizes(fi)) ; rank: # of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (nDimi.ge.2) then ; copy coord vars
+ copy_VarCoords_1(fi,fo) ; except for rightmost dim
+ end if
+
+ nDimo = dimsizes(dimsizes(fo))
+
+ dNam = getvardims( yo )
+ if (.not.ismissing(dNam)) then
+ fo!(nDimo-2) = dNam
+ fo&$dNam$ = yo
+ else
+ fo!(nDimo-2) = "y"
+ fo&y = yo
+ end if
+ delete(dNam)
+
+ dNam = getvardims( xo )
+ if (.not.ismissing(dNam)) then
+ fo!(nDimo-1) = dNam
+ fo&$dNam$ = xo
+ else
+ fo!(nDimo-1) = "x"
+ fo&x = xo
+ end if
+
+ return (fo)
+ end
+
+ ; ******************************************************************
+ ; Dennis Shea
+
+ undef("obj_anal_ic_Wrap")
+ function obj_anal_ic_Wrap (xi[*]:numeric,yi[*]:numeric, fi:numeric
+ ,xo[*]:numeric,yo[*]:numeric,rscan[*]:numeric
+ ,opt[1]:logical)
+
+ local fo, dimfi, nDimi, nDimo
+ begin
+ fo = obj_anal_ic (xi,yi,fi, xo,yo,rscan,opt) ; perform interpolation
+
+ dimfi = dimsizes(fi)
+ nDimi = dimsizes(dimsizes(fi)) ; rank: # of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ if (nDimi.ge.2) then ; copy coord vars
+ copy_VarCoords_1(fi,fo) ; except for rightmost dim
+ end if
+
+ nDimo = dimsizes(dimsizes(fo))
+
+ dNam = getvardims( yo )
+ if (.not.ismissing(dNam)) then
+ fo!(nDimo-2) = dNam
+ fo&$dNam$ = yo
+ else
+ fo!(nDimo-2) = "y"
+ fo&y = yo
+ end if
+ delete(dNam)
+
+ dNam = getvardims( xo )
+ if (.not.ismissing(dNam)) then
+ fo!(nDimo-1) = dNam
+ fo&$dNam$ = xo
+ else
+ fo!(nDimo-1) = "x"
+ fo&x = xo
+ end if
+
+ return (fo)
+ end
+ ; ******************************************************************
+ ; Dennis Shea
+ ; wrapper for NCL function runave
+
+ undef ("runave_Wrap")
+ function runave_Wrap( x:numeric, nave[1]:integer, kopt[1]:integer)
+ local xRunAve
+ begin
+ ;xRunAve = x ; 10 Nov 2008
+ xRunAve = runave (x, nave, kopt)
+ copy_VarMeta(x, xRunAve) ; 10 Nov 2008
+ xRunAve at runave_op_ncl = "runave: nave="+nave
+
+ return(xRunAve)
+ end
+ ; ******************************************************************
+ ; Mary Haley
+ ; wrapper for NCL function runave_n
+
+ undef ("runave_n_Wrap")
+ function runave_n_Wrap( x:numeric, nave[1]:integer, kopt[1]:integer,
+ dim[1]:integer)
+ local xRunAve
+ begin
+ ;xRunAve = x
+ xRunAve = runave_n (x, nave, kopt, dim)
+ copy_VarMeta(x, xRunAve)
+ xRunAve at runave_op_ncl = "runave_n: nave="+nave
+
+ return(xRunAve)
+ end
+ ; ******************************************************************
+ ; Dennis Shea
+ ; wrapper for NCL function wgt_runave
+
+ undef ("wgt_runave_Wrap")
+ function wgt_runave_Wrap( x:numeric, wgt[*]:numeric, kopt[1]:integer)
+ local wRunAve
+ begin
+ ;wRunAve = x ; 10 Nov 2008
+ wRunAve = wgt_runave (x, wgt, kopt)
+ copy_VarMeta(x, wRunAve) ; 10 Nov 2008
+ wRunAve at wgt_runave_op_ncl = "wgt_runave"
+
+ return(wRunAve)
+ end
+ ; ******************************************************************
+ ; Mary Haley
+ ; wrapper for NCL function wgt_runave_n
+
+ undef ("wgt_runave_n_Wrap")
+ function wgt_runave_n_Wrap( x:numeric, wgt[*]:numeric, kopt[1]:integer,
+ dim[1]:integer)
+ local wRunAve
+ begin
+ ;wRunAve = x
+ wRunAve = wgt_runave_n (x, wgt, kopt, dim)
+ copy_VarMeta(x, wRunAve)
+ wRunAve at wgt_runave_op_ncl = "wgt_runave_n"
+
+ return(wRunAve)
+ end
+ ; ******************************************************************
+ ; Dennis Shea
+ ; wrapper for NCL function taper
+
+ undef ("taper_Wrap")
+ function taper_Wrap( x:numeric, pct[1]:numeric, kopt[1]:numeric)
+ local xTaper
+ begin
+ ;xTaper = x
+ xTaper = taper (x, pct, kopt)
+ copy_VarMeta(x, xTaper)
+ xTaper at taper_op_ncl = "taper: pct="+sprintf("%4.2f", pct)
+
+ return(xTaper)
+ end
+
+ ; ******************************************************************
+ ; Mary Haley
+ ; wrapper for NCL function taper_n, added 11/1/2009
+ ;
+ undef ("taper_n_Wrap")
+ function taper_n_Wrap( x:numeric, pct[1]:numeric, kopt[1]:numeric,
+ dim[1]:integer)
+ local xTaper
+ begin
+ ;xTaper = x
+ xTaper = taper_n (x, pct, kopt, dim)
+ copy_VarMeta(x, xTaper)
+ xTaper at taper_op_ncl = "taper_n: pct="+sprintf("%4.2f", pct)
+
+ return(xTaper)
+ end
+
+ ; ******************************************************************
+ ; Mary Haley
+ ; wrapper for NCL function escorc
+ ;
+ ; This wrapper is unique because of the multiple
+ ; dimensionality possibilities of x and y.
+
+ undef ("escorc_Wrap")
+ function escorc_Wrap(x:numeric, y:numeric)
+ local ccr, ndims_x, ndims_y, rank_x, rank_y, xnames, ynames
+ begin
+ dsizes_x = dimsizes(x)
+ dsizes_y = dimsizes(y)
+ rank_x = dimsizes(dsizes_x)
+ rank_y = dimsizes(dsizes_y)
+
+ ccr = escorc (x, y)
+
+ if(rank_x.gt.1.and.rank_x.eq.rank_y) then
+ copy_VarCoords_not_n (x, ccr, rank_x-1)
+ else
+ ccr_n = 0 ; dimension counter for ccr
+ if(rank_x.gt.1) then
+ xnames = getvardims(x)
+ do n=0,rank_x-2
+ if (ismissing(xnames(n))) then
+ xnames(n) = "ncl_"+ccr_n
+ end if
+ ccr!ccr_n = xnames(n)
+ if(iscoord(x,xnames(n))) then
+ ccr&$ccr!ccr_n$ = x&$xnames(n)$
+ end if
+ ccr_n = ccr_n + 1
+ end do
+ end if
+ if(rank_y.gt.1) then
+ ynames = getvardims(y)
+ do n=0,rank_y-2
+ if (ismissing(ynames(n))) then
+ ynames(n) = "ncl_"+ccr_n
+ end if
+ ccr!ccr_n = ynames(n)
+ if(iscoord(y,ynames(n))) then
+ ccr&$ccr!ccr_n$ = y&$ynames(n)$
+ end if
+ end do
+ end if
+ end if
+ ccr at escorc_op_ncl = "escorc"
+ return(ccr)
+ end
+
+ ; ******************************************************************
+ ; Mary Haley
+ ; wrapper for NCL function escorc_n
+ ;
+ ; This wrapper is a pain because of the multiple
+ ; dimensionality possibilities of x and y.
+
+ undef ("escorc_n_Wrap")
+ function escorc_n_Wrap(x:numeric,y:numeric,xdims[*]:integer,
+ ydims[*]:integer)
+ local ccr, rank_x, rank_y, xnames, ynames, n, ccr_n
+ begin
+ rank_x = dimsizes(dimsizes(x))
+ rank_y = dimsizes(dimsizes(y))
+
+ ccr = escorc_n (x, y, xdims, ydims)
+ ; copy_VarAtts(x, ccr)
+
+ if(rank_x.gt.1.and.rank_x.eq.rank_y) then
+ copy_VarCoords_not_n (x, ccr, xdims)
+ else
+ ccr_n = 0 ; dimension counter for ccr
+ if(rank_x.gt.1) then
+ xnames = getvardims(x)
+ do n=0,rank_x-1
+ if (.not.any(n.eq.xdims)) then
+ if(ismissing(xnames(n))) then
+ xnames(n) = "ncl_"+ccr_n
+ end if
+ ccr!ccr_n = xnames(n)
+ if(iscoord(x,xnames(n))) then
+ ccr&$ccr!ccr_n$ = x&$xnames(n)$
+ end if
+ ccr_n = ccr_n + 1
+ end if
+ end do
+ end if
+ if(rank_x.gt.1) then
+ ynames = getvardims(y)
+ do n=0,rank_y-1
+ if (.not.any(n.eq.ydims)) then
+ if (ismissing(ynames(n))) then
+ ynames(n) = "ncl_"+ccr_n
+ end if
+ ccr!ccr_n = ynames(n)
+ if(iscoord(y,ynames(n))) then
+ ccr&$ccr!ccr_n$ = y&$ynames(n)$
+ end if
+ ccr_n = ccr_n + 1
+ end if
+ end do
+ end if
+ end if
+
+ ccr at escorc_op_ncl = "escorc_n"
+
+ return(ccr)
+ end
+
+ ; ******************************************************************
+ ; Dennis Shea
+ ; wrapper for NCL function wgt_areaave
+
+ undef ("wgt_areaave_Wrap")
+ function wgt_areaave_Wrap (x:numeric, wgty[*]:numeric, wgtx[*]:numeric, opt:integer)
+ local dimx, rank, areaAve
+ begin
+ dimx = dimsizes(x)
+ rank = dimsizes(dimx)
+ if (rank.lt.2) then
+ print("wgt_areaave_Wrap: incorrect rank")
+ exit
+ end if
+
+ areaAve = wgt_areaave (x, wgty, wgtx, 0)
+
+ if (rank.gt.2) then
+ copy_VarMeta (x, areaAve) ; contributed.ncl (copy meta data)
+ else
+ copy_VarAtts (x, areaAve)
+ if (isatt(areaAve,"gwt")) then
+ delete(areaAve at gwt)
+ end if
+ end if
+
+ areaAve at wgt_areaave_op_ncl = "Area Average"
+
+ return(areaAve)
+ end
+ ; ******************************************************************
+ undef("wgt_runave_leftdim")
+ function wgt_runave_leftdim(x:numeric, wgt[*]:numeric, opt[1]:integer)
+ ;
+ ; utility routine ... makes for cleaner code
+ ; Reorder so time is rightmost; applies Lanczos weights, reorder back
+ ;
+ ; Updated 11/7/2009 to use wgt_runave_n_Wrap
+ ;
+ begin
+ return( wgt_runave_n_Wrap( x, wgt, opt, 0) )
+ end
+ ; ******************************************************************
+ undef("taper_leftdim")
+ function taper_leftdim(x:numeric, pct[1]:numeric, opt[1]:integer)
+ ;
+ ; utility routine ... makes for cleaner code
+ ; Reorder so time is rightmost; applies taper, reorder back
+ ;
+ ; Updated 11/1/2009 to use taper_n_Wrap. No reordering needed.
+ ;
+ local n, dimx, rank, dNam
+ begin
+ if (pct.le.0 .or. pct.gt.1) then
+ print("**************************************************")
+ print("taper_leftdim: no taper: bad input value: pct="+pct)
+ print("**************************************************")
+ return
+ end if
+
+ dimx = dimsizes(x)
+ rank = dimsizes( dimx )
+
+ if (rank.eq.1) then
+ return( taper_Wrap( x, PCT, opt) )
+ end if
+
+ dNam = getvardims( x )
+ do n=0,rank-1
+ if (ismissing(dNam(n))) then
+ dNam(n) = "ncl_"+n
+ x!n = dNam(n)
+ end if
+ end do
+
+ return( taper_n_Wrap( x, pct, opt, 0) )
+ end
+ ;**********************************************************
+ undef("dtrend_leftdim")
+ function dtrend_leftdim(x:numeric, opt[1]:logical)
+ ;
+ ; utility routine ... makes for cleaner code
+ ;
+ ; Pre V5.2.0: Reorder so time is rightmost; detrend the time series,
+ ; reorder back
+ ;
+ ; Post V5.2.0: Updated 11/1/09 to use dtrend_n.
+ ;
+ local x_dtrend
+ begin
+ x_dtrend = x ; retain meta data
+ x_dtrend = dtrend_n( x, opt, 0)
+ return (x_dtrend)
+ end
+
+ ; ******************************************************************
+ ; Ethan Alpert
+ ;
+ ; This is for fortran SEQUENTIAL files that need to be byte swapped. This
+ ; requires *all* records in the file to be the same type and dimension size.
+ ; It also requires that the use provide the dimensionality of each record.
+ ; The number of records is *not* necessary. If you input wrong dimensions
+ ; for each record it *will* screw up the data.
+ ;
+ ; Output file will be sequential access file
+ ;
+ ; [06 Feb 2011 - added support for "long" dims]
+
+ undef ("fbinseqSwap1")
+ procedure fbinseqSwap1(in_file[1]:string, outfile[1]:string
+ ,type[1]:string, dims[*])
+ local indata, tot, n, sz, i, done, tmp
+ begin
+ indata = cbinread(in_file,-1,"byte")
+ tot = tolong(dimsizes(indata))
+ ;print(tot)
+ n = tolong(product(dims)) ; Use longs to handle large sizes
+ ;print(n)
+ if(type.eq."long")
+ print("fbinswap: won't convert longs due to fact that " +
+ "they can be different sizes on different machines, " +
+ "use int64/double for 64 bit ints and integer for 32 bit longs")
+ return
+ end if
+ if(type.eq."short")
+ sz = 2l
+ end if
+ if(any(type.eq.(/"integer","float"/)))
+ sz = 4l
+ end if
+ if(any(type.eq.(/"int64","double"/)))
+ sz = 8l
+ end if
+ ;
+ ; Skip first control word
+ ;
+ i = 4l
+ done = False
+
+ do while(.not.done)
+ tmp = onedtond(indata(i:i+n*sz-1),(/n,sz/))
+ fbinrecwrite(outfile,-1,tmp(:,::-1))
+ ;
+ ; Skip control word after current record and before next
+ ;
+ i = i + 8l + n*sz
+ if(i.ge.tot)
+ done = True
+ end if
+ end do
+ end
+
+ ; ******************************************************************
+ ; Ethan Alpert
+ ; more memory friendly version of fbinseqSwap1
+ ; note: it requires an extra dimension
+ ;
+ ; Output file will be fortran sequential access file
+ ;
+ ; [06 Feb 2011 - added support for "long" dims]
+
+ undef ("fbinseqSwap2")
+ procedure fbinseqSwap2(in_file[1]:string, outfile[1]:string,
+ type[1]:string, nrec[1]:integer, dims[*])
+ local n, sz, i, indata, tmp
+ begin
+ n = tolong(product(dims))
+ if(type.eq."long")
+ print("fbinswap: won't convert longs due to fact that " +
+ "they can be different sizes on different machines, " +
+ "use int64/double for 64 bit longs and integer for 32 bit longs")
+ return
+ end if
+ if(type.eq."short")
+ sz = 2l
+ end if
+ if(any(type.eq.(/"integer","float"/)))
+ sz = 4l
+ end if
+ if(any(type.eq.(/"int64","double"/)))
+ sz = 8l
+ end if
+ recsize = n*sz
+
+ do rnum = 0,nrec,1
+ indata = fbindirread(in_file,rnum,recsize+8,"byte")
+ tmp = onedtond(indata(4:4+recsize-1),(/n,sz/))
+ fbinrecwrite(outfile,-1,tmp(:,::-1))
+ end do
+ end
+ ;******************
+ ;
+ ; This is for fortran DIRECT access files that need to be byte swapped.
+ ; formerly called "reverseEndian"
+ ;
+ ; Output file will be direct access binary file
+ ;
+
+ undef ("fbindirSwap")
+ procedure fbindirSwap (infile:string, dims
+ ,inType:string, outFile:string)
+
+ ; procedure that reads byte reversed data
+ ; create a new output file which can then be read
+ ; via fbindirread or cbinread
+
+ ; Example: fbindirSwap ("/shea/bigEnd", (/100,72,144/) \
+ ; ,"float","/shea/littleEnd")
+ local nBytes, dimBytes, indata
+ begin
+ ;print ("Start fbindirSwap: "+systemfunc("date"))
+
+ nBytes = 4l ; treat as longs just in case large dimensions
+ if (inType.eq."double") then
+ nBytes = 8l
+ end if
+ dimBytes = (/product(dims),nBytes/)
+ ;print (dimBytes)
+ ; read data as bytes
+ indata = fbindirread(infile,0,dimBytes,"byte")
+ ;printVarSummary (indata)
+ ; write to temporary file
+ ; and reverse byte order
+
+ system ("/usr/bin/rm "+outFile) ; delete if it exists
+
+ fbindirwrite(outFile,indata(:,::-1))
+
+ ;print ("End fbindirSwap: "+systemfunc("date"))
+ end
+ ;***************************************************************
+ ; D. Shea
+ ; Calculates a base 2 logarithm.
+
+ undef("LOG2")
+ function LOG2(x:numeric)
+ begin
+ return(log10(x)/log10(2.))
+ end
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "zonal_mpsi" that copies coord variables
+ ; and adds attributes
+
+ ; usage: zmpsi = zonal_mpsi_Wrap (v, lat, p, ps)
+
+ undef ("zonal_mpsi_Wrap")
+ function zonal_mpsi_Wrap (v:numeric, lat[*]:numeric, p[*]:numeric, ps:numeric)
+ local zmpsi
+ begin
+ zmpsi = zonal_mpsi (v, lat, p, ps)
+ copy_VarCoords_1 (v, zmpsi)
+ zmpsi at long_name = "Zonal Meridional Stream Function"
+ zmpsi at units = "kg/s"
+ return (zmpsi)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; transpose a matrix: copies all attributes and coordinate variables
+
+ ; usage: xT = transpose (x)
+
+ undef ("transpose")
+ function transpose (x)
+ local dimx, N, N1, n, X, namedDim, xT
+ begin
+ dimx = dimsizes (x)
+ N = dimsizes( dimx ) ; rank of matrix
+ N1 = N-1 ; for convenience
+
+ if (N.gt.6) then
+ print ("transpose: currently set up for a max of 6 dimensions")
+ exit
+ end if
+ ; is each dimension named?
+ namedDim = getvardims(x)
+ do n=0,N1
+ if (ismissing(namedDim(n))) then
+ x!n = "dim"+n
+ end if
+ end do
+
+ if (N.eq.1) then
+ xx = onedtond(x, (/1,dimx/) )
+ xx!0 = "dumy"
+ xx!1 = x!0
+ xT = xx($xx!1$|:, $xx!0$|:)
+ delete(xT!1)
+ return(xT)
+ end if
+
+ if (N.eq.2) then
+ xT = x($x!N1$|:, $x!(N1-1)$|:)
+ end if
+
+ if (N.eq.3) then
+ xT = x($x!N1$|:, $x!(N1-1)$|:, $x!(N1-2)$|: )
+ end if
+
+ if (N.eq.4) then
+ xT = x($x!N1$|:, $x!(N1-1)$|:, $x!(N1-2)$|:, $x!(N1-3)$|: )
+ end if
+
+ if (N.eq.5) then
+ xT = x($x!N1$|:, $x!(N1-1)$|:, $x!(N1-2)$|:, $x!(N1-3)$|:, $x!(N1-4)$|: )
+ end if
+
+ if (N.eq.6) then
+ xT = x($x!N1$|:, $x!(N1-1)$|:, $x!(N1-2)$|:, $x!(N1-3)$|:, $x!(N1-4)$|:, $x!(N1-5)$|: )
+ end if
+ ; if temporary dim name
+ do n=0,N1
+ if (ismissing(namedDim(n))) then
+ delete(x!n) ; delete temporary name
+ delete(xT!(N1-n))
+ end if
+ end do
+
+ return (xT)
+ end
+
+ ; ------------------------
+
+ ; D Shea
+ ; compute a user specified seasonal mean [all are three-month means]
+ ; DJF,JFM,FMA,MAM,AMJ,MJJ,JJA,JAS,ASO,SON,OND,NDJ
+
+ ; first (DJF=JF) /last (NDJ=ND) seasons are 2-month averages
+ ;
+ ; x(time,lat,lon), x(time,lev,lat,lon)
+ ; ^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^
+ ; must have named dim BUT can be ANY names
+ ;
+ ; The input "x" are assumed to contain monthly mean data
+ ; The size of "time" MUST be divisible by 12.
+ ; Also, it is assumed the "Jan" is the 1st month.
+ ;
+ ; xMon(time) or xMon(time,lat,lon) or xMon(time,lev,lat,lon)
+ ; USAGE xJJA = month_to_season (xMon, "JJA")
+ ;
+ ; RESULT xJJA(time/12,lev,lat,lon) xJJA(time/12,lat,lon)
+ ;
+ ; Note: this returns (7/2003) NMO as an attribute
+
+ undef ("month_to_season")
+ function month_to_season (xMon:numeric, SEASON:string)
+
+ local season,NMO,dimx,rank,ntim,nlat,mlon,nmos,nyrs,con
+ , nyrStrt,nyrLast,nyr,n,xSea, klev, dName,cv,xSea
+ begin
+ season = (/"DJF","JFM","FMA","MAM","AMJ","MJJ"
+ ,"JJA","JAS","ASO","SON","OND","NDJ" /)
+
+ NMO = ind(season.eq.SEASON) ; index corresponding to season
+ if (ismissing(NMO)) then
+ print ("contributed: month_to_season: bad season: SEASON="+SEASON)
+ exit
+ end if
+
+ dimx = dimsizes(xMon)
+ rank = dimsizes(dimx)
+ if (rank.eq.2 .or. rank.ge.5) then
+ print ("contributed: month_to_season: rank="+rank)
+ print ("----- rank currently not handled -----")
+ end if
+
+ nmos = 12
+ ntim = dimx(0)
+ modCheck ("month_to_season", ntim, nmos)
+
+ if (rank.ge.3) then
+ nlat = dimx(rank-2)
+ mlon = dimx(rank-1)
+ end if
+ nyrs = ntim/nmos
+ con = 1./3.
+
+ nyrStrt = 0
+ nyrLast = nyrs-1
+ if (NMO.eq.0) then
+ nyrStrt = 1
+ end if
+ if (NMO.eq.nmos-1) then
+ nyrLast = nyrs-2
+ end if
+
+ if (rank.eq.1) then
+ xSea = new ( nyrs, typeof(xMon), getFillValue(xMon))
+ do nyr=nyrStrt,nyrLast
+ n = nyr*nmos + NMO
+ xSea(nyr) = (xMon(n-1) + xMon(n) + xMon(n+1))*con
+ end do
+ ; special for beginning/end points
+ if (NMO.eq.0) then
+ n = 0
+ xSea(0) = (xMon(n) + xMon(n+1))*0.5
+ end if
+ if (NMO.eq.nmos-1) then
+ n = (nyrs-1)*nmos + NMO
+ xSea(nyrs-1) = (xMon(n) + xMon(n-1))*0.5
+ end if
+
+ end if
+
+ if (rank.eq.3) then
+ xSea = new ( (/nyrs,nlat,mlon/), typeof(xMon), getFillValue(xMon))
+ do nyr=nyrStrt,nyrLast
+ n = nyr*nmos + NMO
+ xSea(nyr,:,:) = (xMon(n-1,:,:) + xMon(n,:,:) + xMon(n+1,:,:))*con
+ end do
+ ; special for beginning/end points
+ if (NMO.eq.0) then
+ n = 0
+ xSea(0,:,:) = (xMon(n,:,:) + xMon(n+1,:,:))*0.5
+ end if
+ if (NMO.eq.nmos-1) then
+ n = (nyrs-1)*nmos + NMO
+ xSea(nyrs-1,:,:) = (xMon(n,:,:) + xMon(n-1,:,:))*0.5
+ end if
+
+ end if
+
+ if (rank.eq.4) then
+ klev = dimx(1)
+ xSea = new ( (/nyrs,klev,nlat,mlon/), typeof(xMon), getFillValue(xMon))
+ do nyr=nyrStrt,nyrLast
+ n = nyr*nmos + NMO
+ xSea(nyr,:,:,:) = (xMon(n-1,:,:,:) + xMon( n ,:,:,:)
+ + xMon(n+1,:,:,:))*0.33333
+ end do
+
+ if (NMO.eq.0) then
+ n = 0
+ xSea(0,:,:,:) = (xMon(n,:,:,:) + xMon(n+1,:,:,:))*0.5
+ end if
+ if (NMO.eq.nmos-1) then
+ n = (nyrs-1)*nmos + NMO
+ xSea(nyrs-1,:,:,:) = (xMon(n,:,:,:) + xMon(n-1,:,:,:))*0.5
+ end if
+ end if
+
+ copy_VarAtts (xMon, xSea)
+ if (isatt(xMon,"long_name") .or. isatt(xMon,"description") .or.
+ isatt(xMon,"standard_name") ) then
+ xSea at long_name = SEASON+": "+getLongName(xMon)
+ end if
+
+ do n=1,rank-1 ; copy spatial coordinates
+ if (.not.ismissing(xMon!n)) then
+ xSea!n = xMon!n
+ if(iscoord(xMon,xMon!n))
+ xSea&$xSea!n$ = xMon&$xMon!n$
+ end if
+ end if
+ end do
+
+ ;n = 0 ; special coordinate for time
+ ;xSea!n = "year"
+ ;if (iscoord(xMon,xMon!n))
+ ; xSea&$xSea!n$ = xMon&$xMon!n$(NMO:ntim-1:nmos)
+ ;end if
+
+ dName = xMon!0
+ xSea!0 = dName
+
+ if(iscoord(xMon,dName)) then
+ cv = xMon&$dName$(NMO:ntim-1:nmos)
+ ; possibly override
+ ;if (isatt(cv,"units") .and. \
+ ; (cv at units.eq."YYYYMM" .or. cv at units.eq."YYMM")) then
+ ; cv = cv/100
+ ; cv at units = "YYYY"
+ ;end if
+ ;if (isatt(cv,"units") .and. cv at units.eq."YYYYMMDD") then
+ ; cv = cv/10000
+ ; cv at units = "YYYY"
+ ;end if
+
+ xSea&$dName$ = cv
+ end if
+
+ xSea at NMO = NMO ; for possible use in subscripting
+ ; eg: nStrt= xSea at NMO ; time(nStrt:ntim-1,12)
+ return (xSea)
+ end
+ ; ------------------------
+
+ ; D Shea
+ ; Compute 12 seasonal (3-mo) averages using monthly data
+ ;
+ ; DJF,JFM,FMA,MAM,AMJ,MJJ,JJA,JAS,ASO,SON,OND,NDJ
+ ; 0 , 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10, 11
+
+ ; first (DJF=JF) /last (NDJ=ND) seasons are 2-month averages
+ ;
+ ; x(time), x(time,lat,lon), x(time,lev,lat,lon)
+ ; ^^^^^^^^^^^^ ^^^^^^^^^^^^^^^^
+ ; must have named dim BUT can be ANY names
+ ;
+ ; The input "x" are assumed to contain monthly mean data
+ ; The size of "time" MUST be divisible by 12
+
+ ; usage: pSea = mon_to_season12 (pMon)
+ ; result pSea(time,lat,lon) or pSea(time,lev,lat,lon)
+
+ undef ("month_to_season12")
+ function month_to_season12 (xMon:numeric)
+ local season,dimx,rank,ntim,nlat,mlon,nmos,nyrs,dNam,i, xSea
+ begin
+ season = (/"DJF","JFM","FMA","MAM","AMJ","MJJ"
+ ,"JJA","JAS","ASO","SON","OND","NDJ" /)
+
+ dimx = dimsizes(xMon)
+ rank = dimsizes(dimx)
+ if (rank.eq.2 .or. rank.ge.5) then
+ print ("contributed: month_to_season12: rank="+rank)
+ print ("----- rank currently not handled -----")
+ end if
+
+ nmos = 12
+ ntim = dimx(0)
+ modCheck ("month_to_season12", ntim, nmos)
+ nyrs = ntim/nmos
+
+ if (rank.ge.3) then
+ nlat = dimx(rank-2)
+ mlon = dimx(rank-1)
+ end if
+
+ dNam = new ( rank, "string") ; save input dim names
+ do i=0,rank-1
+ if (.not.ismissing(xMon!i)) then
+ dNam(i) = xMon!i
+ else
+ print("mon_to_season12: All dimensions must be named")
+ print(" dimension "+i+" is missing" )
+ exit
+ end if
+ end do
+
+ if (rank.eq.1) then ; (time)
+
+ xSea = xMon ; transfer meta and reorder
+ xSea = runave (xSea ,3, 0 ) ; overwrite with seasonal means
+ xSea(0) = (xMon(0) + xMon(1) )*0.5
+ xSea(ntim-1) = (xMon(ntim-2) + xMon(ntim-1) )*0.5
+
+ xSea at long_name = "seasonal means: "+getLongName(xMon)
+ xSea at season = season
+
+ return (xSea)
+ end if
+
+ if (rank.eq.3) then ; (time,lat,lon)
+
+ ;xSea = xMon(lat|:,lon|:,time|:) ; transfer meta and reorder
+ xSea = xMon($dNam(1)$|:,$dNam(2)$|:,$dNam(0)$|:) ; transfer meta and reorder
+ xSea = runave (xSea ,3, 0 ) ; overwrite with seasonal means
+ xSea(:,:,0) = (xMon(0,:,:) + xMon(1,:,:) )*0.5
+ xSea(:,:,ntim-1) = (xMon(ntim-2,:,:) + xMon(ntim-1,:,:) )*0.5
+
+ xSea at long_name = "seasonal means: "+getLongName(xMon)
+ xSea at season = season
+
+ return (xSea($dNam(0)$|:,$dNam(1)$|:,$dNam(2)$|:)) ; reorder and return
+ ;return (xSea(time|:,lat|:,lon|:))
+ end if
+
+ if (rank.eq.4) then ; (time,lev,lat,lon)
+
+ ;xSea = xMon(lev|:,lat|:,lon|:,time|:) ; transfer meta and reorder
+ xSea = xMon($dNam(1)$|:,$dNam(2)$|:,$dNam(3)$|:,$dNam(0)$|:)
+ xSea = runave (xSea ,3, 0 ) ; overwrite with seasonal means
+ xSea(:,:,:,0) = (xMon(0,:,:,:) + xMon(1,:,:,:) )*0.5
+ xSea(:,:,:,ntim-1) = (xMon(ntim-2,:,:,:) + xMon(ntim-1,:,:,:) )*0.5
+
+ xSea at long_name = "seasonal means: "+getLongName(xMon)
+ xSea at season = season
+
+ return (xSea($dNam(0)$|:,$dNam(1)$|:,$dNam(2)$|:,$dNam(3)$|:))
+ ;return (xSea(time|:,lev|:,lat|:,lon|:))
+ end if
+
+ end
+ ; -------------------------------------------------------
+ undef ("month_to_seasonN")
+ function month_to_seasonN (xMon:numeric, SEASON[*]:string)
+
+ ; D Shea
+
+ ; Compute the seasonal (3-mo) average for user specified seasons.
+ ; These are the conventional seasons:
+ ; DJF,JFM,FMA,MAM,AMJ,MJJ,JJA,JAS,ASO,SON,OND,NDJ
+ ;
+ ; xMon(time) or xMon(time,lat,lon) or xMon(time,lev,lat,lon)
+ ;
+ ; The input "x" are assumed to contain monthly mean data
+ ; The size of "time" MUST be divisible by 12.
+ ; Also, it is assumed the "Jan" is the 1st month.
+ ;
+ ; first DJF season is a 2-month average (DJF=JF)
+ ;
+ ; USAGE: xSea = month_to_seasonN (xMon, (/"DJF","MAM","JJA","SON"/))
+ ; : xSea = month_to_seasonN (xMon, (/"DJF","JJA"/))
+ ; : xSea = month_to_seasonN (xMon, (/"JJA","ASO","OND"/))
+ ;
+ ; RESULT xSea(N,time/12,lat,lon) or xSea(N,time/12,lev,lat,lon)
+ ; where N=dimsizes(SEASON)
+
+ ; The above would return:
+ ; xSea(4,time/12,lat,lon) or xSea(4,time/12,lev,lat,lon)
+ ; xSea(2,time/12,lat,lon) or xSea(2,time/12,lev,lat,lon)
+ ; xSea(3,time/12,lat,lon) or xSea(3,time/12,lev,lat,lon)
+ ;
+ ; NOTE: the "time" dimension may have to be altered to the user's desires.
+ ; it may correspond to those associated with the 1st month.
+ local season, N, n, dimx, rank, nmos, ntim, nyrs, xSea12, nlat, mlon
+ , NMO, NMO1, xSeaN, ns, dName, cv
+ begin
+ season = (/"DJF","JFM","FMA","MAM","AMJ","MJJ"
+ ,"JJA","JAS","ASO","SON","OND","NDJ" /)
+ N = dimsizes(SEASON)
+
+ do n=0,N-1
+ if (.not.any(season.eq.SEASON(n))) then
+ print ("month_to_seasonN: You have at least one spelling error "+
+ "in your SEASON specification. "+SEASON(n)+" is not valid.")
+ exit
+ end if
+ end do
+ ; now subset the data
+ dimx = dimsizes(xMon)
+ rank = dimsizes(dimx)
+ if (rank.eq.2 .or. rank.ge.5) then
+ print ("contributed: month_to_seasonN: rank="+rank)
+ print ("----- rank currently not handled -----")
+ end if
+
+ nmos = 12
+ ntim = dimx(0)
+ modCheck ("month_to_seasonN", ntim, nmos)
+
+ nyrs = ntim/nmos
+
+ xSea12 = month_to_season12 (xMon) ; compute the 12 seasons
+
+ if (rank.ge.3) then
+ nlat = dimx(rank-2)
+ mlon = dimx(rank-1)
+ end if
+
+ NMO1 = ind(SEASON(0).eq.season)
+ ; error checking done
+ if (rank.eq.1) then ; (time,lat,lon)
+ xSeaN = new ( (/N,nyrs/), typeof(xSea12), getFillValue(xMon))
+ do ns =0,N-1
+ NMO= ind(SEASON(ns).eq.season)
+ if (.not.ismissing(NMO)) then
+ xSeaN(ns,:) = (/ xSea12(NMO:ntim-1:nmos) /)
+ end if
+ end do
+ end if
+
+ if (rank.eq.3) then ; (time,lat,lon)
+ xSeaN = new ( (/N,nyrs,dimx(1),dimx(2)/), typeof(xSea12),
+ getFillValue(xMon))
+ do ns =0,N-1
+ NMO= ind(SEASON(ns).eq.season)
+ if (.not.ismissing(NMO)) then
+ xSeaN(ns,:,:,:) = (/ xSea12(NMO:ntim-1:nmos,:,:) /)
+ end if
+ end do
+ end if
+
+ if (rank.eq.4) then ; (time,lev,lat,lon)
+ xSeaN = new ( (/N,nyrs,dimx(1),dimx(2),dimx(3)/), typeof(xSea12),
+ getFillValue(xMon))
+ do ns =0,N-1
+ NMO= ind(SEASON(ns).eq.season)
+ if (.not.ismissing(NMO)) then
+ xSeaN(ns,:,:,:,:) = (/ xSea12(NMO:ntim-1:nmos,:,:,:) /)
+ end if
+ end do
+ end if
+ ; copy attributes
+ copy_VarAtts (xMon, xSeaN)
+ if (isatt(xMon,"long_name") .or. isatt(xMon,"description") .or.
+ isatt(xMon,"standard_name") ) then
+ xSeaN at long_name = "Seasonal Means: "+getLongName(xMon)
+ end if
+ ; copy dimension stuff
+ xSeaN!0 = "season"
+ xSeaN&season = SEASON
+
+ dName = xSea12!0
+ xSeaN!1 = dName
+
+ if(iscoord(xSea12,dName)) then
+ cv = xSea12&$dName$(NMO1:ntim-1:nmos)
+ xSeaN&$dName$ = cv
+ ; possibly override
+ if (isatt(cv,"units") .and.
+ (cv at units.eq."YYYYMM" .or. cv at units.eq."YYMM")) then
+ cv = cv/100
+ cv at units = "YYYY"
+ xSeaN&$dName$ = cv
+ end if
+ if (isatt(cv,"units") .and. cv at units.eq."YYYYMMDD") then
+ cv = cv/10000
+ cv at units = "YYYY"
+ xSeaN&$dName$ = cv
+ end if
+ end if
+
+ if (rank.gt.1) then
+ do i=1,rank-1 ; copy spatial coords
+ dName = xSea12!i
+ xSeaN!(i+1) = dName
+ if(iscoord(xSea12,dName)) then
+ xSeaN&$dName$ = xSea12&$dName$
+ end if
+ end do
+ end if
+
+ return (xSeaN)
+ end
+
+ ; -------------------------------------------------------
+ undef ("wave_number_spc")
+ function wave_number_spc (x:numeric, gridType:string)
+
+ ; D Shea
+
+ ; Compute the total power spectrum as a function of wave number
+ ; Currently "x" must have at least two dimensions and
+ ; may have up to four dimensions. The rightmost dimensions
+ ; must be (lat,lon).
+ ;
+ ; x - a numeric array of two to four dimensions (rightmost [lat,lon) ]
+ ; gridType - "g" or "G" for x being a gaussian grid
+ ; - "f" or "F" for x being a regular (fixed) grid
+ ;
+ ; Usage: power = wave_number_spc (T, "G") ; T is gaussian grid
+ ; power = wave_number_spc (X, "F") ; X is fixed grid
+ local dimx, rank, ab, spc, waveNumber
+ begin
+ dimx = dimsizes(x) ; dimension sizes
+ rank = dimsizes(dimx) ; # of dimensions
+
+ if (rank.lt.2 .or. rank.gt.4) then
+ print ("wave_number_spc: rank="+rank+" error")
+ exit
+ end if
+ ; perform analysis
+ if (gridType.eq."G" .or. gridType.eq."g") then
+ ab = shagC (x)
+ end if
+ if (gridType.eq."F" .or. gridType.eq."f") then
+ ab = shaeC (x)
+ end if
+ ; compute power spectra
+ if (rank.eq.2) then
+ spc = x(:,0) ; spc is 1D
+ spc = dim_sum( ab(0,:,:)^2 + ab(1,:,:)^2 )*0.5
+ end if
+
+ if (rank.eq.3) then
+ spc = x(:,:,0) ; spc is 2D
+ spc = dim_sum( ab(0,:,:,:)^2 + ab(1,:,:,:)^2 )*0.5
+ end if
+
+ if (rank.eq.4) then
+ spc = x(:,:,:,0) ; spc is 3D
+ spc = dim_sum( ab(0,:,:,:,:)^2 + ab(1,:,:,:,:)^2 )*0.5
+ end if
+
+ waveNumber = ispan(1,dimx(rank-2),1)
+ waveNumber!0 = "wave_number"
+ waveNumber at long_name = "Wave Number"
+
+ spc!(rank-2) = waveNumber!0
+ spc&$waveNumber!0$ = waveNumber
+ spc at long_name = "Power"
+ if (isatt(x,"units")) then
+ spc at units = "(" + x at units + ")^2"
+ end if
+
+ return (spc)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; set all values X +/- eps of zero to 0
+ ; X can be ANY dimensions
+ ; note: "abs" is NOT generic like in fortran
+ ;
+ ; Usage: let X = (/ 1,-2, -999., 1.e-05, -1.e-07, 10/)
+ ; X at _FillValue = -999.
+ ; eps = 1.e-04
+ ; epsZero (X, eps)
+ ; result X = (/ 1,-2, -999., 0., 0., 10/)
+
+ undef ("epsZero")
+ procedure epsZero (X:numeric, eps:numeric)
+ local FillValue
+ begin
+ if (isatt(X,"_FillValue")) then
+ FillValue = X at _FillValue ; save the _FillValue
+ delete (X at _FillValue) ; delete original
+ end if
+
+ X at _FillValue = 0.0 ; temporary [trick]
+
+ if (typeof(X).eq."float" .or. typeof(X).eq."double") then
+ X = mask(X,fabs(X).le.eps,False)
+ else
+ X = mask(X, abs(X).le.eps,False)
+ end if
+
+ delete (X at _FillValue) ; delete temporary
+ if (isvar("FillValue")) then
+ X at _FillValue = FillValue ; restore original _FillValue
+ end if
+
+ end
+
+ ; M Haley
+ ; you pass it your multi-dimensioned data array, and
+ ; it will return the indices in that array where the
+ ; first maximum value occurs.
+
+ ; ****> superceded by NCL built-in function "ind_resolve"
+
+ undef ("maxind_ind")
+ function maxind_ind(data:numeric)
+ local i, dsizes, ndims, max_index, ind_product, data_indices, new_val
+ begin
+ dsizes = dimsizes(data) ; dimension sizes
+ ndims = dimsizes(dsizes) ; number of dimensions
+ if(ndims.eq.1)
+ return(maxind(data))
+ end if
+
+ max_index = maxind(ndtooned(data)) ; Get index of first maximum value.
+
+ if(ismissing(max_index))
+ return(max_index)
+ end if
+
+ ind_product = new(ndims,integer) ; This array is used to
+ ind_product(ndims-1) = 1 ; calculate indices.
+
+ do i = ndims-2,0,1
+ ind_product(i) = dsizes(i+1) * ind_product(i+1)
+ end do
+
+ data_indices = new(ndims,integer) ; Will hold the return indices.
+
+ new_val = max_index
+ do i = 0,ndims-1
+ data_indices(i) = new_val/ind_product(i) ; Calculate index.
+ new_val = new_val % ind_product(i) ; "%" is the modulus operator.
+ end do
+
+ delete(ind_product) ; Clean up.
+ delete(max_index)
+ delete(dsizes)
+
+ return(data_indices) ; Return the indices.
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+
+ ; Bring one or more files from the MSS to a local directory
+ ; The options are those for msrcp. The MSS files can be from different dir.
+ ; Usage: mssFiles = (/ "/SHEA/sample/dummy1", ... /) ; a 1D array of MSS names
+ ; target_dir = "/ptmp/shea/whatever/" ; a local directory
+ ; msrcp_mss2local (mssFiles, target_dir, "-n" )
+ undef ("msrcp_mss2local")
+ procedure msrcp_mss2local (source:string,target_dir:string,opts:string)
+ local dims, cmd, mssList, n
+ begin
+ dims = dimsizes(source)
+ if (dims(0).eq.1) then
+ cmd = "msrcp "+opts+" 'mss:"+source+" "+target_dir
+ else
+ mssList = ""
+ do n=0,dims(0)-1
+ mssList = mssList + " mss:"+source(n)
+ end do
+ cmd = "msrcp "+opts + mssList +" "+ target_dir
+ end if
+
+ print ("msrcp_mss2local: "+dims(0)+" files: tStart= "+systemfunc("date"))
+ ;print (cmd)
+ system(cmd)
+ print ("msrcp_mss2local: "+dims(0)+" files: tEnd = "+systemfunc("date"))
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; old ... undocumented function: use "yyyymm_to_yyyyfrac"
+ ; given, say, yyyymm = (/ 197901 , 198407, 200112 /)
+ ; yrFrac = yyyymm2yyyyFrac (yyyymm)
+ ; yrFrac ==> [1979.0 , 1979.5 , 2001.917]
+ ;
+ ; yyyymm - scalar or array of dates
+ ;
+ undef("yyyymm2yyyyFrac")
+ function yyyymm2yyyyFrac (yyyymm:integer)
+ local year, mon, yrFrac
+ begin
+ year = yyyymm/100
+ mon = yyyymm-year*100
+ yrFrac = year + (mon-1.)/12.
+
+ yrFrac at long_name = "Time"
+ yrFrac at units = "YYYY + fractional portion of year"
+ yrFrac at info = "derived using: function yyyymm2yyyyFrac"
+
+ return(yrFrac)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ;
+ ; given, say, yyyymm = (/ 197901 , 198407, 200112 /)
+ ; yrFrac = yyyymm_to_yyyyfrac (yyyymm, 0.0)
+ ; yrFrac ==> [1979.0 , 1979.5 , 2001.917]
+ ;
+ ; yyyymm - scalar or array of dates
+ ; mm_offset - 0.0 or 0.5
+ ;
+ undef("yyyymm_to_yyyyfrac")
+ function yyyymm_to_yyyyfrac (yyyymm[*]:numeric, mmOffset[1]:numeric)
+ local YYYYMM, year, mm, xmos, one, yrFrac
+ begin
+ if (typeof(yyyymm).eq."double" .or. typeof(mmOffset).eq."double") then
+ xmos = 12.d0
+ one = 1.0d0
+ YYYYMM = toint(yyyymm) ; numerical issue
+ else
+ xmos = 12.0
+ one = 1.0
+ if (typeof(yyyymm).eq."float") then
+ YYYYMM = toint(yyyymm) ; numerical issue
+ else
+ YYYYMM = yyyymm
+ end if
+ end if
+
+ year = YYYYMM/100
+ mm = YYYYMM-year*100
+ yrFrac = year + ((mm+mmOffset)-one)/xmos
+
+ copy_VarMeta(yyyymm, yrFrac)
+
+ yrFrac at units = "YYYY + fractional portion of year"
+ yrFrac at NCL = "derived using function yyyymm_to_yyyyfrac"
+
+ return(yrFrac)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; given, say, 19790719 where 0719 (mmdd) is the 200th day of the year
+ ; yrFrac = yyyymmdd2yyyyFrac (19790719)
+ ; yrFrac = 1979.545 ( [200-1]/365.= 0.545..)
+ ;
+ ; yyyymmdd - scalar or array of dates
+ ;
+ ; 6.2.0: calendar attribute
+ ;
+ undef ("yyyymmdd2yyyyFrac")
+ function yyyymmdd2yyyyFrac (yyyymmdd:numeric, ddOffset[1]:numeric)
+ local ntim, year, mmdd, mon, day, dayYear, nDay, yrFrac, n, con, varType, YYYYMMDD
+ begin
+ ntim = dimsizes(yyyymmdd)
+
+ if (isatt(yyyymmdd,"calendar") .and. yyyymmdd at calendar.eq."proleptic_gregorian") then
+ print("yyyymmdd_to_yyyyfrac: yyyymmdd2yyyyFrac: proleptic_gregorian calendar not supported")
+ yrFrac = new( ntim, typeof(yyyymmdd))
+ yrFrac at long_name = "yyyymmdd_to_yyyyfrac: yyyymmdd2yyyyFrac: proleptic_gregorian calendar not supported"
+ return(yrFrac)
+ end if
+
+ varType = typeof(yyyymmdd)
+
+ if (varType.eq."integer") then
+ YYYYMMDD = yyyymmdd
+ else
+ YYYYMMDD = toint(yyyymmdd)
+ end if
+
+ year = YYYYMMDD/10000
+ mmdd = YYYYMMDD-year*10000
+ delete(YYYYMMDD)
+
+ mon = mmdd/100
+ day = mmdd-mon*100
+ delete (mmdd)
+
+ if (isatt(yyyymmdd,"calendar")) then ; retrofit code for calendar
+ year at calendar = yyyymmdd at calendar ; check for calendar
+ end if
+
+ dayYear = day_of_year(year, mon, day)
+ delete ( [/mon, day /] )
+
+ nDay = dimsizes(yyyymmdd) ; all days
+ if (varType.eq."double") then
+ yrFrac = new( nDay, "double")
+ one = 1d0
+ else
+ yrFrac = new( nDay, "float")
+ one = 1.0
+ end if
+ delete(yrFrac at _FillValue)
+
+ if (isatt(yyyymmdd,"calendar")) then ; retrofit to existing code
+ yrFrac at calendar = yyyymmdd at calendar
+
+ if (yyyymmdd at calendar.eq."360_day" .or. yyyymmdd at calendar.eq."360") then
+ con = (/ 360, 360 /)*one
+ end if
+ if (yyyymmdd at calendar.eq."365_day" .or. yyyymmdd at calendar.eq."365" .or.
+ yyyymmdd at calendar.eq."noleap" .or. yyyymmdd at calendar.eq."no_leap") then
+ con = (/ 365, 365 /)*one
+ end if
+ if (yyyymmdd at calendar.eq."366_day" .or. yyyymmdd at calendar.eq."366" .or.
+ yyyymmdd at calendar.eq."allleap" .or. yyyymmdd at calendar.eq."all_leap") then
+ con = (/ 366, 366 /)*one
+ end if
+ if (yyyymmdd at calendar.eq."gregorian" .or. yyyymmdd at calendar.eq."standard") then
+ con = (/ 365, 366 /)*one
+ end if
+ else
+ con = (/ 365, 366 /)*one ; default is gregorian/standard
+ end if
+
+ do n=0,nDay-1
+ if (isleapyear(year(n))) then
+ yrFrac(n) = year(n) + ((dayYear(n)-1)+ddOffset)/con(1)
+ else
+ yrFrac(n) = year(n) + ((dayYear(n)-1)+ddOffset)/con(0)
+ end if
+ end do
+
+ yrFrac at long_name = "Time"
+ yrFrac at units = "YYYY + fractional portion of year"
+ yrFrac at info = "derived using: function yyyymmdd_to_yyyyFrac"
+
+ return(yrFrac)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; a function that invokes yyyymmdd2yyyyFrac
+ ; name consistent with yyyymm_to_yyyyfrac
+ undef("yyyymmdd_to_yyyyfrac")
+ function yyyymmdd_to_yyyyfrac (yyyymmdd:numeric, ddOffset:numeric)
+ local varType
+ begin
+ varType = typeof(yyyymmdd)
+ if (varType.eq."integer" .or.
+ varType.eq."float" .or.
+ varType.eq."double" ) then
+ return (yyyymmdd2yyyyFrac (yyyymmdd, ddOffset))
+ else
+ print("yyyymmdd_to_yyyyfrac: variable type="+varType+" not supported")
+ exit
+ end if
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ;
+ ; given, say, 1979071906 where 0719 is the 200th day of the year
+ ; yrFrac = yyyymmddhh2yyyyFrac (1979071906)
+ ; yrFrac = 1979.5458984375 ([200-1]*86400.+hh*3600.)/(86400*365)
+ ;
+ ; yyyymmddhh - scalar or array of dates
+ ;
+ ; assumes Gregorian calendar
+
+ undef ("yyyymmddhh2yyyyFrac")
+ function yyyymmddhh2yyyyFrac (yyyymmddhh[*]:numeric)
+ local year, mmddhh, mon, ddhh, day, hour, dayYear, nTim, yrFrac
+ , n, ysec, dsec, varType, YEAR
+ begin
+ varType = typeof(yyyymmddhh)
+
+ if (varType.eq."integer") then
+ YYYYMMDDHH = yyyymmddhh
+ else
+ YYYYMMDDHH = toint(yyyymmddhh)
+ end if
+
+ year = YYYYMMDDHH/1000000
+ mmddhh = YYYYMMDDHH-year*1000000
+ delete(YYYYMMDDHH)
+
+ mon = mmddhh/10000
+ ddhh = mmddhh-mon*10000
+ delete (mmddhh)
+
+ day = ddhh/100
+ hour = ddhh-day*100
+ delete (ddhh)
+
+ if (isatt(yyyymmddhh,"calendar")) then
+ year at calendar = yyyymmddhh at calendar ; check for calendar
+ end if
+
+ dayYear = day_of_year(year, mon, day) ; Gregorian calendar
+ delete ([/mon, day/])
+
+ nTim = dimsizes(yyyymmddhh)
+
+ if (varType.eq."double") then
+ yrFrac = new( nTim, "double", "No_FillValue")
+ one = 1d0
+ else
+ yrFrac = new( nTim, "float", "No_FillValue")
+ one = 1.0
+ end if
+
+ if (isatt(yyyymmddhh,"calendar")) then ; retrofit to existing code
+ yrFrac at calendar = yyyymmddhh at calendar
+
+ if (yyyymmddhh at calendar.eq."360_day" .or. yyyymmddhh at calendar.eq."360") then
+ con = (/ 360, 360, 86400, 3600 /)*one
+ end if
+ if (yyyymmddhh at calendar.eq."365_day" .or. yyyymmddhh at calendar.eq."365" .or.
+ yyyymmddhh at calendar.eq."noleap" .or. yyyymmddhh at calendar.eq."no_leap") then
+ con = (/ 365, 365, 86400, 3600 /)*one
+ end if
+ if (yyyymmddhh at calendar.eq."366_day" .or. yyyymmddhh at calendar.eq."366" .or.
+ yyyymmddhh at calendar.eq."allleap" .or. yyyymmddhh at calendar.eq."all_leap") then
+ con = (/ 366, 366, 86400, 3600 /)*one
+ end if
+ if (yyyymmddhh at calendar.eq."gregorian" .or. yyyymmddhh at calendar.eq."standard") then
+ con = (/ 365, 366, 86400, 3600 /)*one
+ end if
+ else
+ con = (/ 365, 366, 86400, 3600 /)*one ; default is gregorian/standard
+ end if
+
+ do n=0,nTim-1
+ if (isleapyear(year(n))) then
+ ysec = con(2)*con(1)
+ else
+ ysec = con(2)*con(0)
+ end if
+ dsec = (dayYear(n)-1)*con(2) + hour(n)*con(3)
+ yrFrac(n) = year(n) + dsec/ysec
+ end do
+
+ yrFrac at long_name = "Time"
+ yrFrac at units = "YYYY + fractional portion of year"
+ yrFrac at NCL = "contributed.ncl: function yyyymmddhh_to_yyyyFrac"
+
+ return(yrFrac)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; a function that invokes yyyymmddhh2yyyyFrac
+ ; name consistent with yyyymm_to_yyyyfrac
+ ; name consistent with yyyymmdd_to_yyyyfrac
+ ;
+ ; ignore hhOffset
+ ;
+ undef("yyyymmddhh_to_yyyyfrac")
+ function yyyymmddhh_to_yyyyfrac (yyyymmddhh:numeric, hhOffset[1]:numeric)
+ local varType
+ begin
+ varType = typeof(yyyymmddhh)
+
+ if (varType.eq."integer" .or.
+ varType.eq."float" .or.
+ varType.eq."double" ) then
+ return (yyyymmddhh2yyyyFrac (yyyymmddhh))
+ else
+ print("yyyymmddhh_to_yyyyfrac: variable type="+varType+" not supported")
+ exit
+ end if
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; convert initial_time (type string) to integer time
+ ;
+ ; 01/01/1997 (18:00) <==> MM/DD/YYYY (HH:NN) {ignore NN}
+ ; return will be integer of form YYYYMMDDHH
+ ;
+ undef ("grib_stime2itime")
+ function grib_stime2itime(stime[*]:string)
+ local N, time, i, tmp_c
+ begin
+
+ N = dimsizes(stime)
+ time = new( N ,integer)
+ delete(time at _FillValue)
+
+ do i=0,N-1
+ tmp_c = stringtochar(stime(i))
+ time(i) = stringtointeger((/tmp_c(6:9)/)) * 1000000 +
+ stringtointeger((/tmp_c(0:1)/)) * 10000 +
+ stringtointeger((/tmp_c(3:4)/)) * 100 +
+ stringtointeger((/tmp_c(12:13)/))
+ end do
+
+ time!0 = "time"
+ time at long_name = "time"
+ time at units = "yyyymmddhh"
+
+ time&time = time ; make coordinate variable
+ return (time)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; convert initial_time (type string) to COARDS time
+ ;
+ ; 01/01/1997 (18:00) <==> MM/DD/YYYY (HH:NN) {ignore NN}
+ ; return will be "double"
+ ; Usage:
+ ; sit0 = a->initial_time0
+ ; time = grib_stime2COARDStime(sit0, "days since 1801-01-01 00:00:0.0")
+ ; ^^^^ can be anything^^^^^^^^^^^^
+ ;
+ undef ("grib_stime2COARDStime")
+ function grib_stime2COARDStime(stime[*]:string, tunits:string)
+ local N, time, tmp_c, year, month, day, hour, min, sec
+ begin
+
+ N = dimsizes(stime)
+ time = new( N ,"double")
+ time at units = tunits
+ time!0 = "time"
+ time at long_name = "time"
+
+ tmp_c = stringtochar(stime)
+ year = stringtointeger((/tmp_c(:,6:9)/))
+ month = stringtointeger((/tmp_c(:,0:1)/))
+ day = stringtointeger((/tmp_c(:,3:4)/))
+ hour = stringtointeger((/tmp_c(:,12:13)/))
+ min = stringtointeger((/tmp_c(:,15:16)/))
+ sec = new( N ,"float")
+ sec = 0.0
+
+ time = (/ cd_inv_calendar(year,month,day,hour,min,sec,tunits, 0) /)
+
+ time&time = time ; make coordinate variable
+
+ if (isatt(time,"_FillValue")) then
+ delete(time at _FillValue)
+ end if
+ return (time)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; Concatenate 2 (or more) variables to create one variable
+ ; All dimensions must match except for the leftmost (record) dimension
+ ;
+ ; Usage: let xa(22,73,144) and xb(38,73,144)
+ ; X = cat2Var(xa,xb) ; X(60,73,144)
+ ; Note: More than two variables can be concatenated by embedding the function
+ ; let xa(22,73,144), xb(38,73,144), xc(5,73,144), xd(25,73,144)
+ ; Xabc = cat2Var( cat2Var(xa,xb), xc) ; X(65,73,144)
+ ; Xabcd = cat2Var (cat2Var( cat2Var(xa,xb), xc), xd ) ; X(90,73,144)
+ ;
+ undef ("cat2Var")
+ function cat2Var (xa, xb)
+ local dim_xa, dim_xb, rank_xa, rank_xb, rank, nr_xa, nr_xb, dim_X
+ , X, nab, i, ca, cb, cv
+ begin
+ dim_xa = dimsizes(xa)
+ dim_xb = dimsizes(xb)
+
+ rank_xa = dimsizes(dim_xa)
+ rank_xb = dimsizes(dim_xb)
+
+ if (rank_xa.ne.rank_xb) then
+ print ("contributed.ncl: cat2Var: rank mismatch")
+ exit
+ end if
+
+ rank = rank_xa ; all rank the same
+
+ if (rank.gt.5) then
+ print ("contributed.ncl: cat2Var: rank="+rank+" too big: change function")
+ exit
+ end if
+
+ if (rank.gt.1) then
+ if (.not.all(dim_xa(1:).eq.dim_xb(1:))) then
+ print ("contributed.ncl: cat2Var: non-record dim(s) must match")
+ exit
+ end if
+ end if
+
+ if (typeof(xa).ne.typeof(xb)) then
+ print ("contributed.ncl: cat2Var: types must match (could be worked around) ")
+ exit
+ end if
+
+ nr_xa = dim_xa(0) ; # of records in xa
+ nr_xb = dim_xb(0) ; xb
+
+ dim_X = dim_xa
+ dim_X(0) = nr_xa + nr_xb
+
+ X = new (dim_X, typeof(xa), getFillValue(xa) )
+
+ nab = nr_xa+nr_xb-1 ; last subscript
+
+ if (rank.eq.1) then
+ X(0:nr_xa-1) = (/ xa /)
+ X(nr_xa:nab) = (/ xb /)
+ end if
+ if (rank.eq.2) then
+ X(0:nr_xa-1,:) = (/ xa /)
+ X(nr_xa:nab,:) = (/ xb /)
+ end if
+ if (rank.eq.3) then
+ X(0:nr_xa-1,:,:) = (/ xa /)
+ X(nr_xa:nab,:,:) = (/ xb /)
+ end if
+ if (rank.eq.4) then
+ X(0:nr_xa-1,:,:,:) = (/ xa /)
+ X(nr_xa:nab,:,:,:) = (/ xb /)
+ end if
+ if (rank.eq.5) then
+ X(0:nr_xa-1,:,:,:,:) = (/ xa /)
+ X(nr_xa:nab,:,:,:,:) = (/ xb /)
+ end if
+
+ copy_VarAtts (xa, X) ; contributed.ncl
+
+ if (rank.gt.1) then
+ do i=1,rank-1 ; copy all coords but rec dim
+ if (.not.ismissing(xa!i)) then
+ X!i = xa!i ; copy named dimension
+ if(iscoord(xa,xa!i)) then ; is there a coord var
+ X&$X!i$ = xa&$xa!i$ ; copy coord variable
+ end if
+ end if
+ end do
+ end if
+
+ if (.not.ismissing(xa!0)) then
+ X!0 = xa!0 ; copy named dimension
+ if(iscoord(xa,xa!0) .and. iscoord(xb,xb!0)) then ; is there a coord var
+ ca = xa&$xa!0$
+ cb = xb&$xb!0$
+ cv = new ( dim_X(0), typeof(ca) )
+ delete (cv at _FillValue)
+ cv(0:nr_xa-1) = (/ ca /)
+ cv(nr_xa:nab) = (/ cb /)
+ X&$X!0$ = cv
+ end if
+ end if
+
+ return (X)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; Basically, this takes a 2D {homo/hetero}geneous array
+ ; and partitions it into a 3D array with lat/lon coordinate
+ ; arrays. Attributes are also added.
+ ;
+ ; usage:
+ ; homlft = new((/nsvd,ncols/),typeof(x))
+ ; hetlft = new((/nsvd,ncols/),typeof(x))
+ ; homrgt = new((/nsvd,ncols/),typeof(x))
+ ; hetrgt = new((/nsvd,ncols/),typeof(x))
+ ; pcvar = svdstd(x,y,nsvd,homlft,hetlft,homrgt,hetrgt)
+ ;
+ ; HOMLFT = svdHomHet2latlon(homlft,lat,lon,"homogeneous left" ,"")
+ ; HOMRGT = svdHomHet2latlon(homrgt,lat,lon,"homogeneous right" ,"")
+ ; HETLFT = svdHomHet2latlon(hetlft,lat,lon,"heterogeneous left" ,"")
+ ; HETRGT = svdHomHet2latlon(hetrgt,lat,lon,"heterogeneous right" ,"")
+ ;
+ undef ("svdHomHet2latlon")
+ function svdHomHet2latlon (x[*][*]:numeric
+ ,lat[*]:numeric, lon[*]:numeric
+ ,long_name:string, units:string )
+ local nlat, mlon, dimx, nsvd, ncols, X
+ begin
+ nlat = dimsizes(lat)
+ mlon = dimsizes(lon)
+
+ dimx = dimsizes(x)
+ nsvd = dimx(0)
+ ncols = dimx(1)
+
+ if ((nlat*mlon).ne.ncols) then
+ print ("contributed: svdHomHet2latlon: size mismatch: nlat="+nlat
+ +" mlon="+mlon+" ncols="+ncols
+ +" nlat*mlon="+(nlat*mlon) )
+ exit
+ end if
+
+ X = onedtond( ndtooned(x), (/nsvd,nlat,mlon/) )
+ X!0 = "svd"
+ X!1 = "lat"
+ X!2 = "lon"
+ X&svd = ispan(1,nsvd,1)
+ X&lat = lat
+ X&lon = lon
+
+ X at long_name = long_name
+ X at units = units
+
+ return (X)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; Basically, this takes a 1D expansion coef
+ ; and partitions it into a 2D array with (svd,time)
+ ; arrays. Attributes are also added.
+ ;
+ ; usage:
+ ; pcvar = svdstd(x,y,nsvd,homlft,hetlft,homrgt,hetrgt)
+ ; or
+ ; pcvar = svdcoc(x,y,nsvd,homlft,hetlft,homrgt,hetrgt)
+ ;
+ ; ak = svdAkBk2time (pcvar at ak, nsvd, time, "Exp Coef AK","")
+ ; bk = svdAkBk2time (pcvar at bk, nsvd, time, "Exp Coef BK","")
+ ;
+ undef ("svdAkBk2time")
+ function svdAkBk2time (xk[*]:numeric, nsvd:integer, time[*]:numeric
+ ,long_name:string, units:string )
+ local ntim, nxk, XK
+ begin
+ ntim = dimsizes(time)
+ nxk = dimsizes(xk)
+
+ if ((nsvd*ntim).ne.nxk) then
+ print ("contributed: svdAkBk2time: size mismatch: nsvd="+nsvd
+ +" ntim="+ntim+" nxk="+nxk
+ +" nsvd*ntim="+(nsvd*ntim) )
+ exit
+ end if
+
+ XK = onedtond ( xk, (/nsvd,ntim/) )
+ XK!0 = "svd"
+ XK!1 = "time"
+ XK&svd = ispan(1,nsvd,1)
+ XK&time = time
+
+ XK at long_name = long_name
+ XK at units = units
+
+ return (XK)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ undef ("timeCoads2YYYYMM")
+ function timeCoads2YYYYMM (yrStrt:integer, yrLast:integer, TYPE:string)
+ ;
+ ; This was a *terrible* name for a function.
+ ; It was never explicitly documented.
+ ; It was used in some "COADS" application examples.
+ ; The function "yyyymm_time" is documented.
+ ; It is just a different interface to this function.
+ ;
+ ; usage
+ ; yrLast = 1997 ; last year on this COADS file
+ ; yyyymm = timeCoads2YYYYMM (1800,yrLast,typeof(time))
+ local nmos, nyrs, ntim, time, n
+ begin
+ nmos = 12
+ nyrs = yrLast-yrStrt+1
+ ntim = nmos*nyrs
+
+ time = new ( ntim, TYPE)
+ n = 0
+ do yr=yrStrt,yrLast
+ time(n:n+nmos-1) = yr*100 + ispan(1,nmos,1)
+ n = n+nmos
+ end do
+
+ time at long_name = "time"
+ time at units = "YYYYMM"
+
+ if (isatt(time,"_FillValue")) then
+ delete(time at _FillValue)
+ end if
+ time!0 = "time"
+ time&time = time
+
+ return (time)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ undef ("yyyymm_time")
+ function yyyymm_time (yrStrt:integer, yrLast:integer, TYPE:string)
+ ;
+ ; documented interface to "timeCoads2YYYYMM"
+ ; It is just a different interface to this function.
+ ;
+ ; usage
+ ; yyyymm = yyyymm_time (1800,2001, "integer")
+ begin
+ return( timeCoads2YYYYMM (yrStrt, yrLast, TYPE) )
+ end
+ ;*************************************************************************
+ ; Nadine Salzmann and Simon Scherrer
+
+ undef ("yyyymmdd_time")
+
+ function yyyymmdd_time (yrStrt:integer, yrLast:integer, TYPE:string)
+ local n, nmos, nyrs, ntim, year, nmo, ndy, tdum
+ begin
+ nmos = 12
+ nyrs = yrLast-yrStrt+1
+ ntim = nyrs*nmos*31 ; make long enough array
+ tdum = new ( ntim, TYPE, "No_FillValue" )
+
+ year = 0
+ if (isatt(yrStrt,"calendar")) then
+ year at calendar = yrStrt at calendar
+ end if
+
+ n = -1 ; initialize day counter
+ do year = yrStrt,yrLast
+ do nmo=1,nmos
+ YRM = year*10000 + nmo*100
+ nday = days_in_month(year, nmo)
+ do ndy = 1,nday
+ n = n+1
+ tdum(n) = YRM + ndy
+ end do
+ end do
+ end do
+
+ time = tdum(0:n) ; cut out only filled in times
+ time at long_name = "time"
+ time at units = "YYYYMMDD"
+
+ if (isatt(yrStrt,"calendar")) then
+ time at calendar = yrStrt at calendar
+ end if
+
+ time!0 = "time"
+ time&time = time
+ return (time)
+ end
+ ;*************************************************************************
+
+ undef ("yyyymmddhh_time")
+ function yyyymmddhh_time (yrStrt[1]:integer, yrLast[1]:integer, hrStep[1]:integer, TYPE:string)
+ local n, nmos, nyrs, ntim, year, nmo, ndy, tdum, nhr, nhrs
+ begin
+ nmos = 12
+ nyrs = yrLast-yrStrt+1
+ nhrd = 24/hrStep ; # of hours per day
+ ntim = nyrs*nmos*nhrd*31 ; make long enough array
+ tdum = new ( ntim, TYPE, "No_FillValue" )
+
+ year = 0
+ if (isatt(yrStrt,"calendar")) then
+ year at calendar = yrStrt at calendar ; needed for days in month
+ end if
+
+ n = -1 ; initialize counter index
+ do year=yrStrt,yrLast
+ do nmo=1,nmos
+ YRM = year*1000000 + nmo*10000
+ nday = days_in_month(year, nmo)
+ do ndy=1,nday
+ do nhr=0,23,hrStep
+ n = n+1
+ tdum(n) = YRM + ndy*100 + nhr
+ end do
+ end do
+ end do
+ end do
+
+ time = tdum(0:n) ; cut out only filled in times
+ time at long_name = "time"
+ time at units = "YYYYMMDDHH"
+
+ if (isatt(yrStrt,"calendar")) then
+ time at calendar = yrStrt at calendar
+ end if
+
+ time!0 = "time"
+ time&time = time
+ return (time)
+ end
+ ;*************************************************************************
+ ; D. Shea
+ ; Parse (Partition) YYYYMM, YYYYMMDD, YYYYMMDDHH into a (:,6) array
+
+ undef("date_expand")
+ function date_expand(date[*]:numeric, opt:integer)
+ local ndate, DATE, utest, yyyy, mm, dd, hh, mn, sc
+ begin
+ ndate = dimsizes(date)
+ DATE = new( (/ndate,6/), "integer", "No_FillValue")
+
+ if (.not.isatt(date,"units")) then
+ print(" ")
+ print("date_expand: no units attribute: no expansion")
+ print(" ")
+ return(DATE)
+ end if
+
+ utest = str_lower(date at units)
+ if (.not.any(utest.eq.(/"yyyymm","yyyymmdd","yyyymmddhh"/))) then
+ print(" ")
+ print("date_expand: units not recognized: units="+date at units)
+ print("recognized units: yyyymm,yyyymmdd,yyyymmddhh or YYYYMM,YYYYMMDD,YYYYMMDDHH")
+ print(" ")
+ return(DATE)
+ end if
+
+ mn = conform(date, 0, -1)
+ sc = conform(date, 0, -1)
+
+ if (utest.eq."yyyymm") then
+ yyyy = date/100
+ mm = date-(yyyy*100)
+ dd = conform(date, 0, -1)
+ hh = conform(date, 0, -1)
+ end if
+
+ if (utest.eq."yyyymmdd") then
+ yyyy = date/10000
+ mmdd = date-(yyyy*10000)
+ mm = mmdd/100
+ dd = mmdd-(mm*100)
+ hh = conform(date, 0, -1)
+ end if
+
+ if (utest.eq."yyyymmddhh") then
+ yyyy = date/1000000
+ mmddhh = date-(yyyy*1000000)
+ mm = mmddhh/10000
+ mmdd = mmddhh/100
+ dd = mmdd-(mm*100)
+ hh = date-(yyyy*1000000+mm*10000+dd*100)
+ end if
+
+ DATE(:,0) = yyyy
+ DATE(:,1) = mm
+ DATE(:,2) = dd
+ DATE(:,3) = hh
+ DATE(:,4) = mn
+ DATE(:,5) = sc
+ DATE at long_name = "time elements"
+ DATE at units = "yyyy,mm,dd,hh,m,sc"
+
+ dName = getvardims(date)
+ if (.not.ismissing(dName)) then
+ DATE!0 = dName
+ if (iscoord(date,dName)) then
+ DATE&$dName$ = date&$dName$
+ end if
+ end if
+
+ if (isatt(date,"calendar")) then
+ DATE at calendar = date at calendar
+ end if
+
+ return(DATE)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; Read simple f90 namelist file as indicated by Ben Foster [HAO]
+ ; An integer variable is returned. Upon return it will have
+ ; associated with it attributes that were created from the
+ ; input namelist file.
+ ;
+ ; Usage:
+ ;
+ ; hao_user = namelist("haoUserNameList")
+ ;
+ ; In some cases, these new attributes are used to modify an
+ ; existing (say, default) suite of attributes (say, haoDefault).
+ ;
+ ; hao = merge_VarAtts(hao_user, haoDefault)
+ ;
+ undef ("namelist")
+ function namelist (fname:string)
+ local lines, nam, chr, blankc, eqc, quot1c, quot2c, semic
+ , decimalc, slashc, commac, ampc, nullc, newlc, nLines
+ , nl, cc, CC, nc, NC, nEq, iEq, iSemic, aName, iq, i, n
+ , iComma, nComma, nDecimal, rhs, RHS
+ begin
+ lines = asciiread (fname, -1, "string")
+ nam = 1 ; create variable to which
+ ; attributes may be attached
+
+ ; special characters to check
+ ; for clarity use stringtochar
+ chr = stringtochar(" ") ; dimsizes(chr)=2
+ blankc = chr(0) ; blank space (int 32)
+
+ chr = stringtochar("=") ; dimsizes(chr)=2
+ eqc = chr(0) ; equal (int 61)
+
+ chr = stringtochar(";") ; dimsizes(chr)=2
+ semic = chr(0) ; comment (int 59)
+
+ chr = stringtochar("\") ; dimsizes(chr)=2
+ slashc = chr(0) ; line continuation (int 92)
+
+ chr = stringtochar(",") ; dimsizes(chr)=2
+ commac = chr(0) ; value separator (int 44)
+
+ chr = stringtochar(".") ; dimsizes(chr)=2
+ decimalc= chr(0) ; indicate float (int 46)
+
+ chr = stringtochar("&") ; dimsizes(chr)=2
+ ampc = chr(0) ; ampersand (int 38)
+
+ chr = stringtochar("'") ; dimsizes(chr)=2
+ quot1c = chr(0) ; single quote (int 39)
+
+ quot2c= integertochar(34) ; double quote " (int 34)
+ newlc = integertochar(10) ; new line character
+ nullc = integertochar(0) ; null
+
+ nLines = dimsizes(lines) ; # of lines (strings)
+
+ do nl=0,nLines-1 ; loop over each line
+ cc = stringtochar(lines(nl)) ; convert to characters
+ nc = dimsizes(cc) ; # characters
+ nc = nc - 1 ; ignore last character
+
+ nEq = num(cc.eq.eqc) ; number of = signs
+ ; eliminate (a) HAO's &proc
+ ; (b) any line without an =
+ if (cc(0).eq.ampc .or. nEq.eq.0) then
+ delete (cc) ; delete cuz size changes
+ continue ; go to next iteration
+ end if
+
+ iSemic = ind(cc.eq.semic) ; is simicolon (;) present [comment]
+ if (.not.ismissing(iSemic)) then
+ nc = iSemic(0)-1 ; only look up to semi-colon
+ if (nc.le.1) then ; need at least 3 char [eg: i=0]
+ delete (cc)
+ delete (iSemic)
+ continue ; go to next iteration
+ end if
+ end if
+ delete (iSemic)
+
+ NC = -1 ; remove blanks
+ CC = new ( nc, "character") ; cc after blanks removed
+ do n=0,nc-1
+ if (cc(n).ne.blankc .and. cc(n).ne.nullc .and. cc(n).ne.newlc) then
+ NC = NC+1
+ CC(NC) = cc(n)
+ end if
+ end do
+ delete (cc) ; no longer needed
+
+ if (NC.le.1) then ; again need min 3 char
+ delete (CC) ; size might change
+ continue ; go to next iteration
+ end if
+
+ iEq = ind(CC.eq.eqc) ; = is separator; return index
+
+ ; name of attribute (lhs)
+ aName = chartostring( (/CC(0:iEq-1)/) )
+
+ nComma = num(CC.eq.commac) ; a comma (,) means more than one
+ RHS = chartostring(CC(iEq+1:)) ; right hand side
+
+ ; does rhs have a ' or " [if so, string]
+ iq = ind(CC.eq.quot1c .or. CC.eq.quot2c) ; indices of quotes (',")
+
+ if (any(.not.ismissing(iq))) then
+ CC(iq) = quot2c ; change ' to " [also "-to-" for convenience]
+
+ if (nComma.gt.0) then ; more than 1 element
+ rhs = new ( nComma+1, "string")
+ delete (rhs at _FillValue)
+ ; must parse CC(iEq+1:)
+ ; put each element => array rhs
+ iComma = ind(CC.eq.commac); indices of commas
+ rhs(0) = chartostring( CC(iEq+1:iComma(0)-1) )
+ rhs(nComma) = chartostring( CC(iComma(nComma-1)+1:nc-1) )
+ if (nComma.gt.1) then
+ do i=0,nComma-2
+ rhs(i+1) = chartostring(CC(iComma(i)+1:iComma(i+1)-1))
+ end do
+ end if
+
+ nam@$aName$ = rhs
+ delete (rhs)
+ delete (iComma)
+ else
+ nam@$aName$ = RHS ; single string
+ end if
+
+ delete (iq)
+ delete (CC)
+ continue ; go to next iteration
+ end if
+ ; MUST be integer or real
+ delete (iq) ; iq referred to index of ' or "
+
+ nDecimal = num(CC.eq.decimalc) ; number of decimal pts
+
+ if (nComma.gt.0) then
+ iComma = ind(CC.eq.commac) ; inices of ,
+ if (nDecimal.eq.0) then
+ rhs = new ( nComma+1, "integer")
+ rhs(0) = stringtointeger( chartostring( CC(iEq+1:iComma(0)-1) ))
+ rhs(nComma) = stringtointeger( chartostring( CC(iComma(nComma-1)+1:nc-1) ))
+ if (nComma.gt.1) then
+ do i=0,nComma-2
+ rhs(i+1) = stringtointeger(chartostring(CC(iComma(i)+1:iComma(i+1)-1)))
+ end do
+ end if
+ else
+ rhs = new ( nComma+1, "float")
+ rhs(0) = stringtofloat( chartostring( CC(iEq+1:iComma(0)-1) ))
+ rhs(nComma) = stringtofloat( chartostring( CC(iComma(nComma-1)+1:nc-1) ))
+ if (nComma.gt.1) then
+ do i=0,nComma-2
+ rhs(i+1) = stringtofloat( chartostring(CC(iComma(i)+1:iComma(i+1)-1)))
+ end do
+ end if
+ end if
+ delete (rhs at _FillValue)
+ delete (iComma)
+ else
+ if (nDecimal.eq.0) then
+ rhs = stringtointeger(RHS)
+ else
+ rhs = stringtofloat(RHS)
+ end if
+ end if
+
+ nam@$aName$ = rhs ; associate values with variable
+ delete (rhs)
+
+ delete (CC)
+ end do
+
+ return(nam)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ;Within a string: replace one character with another
+ ; usage: s = "apples are good"
+ ; replaceSingleChar(s, " ", "_") ; ==> s="apples_are_good""
+
+ ; This function was deprecated in V5.1.1 and replaced with
+ ; the built-in function "str_sub_str".
+
+ undef("replaceSingleChar")
+ procedure replaceSingleChar (s[*]:string, oldStr[1]:string, newStr[1]:string)
+ begin
+ print("replaceSingChar: this function has been deprecated.")
+ print(" Will use str_sub_str.")
+ s = str_sub_str(s,oldStr,newStr)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; create symmetric min/max values for plots
+ ; will add additional plot resources to the "res" variable
+ ;
+ ; usage: res = True
+ ; symMinMaxPlt(zData, 14, False, res)
+ ;
+ undef("symMinMaxPlt")
+ procedure symMinMaxPlt (x:numeric, nCnLvl:integer, inOut:logical, res:logical)
+ local xMin, xMax, cmnmx, mnmxint
+ begin
+ xMin = min(x)
+ xMax = max(x)
+ cmnmx = max( (/fabs(xMin), fabs(xMax)/) ) ; larger of two values
+
+ mnmxint = nice_mnmxintvl( -cmnmx, cmnmx, nCnLvl, inOut)
+
+ res at cnLevelSelectionMode = "ManualLevels"
+ res at cnMinLevelValF = mnmxint(0)
+ res at cnMaxLevelValF = mnmxint(1)
+ if (isnan_ieee(mnmxint(2))) then ; extreme case
+ res at cnLevelSpacingF = 1.0
+ else
+ res at cnLevelSpacingF = mnmxint(2)
+ end if
+ end
+
+ undef("isStrSubset")
+ function isStrSubset(S[1]:string, s[1]:string)
+ ; return True or False is "s" is a subset of "S"
+ local SC, sc, nsc, nSC, n, sTF
+ begin
+
+ SC = stringtochar(S) ; main
+ sc = stringtochar(s) ; subset
+
+ nSC = dimsizes( SC ) - 1 ; extra 'end of char' at end
+ nsc = dimsizes( sc ) - 1
+
+ sTF = False
+ if (nsc.le.nSC) then ; nsc must be <= nSC
+ do n=0,nSC-nsc
+ if (all(SC(n:n+nsc-1).eq.sc(0:nsc-1)) ) then
+ sTF = True
+ return (sTF)
+ end if
+ end do
+ end if
+
+ return (sTF)
+ end
+ ; ----------------------
+ undef("indStrSubset")
+ function indStrSubset(S[1]:string, s[1]:string)
+ ; return the indices of the characters
+ ; of "S" of which "s" is a subset.
+ local SC, sc, nsc, nSC, n, ii
+ begin
+
+ if (ismissing(S) .or. ismissing(s)) then
+ print("indStrSubset: missing string")
+ imsg = default_fillvalue("integer")
+ ii = (/imsg,imsg/)
+ ii at _FillValue = imsg
+ return(ii)
+ end if
+
+ SC = stringtochar(S) ; main
+ sc = stringtochar(s) ; subset
+
+ nSC = dimsizes( SC ) - 1 ; extra 'end of char' at end
+ nsc = dimsizes( sc ) - 1
+
+ if (nsc.le.nSC) then ; nsc must be <= nSC
+ do n=0,nSC-nsc
+ if (all(SC(n:n+nsc-1).eq.sc(0:nsc-1)) ) then
+ ii = ispan(n,n+nsc-1,1)
+ return( ii )
+ end if
+ end do
+ end if
+
+ ii = new ( 1, integer)
+ return (ii)
+ end
+
+ undef ("getSubString")
+ function getSubString (s[*]:string, iStrt:integer, iLast:integer)
+ ;*************************************************************************
+ ; D. Shea
+ ; extract a sub-string from one or more strings
+ ; a = "0850-0899"
+ ; a1= getSubString(a, 0, 3) ; ==> a1 = "0850"
+ ; a2= getSubString(a, 5, 8) ; ==> a2 = "0899"
+ ;
+ ; A = (/ "vorticity", "flux", "divergence" /)
+ ; As= getSubString(A, 0, 4) ; ==> As = (/"vort","flux","dive"/)
+
+ ; This function was deprecated in V5.1.1 and replaced with
+ ; the built-in function "str_get_cols".
+
+ begin
+ return(str_get_cols(s,iStrt,iLast))
+ end
+
+ undef("wallClockElapseTime")
+ procedure wallClockElapseTime(wcStrt:string, title:string, opt:integer)
+ ;
+ ; compute *Wall Clock* elapsed time in seconds
+ ; Usage: wcStrt = systemfunc("date")
+ ; : ; one or more statements [usually a block of code]
+ ; wallClockElapseTime(wcStrt, "short_info", 0)
+ ; opt not used right now
+ ; this will not handle case where year or month changes
+ ;
+ ; Haley: updated Aug 2014 to return the date in the correct format.
+ ;
+ local wcNow, wcStrt_c, tSTRT, wcNow_c, tNOW, sec, NLINE, dq, date_cmd
+ begin
+ dq = str_get_dq()
+ date_cmd = "date +" + dq + "%a %b %d %H:%M:%S %Z %Y" + dq
+ ;;wcNow = systemfunc("date")
+ wcNow = systemfunc(date_cmd) ; current ("now") time; must be
+ wcNow_c = stringtochar(wcNow) ; be 'Wed Aug 27 08:38:33 MDT 2014' format
+ wcStrt_c = stringtochar(wcStrt)
+
+ if (dimsizes(wcNow_c).eq.dimsizes(wcStrt_c) .and.
+ dimsizes(wcNow_c).eq.29) then ; includes end-of-line character
+
+ tSTRT = stringtointeger((/wcStrt_c( 8: 9)/))*86400
+ + stringtointeger((/wcStrt_c(11:12)/))*3600
+ + stringtointeger((/wcStrt_c(14:15)/))*60
+ + stringtointeger((/wcStrt_c(17:18)/))
+
+ tNOW = stringtointeger((/wcNow_c( 8: 9)/))*86400
+ + stringtointeger((/wcNow_c(11:12)/))*3600
+ + stringtointeger((/wcNow_c(14:15)/))*60
+ + stringtointeger((/wcNow_c(17:18)/))
+
+ secElapseTime = tNOW-tSTRT
+
+ NLINE = inttochar(10) ; new line character
+ print (NLINE+
+ "=====> Wall Clock Elapsed Time: "+title+": "+
+ secElapseTime+" seconds <====="+NLINE)
+ else
+ print("wallClockElapseTime: something wrong: no printed value")
+ end if
+
+ end
+
+ undef("partitionString")
+ function partitionString(s:string , fs:string)
+ ; D Shea
+ ; Subset a string into parts depending upon a string separator [fs].
+ ; The fs argument can be only one character.
+ ;
+ ; code = "apple:orange:cider:peach" ; 4 components
+ ; a = partitionString(code, ":")
+ ; result will be a 1D array of length 4 containing
+ ; a = (/"apple","orange","cider","peach"/)
+
+ local cs, cfs, i, nStr, str, n, iStrt, iLast
+ begin
+ cs = stringtochar(s) ; string to individual characters
+ cfs = stringtochar(fs) ; string separator as character
+ if (dimsizes(cfs).ne.2) then
+ print ("*****")
+ print ("partitionString: fs can contain only one character, fs="+fs)
+ print ("*****")
+ return(s)
+ end if
+
+ i = ind(cs .eq. cfs(0)) ; indices where fs occurs
+
+ if (.not.any(ismissing(i)) ) then
+ nStr = dimsizes(i) + 1
+ str = new ( nStr, "string")
+
+ iStrt = 0
+ do n=0,nStr-2
+ iLast = i(n)-1
+ str(n) = chartostring((/cs(iStrt:iLast)/))
+ iStrt = i(n)+1
+ end do
+ iLast = dimsizes(cs)-2
+ str(nStr-1) = chartostring((/cs(iStrt:iLast)/))
+ else
+ str = s ; string separator found
+ end if
+
+ return(str)
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; read an ascii file and return just the header as a 1D array of strings.
+ ;
+ ; The header is the non-numeric part. Note upon
+ ; return this may have to be parsed individually for specific info.
+ ;
+ ; opt - option
+ ; if type "integer" or "long" then it is the number of rows
+ ; (line) for the header. This is a 'fixed' number of lines.
+ ; [06 Feb 2011 - add support for "long" nrows]
+ ;
+ ; if type "string" then it is a sequence of characters
+ ; that terminate a variable number of header rows.
+ ; Currently this just checks character sequences
+ ; starting in col 0.
+ ;
+ ; if type "float" and positive then it will read all values as float.
+ ; eg: f_head = readAsciiHead("foo.ascii", 3.)
+ ; all numbers on the 1st three rows will be read as float.
+
+ undef("readAsciiHead")
+ function readAsciiHead( fName:string, opt)
+ local xs, xc, nr, nrow, noptc, nxc, f_head
+ begin
+ xs = asciiread(fName, -1, "string") ; all rows as strings
+
+ if (any(typeof(opt).eq.(/"integer","long"/))) then
+ if (opt.gt.0) then
+ return( xs(0:opt-1) ) ; return just header rows
+ else
+ print ("contributed: readAsciiHead: opt must be >0")
+ return( new(1,string) )
+ end if
+ end if
+
+ if (typeof(opt).eq."string") then
+ nrow = dimsizes(xs)
+ do nr=0,nrow-1
+ ii = str_index_of_substr(xs(nr),opt,1) ; Find the 1st match
+ if(.not.any(ismissing(ii)).and.ii.eq.0) then
+ return( xs(0:nr) )
+ exit
+ end if
+ end do
+ return(new(1,string))
+ end if
+
+ if (typeof(opt).eq."float") then
+ nrow = tolong(opt) ; # of rows to be read as float
+
+ tmpdir = ncargpath("tmp") + "/"
+ if(ismissing(tmpdir)) then
+ tmpdir = "./"
+ end if
+
+ tmpfile = systemfunc("echo tmp$$")
+ if (ismissing(tmpfile)) then
+ tmpfile = "BoGuS_file"
+ end if
+
+ asciiwrite (tmpdir+tmpfile, xs(0:nrow-1))
+ f_head = asciiread(tmpdir+tmpfile, -1, "float")
+ system("/bin/rm "+tmpdir+tmpfile)
+
+ return( f_head )
+ end if
+
+ end
+
+ ;*************************************************************************
+ ; D. Shea
+ ; read an ascii file and return the table data after the header portion
+ ; opt - option
+ ; if type "integer" it can be a scalar or have size [2]
+ ; opt/opt(0) specifies the number of rows (lines) for the header.
+ ; This is a 'fixed' number of lines.
+ ; if opt has 2 elements, the second integer value [ opt(1) ]
+ ; specifies the number of lines at the end of the
+ ; file to be ignored.
+ ;
+ ; if type "string" then it is a sequence of characters
+ ; that terminate a variable number of header rows.
+ ; Currently this just checks character sequences
+ ; starting in col 0.
+ ; ncol- number of columns in table
+ ;
+ ; [06 Feb 2011 - added support for "long" ncol]
+
+ undef("readAsciiTable")
+ function readAsciiTable( fName:string, ncol, datatype:string, opt)
+ local head, nh, xs, nrow, table, nopt, valid_dim_types
+ begin
+ valid_dim_types = (/"integer","long"/)
+ if (.not.any(typeof(ncol).eq.valid_dim_types)) then
+ print ("contributed: readAsciiTable: ncol must be int or long")
+ return(new(1,string))
+ end if
+ nopt = dimsizes(opt)
+ if (any(typeof(opt).eq.valid_dim_types) .and. nopt.eq.1 .and.
+ opt(0).eq.0) then
+ nrow = dimsizes(asciiread(fName, -1, "string")) ; all rows as strings
+ table = asciiread(fName, (/nrow,ncol/), datatype)
+ else
+ ;;if (opt(0).gt.0) then
+ if ((nopt.eq.1 .and. typeof(opt).eq."string") .or.
+ opt(0).gt.0) then
+ head = readAsciiHead( fName, opt(0))
+ nh = dimsizes(head) ; # header records
+ else
+ nh = 0 ; no header to read
+ end if
+ xs = asciiread(fName, -1, "string") ; all rows as strings
+ nrow = dimsizes(xs)-nh ; # rows after header
+ if (nopt.gt.1) then
+ nrow = nrow - opt(1)
+ end if
+
+ tmpdir = ncargpath("tmp") + "/"
+ if(ismissing(tmpdir)) then
+ tmpdir = "./"
+ end if
+
+ ;;tmpfile = systemfunc("echo tmp$$") ; See JIRA: NCL-2174
+ tmpnum = systemfunc("date +%N") ; introduced 6.3.0
+ if(tmpnum.eq."N")then
+ delete(tmpnum)
+ srand(toint(systemfunc("date +%s")))
+ tmpnum = rand()
+ end if
+ tmpfile = "tmp"+tmpnum
+
+ if (ismissing(tmpfile)) then
+ tmpfile = "BoGuS_file"
+ end if
+
+ asciiwrite (tmpdir+tmpfile, xs(nh:nh+nrow-1))
+ table = asciiread(tmpdir+tmpfile, (/nrow,ncol/), datatype)
+ system("/bin/rm "+tmpdir+tmpfile)
+ end if
+ return(table)
+ end
+
+ ;********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "hyi2hyo" that copies attributes and coordinate vars.
+ ; It adds the new level coordinates.
+
+
+ undef("hyi2hyo_Wrap")
+ function hyi2hyo_Wrap(p0,hyai,hybi,psfc,xi,hyao,hybo,option)
+ ;
+ ; hyai, hybi - input hybrid coordinates
+ ; hyao, hybo - output hybrid coordinates
+ ;
+ local xo, dName, nDim, P0, lev, n
+ begin
+ xo = hyi2hyo(p0,hyai,hybi,psfc,xi,hyao,hybo,option)
+
+ copy_VarAtts(xi,xo)
+ xo at info = "NCL function hyi2hyo used to interpolate"
+
+ dName = getvardims( xi ) ; get dim names of the input variable
+ if (any(dName.eq."missing")) then
+ return (xo)
+ end if
+
+ nDim = dimsizes( dimsizes(xo) )
+
+ do n=0,nDim-1 ; name the dimensions
+ xo!n = dName(n)
+ ;print("dName: "+n+": "+dName(n))
+ end do
+
+ if (isatt(p0,"units") .and.
+ (p0 at units.eq."Pa" .or. p0 at units.eq."Pascals") .or.
+ (p0.eq.100000.)) then
+ P0 = p0/100.
+ P0 at units = "hPa"
+
+ if (isStrSubset(hyai at long_name,"interfaces") .or.
+ isStrSubset(hyai at long_name,"midpoints" )) then
+ lev = (hyao+hybo)*P0
+ lev at long_name = "level"
+ lev at units = "hPa"
+
+ if (isStrSubset(hyai at long_name,"interfaces")) then
+ lev at long_name = "hybrid level at interfaces (1000*(A+B))"
+ lev at formula_terms = "a: hyai b: hybi p0: P0 ps: PS"
+ lev!0 = "ilev"
+ end if
+ if (isStrSubset(hyai at long_name,"midpoints")) then
+ lev at long_name = "hybrid level at midpoints (1000*(A+B))"
+ lev at formula_terms = "a: hyam b: hybm p0: P0 ps: PS"
+ lev!0 = "lev"
+ end if
+ else
+ lev = (hyao+hybo)*P0
+ lev at long_name = "level"
+ lev at units = "hPa"
+ lev at long_name = "hybrid level (1000*(A+B))"
+ lev at formula_terms = "a: hya b: hyb p0: P0 ps: PS"
+ end if
+ end if
+ lev at standard_name = "atmosphere_hybrid_sigma_pressure_coordinate"
+ lev at positive = "down"
+
+ if (nDim.eq.3) then
+ if (isvar("lev")) then
+ xo&$dName(0)$ = lev
+ end if
+
+ do n=1,2
+ if (iscoord(xi, dName(n)) ) then
+ xo&$dName(n)$ = xi&$dName(n)$
+ end if
+ end do
+ end if
+
+ if (nDim.eq.4) then
+ do n=0,3
+ if (n.eq.1 .and. isvar("lev")) then
+ xo&$dName(n)$ = lev
+ else
+ if (iscoord(xi, dName(n)) ) then
+ xo&$dName(n)$ = xi&$dName(n)$
+ end if
+ end if
+ end do
+ end if
+
+ return (xo)
+ end
+ ;**************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "shsgc_R42" that copies attributes and coordinate vars.
+ ; It adds the longitude and gaussian latitude coordinates.
+
+ undef("shsgc_R42_Wrap")
+ function shsgc_R42_Wrap (a:numeric, b:numeric)
+ local xNew, lat, gwt, lon, nDim
+ begin
+ xNew = shsgc_R42(a,b)
+ lat = latGau (108, "lat", "latitude" , "degrees_north")
+ gwt = latGauWgt (108, "lat", "gaussian weights", "")
+ lon = lonGlobeF (128, "lon", "longitude", "degrees_east")
+
+ if (isatt(a,"long_name")) then
+ xNew at long_name = a at long_name
+ end if
+ if (isatt(a,"units")) then
+ xNew at units = a at units
+ end if
+
+ nDim = dimsizes(dimsizes(xNew)) ; number of dimensions
+ xNew!(nDim-2) = "lat" ; 2nd rightmost dimension
+ xNew!(nDim-1) = "lon" ; rightmost dimension
+
+ xNew&lat = lat(::-1) ; add new coord var
+ xNew&lon = lon
+ xNew at gwt = gwt ; attach as attribute
+ return (xNew)
+ end
+ ;********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "pres2hybrid" that copies attributes and coordinate vars.
+ ; It adds the new level coordinates.
+
+
+ undef("pres2hybrid_Wrap")
+ function pres2hybrid_Wrap(p[*],psfc,p0,xi,hyao,hybo,intflg)
+ local xo, dName, nDim, P0, lev, n
+ begin
+ xo = pres2hybrid(p,psfc,p0,xi,hyao,hybo,intflg)
+
+ copy_VarAtts(xi,xo)
+ xo at info = "NCL function pres2hybrid used to interpolate"
+
+ dName = getvardims( xi ) ; get dim names of the input variable
+ if (any(ismissing(dName))) then
+ return (xo)
+ end if
+
+ nDim = dimsizes( dimsizes(xo) )
+ if (nDim.ge.5) then
+ print("pres2hybrid_Wrap: Too many dimensions: nDim="+nDim)
+ exit
+ end if
+ if (nDim.lt.3) then
+ print("pres2hybrid_Wrap: Too few dimensions: nDim="+nDim)
+ exit
+ end if
+
+ do n=0,nDim-1 ; name the dimensions
+ xo!n = dName(n)
+ end do
+
+ if (isatt(p0,"units") .and.
+ (p0 at units.eq."Pa" .or. p0 at units.eq."Pascals") .or.
+ (p0.eq.100000.)) then
+ P0 = p0/100.
+ P0 at units = "hPa"
+ lev = (hyao+hybo)*P0
+ lev at long_name = "level"
+ lev at units = "hPa"
+ lev at formula_terms = "a: hyam b: hybm p0: P0 ps: PS"
+ lev at positive = "down"
+ lev at standard_name = "atmosphere_hybrid_sigma_pressure_coordinate"
+ end if
+
+ if (nDim.eq.3) then
+ if (isvar("lev")) then
+ xo&$dName(0)$ = lev
+ end if
+
+ do n=1,2
+ if (iscoord(xi, dName(n)) ) then
+ xo&$dName(n)$ = xi&$dName(n)$
+ end if
+ end do
+ end if
+
+ if (nDim.eq.4) then
+ do n=0,3
+ if (n.eq.1 .and. isvar("lev")) then
+ xo&$dName(n)$ = lev
+ else
+ if (iscoord(xi, dName(n)) ) then
+ xo&$dName(n)$ = xi&$dName(n)$
+ end if
+ end if
+ end do
+ end if
+
+ return (xo)
+ end
+ ;
+ ;**************************************************************
+ ; D. Shea
+ ; Driver for NCL function "omega_ccm"
+ ; It calculates intermediate quantities needed for input.
+ ;
+ undef("omega_ccm_driver")
+ function omega_ccm_driver(p0,psfc,u,v,hyam[*],hybm[*],hyai[*],hybi[*])
+
+ ; calculate assorted intermediate quantities
+ ; prior to invoking the built-in function "omega_ccm"
+ ;
+ ; p0 - Scalar numeric value equal to surface reference pressure in Pa.
+ ; psfc - 2D or 3D array ([time,]lat,lon) of surface pressures in Pa.
+ ; u, v - 3D or 4D arrays ([time,]lev,lat,lon) of zonal and meridional wind (m/s)
+ ; hyam - 1D array containing the hybrid A coefficients. Must have the
+ ; same dimension as the level dimension of u and v.
+ ; The order must be top-to-bottom.
+ ; hybm - 1D array containing the hybrid B coefficients. Must have the
+ ; same dimension as the level dimension of u and v.
+ ; The order must be top-to-bottom.
+ ; hyai - 1D array containing the interface hybrid A coefficients.
+ ; The order must be top-to-bottom.
+ ; hybi - 1D array containing the interface hybrid B coefficients.
+ ; The order must be top-to-bottom.
+
+
+ begin
+ dimps = dimsizes(psfc)
+ rankps = dimsizes(dimps)
+ dimu = dimsizes(u)
+ ranku = dimsizes(dimu)
+ if ((ranku .eq.rankps) .or.
+ (ranku .le.2 .or. ranku.ge.5) .or.
+ (rankps.le.1 .or. rankps.ge.4) .or.
+ (ranku .eq.4 .and.rankps.ne.3) .or.
+ (ranku .eq.3 .and.rankps.ne.2)) then
+ print("omega_ccm_driver: expected ranku=3 or 4 and rankps=2 or 3")
+ print("omega_ccm_driver: got ranku="+ranku+" and rankps="+rankps)
+ exit
+ end if
+ ; only klev is used below: ntim, nlat, mlon are FYI only
+ if (ranku.eq.3) then
+ klev = dimu(0)
+ nlat = dimu(1)
+ mlon = dimu(2)
+ else
+ ntim = dimu(0)
+ klev = dimu(1)
+ nlat = dimu(2)
+ mlon = dimu(3)
+ end if
+
+ omega = u ; create space
+ omega at long_name = "Vertical pressure velocity"
+ omega at units = "Pa/s"
+
+ lat = omega&lat
+ ; hybd = new((/klev/),typeof(hyai))
+ ; do k=0,klev-1
+ ; hybd(k) = hybi(k+1)-hybi(k)
+ ; end do
+ klevi = dimsizes(hybi)
+ hybd = hybi(1:) - hybi(0:klevi-2)
+ nprlev = 0 ; number of pure pressure levels
+ do k=1,klev
+ if (nprlev .eq. 0 .and. hybi(k) .ne. 0.0) then
+ nprlev = k - 1
+ end if
+ end do
+
+ pdel = dpres_hybrid_ccm(psfc,p0,hyai,hybi)
+ pmid = pres_hybrid_ccm (psfc,p0,hyam,hybm)
+
+ dpsl = psfc ; create space for retrn variables
+ dpsm = psfc
+ psln = log(psfc)
+ gradsg(psln,dpsl,dpsm) ; gradients of log(psfc) gaussian grid
+
+ div = uv2dvG(u,v) ; divergence on gaussian grid
+
+ omega = omega_ccm(u ,v ,div ,dpsl
+ ,dpsm ,pmid ,pdel
+ ,psfc ,hybd ,hybm ,nprlev )
+
+ return(omega)
+ end
+ ;************************************************************
+ ; D. Shea
+ ;
+ ; Converts OMEGA (Pa/s) to W (m/s)
+ ; This is a 1st order approximation.
+
+ undef("omega_to_w")
+ function omega_to_w (omega, p, t)
+ ;
+ ; first order conversion: w = -omega/(density*gravity)
+ ;
+ ; omega: units = "Pa/sec"
+ ; p : units = "Pa"
+ ; t : units = "K"
+
+ local dims_omega, dims_t, dims_p, rank_omega, rank_t, rank_p, RGAS, GRAV, rho, w
+ begin
+ dims_omega = dimsizes( omega )
+ dims_t = dimsizes( t )
+ dims_p = dimsizes( p )
+
+ rank_omega = dimsizes( dims_omega )
+ rank_t = dimsizes( dims_t )
+ rank_p = dimsizes( dims_p )
+
+ if (rank_omega.ne.rank_t .or. rank_omega.ne.rank_p .or.
+ .not.(all(dims_omega.eq.dims_t) .and. all(dims_omega.eq.dims_p)) ) then
+ print("omega_to_w: omega, p, t must be the same rank & size")
+ exit
+ end if
+
+ RGAS = 287.058 ; J/(kg-K) => m2/(s2 K)
+ GRAV = 9.80665 ; m/s2
+ rho = p/(RGAS*t) ; density => kg/m3
+ w = -omega/(rho*GRAV) ; array operation
+
+ w at long_name = "vertical velocity"
+ w at units = "m/s"
+ w at info_tag = "NCL: omega_to_w: -omega/(rho*g): approximation "
+ copy_VarCoords( omega, w)
+ return( w )
+ end
+ ;************************************************************
+ ; D. Shea
+ ;
+ ; Converts W (m/s) to OMEGA (Pa/s)
+ ; This is a 1st order approximation.
+
+ undef("w_to_omega")
+ function w_to_omega (w, p, t)
+ ;
+ ; first order conversion: omega= -w*density*gravity
+ ;
+ ; w : units = "m/sec"
+ ; p : units = "Pa"
+ ; t : units = "K"
+
+ local dims_w, dims_t, dims_p, rank_w, rank_t, rank_p, RGAS, GRAV, rho, omega
+ begin
+ dims_w = dimsizes( w )
+ dims_t = dimsizes( t )
+ dims_p = dimsizes( p )
+
+ rank_w = dimsizes( dims_w )
+ rank_t = dimsizes( dims_t )
+ rank_p = dimsizes( dims_p )
+
+ if (rank_w.ne.rank_t .or. rank_w.ne.rank_p .or.
+ .not.(all(dims_w.eq.dims_t) .and. all(dims_w.eq.dims_p)) ) then
+ print("w_to_omega: omega, p, t must be the same rank & size")
+ exit
+ end if
+
+ RGAS = 287.058 ; J/(kg-K) => m2/(s2 K)
+ GRAV = 9.80665 ; m/s2
+ rho = p/(RGAS*t) ; density => kg/m3
+ omega = -w*rho*GRAV ; array operation
+
+ omega at long_name = "vertical velocity"
+ omega at units = "Pa/s"
+ omega at info_tag = "NCL: w_to_omega: omega= -w*rho*g: approximation "
+ copy_VarCoords( w, omega)
+ return( omega )
+ end
+
+ ;************************************************************
+ ; D. Shea and S. N. Hameed <U. Hawaii>
+ ;
+ ; Determines the relative minima for a 1-dimensional array.
+ ; x - A 1-dimensional float or double array.
+ ; Missing data are not allowed.
+ ; cyclic - Set to True if data are cyclic.
+ ; Set to False if the data array is not cyclic in x.
+ ; delta - Tolerance level (negative). If values are within delta of
+ ; surrounding values it will not be counted as a local min value.
+ ; opt - indicates what is to be returned
+ ; 0 ; return the minimum values
+ ; opt.ne.0 ; return the indices [subscripts] where
+ ; ; minimum values occured.
+ ;
+ ; usage: qmin = local_min_1d(q, False, -0.25, 0)
+ ;
+ ; imin = local_min_1d(q, False, -0.25, 1)
+ ; if (.not.ismissing(imax)) then
+ ; qmin = q(imin)
+ ; zmin = z(imin) ; z where q is at a minimum
+ ; end if
+ ;
+ ; M.Haley, 5 Feb 2011 - updated to allow long dimension sizes
+
+ undef("local_min_1d")
+ function local_min_1d( X[*]:numeric , cyclic:logical
+ , del[1]:numeric, opt[1]:integer )
+ local NX, nx, x, iOffSet, nStrt, nLast, imn, i, type_nx
+ begin
+ if (del.gt.0.0) then
+ print("contributed: local_min_1d: del must be .le. 0.0")
+ print("contributed: local_min_1d: del ="+del)
+ exit
+ end if
+
+ if (any(ismissing(X))) then
+ print("contributed: local_min_1d: missing values not allowed")
+ print("contributed: local_min_1d: "+num(ismissing(X))
+ +" missing values encountered")
+ exit
+ end if
+
+ NX = dimsizes(X)
+
+ if (cyclic) then
+ nx = NX+2
+ x = new (nx, typeof(X), getFillValue(X))
+ x(0) = (/ X(NX-1) /)
+ x(nx-1) = (/ X(0) /)
+ x(1:nx-2) = (/ X /)
+ iOffSet = -1
+ else
+ x = (/ X /)
+ iOffSet = 0
+ end if
+
+ nx = dimsizes(x)
+ type_nx = typeof(nx) ; int or long
+ imn = new( nx, type_nx )
+ nStrt = new( 1, type_nx )
+ nLast = new( 1, type_nx )
+ i = new( 1, type_nx )
+
+ nStrt = 1
+ nLast = nx-2
+ i = -1
+ do n=nStrt,nLast
+ if ((x(n)-x(n-1)).le.del .and. (x(n)-x(n+1)).le.del) then
+ i = i+1
+ imn(i) = n ; indices of local minima
+ end if
+ end do
+ i at _FillValue = -1 ; trick ... assign after loop
+
+ if (.not.ismissing(i)) then
+ if (opt.eq.0) then
+ return(x(imn(0:i))) ; return actual minimum values
+ else
+ return(imn(0:i)+iOffSet)
+ end if
+ else ; must be no local minima
+ if (opt.eq.0) then
+ return(default_fillvalue(typeof(x)))
+ else
+ return(i) ; default integer missing code
+ end if
+ end if
+ end
+ ;************************************************************
+ ; D. Shea and S. N. Hameed <U. Hawaii>
+ ;
+ ; Determines the relative maxima for a 1-dimensional array.
+ ; x - A 1-dimensional float or double array.
+ ; Missing data are not allowed.
+ ; cyclic - Set to True if data are cyclic.
+ ; Set to False if the data array is not cyclic in x.
+ ; delta - Tolerance level (positive). If values are within delta
+ ; of surrounding values it will not be counted as a local max value.
+ ; opt = indicates what is to be returned
+ ; 0 ; return the maximum values
+ ; opt.ne.0 ; return the indices [subscripts] where
+ ; ; maximum values occured.
+ ;
+ ; usage: qmax = local_max_1d(q, False, 0.25, 0)
+ ;
+ ; imax = local_max_1d(q, False, 0.25, 1)
+ ; if (.not.ismissing(imax)) then
+ ; qmax = q(imax)
+ ; zmax = z(imax) ; z where q is at a maximum
+ ; end if
+
+ undef("local_max_1d")
+ function local_max_1d( X[*]:numeric , cyclic:logical
+ , del[1]:numeric, opt[1]:integer )
+ local NX, nx, x, iOffSet, nStrt, nLast, imx, i, type_nx
+ begin
+ if (del.lt.0.0) then
+ print("contributed: local_max_1d: del must be .ge. 0.0")
+ print("contributed: local_max_1d: del ="+del)
+ exit
+ end if
+
+ if (any(ismissing(X))) then
+ print("contributed: local_max_1d: missing values not allowed")
+ print("contributed: local_max_1d: "+num(ismissing(X))
+ +" missing values encountered")
+ exit
+ end if
+
+ NX = dimsizes(X)
+
+ if (cyclic) then
+ nx = NX+2
+ x = new (nx, typeof(X), getFillValue(X))
+ x(0) = (/ X(NX-1) /)
+ x(nx-1) = (/ X(0) /)
+ x(1:nx-2) = (/ X /)
+ iOffSet = -1
+ else
+ x = (/ X /)
+ iOffSet = 0
+ end if
+
+ nx = dimsizes(x)
+ type_nx = typeof(nx) ; int or long
+ imx = new( nx, type_nx )
+ nStrt = new( 1, type_nx )
+ nLast = new( 1, type_nx )
+ i = new( 1, type_nx )
+
+ nStrt = 1
+ nLast = nx-2
+ i = -1
+ do n=nStrt,nLast
+ if ((x(n)-x(n-1)).ge.del .and. (x(n)-x(n+1)).ge.del) then
+ i = i+1
+ imx (i) = n
+ end if
+ end do
+ i at _FillValue = -1 ; trick ... assign after loop
+
+ if (.not.ismissing(i)) then
+ if (opt.eq.0) then
+ return(x(imx(0:i))) ; return actual maximum values
+ else
+ return(imx(0:i)+iOffSet) ; return index values
+ end if
+ else ; must be no local maxima
+ if (opt.eq.0) then
+ return(default_fillvalue(typeof(x)))
+ else
+ return(i)
+ end if
+ end if
+ end
+ ;************************************************************
+ ; Internal
+ ; Copy all of the coordinate variables from one variable to another.
+ ; starting at dimension 1
+
+ undef("copy_VarCoords_skipDim0")
+ procedure copy_VarCoords_skipDim0(var_from,var_to)
+ local dfrom, dto, rfrom, rto, i, dName
+ begin
+ dfrom = dimsizes(var_from)
+ dto = dimsizes(var_to)
+
+ rfrom = dimsizes(dfrom)
+ rto = dimsizes(dto)
+ ; coordinates must have names
+ dName = getvardims(var_from) ; Oct 18, 2005
+
+ if (.not.all(ismissing(dName))) then
+ do i = 1,rto-1
+ if (.not.ismissing(dName(i))) then ; Oct 18, 2005
+ var_to!i = var_from!i
+ if(iscoord(var_from,var_from!i))
+ var_to&$var_to!i$ = var_from&$var_from!i$
+ end if
+ end if
+ end do
+ end if
+ end
+ ; *****************************************************************
+ ; D. Shea
+ ; Turn monthly values [eg, precipitation] to annual values
+ ; Two options: (a) sum of all 12 months (b) [sum of 12 values]/12
+ ; Caveats: If there is more than one dimension,
+ ; (a) all dimensions *must* be named.
+ ; (b) If there are no missing data [_FillValue],
+ ; this function will work as expected.
+ ; Nomenclature:
+ ; x - data array
+ ; if rank is greater than one, then it is required that
+ ; the *leftmost* dimension be "time"
+ ; eg: prc(time,lat,lon), z(time,stations), q(time,lev,lat,lon)
+ ;
+ ; if 1D missing values [_FillValue] are allowed
+ ; otherwise
+ ; no missing values currently alloed
+ ;
+ ; opt - flag: opt=0 if annual total value [sum 12 values] is to be returned
+ ; opt=1 if annual mean value is to be returned [(annual total)/12]
+ ; opt>1 special: calculate annual mean with < 12 values
+ ; # values used to calculate "annual" mean
+ ; can be 1<=opt<=12
+ ;
+ ; Usage:
+ ; PRC_annual_total = month_to_annual( prc, 0)
+ ; TMP_annual_mean = month_to_annual( tmp, 1)
+ ; special
+ ; TMP_annual_mean = month_to_annual( tmp, 10) ; 10 or more values
+ ;
+
+ undef("month_to_annual")
+ function month_to_annual(x:numeric, opt:integer)
+ local dimx, rankx, ntim, nyr, nyrs, nt, nx, ny, kz, nn, nmo
+ , dName, xAnnual, xTemp, n, m, k, nMsg, nmos, NMOS, nGood
+ begin
+ if (opt.lt.0 .or. opt.gt.12) then
+ print("month_to_annual: illegal value of opt: opt="+opt)
+ exit
+ end if
+
+ NMOS = 12 ; fixed ... will not change
+ nmos = 12 ; possible change in value
+ if (opt.gt.1) then
+ nmos = opt
+ end if
+ NMOS1 = NMOS-1 ; convenience
+
+ dimx = dimsizes(x)
+ rankx = dimsizes(dimx)
+ NTIM = dimx(0)
+ if (dimx(0).ne.NTIM) then
+ print("month_to_annual: yyyymm and x time dimension must be same size")
+ exit
+ end if
+
+ if (rankx .gt. 4) then
+ print("*** FATAL ***")
+ print("month_to_annual: currently support up to 4D only")
+ print("month_to_annual: rank="+rankx)
+ exit
+ end if
+
+ nyrs = NTIM/NMOS
+ ntim = nyrs*NMOS
+ if (NTIM%NMOS .ne. 0) then
+ print("*** WARNING ***")
+ print("month_to_annual: ntim="+NTIM+" not multiple of 12: nyrs="+nyrs)
+ nyrs = nyrs + 1
+ end if
+
+
+ if (rankx.eq.1) then
+ xAnnual = new ( nyrs, typeof(x), getFillValue(x)) ; contributed.ncl
+
+ nyr = -1
+ do nt=0,ntim-1,NMOS
+ nyr = nyr+1
+
+ nMsg = 0
+ if (isatt(x,"_FillValue")) then
+ nMsg = num (ismissing(x(nt:nt+NMOS1)) )
+ end if
+ nGood = NMOS-nMsg
+
+ if (nMsg.eq.0 .and. opt.eq.0) then
+ xAnnual(nyr) = sum ( x(nt:nt+NMOS1) )
+ end if
+ if (nMsg.eq.0 .and. opt.ge.1) then
+ xAnnual(nyr) = avg ( x(nt:nt+NMOS1) ) ; always opt=1
+ end if
+ if (nMsg.gt.0 .and. opt.gt.1 .and. nGood.ge.nmos) then
+ xAnnual(nyr) = avg ( x(nt:nt+NMOS1) ) ; always opt=1
+ end if
+ end do
+
+ copy_VarAtts (x, xAnnual)
+ xAnnual at NCL = "month_to_annual"
+ xAnnual!0 = "year"
+ return(xAnnual)
+ end if
+
+ dName = getvardims(x) ; get dim names
+ if (any(ismissing(dName))) then
+ print("*** FATAL ***")
+ print("month_to_annual: requires that all dimensions be named")
+ exit
+ end if
+
+ if (rankx.eq.2) then
+ nn = dimx(1)
+ nyr = -1
+ xAnnual= new ( (/nyrs,nn/), typeof(x), getFillValue(x)) ; contributed.ncl
+ do nt=0,ntim-1,NMOS
+ xTemp = x(nt:nt+NMOS1, :) ; cleaner code only
+ nyr = nyr+1
+
+ if (opt.eq.0) then
+ xAnnual(nyr,:) = dim_sum_n ( xTemp, 0 )
+ else
+ xAnnual(nyr,:) = dim_avg_n ( xTemp, 0 )
+ end if
+
+ nMsg = 0 ; number of missing for current year (nyr)
+ if (isatt(x,"_FillValue")) then
+ nMsg = num (ismissing(xTemp) ) ; for all grid points
+ end if
+
+ if (nMsg.gt.0) then
+ nGood = dim_num_n(.not.ismissing(xTemp), 0 )
+ xAnnual(nyr,:) = mask( xAnnual(nyr,:), nGood.ge.nmos, True) ; ?False
+ print("month_to_annual: some points have missing data: nt="+nt
+ +" nyr="+nyr+" num(nGood)="+num(nGood.gt.0))
+ end if
+
+ end do
+
+ copy_VarAtts (x, xAnnual)
+ xAnnual at NCL = "month_to_annual"
+ xAnnual!0 = "year"
+ copy_VarCoords_skipDim0 (x, xAnnual)
+ return(xAnnual)
+ end if
+
+ if (rankx.eq.3) then
+ ny = dimx(1) ; nlat
+ mx = dimx(2) ; mlon
+ nyr = -1
+ xAnnual= new ( (/nyrs,ny,mx/), typeof(x), getFillValue(x)) ; contributed.ncl
+ do nt=0,ntim-1,NMOS
+ xTemp = x(nt:nt+NMOS1,:,:) ; cleaner code only
+ nyr = nyr+1
+
+ if (opt.eq.0) then
+ xAnnual(nyr,:,:) = dim_sum_n ( xTemp, 0 )
+ else
+ xAnnual(nyr,:,:) = dim_avg_n ( xTemp, 0 )
+ end if
+
+ nMsg = 0 ; number of missing for current year (nyr)
+ if (isatt(x,"_FillValue")) then
+ nMsg = num (ismissing(xTemp) ) ; for all grid points
+ end if
+
+ if (nMsg.gt.0) then
+ nGood = dim_num_n(.not.ismissing(xTemp), 0 ) ; (lat,lon)
+ xAnnual(nyr,:,:) = mask( xAnnual(nyr,:,:), nGood.ge.nmos, True) ; ?False
+ print("month_to_annual: some grid points have missing data: nt="+nt
+ +" nyr="+nyr+" num(nGood)="+num(nGood.gt.0))
+ end if
+ end do
+
+ copy_VarAtts (x, xAnnual)
+ xAnnual at NCL = "month_to_annual"
+ xAnnual!0 = "year"
+ copy_VarCoords_skipDim0 (x, xAnnual)
+ return(xAnnual)
+ end if
+
+ if (rankx.eq.4) then
+ kz = dimx(1) ; nlev
+ ny = dimx(2) ; nlat
+ mx = dimx(3) ; mlon
+ nyr = -1
+ xAnnual= new ( (/nyrs,kz,ny,mx/), typeof(x), getFillValue(x)) ; contributed.ncl
+ do nt=0,ntim-1,NMOS
+ xTemp = x(nt:nt+NMOS1,:,:,:)
+ nyr = nyr+1
+
+ if (opt.eq.0) then
+ xAnnual(nyr,:,:,:) = dim_sum_n ( xTemp, 0 )
+ else
+ xAnnual(nyr,:,:,:) = dim_avg_n ( xTemp, 0 )
+ end if
+
+ nMsg = 0 ; number of missing for current year (nyr)
+ if (isatt(x,"_FillValue")) then
+ nMsg = num (ismissing(xTemp) ) ; for all grid points
+ end if
+
+ if (nMsg.gt.0) then
+ nGood = dim_num_n(.not.ismissing(xTemp), 0 )
+ xAnnual(nyr,:,:,:) = mask( xAnnual(nyr,:,:,:), nGood.ge.nmos, True)
+ print("month_to_annual: some grid points have missing data: nt="+nt
+ +" nyr="+nyr+" num(nGood)="+num(nGood.gt.0))
+ end if
+ end do
+
+ copy_VarAtts (x, xAnnual)
+ xAnnual at NCL = "month_to_annual"
+ xAnnual!0 = "year"
+ copy_VarCoords_skipDim0 (x, xAnnual)
+ return(xAnnual)
+ end if
+ return
+ end
+
+ ; *****************************************************************
+ ; D. Shea
+
+ undef("month_to_annual_weighted")
+ function month_to_annual_weighted(yyyymm[*]:numeric, x:numeric, opt:integer)
+ local dimx, rankx, ntim, nyr, nyrs, nt, nx, ny, nz, nn, nmo
+ , dName, xAnnual, xTemp, nmos
+ begin
+ yyyy = yyyymm/100
+ mm = yyyymm - (yyyy*100) ; mm=1,...,12
+ nmos = 12
+ if (any(mm.lt.1 .or. mm.gt.12)) then
+ print("month_to_annual_weighted: mm must be 1-to-12 inclusive")
+ exit
+ end if
+
+ dimx = dimsizes(x)
+ rankx = dimsizes(dimx)
+ NTIM = dimx(0)
+
+ if (NTIM.ne.dimsizes(yyyymm)) then
+ print("month_to_annual_weighted: incompatible time dimesnions")
+ print(" dimsizes(yyyymm) .ne. ntim ")
+ exit
+ end if
+
+ if (rankx .gt. 4) then
+ print("*** FATAL ***")
+ print("month_to_annual_weighted: currently supports up to 4D only")
+ print("month_to_annual_weighted: rank="+rankx)
+ exit
+ end if
+
+ nyrs = NTIM/12
+ ntim = nyrs*12
+
+ if (NTIM%12 .ne. 0) then
+ print("*** WARNING ***")
+ print("month_to_annual_weighted: ntim="+NTIM+" not multiple of 12")
+ end if
+
+ if (isatt(yyyymm,"calendar")) then
+ yyyy at calendar = yyyymm at calendar ; needed for days_in_month
+ end if
+
+ dymon = days_in_month ( yyyy, mm) ; accounts for calendar attribute
+
+ if (typeof(x).eq."double") then
+ one = 1d0
+ else
+ one = 1.0
+ end if
+
+ if (isatt(yyyymm,"calendar")) then ; retrofit to existing code
+
+ if (yyyymm at calendar.eq."360_day" .or. yyyymm at calendar.eq."360") then
+ con = (/ 360, 360 /)*one
+ end if
+ if (yyyymm at calendar.eq."365_day" .or. yyyymm at calendar.eq."365" .or.
+ yyyymm at calendar.eq."noleap" .or. yyyymm at calendar.eq."no_leap") then
+ con = (/ 365, 365 /)*one
+ end if
+ if (yyyymm at calendar.eq."366_day" .or. yyyymm at calendar.eq."366" .or.
+ yyyymm at calendar.eq."allleap" .or. yyyymm at calendar.eq."all_leap") then
+ con = (/ 366, 366 /)*one
+ end if
+ if (yyyymm at calendar.eq."gregorian" .or. yyyymm at calendar.eq."standard") then
+ con = (/ 365, 366 /)*one
+ end if
+ else
+ con = (/ 365, 366 /)*one ; default is gregorian/standard
+ end if
+
+ wSum_1 = con(0)
+ wSum_2 = con(1)
+
+ if (rankx.eq.1) then
+ xAnnual = new ( nyrs, typeof(x), getFillValue(x)) ; contributed
+
+ nyr = -1
+ do nt=0,ntim-1,12
+ nyr = nyr+1
+
+ ;nMsg = 0
+ ;if (isatt(x,"_FillValue")) then
+ ; nMsg = num (ismissing(x(nt:nt+11)) )
+ ;end if
+
+ ;if (nMsg.eq.0) then
+ wgt = dymon(nt:nt+11) ; days for each month
+ xTemp = x(nt:nt+11)*wgt ; values(:)*wgt(:)
+ xAnnual(nyr) = sum( xTemp ) ; opt=0
+ nAnnual = num( .not.ismissing(xTemp) )
+
+ if (opt.eq.1) then
+ wgtSum = wSum_1
+ if (isleapyear(yyyy(nt))) then
+ wgtSum = wSum_2
+ end if
+ xAnnual(nyr) = xAnnual(nyr)/wgtSum ; weighted average
+ end if
+ if (opt.eq.2) then
+ xAnnual(nyr) = xAnnual(nyr)/12
+ end if
+
+ if (nAnnual.ne.12) then
+ xAnnual(nyr) = x at _FillValue
+ end if
+ ;end if
+ end do
+
+ xAnnual!0 = "year"
+ xAnnual&year = yyyy(0:ntim-1:12)
+ copy_VarCoords_skipDim0 (x, xAnnual)
+
+ if (isatt(x, "long_name")) then
+ xAnnual at long_name = x at long_name
+ end if
+ if (isatt(x, "units")) then
+ xAnnual at units = x at units
+ end if
+
+ if (isatt(yyyymm,"calendar")) then
+ xAnnual at calendar = yyyymm at calendar
+ end if
+
+ return(xAnnual)
+ end if
+
+ if (rankx.eq.2) then
+ dName = getvardims(x) ; get dim names
+ xAnnual= new ( (/nyrs,dimx(1)/), typeof(x), getFillValue(x)) ; contributed
+
+ nyr = -1
+ do nt=0,ntim-1,12
+ nyr = nyr+1
+ xTemp = x(nt:nt+11,:)
+
+ ;nMsg = 0
+ ;if (isatt(x,"_FillValue")) then
+ ; nMsg = num (ismissing(xTemp) )
+ ;end if
+
+ ;if (nMsg.eq.0) then
+ wgt = conform(xTemp, dymon(nt:nt+11), 0)
+ xTemp = xTemp*wgt ; values*wgt
+ xAnnual(nyr,:) = dim_sum_n( xTemp, 0 ) ; opt=3
+ nAnnual = dim_num_n(.not.ismissing(xTemp), 0 )
+
+ if (opt.eq.1) then
+ wgtSum = wSum_1
+ if (isleapyear(yyyy(nt))) then
+ wgtSum = wSum_2
+ end if
+ xAnnual(nyr,:) = xAnnual(nyr,:)/wgtSum
+ end if
+ if (opt.eq.2) then
+ xAnnual(nyr,:) = xAnnual(nyr,:)/12
+ end if
+
+ xAnnual(nyr,:) = mask( xAnnual(nyr,:), nAnnual.eq.12, True)
+ ;end if
+ end do
+
+ xAnnual!0 = "year"
+ xAnnual&year = yyyy(0:ntim-1:12)
+ copy_VarCoords_skipDim0 (x, xAnnual)
+
+ if (isatt(x, "long_name")) then
+ xAnnual at long_name = x at long_name
+ end if
+ if (isatt(x, "units")) then
+ xAnnual at units = x at units
+ end if
+
+ return(xAnnual)
+ end if
+
+ if (rankx.eq.3) then
+ dName = getvardims(x)
+ ny = dimx(1) ; nlat
+ mx = dimx(2) ; mlon
+ xAnnual = new ( (/nyrs,ny,mx/), typeof(x), getFillValue(x)) ; contributed
+
+ nyr = -1
+ do nt=0,ntim-1,12
+ xTemp = x(nt:nt+11,:,:)
+
+ nyr = nyr+1
+
+ ;nMsg = 0
+ ;if (isatt(x,"_FillValue")) then
+ ; nMsg = num (ismissing(xTemp) )
+ ;end if
+
+ ;if (nMsg.eq.0) then
+ wgt = conform(xTemp, dymon(nt:nt+11), 0)
+ xTemp = xTemp*wgt
+ xAnnual(nyr,:,:) = dim_sum_n ( xTemp, 0 ) ; opt=0
+ nAnnual = dim_num_n (.not.ismissing(xTemp), 0 )
+
+ if (opt.eq.1) then
+ wgtSum = wSum_1
+ if (isleapyear(yyyy(nt))) then
+ wgtSum = wSum_2
+ end if
+ xAnnual(nyr,:,:) = xAnnual(nyr,:,:)/wgtSum
+ end if
+ if (opt.eq.2) then
+ xAnnual(nyr,:,:) = xAnnual(nyr,:,:)/12
+ end if
+
+ xAnnual(nyr,:,:) = mask( xAnnual(nyr,:,:), nAnnual.eq.12, True)
+ ;end if
+ end do
+
+ xAnnual!0 = "year"
+ xAnnual&year = yyyy(0:ntim-1:12)
+ copy_VarCoords_skipDim0 (x, xAnnual)
+
+ if (isatt(x, "long_name")) then
+ xAnnual at long_name = x at long_name
+ end if
+ if (isatt(x, "units")) then
+ xAnnual at units = x at units
+ end if
+
+ return(xAnnual)
+ end if
+
+ if (rankx.eq.4) then
+ dName = getvardims(x)
+ nz = dimx(1) ; nlev
+ ny = dimx(2) ; nlat
+ mx = dimx(3) ; mlon
+ xAnnual = new ( (/nyrs,nz,ny,mx/), typeof(x), getFillValue(x)) ; contributed
+
+ nyr = -1
+ do nt=0,ntim-1,12
+ xTemp = x(nt:nt+11,:,:,:)
+
+ nyr = nyr+1
+
+ ;nMsg = 0
+ ;if (isatt(x,"_FillValue")) then
+ ; nMsg = num (ismissing(xTemp) )
+ ;end if
+
+ ;if (nMsg.eq.0) then
+ wgt = conform(xTemp, dymon(nt:nt+11),0)
+ xTemp = xTemp*wgt
+ xAnnual(nyr,:,:,:) = dim_sum_n ( xTemp, 0 ) ; opt=0
+ nAnnual = dim_num_n (.not.ismissing(xTemp), 0 )
+
+ if (opt.eq.1) then
+ wgtSum = wSum_1
+ if (isleapyear(yyyy(nt))) then
+ wgtSum = wSum_2
+ end if
+ xAnnual(nyr,:,:,:) = xAnnual(nyr,:,:,:)/wgtSum
+ end if
+ if (opt.eq.2) then
+ xAnnual(nyr,:,:,:) = xAnnual(nyr,:,:,:)/12.
+ end if
+
+ xAnnual(nyr,:,:,:) = mask( xAnnual(nyr,:,:,:), nAnnual.eq.12, True)
+ ;end if
+ end do
+
+ xAnnual!0 = "year"
+ xAnnual&year = yyyy(0:ntim-1:12)
+ copy_VarCoords_skipDim0 (x, xAnnual)
+
+ if (isatt(x, "long_name")) then
+ xAnnual at long_name = x at long_name
+ end if
+ if (isatt(x, "units")) then
+ xAnnual at units = x at units
+ end if
+
+ if (isatt(yyyymm,"calendar")) then
+ xAnnual at calendar = yyyymm at calendar
+ end if
+
+ return(xAnnual)
+ end if
+ end
+ ; *****************************************************************
+ ; D. Shea
+ ; Convert monthly total values [eg, precipitation] to "per day" values.
+ ; Each monthly total is divided by the number of days in the month.
+ ; Leap years use 29 days.
+ ;
+ ; Nomenclature:
+ ; yyyymm - yearMonth [eg 195602]
+ ; Values correspond to the time dimension of "x"
+ ; Must be the same size as time dimension of "x".
+ ; x - data array
+ ; if rank is greater than one, then it is required that
+ ; the *leftmost* dimension be "time"
+ ; eg: prc(time), prc(time,lat,lon), prc(time,stations)
+ ; opt - not used currently: set to zero [ 0 ]
+ ;
+ ; Usage: prc(time), prc(time,stations) or prc(time,lat,lon)
+ ; PRC = monthly_total_to_daily_mean( time, prc, 0) ; time is yyyymm
+ ;
+
+ undef("monthly_total_to_daily_mean")
+ function monthly_total_to_daily_mean(yyyymm[*]:numeric, x:numeric, opt:integer)
+ local yyyy, mm, dymon, DYMON, dimx, rankx, xNew
+ begin
+
+ dimx = dimsizes(x)
+ if (dimx(0).ne.dimsizes(yyyymm)) then
+ print("monthly_total_to_daily_mean: yyyymm and x time dimension must be same size")
+ exit
+ end if
+
+ yyyy = yyyymm/100
+ mm = yyyymm - (yyyy*100) ; mm=1,...,12
+ if (any(mm.lt.1 .or. mm.gt.12)) then
+ print("monthly_total_to_daily_mean: mm must be 1-to-12 inclusive")
+ exit
+ end if
+
+ rankx = dimsizes(dimx) ; number of dimensions
+
+ if (isatt(yyyymm,"calendar")) then
+ yyyy at calendar = yyyymm at calendar ; needed for 'day_in_month'
+ end if
+
+ dymon = days_in_month ( yyyy, mm) ; accounts for leap year
+
+ if (rankx.eq.1) then
+ xNew = x/dymon ; per day
+ else
+ DYMON = conform(x, dymon, 0) ; time is the left dim of x [0]
+ xNew = x/DYMON
+ end if
+
+ copy_VarMeta(x, xNew)
+ if (isatt(x,"units")) then
+ xNew at units = x at units + "/day"
+ end if
+
+ return(xNew)
+ end
+ ;**************************************************************************
+ ; D Shea
+ ;
+ ; Standard "lossy" approach to compressing (packing) data.
+ ; The contributed.ncl functions "short2flt", "byte2flt"
+ ; can be used to unpack the values.
+ ;
+ ; NOTE: THE ORIGINAL INPUT VALUES CAN NOT BE RECOVERED.
+ ;
+ ; The actual packing is pretty simple.
+ ; Most of the code is to handle _FillValue and assorted permutations/options
+
+ undef("pack_values")
+ function pack_values(var:numeric, packType:string, opt:logical)
+ local vType, one, two, pMax, sFill, vMin, vMax, vRange, vPack
+ , scale_factor, add_offset, vMinVar, vMaxVar, msgFlag, msgVal, filFlag, filVal
+ begin
+ vType = typeof(var)
+ if (.not.(vType.eq."float" .or. vType.eq."double")) then
+ print("pack_values: FATAL: input must be float or double: vType="+vType)
+ exit
+ end if
+
+ if (.not.(packType.eq."short" .or. packType.eq."byte")) then
+ print("pack_values: FATAL: packType must be short or byte: packType="+packType)
+ exit
+ end if
+ ; user may input both scale_factor and add_offset
+ if (opt .and. (isatt(opt,"scale_factor") .and. .not.isatt(opt,"add_offset" )) .or.
+ (isatt(opt,"add_offset") .and. .not.isatt(opt,"scale_factor"))) then
+ print("pack_values: FATAL: User must specify BOTH scale_factor and add_offset")
+ exit
+ end if
+ ; ensure that float/double handle correctly
+ if (vType.eq."float") then
+ one = 1.0
+ two = 2.0
+ else
+ one = 1.0d
+ two = 2.0d
+ end if
+
+ if (packType.eq."short") then
+ pMax = 2^15 - one
+ else
+ pMax = 2^7 - one
+ end if
+
+ vMinVar = min(var) ; calculate [default]
+ if (opt .and. isatt(opt,"min_value") ) then
+ vMin = opt at min_value ; knowledgable user
+ if (vMinVar.lt.vMin) then
+ print("pack_values: FATAL: User specified opt at min_value is too high")
+ print("pack_values: opt at min_value = "+opt at min_value)
+ print("pack_values: actual min value = "+vMinVar)
+ exit
+ end if
+ else
+ vMin = vMinVar
+ end if
+
+ vMaxVar = max(var) ; calculate [default]
+ if (opt .and. isatt(opt,"max_value") ) then
+ vMax = opt at max_value ; knowledgable user
+ if (vMaxVar.gt.vMax) then
+ print("pack_values: FATAL: User specified opt at max_value is too low")
+ print("pack_values: opt at max_value = "+opt at max_value)
+ print("pack_values: actual max value = "+vMaxVar)
+ exit
+ end if
+ else
+ vMax = vMaxVar
+ end if
+
+ if (.not.isatt(var,"_FillValue") .and. isatt(var,"missing_value")) then
+ var at _FillValue = var at missing_value ; NCL only understands _FillValue
+ end if
+
+ if (isatt(var,"_FillValue")) then
+ if (opt .and. isatt(opt,"msgFill") ) then
+ if (packType.eq."short") then
+ if (typeof(opt at msgFill).eq."integer") then
+ sFill = inttoshort(opt at msgFill) ; user specified _FillValue
+ else
+ sFill = opt at msgFill ; must be same as packType
+ end if
+ else
+ if (typeof(opt at msgFill).eq."integer") then
+ sFill = inttobyte(opt at msgFill) ; user specified _FillValue
+ else
+ sFill = opt at msgFill ; must be same as packType
+ end if
+ end if
+ else
+ if (packType.eq."short") then
+ if (vType.eq."float") then
+ sFill = floattoshort (pMax) ; default _FillValue
+ else
+ sFill = doubletoshort(pMax)
+ end if
+ else
+ if (vType.eq."float") then
+ sFill = floattobyte (pMax) ; default _FillValue
+ else
+ sFill = doubletobyte(pMax)
+ end if
+ end if
+ end if
+ vPack = new ( dimsizes(var), packType, sFill) ; pre-fill with _FillValue
+ end if ; if _FillValue associated var
+
+ vRange = vMax-vMin
+ scale_factor = vRange/pMax
+ add_offset = (vMax+vMin)/two
+
+ if (opt .and. isatt(opt,"scale_factor") .and. isatt(opt,"add_offset") ) then
+ scale_factor = opt at scale_factor ; must be careful
+ add_offset = opt at add_offset ; " " "
+ end if
+
+ if (packType.eq."short") then
+ if (vType.eq."float") then
+ vPack = floattoshort((var-add_offset)/scale_factor) ; pack ... array syntax
+ else
+ vPack = doubletoshort((var-add_offset)/scale_factor)
+ end if
+ else ; byte
+ if (vType.eq."float") then
+ vPack = floattobyte((var-add_offset)/scale_factor) ; pack ... array syntax
+ else
+ vPack = doubletobyte((var-add_offset)/scale_factor)
+ end if
+ end if
+
+ copy_VarCoords(var,vPack) ; copy coordinates
+
+ msgFlag = False
+ if (isatt(var,"missing_value")) then
+ msgVal = var at missing_value ; float/double
+ delete(var at missing_value) ; so it will not be copied to new variable
+ msgFlag = True
+ end if
+
+ filFlag = False
+ if (isatt(var,"_FillValue")) then
+ filVal = var at _FillValue ; float/double
+ delete(var at _FillValue) ; so it will not be copied to new variable
+ filFlag = True
+ end if
+
+ copy_VarAtts(var,vPack) ; copy attributes but not original
+ ; missing_value or _FillValue
+ if (msgFlag) then
+ var at missing_value = msgVal ; reassign to input variable
+ vPack at missing_value = sFill ; explicitly add
+ end if
+
+ if (filFlag) then
+ var at _FillValue = filVal ; reassign to input variable
+ end if
+
+ vPack at add_offset = add_offset
+ vPack at scale_factor = scale_factor
+
+ vPack at vMin_original_data = vMinVar
+ if (opt .and. isatt(opt,"min_value") ) then
+ vPack at vMin_user_specified = opt at min_value
+ end if
+
+ vPack at vMax_original_data = vMaxVar
+ if (opt .and. isatt(opt,"max_value") ) then
+ vPack at vMax_user_specified = opt at max_value
+ end if
+
+ vPack at vRange = vRange
+
+
+ return(vPack)
+ end
+ ;**************************************************************************
+ ; D Shea
+ ;
+ ; Get the suffix associated with a file. Minor options.
+ ; The attribute "fBase" is the file name without the suffix
+ ;
+ ; Usage:
+ ; fName = "sample.1958-2005.nc.gz"
+ ; suffix = get_file_suffix(fName, 0) ; ".gz"
+ ; if (suffix.eq.".gz") then
+ ; system("gzip -d "+fName)
+ ; fileName = suffix at fBase ; sample.1958-2005.nc
+ ; end if
+ ; f = addfile(fileName, "r")
+ ;
+ ; fName = "sample.1958-2005.nc.gz"
+ ; suffix = get_file_suffix(fName, 1) ; ".1958-2005.gz"
+ ; fBase = suffix at fBase ; sample
+
+ undef("get_file_suffix")
+ function get_file_suffix (filName[1]:string, opt:integer)
+ local chr, ckey, cstr, N, filName_suffix, nStrt, nLast, n
+ begin
+ chr = stringtochar(".") ; dimsizes(chr)=2
+ ckey = chr(0) ; int 46
+
+ cstr = stringtochar(filName)
+ N = dimsizes(cstr) ; one extra for end of char
+
+ filName_suffix = new (1, "string") ; _FillValue="missing"
+
+ if (opt.eq.0) then
+ nStrt = N-2
+ nLast = 0
+ else
+ nStrt = 0
+ nLast = N-2
+ end if
+
+ do n=nStrt,nLast,1
+ if (cstr(n).eq.ckey) then
+ filName_suffix = chartostring(cstr(n:N-2))
+ filName_suffix at fBase = chartostring(cstr(0:n-1))
+ break
+ end if
+ end do
+
+ return(filName_suffix)
+ end
+
+ ;**************************************************************************
+ ; D Shea
+ ;
+ undef("niceLatLon2D")
+ function niceLatLon2D(lat2d[*][*], lon2d[*][*])
+ ; check map coordinates to see if they have a "nice" structure
+ ;
+ ; if True then
+ ; the data could be made accessible via classic
+ ; netCDF coordinate array subscripting.
+ ;
+ ; lat = lat2d(:,0)
+ ; lon = lon2d(0,:)
+ ; lat at units= "degrees_north"
+ ; lon at units= "degrees_east"
+ ; lat!0 = "lat"
+ ; lon!0 = "lon"
+ ; lat&lat = lat
+ ; lon&lon = lon
+ ;
+ ; assign to a variable
+
+ local dimll, nLeft, nRght
+ begin
+ dimll = dimsizes(lat2d) ; (south_north,west_east)
+ nLeft = dimll(0)
+ nRght = dimll(1)
+
+ if (all(lat2d(:,0).eq.lat2d(:,nRght/2)) .and.
+ all(lat2d(:,0).eq.lat2d(:,nRght-1)) .and.
+ all(lon2d(0,:).eq.lon2d(nLeft/2,:)) .and.
+ all(lon2d(0,:).eq.lon2d(nLeft-1,:)) ) then
+ return(True)
+ else
+ return(False)
+ end if
+ end
+ ;**************************************************************************
+ ; D Shea
+
+ undef("isMonotonic")
+ function isMonotonic(x[*]:numeric)
+ ; check for monoticity
+ local nx
+ begin
+ nx = dimsizes(x)
+
+ if (all(x(1:nx-1).gt.x(0:nx-2))) then
+ return(1)
+ end if
+ if (all(x(1:nx-1).lt.x(0:nx-2))) then
+ return(-1)
+ end if
+ return(0)
+ end
+
+ ;**************************************************************************
+ ; Contributed by Christine Shields, March 2006.
+ ; Slight mods were made to allow input to be numeric.
+ ; Bug fix: 23 Sept 2009
+
+ undef("rho_mwjf")
+ function rho_mwjf(t2d[*][*]:numeric,s2d[*][*]:numeric,depth:numeric)
+
+ ;-- based on Steve Yeager's rhoalphabeta
+ ;-- which in turn is based on POP state_mod.F (ccsm3_0_beta22) for 'mwjf'
+ ;=========================================================================
+
+
+ local dims,nx,ny,c1,c1p5,c2,c3,c4,c5,c10,c1000,p001,mwjfnp0s0t0,mwjfnp0s0t1,
+ mwjfnp0s0t2,mwjfnp0s0t3,mwjfnp0s1t0,mwjfnp0s1t1,mwjfnp0s2t0,mwjfnp1s0t0,
+ mwjfnp1s0t2,mwjfnp1s1t0,mwjfnp2s0t0,mwjfnp2s0t2,mwjfdp0s0t0,mwjfdp0s0t1,
+ mwjfdp0s0t2,mwjfdp0s0t3,mwjfdp0s0t4,mwjfdp0s1t0,mwjfdp0s1t1,mwjfdp0s1t3,
+ mwjfdp0sqt0,mwjfdp0sqt2,mwjfdp1s0t0,mwjfdp2s0t3,mwjfdp3s0t1,pressure,p,
+ sqr,work1,work2,rhofull
+ begin
+
+ ;========= define rho
+ rhoout = new(dimsizes(t2d),typeof(t2d))
+
+ ;========== define constants
+ c1 = 1.0
+ c1p5 = 1.5
+ c2 = 2.0
+ c3 = 3.0
+ c4 = 4.0
+ c5 = 5.0
+ c10 = 10.0
+ c1000 = 1000.0
+ ;*** these constants will be used to construct the numerator
+ ;*** factor unit change (kg/m^3 -> g/cm^3) into numerator terms
+ p001 = 0.001
+ mwjfnp0s0t0 = 9.99843699e+2 * p001
+ mwjfnp0s0t1 = 7.35212840e+0 * p001
+ mwjfnp0s0t2 = -5.45928211e-2 * p001
+ mwjfnp0s0t3 = 3.98476704e-4 * p001
+ mwjfnp0s1t0 = 2.96938239e+0 * p001
+ mwjfnp0s1t1 = -7.23268813e-3 * p001
+ mwjfnp0s2t0 = 2.12382341e-3 * p001
+ mwjfnp1s0t0 = 1.04004591e-2 * p001
+ mwjfnp1s0t2 = 1.03970529e-7 * p001
+ mwjfnp1s1t0 = 5.18761880e-6 * p001
+ mwjfnp2s0t0 = -3.24041825e-8 * p001
+ mwjfnp2s0t2 = -1.23869360e-11 * p001
+ ;*** these constants will be used to construct the denominator
+ mwjfdp0s0t0 = 1.0e+0
+ mwjfdp0s0t1 = 7.28606739e-3
+ mwjfdp0s0t2 = -4.60835542e-5
+ mwjfdp0s0t3 = 3.68390573e-7
+ mwjfdp0s0t4 = 1.80809186e-10
+ mwjfdp0s1t0 = 2.14691708e-3
+ mwjfdp0s1t1 = -9.27062484e-6
+ mwjfdp0s1t3 = -1.78343643e-10
+ mwjfdp0sqt0 = 4.76534122e-6
+ mwjfdp0sqt2 = 1.63410736e-9
+ mwjfdp1s0t0 = 5.30848875e-6
+ mwjfdp2s0t3 = -3.03175128e-16
+ mwjfdp3s0t1 = -1.27934137e-17
+
+ ;=====pressure calculaton
+ ; taken from gokhan's idl pressure.pro for references
+ ; this function computes pressure in bars from depth in meters
+ ; by using a mean density derived from depth-dependent global
+ ; average temperatures and salinities from Levitus_94, and
+ ; integrating using hydrostatic balance.
+ ;
+ ; references:
+ ; Levitus, S., R. Burgett, and T.P. Boyer, World Ocean Atlas
+ ; 1994, Volume 3: Salinity, NOAA Atlas NESDIS 3, US Dept. of
+ ; Commerce, 1994.
+ ; Levitus, S. and T.P. Boyer, World Ocean Atlas 1994,
+ ; Volume 4: Temperature, NOAA Atlas NESDIS 4, US Dept. of
+ ; Commerce, 1994.
+ ; Dukowicz, J. K., 2000: Reduction of Pressure and Pressure
+ ; Gradient Errors in Ocean Simulations, J. Phys. Oceanogr.,
+ ; submitted.
+
+ if(depth.ne.0) then
+ pressure = 0.059808*(exp(-0.025*depth) - 1.0) + 0.100766*depth +
+ 2.28405e-7*(depth^2)
+ else
+ pressure = 0.
+ end if
+
+ p = pressure
+ ; CAS corrected this; verified w/Steve Yeager 9/8/09
+ ; p = pressure only works for potential density; depth/pressure = 0.
+ p = pressure*c10
+
+ ;========= compute the numerator of the MWFJ density [P_1(S,T,p)]
+
+ mwjfnums0t0 = mwjfnp0s0t0 + p*(mwjfnp1s0t0 + p*mwjfnp2s0t0)
+ mwjfnums0t1 = mwjfnp0s0t1
+ mwjfnums0t2 = mwjfnp0s0t2 + p*(mwjfnp1s0t2 + p*mwjfnp2s0t2)
+ mwjfnums0t3 = mwjfnp0s0t3
+ mwjfnums1t0 = mwjfnp0s1t0 + p*mwjfnp1s1t0
+ mwjfnums1t1 = mwjfnp0s1t1
+ mwjfnums2t0 = mwjfnp0s2t0
+
+ work1 = t2d
+ work1 = mwjfnums0t0 + t2d * (mwjfnums0t1 + t2d * (mwjfnums0t2 +
+ mwjfnums0t3 * t2d )) + s2d * (mwjfnums1t0 +
+ mwjfnums1t1 * t2d + mwjfnums2t0 * s2d)
+
+ ;============= compute the denominator of MWJF density [P_2(S,T,p)]
+
+ sqr = sqrt(s2d)
+
+ mwjfdens0t0 = mwjfdp0s0t0 + p*mwjfdp1s0t0
+ mwjfdens0t1 = mwjfdp0s0t1 + p^3 * mwjfdp3s0t1
+ mwjfdens0t2 = mwjfdp0s0t2
+ mwjfdens0t3 = mwjfdp0s0t3 + p^2 * mwjfdp2s0t3
+ mwjfdens0t4 = mwjfdp0s0t4
+ mwjfdens1t0 = mwjfdp0s1t0
+ mwjfdens1t1 = mwjfdp0s1t1
+ mwjfdens1t3 = mwjfdp0s1t3
+ mwjfdensqt0 = mwjfdp0sqt0
+ mwjfdensqt2 = mwjfdp0sqt2
+
+ work2 = t2d
+ work2 = mwjfdens0t0 + t2d * (mwjfdens0t1 + t2d * (mwjfdens0t2 +
+ t2d * (mwjfdens0t3 + mwjfdens0t4 * t2d ))) +
+ s2d * (mwjfdens1t0 + t2d * (mwjfdens1t1 + t2d*t2d*mwjfdens1t3) +
+ sqr * (mwjfdensqt0 + t2d*t2d*mwjfdensqt2))
+
+ denomk = work2
+ denomk = c1/work2
+
+ rhofull = work1
+ rhofull = work1*denomk
+
+ rhoout = rhofull
+
+ ;==== return density
+
+ return (rhoout)
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; append [concatenate] arrays along record dimension
+ undef("array_append_record")
+ function array_append_record (x1, x2, iopt:integer)
+ local dim_x1, dim_x2, rank_x1, rank_x2, n1, n2, dim_xNew, xNew
+ , errFlag, dimNames_x1, dimNames_x2, dimNames, n
+ , recCoord, recFlag
+
+ begin
+ ; get array shape/sizes
+ dim_x1 = dimsizes(x1)
+ dim_x2 = dimsizes(x2)
+
+ rank_x1 = dimsizes(dim_x1)
+ rank_x2 = dimsizes(dim_x2)
+
+ errFlag = 0 ; ERROR CHECKING
+ ; ranks must be equal
+ if (rank_x1.ne.rank_x1) then
+ print("array_append_record: ranks not equal: rank_x1="+rank_x1+
+ " rank_x2="+rank_x2)
+ errFlag = errFlag + 1
+ end if
+ ; current version only supports
+ if (rank_x1.gt.5) then
+ print ("array_append_record: currently will only append array of rank 5 or less")
+ print (" rank="+rank_x1)
+ errFlag = errFlag + 1
+ end if
+ ; types must match
+ if (typeof(x1).ne.typeof(x2)) then
+ print ("array_append_record: arrays must be of the same type")
+ print (" typeof(x1)="+typeof(x1))
+ print (" typeof(x2)="+typeof(x2))
+ errFlag = errFlag + 1
+ end if
+
+ if (rank_x1.gt.1 .and. .not.all(dim_x1(1:).eq.dim_x2(1:))) then
+ print ("array_append_record: non-record dimensions must be the same size")
+ errFlag = errFlag + 1
+ end if
+
+ if (errFlag.ne.0) then
+ exit
+ end if
+ ; allocate space for new array
+ n1 = dim_x1(0)
+ n2 = dim_x2(0)
+ dim_xNew = dim_x1
+ dim_xNew(0) = n1 + n2
+ xNew = new ( dim_xNew, typeof(x1), getFillValue(x1) )
+ ; chk _FillValue stuff
+ if (.not.isatt(x1,"_FillValue") ) then
+ if (isatt(xNew,"_FillValue") ) then
+ delete(xNew at _FillValue)
+ end if
+ end if
+
+ if (isatt(x2,"_FillValue") ) then
+ xNew at _FillValue = x2 at _FillValue
+ end if
+ ; assign values
+ if (rank_x1.eq.1) then
+ xNew(0:n1-1) = (/ x1 /)
+ xNew(n1: ) = (/ x2 /)
+ end if
+
+ if (rank_x1.eq.2) then
+ xNew(0:n1-1,:) = (/ x1 /)
+ xNew(n1: ,:) = (/ x2 /)
+ end if
+
+ if (rank_x1.eq.3) then
+ xNew(0:n1-1,:,:) = (/ x1 /)
+ xNew(n1: ,:,:) = (/ x2 /)
+ end if
+
+ if (rank_x1.eq.4) then
+ xNew(0:n1-1,:,:,:) = (/ x1 /)
+ xNew(n1: ,:,:,:) = (/ x2 /)
+ end if
+
+ if (rank_x1.eq.5) then
+ xNew(0:n1-1,:,:,:,:) = (/ x1 /)
+ xNew(n1: ,:,:,:,:) = (/ x2 /)
+ end if
+ ; meta data
+ copy_VarAtts (x1, xNew) ; copy attributes
+ copy_VarAtts (x2, xNew) ; may overwrite previous info
+
+ dimNames_x1 = getvardims(x1) ; dimension names
+ dimNames_x2 = getvardims(x2)
+ dimNames = dimNames_x1 ; default
+ ; only go here if dimNames are not the same
+ ; name all dimensions
+ do n=0,rank_x1-1
+ if (ismissing(dimNames_x1(n)) .and.
+ .not.ismissing(dimNames_x2(n))) then
+ dimNames(n) = dimNames_x2(n)
+ x1!n = dimNames(n)
+ end if
+ if (ismissing(dimNames_x1(n)) .and.
+ ismissing(dimNames_x2(n))) then
+ dimNames(n) = "dim"+n
+ x1!n = "dim"+n
+ x2!n = "dim"+n
+ end if
+ end do
+
+ if (iscoord(x1,dimNames_x1(0)) ) then
+ recCoord = new ( n1+n2, typeof(x1&$dimNames_x1(0)$) )
+ if (iscoord(x1,dimNames_x1(0)) ) then
+ recCoord(0:n1-1) = x1&$dimNames_x1(0)$
+ end if
+ if (iscoord(x2,dimNames_x2(0)) ) then
+ recCoord(n1: ) = x2&$dimNames_x2(0)$
+ end if
+ end if
+
+ recFlag = False
+ if (isvar("recCoord") .and. .not.all(ismissing(recCoord))) then
+ recFlag = True ; must have coord
+ ;delete(recCoord at _FillValue)
+ end if
+ ; assign coordinate variables [if present]
+ do n=0,rank_x1-1
+ xNew!n = dimNames(n) ; name all dimensions
+ if (n.eq.0 .and. recFlag) then
+ xNew&$dimNames(n)$ = recCoord
+ else
+ if (iscoord(x1,dimNames_x1(n)) ) then
+ xNew&$dimNames(n)$ = x1&$dimNames(n)$ ; right dimensions
+ else
+ if (iscoord(x1,dimNames_x2(n)) ) then
+ xNew&$dimNames(n)$ = x2&$dimNames(n)$
+ end if
+ end if
+ end if
+ end do
+
+ return (xNew)
+ end
+ ; ******************************************************************
+ ; D. Shea
+ ; attaches/appends table data: ie (row,column) arrays ; add additional rows
+ ; will add the coordinate variable of the right dimension
+ ; but will not do so for the left dimension. The left dimension
+ ; will be named but no coordinates will be associated with the name.
+
+ undef("table_attach_rows")
+ function table_attach_rows (t1[*][*], t2[*][*], iopt:integer)
+
+ local dim_t1, dim_t2, ncol1, ncol2, nrow1, nrow2
+ , dimNames_t1, dimNames_t2, dimNames, n
+ begin
+
+ printVarSummary(t1)
+ printVarSummary(t2)
+ ; get array shape/sizes
+ dim_t1 = dimsizes(t1)
+ dim_t2 = dimsizes(t2)
+
+ ncol1 = dim_t1(1)
+ ncol2 = dim_t2(1)
+
+ if (ncol1.ne.ncol2) then
+ print ("table_attach_rows: tables must have same number of columns")
+ print (" ncol1="+ncol1)
+ print (" ncol2="+ncol2)
+ exit
+ end if
+
+ if (typeof(t1).ne.typeof(t2)) then
+ print ("table_attach_rows: arrays must be of the same type")
+ print (" typeof(t1)="+typeof(t1))
+ print (" typeof(t2)="+typeof(t2))
+ exit
+ end if
+ ; allocate space for new array
+ nrow1 = dim_t1(0)
+ nrow2 = dim_t2(0)
+
+ ; chk _FillValue stuff
+ if (isatt(t1,"_FillValue") ) then
+ tNew = new ( (/nrow1+nrow2, ncol1/), typeof(t1), t1 at _FillValue)
+ else if (isatt(t2,"_FillValue") ) then
+ tNew = new ( (/nrow1+nrow2, ncol1/), typeof(t2), t2 at _FillValue)
+ else
+ tNew = new ( (/nrow1+nrow2, ncol1/), typeof(t2), "No_FillValue")
+ end if
+ end if
+ ; insert values
+ tNew(0:nrow1-1,:) = (/ t1 /)
+ tNew(nrow1: ,:) = (/ t2 /)
+ write_matrix(tNew, "10f7.2" , False)
+ ; meta data
+ tNew!0 = "row" ; *default* dim names
+ tNew!1 = "col"
+
+ copy_VarAtts (t1, tNew) ; copy attributes
+ copy_VarAtts (t2, tNew) ; may overwrite previous info
+
+ dimNames_t1 = getvardims(t1) ; dimension names
+ dimNames_t2 = getvardims(t2)
+
+ do n=0,1 ; override "row", "col"
+ if (.not.ismissing(dimNames_t1(n))) then
+ tNew!n = dimNames_t1(n) ; default ... use t1 dim names
+ else if (.not.ismissing(dimNames_t2(n))) then
+ tNew!n = dimNames_t2(n) ; use t2 dim names if t1 not present
+ end if
+ end if
+ end do
+ ; coord for the right dim (n=1) only
+ ; left dim (n=0) will be named but no coord
+ ; too many hassles when testing
+ n = 1
+ if (iscoord(t1,dimNames_t1(n)) ) then
+ tNew&$dimNames_t1(n)$ = t1&$dimNames_t1(n)$ ; right dimensions
+ else if (iscoord(t2,dimNames_t2(n)) ) then
+ tNew&$dimNames_t2(n)$ = t2&$dimNames_t2(n)$
+ end if
+ end if
+
+ return (tNew)
+ end
+
+ ; ******************************************************************
+ ; D. Shea
+ ; appends table data: ie (row,column) arrays
+ ; adds additional columns
+ ;
+
+ undef("table_attach_columns")
+ function table_attach_columns (t1[*][*], t2[*][*], iopt:integer)
+ local dim_t1, dim_t2, nrow1, nrow2, trows
+ , dimNames_t1, dimNames_t2, dimNames, n
+ begin
+ ; get array shape/sizes
+ dim_t1 = dimsizes(t1)
+ dim_t2 = dimsizes(t2)
+
+ nrow1 = dim_t1(0)
+ nrow2 = dim_t2(0)
+
+ dimNames_t1 = getvardims(t1) ; dimension names
+ dimNames_t2 = getvardims(t2)
+
+ if (nrow1.ne.nrow2) then
+ print ("table_attach_columns: tables must have same number of rows")
+ print (" nrow1="+nrow1)
+ print (" nrow2="+nrow2)
+ exit
+ end if
+
+ if (typeof(t1).ne.typeof(t2)) then
+ print ("table_attach_columns: tables must be of the same type")
+ print (" typeof(t1)="+typeof(t1))
+ print (" typeof(t2)="+typeof(t2))
+ exit
+ end if
+
+ if (any(ismissing(dimNames_t1))) then
+ if (ismissing(dimNames_t1(0))) then
+ t1!0 = "row_1"
+ dimNames_t1(0) = t1!0
+ end if
+ if (ismissing(dimNames_t1(1))) then
+ t1!1 = "col_1"
+ dimNames_t1(1) = t1!1
+ end if
+ end if
+
+ if (any(ismissing(dimNames_t2))) then
+ if (ismissing(dimNames_t2(0))) then
+ t2!0 = "row_2"
+ dimNames_t2(0) = t2!0
+ end if
+ if (ismissing(dimNames_t2(1))) then
+ t2!1 = "col_2"
+ dimNames_t2(1) = t2!1
+ end if
+ end if
+ ; reverse order ... invoke row append
+ trows = table_attach_rows(t1($dimNames_t1(1)$|:,$dimNames_t1(0)$|:)
+ ,t2($dimNames_t2(1)$|:,$dimNames_t2(0)$|:) , 0 )
+ dimNames = getvardims(trows) ; dimension names
+ ; revert back to original order
+ return (trows($dimNames(1)$|:,$dimNames(0)$|:) )
+ end
+ ;****************************************************************
+ ; D Shea
+ ; requires NCL version a034 or later
+ ;
+ ; Get the indices [subscripts] of the 2D lat/lon arrays
+ ; closest to each LAT/LON coordinate pair.
+ ;
+ undef("getind_latlon2d")
+ function getind_latlon2d(lat2d[*][*]:numeric,lon2d[*][*]:numeric
+ ,LAT[*]:numeric, LON[*]:numeric)
+ local N, ij, lat1d, lon1d, dist, mndist, indx
+ begin
+ N = dimsizes( LAT )
+ ij = new ( (/N,2/) , typeof(N))
+
+ lat1d = ndtooned( lat2d )
+ lon1d = ndtooned( lon2d )
+ n2d = dimsizes( lat2d )
+
+ do n=0,N-1
+ dist = gc_latlon(LAT(n),LON(n),lat1d,lon1d, 2,2)
+ mndist = min( dist )
+ ind1d = ind(dist.eq.mndist)
+ if (.not.ismissing(ind1d(0))) then
+ ij(n,:) = ind_resolve( ind1d(0), n2d )
+ else
+ print("getind_latlon2d: lat="+ LAT(n)+" lon="+ LON(n)+" problem")
+ end if
+
+ delete(mndist)
+ delete(ind1d)
+ end do
+ ij at long_name = "indices closest to specified LAT/LON coordinate pairs"
+
+ if (.not.any(ismissing(ij))) then
+ delete(ij at _FillValue)
+ end if
+
+ return( ij )
+ end
+
+ ;****************************************************************
+ ; D Shea
+ ; Emulate the fortran "mod" function
+
+ undef ("mod")
+ function mod (r1:numeric, r2:numeric)
+ ; mod function like GNU fortran ; AS ALWAYS: BE CAREFUL MIXING NUMERIC TYPES
+ local rank_r1, rank_r2, type_r1, type_r2, tmp, R2
+ begin
+ if (any(r2.eq.0)) then
+ print("mod: contributed: r2 cannot be zero")
+ exit
+ end if
+
+ rank_r1 = dimsizes(dimsizes(r1))
+ rank_r2 = dimsizes(dimsizes(r2))
+ if (rank_r1.ne.rank_r2 .and. rank_r2.gt.1) then
+ print("mod: contributed: rank(r1).ne.rank(r2)")
+ print(" rank(r1)= "+rank_r1)
+ print(" rank(r2)= "+rank_r2)
+ exit
+ end if
+
+ type_r1 = typeof(r1)
+ type_r2 = typeof(r2)
+
+ if (type_r1.eq."double") then
+ return( r1 - (r2 * toint( r1/r2) ) )
+ end if
+
+ if (type_r1.eq."float") then
+ if (type_r2.eq."float" .or. type_r2.eq."integer") then
+ return( r1 - (r2 * toint( r1/r2 ) ))
+ end if
+
+ if (type_r2.eq."double") then
+ tmp = doubletofloat( r1 - (r2 * toint( r1/r2 ) ))
+ return( tmp )
+ end if
+ end if
+
+ if (type_r1.eq."integer") then
+ if (type_r2.eq."integer") then
+ return( r1 % r2 )
+ end if
+ if (type_r2.eq."float") then
+ R2 = toint(r2)
+ return( r1 - toint(R2 * (r1/R2)))
+ end if
+ if (type_r2.eq."double") then
+ R2 = toint(r2)
+ return( r1 - toint(R2 * (r1/R2)))
+ end if
+ end if
+
+ end
+
+ ;-------------------------------------------------------------
+ ; find indices corresponding to closest distance
+ ; to a coordinate array [ie: 1D mononic array]
+ ;
+ undef("ind_nearest_coord")
+ function ind_nearest_coord ( z[*]:numeric, zgrid[*]:numeric, iopt:integer)
+ local n, nz, iz, zz, mnzz, imn
+ begin
+ nz = dimsizes(z)
+ iz = new(nz, "integer", "No_FillValue")
+ do n=0,nz-1 ; loop over each value
+ zz = abs(z(n)-zgrid) ; distances
+ mnzz = min( zz ) ; min distance
+ imn = ind(zz.eq.mnzz) ; index on min distance: may be more than one
+ iz(n) = imn(0) ; select only the 1st one
+ delete(imn)
+ end do
+
+ return(iz)
+ end
+
+ ;****************************************************************
+ ; Christophe Cassou [CERFACS, Toulouse CEDEX France] and Dennis Shea
+ ; Generate unique random subscript indices
+ ;
+ ; As of 6.0.0, N can be integer or long
+ ;
+ undef("generate_unique_indices")
+ function generate_unique_indices( N )
+ local r
+ begin
+ if(.not.any(typeof(N).eq.(/"integer","long"/))) then
+ print("generate_unique_indices: N must be integer or long")
+ exit
+ end if
+ r = random_uniform(0,100,N)
+ return( dim_pqsort(r, 1) )
+ end
+ ; **********************************************************************
+ ; D. Shea
+ ;
+ undef("isEqualSpace")
+ function isEqualSpace(z[*]:numeric, epsz[1]:numeric)
+ local nz, dz, dz_low, dz_high, diff
+ begin
+ nz = dimsizes(z)
+ if (nz.le.1) then
+ print("is_equal_space: input array must be > 2")
+ exit
+ end if
+ dz = abs(z(1)-z(0)) ; error check
+ dz_low = dz-epsz
+ dz_hgh = dz+epsz
+ diff = all(abs(z(1:nz-1)-z(0:nz-2)) .ge. dz_low) .and.
+ all(abs(z(1:nz-1)-z(0:nz-2)) .le. dz_hgh)
+ return (diff)
+ end
+ ; ---
+ undef("isConstantSpace")
+ ; old name
+ function isConstantSpace(z[*]:numeric, epsz[1]:numeric)
+ begin
+ return(isEqualSpace(z,epsz))
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "area_hi2lores": copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+ ;
+ undef ("area_conserve_remap_Wrap")
+ function area_conserve_remap_Wrap (xi[*]:numeric,yi[*]:numeric, fi:numeric
+ ,xo[*]:numeric,yo[*]:numeric, opt)
+
+ ; wrapper for NCL function "area_conserve_remap"
+ ; that copies attributes and coordinate vars
+
+ local fo, dimfi, nDim, nD
+ begin
+ fo = area_conserve_remap (xi,yi,fi, xo,yo, opt) ; perform interp
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+
+ fo!(nDim-2) = "Y" ; default named dimensions
+ fo!(nDim-1) = "X"
+ ; override if possible
+ if (isdimnamed(xo,0) .and. isdimnamed(yo,0) ) then
+ fo!(nDim-2) = yo!0 ; if present, use xo name
+ fo!(nDim-1) = xo!0 ; if present, use xo name
+ else
+ do nD=nDim-2,nDim-1 ; two rightmost dimensions
+ if (.not.ismissing(fi!nD)) then
+ ;fo!nD = changeCaseChar(fi!nD) ; if present, use same name
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ end if ; but change case
+ end do
+ end if
+
+ fo&$fo!(nDim-2)$ = yo ; create coordinate var
+ fo&$fo!(nDim-1)$ = xo ; two rightmost dimensions
+
+ return (fo)
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "area_hi2lores": copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef ("area_hi2lores_Wrap")
+ function area_hi2lores_Wrap (xi[*]:numeric,yi[*]:numeric, fi:numeric, wrapX:logical
+ ,wy[*]:numeric,xo[*]:numeric,yo[*]:numeric, Opt)
+
+ ; wrapper for NCL function "area_hi2lores" that copies attributes and coordinate vars
+
+ local fo, dimfi, nDim, nD
+ begin
+ fo = area_hi2lores (xi,yi,fi, wrapX, wy, xo,yo, Opt) ; perform interp
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fi)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ copy_VarCoords_2 (fi, fo) ; copy coord variables
+
+ fo!(nDim-2) = "Y" ; default named dimensions
+ fo!(nDim-1) = "X"
+ ; override if possible
+ if (isdimnamed(xo,0) .and. isdimnamed(yo,0) ) then
+ fo!(nDim-2) = yo!0 ; if present, use xo name
+ fo!(nDim-1) = xo!0 ; if present, use xo name
+ else
+ do nD=nDim-2,nDim-1 ; two rightmost dimensions
+ if (.not.ismissing(fi!nD)) then
+ ;fo!nD = changeCaseChar(fi!nD) ; if present, use same name
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ end if ; but change case
+ end do
+ end if
+
+ fo&$fo!(nDim-2)$ = yo ; create coordinate var
+ fo&$fo!(nDim-1)$ = xo ; two rightmost dimensions
+
+ return (fo)
+ end
+ ; **********************************************************************
+ ; D. Shea
+ ; Generate [sin(lat+dlat/2)-sin(lat-dlat/2)] weights
+ ; for equally spaced grids. Currently, only global grids are supported.
+ ;
+ undef("latRegWgt")
+ function latRegWgt(lat[*]:numeric, nType[1]:string, opt[1]:integer)
+ ; usage: wgt = latRegWgt(lat, "double", 0)
+ ; wgt = latRegWgt(lat, "float" , 0)
+ local nlat, pi, rad, err, eps, dlat, dlat_low, dlat_hgh, diff, nl, dNam
+ begin
+ nlat = dimsizes(lat)
+ pi = 4.0d*atan(1.0d)
+ rad = pi/180.0d
+ err = 1d20
+ eps = 0.001 ; arbitrary
+
+ dlat = abs(lat(2)-lat(1)) ; error check
+ dlat_low = dlat-eps
+ dlat_hgh = dlat+eps
+ diff = all(abs(lat(1:nlat-1)-lat(0:nlat-2)) .ge. dlat_low) .and.
+ all(abs(lat(1:nlat-1)-lat(0:nlat-2)) .le. dlat_hgh)
+ if (.not.diff) then
+ print("latRegWgt: Expecting equally spaced latitudes")
+ if (nType.eq."double") then
+ return(new(nlat,"double",err))
+ else
+ return(new(nlat,"float",doubletofloat(err)))
+ end if
+ end if
+ delete(dlat)
+
+ dlat = abs((lat(2)-lat(1))*rad)*0.5d
+
+ w = new (nlat, "double", "No_FillValue")
+
+ do nl=0,nlat-1
+ w(nl) = abs( sin(lat(nl)*rad+dlat) - sin(lat(nl)*rad-dlat))
+ end do
+ ; poles
+ if (abs(lat(0)).gt.89.9999d) then
+ nl = 0
+ ;;w(nl) = abs( sin(lat(nl)*rad)- sin(lat(nl)*rad-dlat))
+ ;;weight_pole = abs ( 1. - sin(pi/2 - (Delta_phi)/2 ) ; CJ
+ w(nl) = abs ( 1d0 - sin(pi/2d0 - dlat)) ; CJ
+ end if
+ if (abs(lat(nlat-1)).gt.89.9999d) then
+ nl = nlat-1
+ ;;w(nl) = abs( sin(lat(nl)*rad)- sin(lat(nl)*rad-dlat))
+ ;;weight_pole = abs ( 1. - sin(pi/2 - (Delta_phi)/2 ) ; CJ
+ w(nl) = abs ( 1d0 - sin(pi/2d0 - dlat)) ; CJ
+ end if
+
+ dNam = getvardims( lat )
+ if (.not.ismissing(dNam)) then
+ w!0 = dNam
+ if (iscoord(lat, dNam)) then
+ w&$dNam$ = lat
+ end if
+ end if
+ w at long_name = "latitude weight"
+
+ if (nType.eq."double") then
+ return( w )
+ else
+ return(dble2flt(w))
+ end if
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ undef("quadroots")
+ function quadroots(a[1]:numeric, b[1]:numeric, c[1]:numeric)
+ ; solve quadratic formula
+ local x, d, droot, dble, two, con, D
+ begin
+ if (typeof(a).eq."double" .or. typeof(b).eq."double"
+ .or. typeof(c).eq."double" ) then
+ d = 0.0d
+ con = 2.0d*a
+ dble = True
+ else
+ d = 0.0
+ con = 2.0*a
+ dble = False
+ end if
+
+ d = b^2 - 4*a*c ; discriminant
+
+ if (d.ge.0) then ; positive roots
+ if (dble) then
+ x = (/0.0d,0.0d,0.0d0/)
+ else
+ x = (/0.0 , 0.0, 0.0 /)
+ end if
+
+ if (d.gt.0) then ; two distinct real roots
+ droot = sqrt(d)
+ x(0) = (-b + droot)/con
+ x(1) = (-b - droot)/con
+ else
+ x = -b/con ; one distinct root
+ end if ; return as double root
+
+ x at root = "real"
+ x at discriminant = d
+ ;x at result1 = a*x(0)^2 + b*x(0) + c
+ ;x at result2 = a*x(1)^2 + b*x(1) + c
+ return (x)
+ end if
+
+ D = sqrt(-d)/con ; (4*a*c -b^2)/2a
+
+ x = new ( 3, typeof(d), "No_FillValue")
+ x(0) = -b/con ; real part
+ ; imaginary parts
+ x(1) = D ; positive
+ x(2) = -D ; negative
+
+ x at root = "complex"
+ x at discriminant = d
+ return (x)
+ end
+
+ ; **********************************************************************
+ ; Contributed by Carl J. Schreck, III, July 2008
+ ;
+ ; Converts a time variable from one units to another. The input
+ ; variable must contain a "units" attribute of the correct form.
+ ;
+ ; Input variables:
+ ; dateFrom: the original date
+ ; unitsTo: the NEW date units
+ ; Return Value:
+ ; retVal: the date converted to its new units
+ ;***********************************************************************
+ undef("ut_convert")
+ function ut_convert( dateFrom:numeric, unitsTo:string )
+ local retVal, tempDate, utcDate
+ begin
+ if(.not.isatt(dateFrom,"units")) then
+ print("ut_convert: 'dateFrom' contains no 'units' attribute.")
+ print(" Will return all missing values.")
+
+ retVal = new(dimsizes(dateFrom),double)
+ return(retVal)
+ end if
+
+ tempDate = dateFrom
+ tempDate at units = dateFrom at units
+
+ utcDate = ut_calendar( tempDate, -5 )
+
+ retVal = ut_inv_calendar( utcDate(:,0), utcDate(:,1), utcDate(:,2),
+ utcDate(:,3), utcDate(:,4), utcDate(:,5),
+ unitsTo, 0 )
+ return( retVal )
+ end
+
+ ; **********************************************************************
+ ; This is identical to ut_convert, except it uses cd_calendar.
+ ;***********************************************************************
+ undef("cd_convert")
+ function cd_convert( dateFrom:numeric, unitsTo:string )
+ local retVal, tempDate, utcDate
+ begin
+ if(.not.isatt(dateFrom,"units")) then
+ print("cd_convert: 'dateFrom' contains no 'units' attribute.")
+ print(" Will return all missing values.")
+
+ retVal = new(dimsizes(dateFrom),double)
+ return(retVal)
+ end if
+
+ tempDate = dateFrom
+ tempDate at units = dateFrom at units
+
+ utcDate = cd_calendar( tempDate, -5 )
+
+ retVal = cd_inv_calendar( utcDate(:,0), utcDate(:,1), utcDate(:,2),
+ utcDate(:,3), utcDate(:,4), utcDate(:,5),
+ unitsTo, 0 )
+ return( retVal )
+ end
+
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL function "triple2grid" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+
+ undef ("triple2grid_Wrap")
+ function triple2grid_Wrap (xi[*]:numeric,yi[*]:numeric, fi:numeric
+ ,xo[*]:numeric,yo[*]:numeric, Opt)
+
+ ; wrapper for NCL function "triple2grid" that copies attributes and coordinate vars
+
+ local fo, dimfi, nDim, nD
+ begin
+ fo = triple2grid (xi,yi,fi, xo,yo, Opt) ; builtin
+ dimfi = dimsizes(fi)
+ nDimi = dimsizes(dimsizes(fi)) ; number of in dimensions [rank]
+ nDimo = dimsizes(dimsizes(fo))
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+
+ fo!(nDimo-2) = "Y" ; default named dimensions
+ fo!(nDimo-1) = "X"
+ ; override if possible
+ if (isdimnamed(yo,0) ) then
+ fo!(nDimo-2) = yo!0 ; if present, use xo name
+ fo&$fo!(nDimo-2)$ = yo ; create coordinate var
+ end if
+ if (isdimnamed(xo,0)) then
+ fo!(nDimo-1) = xo!0 ; if present, use xo name
+ fo&$fo!(nDimo-1)$ = xo ; two rightmost dimensions
+ end if
+
+ if (nDimo.ge.2) then
+ copy_VarCoords_1 (fi,fo)
+ end if
+
+ return (fo)
+ end
+ ;**************************************************************
+ ; Calculate the PDF of an array
+ ; Original source IDL code by Andrew Gettleman
+ ; pdfx_v510 is to provide backward compatibility for the 5.1.0 version
+ ;
+ undef("pdfx_v510")
+ function pdfx_v510(x:numeric, nbin[1]:integer, opt:logical)
+ local nGood, nbins, xMin, xMax, mnmxint, xSpace
+ ,bin, pdf, nTot
+ begin
+ nGood = num(.not.ismissing(x))
+ if (nGood.lt.3) then
+ print("pdfx: nGood="+nGood+" : Need more non-missing points")
+ exit
+ end if
+
+ if (nbin.le.2) then
+ nbins = 50 ; default
+ else
+ nbins = nbin
+ end if
+
+ xMin = 0.0d ; not required but done for test
+ xMax = 0.0d
+
+ if (opt .and. isatt(opt,"bin_min")) then
+ xMin = opt at bin_min ; user set
+ else
+ xMin = min(x) ; calculate
+ end if
+
+ if (opt .and. isatt(opt,"bin_max")) then
+ xMax = opt at bin_max ; user set
+ else
+ xMax = max(x) ; calculate
+ end if
+
+ if (opt .and. isatt(opt,"bin_nice")) then ; nice xMin, xMax
+ outside = False
+ if (isatt(opt,"bin_nice_outside")) then
+ outside = opt at bin_nice_outside
+ end if
+ mnmxint = nice_mnmxintvl( min(x), max(x), nbins, outside)
+ xMin = mnmxint(0)
+ xMax = mnmxint(1)
+ xSpace = mnmxint(2)
+ nbins = round( (xMax-xMin)/xSpace , 3)
+ end if
+
+ binBound = fspan(xMin,xMax,nbins+1)
+ pdf = new( nbins, "double", getFillValue(x))
+ binCenter = (binBound(0:nbins-1) + binBound(1:nbins))*0.5d
+ pdf = 0.0d
+
+ do nb=0,nbins-2
+ pdf(nb) = num( x.ge.binBound(nb) .and. x.lt.binBound(nb+1) )
+ end do
+
+ nTot = num(x.ge.xMin .and. x.le.xMax) ; actual number used
+ pdf = pdf/nTot ; frequency
+
+ pdf at bin_center = binCenter
+ pdf at bin_bounds = binBound
+ pdf at bin_bound_min = min(binBound)
+ pdf at bin_bound_max = max(binBound)
+ pdf at bin_spacing = binBound(2)-binBound(1)
+ pdf at nbins = nbins
+
+ pdf at long_name = "PDF"
+ if (isatt(x,"long_name")) then
+ pdf at long_name = "PDF: "+x at long_name
+ end if
+ pdf at units = "frequency"
+
+ return( pdf )
+ end
+ ;***********************************************
+ ; binning consistent with the "pdfxy" function
+ ; Feb 2012: replaced NCL loop with fortran loop
+ ; in pdfx_bin. This is much faster.
+ ;
+ undef("pdfx")
+ function pdfx(x:numeric, nbin[1]:integer, opt:logical)
+ local nGood, nbins, xMin, xMax, mnmxint, xSpace
+ ,bin, pdf, nTot, XMIN, XMAX, nLoOut, nHiOut
+ begin
+
+ if (opt .and. isatt(opt, "v510") .and. opt at v510) then
+ pdf = pdfx_v510(x, nbin, opt) ; different binning
+ return(pdf)
+ end if
+
+ if (nbin.le.2) then
+ nbins = 25 ; default
+ else
+ nbins = nbin
+ end if
+
+ nGood = num(.not.ismissing(x))
+ if (nGood.lt.3) then
+ print("pdfx: nGood="+nGood+" : Need more non-missing points")
+ pdf = new( nbins, "double", getFillValue(x))
+ return( pdf )
+ end if
+
+ XMIN = min(x)*1d0 ; min/max for ENTIRE array
+ XMAX = max(x)*1d0 ; force "double" [*1d0]
+
+ xMin = 0.0d ; prototype as double
+ xMax = 0.0d
+
+ if (opt .and. isatt(opt,"bin_min")) then
+ xMin = opt at bin_min ; user set
+ else
+ xMin = XMIN ; calculate
+ end if
+
+ if (opt .and. isatt(opt,"bin_max")) then
+ xMax = opt at bin_max ; user set
+ else
+ xMax = XMAX ; calculate
+ end if
+
+ if (opt .and. isatt(opt,"bin_nice")) then ; nice xMin, xMax
+ outside = False
+ if (isatt(opt,"bin_nice_outside")) then
+ outside = opt at bin_nice_outside
+ end if
+ mnmxint = nice_mnmxintvl( XMIN, XMAX, nbins, outside)
+ xMin = mnmxint(0)
+ xMax = mnmxint(1)
+ xSpace = mnmxint(2)
+ ;;nbins = round( (xMax-xMin)/xSpace , 3)
+ end if
+
+ ;;dbin = (xMax-xMin)/(nbins-1) ; 5.2.0
+ dbin = (xMax-xMin)/nbins
+ binBound = xMin + ispan(0,nbins,1)*dbin
+ binBound(nbins) = xMax ; avoid roundoff
+ binCenter = (binBound(0:nbins-1) + binBound(1:nbins))*0.5d
+
+ binBoundMin = binBound(0)
+ binBoundMax = binBound(nbins)
+
+ pdf = new( nbins, "double", getFillValue(x))
+ pdf = 0.0d
+
+ ;;---- the following replaces the ;; NCL loop below ---
+ popt = True
+ popt at fraction = True ; True mean total count (**DO NOT CHANGE**)
+ pdf = pdfx_bin(x, binBound, popt) ; fortran
+
+ ;;do nb=0,nbins-1
+ ;; pdf(nb) = num( x.ge.binBound(nb) .and. x.lt.binBound(nb+1) )
+ ;; if (nb.eq.(nbins-1)) then ; last bin
+ ;; pdf(nb) = pdf(nb) + num( x.eq.binBound(nb+1) ) ; include last bound
+ ;; end if
+ ;;end do
+ ;;----
+
+ pdf!0 = "x"
+ pdf&x = binCenter
+ ; max possible in data
+ nMax = num(x.ge.XMIN .and. x.le.XMAX)
+ ; actual number used
+ nUse = num(x.ge.binBoundMin .and. x.le.binBoundMax)
+
+ nLoOut = num(x.lt.binBoundMin) ; number outliers
+ nHiOut = num(x.gt.binBoundMax)
+
+ pdf = 100d0*pdf/nMax ; percent frequency
+
+ pdf at bin_center = binCenter
+ pdf at bin_bounds = binBound
+ pdf at bin_bound_min = binBoundMin
+ pdf at bin_bound_max = binBoundMax
+ pdf at bin_spacing = dbin ; binBound(2)-binBound(1)
+ pdf at nbins = nbins
+ pdf at nMax = nMax
+ pdf at nUse = nUse
+ if (nLoOut.gt.0 .or. nHiOut.gt.0) then
+ pdf at nLoOut = nLoOut
+ pdf at nHiOut = nHiOut
+ end if
+
+ pdf at long_name = "PDF"
+ if (isatt(x,"long_name")) then
+ pdf at long_name = "PDF: "+x at long_name
+ end if
+ pdf at units = "%"
+
+ return( pdf )
+ end
+ ;**************************************************************
+ ; Calculate the "joint PDF [%]" of arrays "x" and "y"
+ ;**************************************************************
+ undef("pdfxy")
+ function pdfxy(x:numeric, y:numeric, nbinx[1]:integer, nbiny[1]:integer, opt:logical)
+ local nGood_x, nbinsx, xMin, xMax, mnmxint, binx, binxBound, binxCenter, nbx
+ ,nGood_y, nbinsy, yMin, yMax, ySpace , biny, binyBound, binyCenter, nby
+ ,outside, mnmxint, pdf2, nTot, dimx, dimy, rankx, ranky, x1d, y1d, iy, warnFlag
+ ,xMIN, xMAX, yMIN, yMAX, binxBoundMin, binxBoundMax, binyBoundMin, binyBoundMax
+ ,nMax, nUse, nxLoOut, nxHiOut, nyLoOut, nyHiOut, popt, fmsg, epsx, epsy
+ begin
+
+ fmsg = default_fillvalue("float")
+
+ if (nbinx.le.2) then
+ nbinsx = 25 ; default
+ else
+ nbinsx = nbinx ; user sprecified
+ end if
+
+ if (nbiny.le.2) then
+ nbinsy = 25 ; default
+ else
+ nbinsy = nbiny ; user specified
+ end if
+ ; error check
+ warnFlag = True ; default ... print warning messages
+ if (opt .and. isatt(opt,"WarningMsg") .and. .not.opt at WarningMsg) then
+ warnFlag = False
+ end if
+
+ if (warnFlag) then
+ nGood_x = num(.not.ismissing(x))
+ if (nGood_x.lt.3) then
+ print("pdfxy: nGood(x)="+nGood_x+" : Need more non-missing points")
+ end if
+
+ nGood_y = num(.not.ismissing(y))
+ if (nGood_y.lt.3) then
+ print("pdfxy: nGood(y)="+nGood_y+" : Need more non-missing points")
+ end if
+
+ if (nGood_x.lt.3 .or. nGood_y.lt.3) then
+ print("pdfxy: exit error: not enough points")
+ pdf2 = new( (/nbinsy,nbinsx/), "double", 1d20)
+ return( pdf2 )
+ end if
+ end if ; warnFlag
+
+ xMIN = min(x)*1d0 ; min/max for ENTIRE array
+ xMAX = max(x)*1d0 ; force "double" [*1d0] ... convenience only
+ yMIN = min(y)*1d0
+ yMAX = max(y)*1d0
+ ; max number possible (excludes _FillValue)
+ nMax = num(x.ge.xMIN .and. x.le.xMAX .and.
+ y.ge.yMIN .and. y.le.yMAX)
+
+ if (nMax.lt.3) then
+ print("pdfxy: exit error: nMax.lt.3")
+ pdf2 = new( (/nbinsy,nbinsx/), "double", 1d20)
+ return( pdf2 )
+ end if
+
+ xMin = 0.0d ; prototype as "double"
+ xMax = 0.0d
+ yMin = 0.0d
+ yMax = 0.0d
+ ; User may want different min/max used
+ if (opt .and. isatt(opt,"binx_min")) then
+ xMin = opt at binx_min ; user
+ else
+ xMin = xMIN ; calculated
+ end if
+
+ if (opt .and. isatt(opt,"binx_max")) then
+ xMax = opt at binx_max ; user
+ else
+ xMax = xMAX
+ end if
+
+ if (opt .and. isatt(opt,"biny_min")) then
+ yMin = opt at biny_min ; user
+ else
+ yMin = yMIN
+ end if
+
+ if (opt .and. isatt(opt,"biny_max")) then
+ yMax = opt at biny_max ; user
+ else
+ yMax = yMAX
+ end if
+
+ if (opt.and.isatt(opt,"binx_nice")) then ; nice xMin, xMax
+ outside = False
+ if (isatt(opt,"binx_nice_outside")) then
+ outside = opt at binx_nice_outside
+ end if
+ mnmxint = nice_mnmxintvl( xMIN, xMAX, nbinsx, outside)
+ xMin = mnmxint(0)
+ xMax = mnmxint(1)
+ xSpace = mnmxint(2)
+ ;;nbinsx = round( (xMax-xMin)/xSpace , 3)
+ delete(mnmxint)
+ end if
+
+ if (opt .and. isatt(opt,"biny_nice")) then ; nice yMin, yMax
+ outside = False
+ if (isatt(opt,"biny_nice_outside")) then
+ outside = opt at biny_nice_outside
+ end if
+ mnmxint = nice_mnmxintvl( yMIN, yMAX, nbinsy, outside)
+ yMin = mnmxint(0)
+ yMax = mnmxint(1)
+ ySpace = mnmxint(2)
+ ;;nbinsy = round( (yMax-yMin)/ySpace , 3)
+ delete(mnmxint)
+ end if
+
+ ;;dbinx = (xMax-xMin)/(nbinsx-1)
+ dbinx = (xMax-xMin)/nbinsx
+ binxBound = xMin + ispan(0,nbinsx,1)*dbinx
+ binxBound(nbinsx) = xMax ; avoid roundoff
+ binxCenter = (binxBound(0:nbinsx-1) + binxBound(1:nbinsx))*0.5d
+
+ ;;dbiny = (yMax-yMin)/(nbinsy-1)
+ dbiny = (yMax-yMin)/nbinsy
+ binyBound = yMin + ispan(0,nbinsy,1)*dbiny
+ binyBound(nbinsy) = yMax ; avoid roundoff
+ binyCenter = (binyBound(0:nbinsy-1) + binyBound(1:nbinsy))*0.5d
+
+ binxBoundMin= binxBound(0) ; convenience
+ binxBoundMax= binxBound(nbinsx)
+ binyBoundMin= binyBound(0)
+ binyBoundMax= binyBound(nbinsy)
+
+ pdf2 = new( (/nbinsy,nbinsx/), "double", 1d20)
+ pdf2 = 0.0d ; initialize
+
+ dimx = dimsizes(x)
+ dimy = dimsizes(y)
+ rankx = dimsizes(dimx)
+ ranky = dimsizes(dimy)
+
+ popt = True
+ popt at fraction = False ; False means to return %
+
+ ; -------------------------------------------
+ ; epsx, epsy: Nov 2013 for v6.2.0
+ ; get around: LastLeftBin <= x,y < LastRightBin
+ ; Add eps LastRightBin will *include* xMAX and yMAX
+ if (opt .and. isatt(opt, "bin_max_epsx")) then
+ epsx = opt at bin_max_epsx ; set to 0.0 for pre 6.2.0 results
+ else
+ epsx = 1d-6 ; default (arbitrary)
+ end if
+
+ if (opt .and. isatt(opt, "bin_max_epsy")) then
+ epsy = opt at bin_max_epsy
+ else
+ epsy = 1d-6
+ end if
+
+ binxBound(nbinsx)= binxBound(nbinsx) + epsx*binxBound(nbinsx)
+ binyBound(nbinsy)= binyBound(nbinsy) + epsy*binyBound(nbinsy)
+ ; -------------------------------------------
+
+ pdf2 = pdfxy_bin(x,y, binxBound,binyBound, popt)
+ ; all NCL [original code]
+ ;;x1d = ndtooned(x) ; requires more memory
+ ;;y1d = ndtooned(y)
+
+ ;;do nby=0,nbinsy-1
+ ;; iy = ind(y1d.ge.binyBound(nby) .and. y1d.lt.binyBound(nby+1))
+ ;; if (.not.ismissing(iy(0))) then
+ ;; do nbx=0,nbinsx-1
+ ;; pdf2(nby,nbx) = num(x1d(iy).ge.binxBound(nbx) .and. \
+ ;; x1d(iy).lt.binxBound(nbx+1) )
+ ;; end do
+ ;; end if
+ ;; delete(iy) ; size may change
+ ;;end do
+
+ if (opt .and. isatt(opt,"fraction") .and. opt at fraction) then
+ pdf2 = pdf2/1d2 ; fraction [0,1]
+ end if
+
+ pdf2!0 = "y" ; arbitrary name
+ pdf2!1 = "x"
+ pdf2&x = binxCenter
+ pdf2&y = binyCenter
+ ; actual number used, excludes outliers
+
+ nUse = num(x.ge.binxBoundMin .and. x.le.binxBoundMax .and.
+ y.ge.binyBoundMin .and. y.le.binyBoundMax)
+
+ if (nMax.eq.nUse) then
+ nxLoOut = 0
+ nxHiOut = 0
+ nyLoOut = 0
+ nyHiOut = 0
+ else
+ nxLoOut = num(x.lt.binxBoundMin)
+ nxHiOut = num(x.ge.binxBoundMax)
+ nyLoOut = num(y.lt.binyBoundMin)
+ nyHiOut = num(y.ge.binyBoundMax)
+ end if
+
+ pdf2 at nMax = nMax
+ pdf2 at nUse = nUse
+ pdf2 at nOut = nxLoOut + nxHiOut + nyLoOut + nyHiOut
+ if (nMax.gt.0) then
+ pdf2 at pcUse = (1e2*nUse)/nMax ; percent [pc]
+ pdf2 at pcOut = (1e2*pdf2 at nOut)/nMax
+ else
+ pdf2 at pcUse = fmsg
+ pdf2 at pcOut = fmsg
+ end if
+
+ pdf2 at xMIN = xMIN
+ pdf2 at xMAX = xMAX
+ pdf2 at binx_center = binxCenter
+ pdf2 at binx_bounds = binxBound
+ pdf2 at binx_bound_min = binxBoundMin
+ pdf2 at binx_bound_max = binxBoundMax
+ pdf2 at binx_spacing = dbinx ; binxBound(2)-binxBound(1)
+ pdf2 at nbinsx = nbinsx
+ ;pdf2 at nxLoOut = nxLoOut
+ ;pdf2 at nxHiOut = nxHiOut
+
+ if (nMax.gt.0) then
+ pdf2 at pcxLoOut = (1e2*nxLoOut)/nMax ; %
+ pdf2 at pcxHiOut = (1e2*nxHiOut)/nMax
+ else
+ pdf2 at pcxLoOut = fmsg
+ pdf2 at pcxHiOut = fmsg
+ end if
+
+ pdf2 at yMIN = yMIN
+ pdf2 at yMAX = yMAX
+ pdf2 at biny_center = binyCenter
+ pdf2 at biny_bounds = binyBound
+ pdf2 at biny_bound_min = binyBoundMin
+ pdf2 at biny_bound_max = binyBoundMax
+ pdf2 at biny_spacing = dbiny ; binyBound(2)-binyBound(1)
+ pdf2 at nbinsy = nbinsy
+ ;pdf2 at nyLoOut = nyLoOut
+ ;pdf2 at nyHiOut = nyHiOut
+ if (nMax.gt.0) then
+ pdf2 at pcyLoOut = (1e2*nyLoOut)/nMax ; %
+ pdf2 at pcyHiOut = (1e2*nyHiOut)/nMax
+ else
+ pdf2 at pcyLoOut = fmsg
+ pdf2 at pcyHiOut = fmsg
+ end if
+
+ ;pdf2 at long_name = "Joint PDF"
+ ;if (isatt(x,"long_name") .and. isatt(y,"long_name")) then
+ ; pdf2 at long_name = "Joint PDF: "+x at long_name+" | " \
+ ; +y at long_name
+ ;end if
+ ;pdf2 at units = "frequency"
+
+ return( pdf2 )
+ end
+ ; ----
+ undef("pdfxy_conform")
+ function pdfxy_conform(x,y,nbinx,nbiny,opt) ; same arguments as pdfxy
+ ;
+ ; Work around to allow x and y to be different sizes
+ ; Same arguments as pdfxy
+
+ local N, M, X, Y, XX, YY, pdf2
+ begin
+ N = product(dimsizes(x))
+ M = product(dimsizes(y))
+
+ if (N.eq.M) then
+ pdf2 = pdfxy(x,y,nbinx,nbiny,opt)
+ return(pdf2)
+ end if
+
+ X = ndtooned(x)
+ Y = ndtooned(y)
+
+ if (N.gt.M) then
+ YY = new(N, typeof(Y), getVarFillValue(Y))
+ YY(0:M-1) = (/ Y /)
+ pdf2 = pdfxy(X,YY,nbinx,nbiny,opt)
+ else
+ XX = new(M, typeof(X), getVarFillValue(X))
+ XX(0:N-1) = (/ X /)
+ pdf2 = pdfxy(XX,Y,nbinx,nbiny,opt)
+ end if
+
+ return(pdf2)
+ end
+
+ ; ----
+ undef ("genNormalDist")
+ function genNormalDist(xAve[1]:numeric, xStd[1]:numeric, opt:logical)
+ ; Usage:
+ ; xAve = 100
+ ; xStd = 10
+ ; xNor = createNormal(xAve, xStd, False)
+ local zero, one, pi, spn, N, con, xVar, x, nor
+ begin
+ if (typeof(xAve).eq."double" .or. typeof(xAve).eq."double") then
+ zero = 0.0d
+ one = 1.0d
+ pi = 4.0d*atan(1.0d)
+ spn = 3.0d ; 99.7% of normal
+ else
+ zero = 0.0
+ one = 1.0
+ pi = 4.0*atan(1.0)
+ spn = 3.0
+ end if
+
+ if (xStd.eq.zero) then
+ print("genNormalDist: xStd=0 is not allowed")
+ exit
+ end if
+
+ if (opt .and. isatt(opt,"std_span")) then
+ spn = opt at std_span
+ end if
+ ; fix an incorrect documention issue
+ ; allow 'npts' or 'N'
+ if (opt .and. (isatt(opt,"npts") .or. isatt(opt,"N"))) then
+ if (isatt(opt,"N")) then
+ N = opt at N
+ else
+ N = opt at npts
+ end if
+ else
+ N = 101
+ end if
+
+ con = one/(xStd*sqrt(2*pi))
+ xVar = xStd^2
+
+ x = fspan( (xAve-spn*xStd), (xAve+spn*xStd), N)
+ nor = con*exp(-((x-xAve)^2/(2*xVar)) )
+ nor at long_name = "Normal Distribution"
+
+ if (isatt(xAve,"units")) then
+ x at units = xAve at units
+ end if
+ nor at x = x
+ nor at xsd = (x-xAve)/xStd
+ return( nor )
+ end
+ ; ------------
+ undef("relhum_ttd")
+ function relhum_ttd (t:numeric, td:numeric, opt:integer)
+ ;
+ ; Calculate relative humidity given temperature (K)
+ ; and dew point temperature (K)
+ ;
+ ; reference: John Dutton, Ceaseless Wind, 1976
+
+ local gc, lhv, rh
+ begin
+ rankt = dimsizes( dimsizes(t ) )
+ ranktd = dimsizes( dimsizes(td) )
+ if (rankt.ne.ranktd) then
+ print("relhum_ttd: rank mismatch: fatal")
+ print(" rank(t )="+rankt )
+ print(" rank(td)="+ranktd)
+ exit
+ end if
+
+ gc = 461.5 ; [j/{kg-k}] gas constant water vapor
+ gc = gc/(1000.*4.186) ; [cal/{g-k}] change units
+ ; lhv=latent heat vap
+ lhv = ( 597.3-0.57*(t-273.) ) ; dutton top p273 [empirical]
+
+ rh = exp( (lhv/gc)*(1.0/t - 1.0/td) )
+ rh at long_name = "relative humidity"
+ rh at units = "fraction"
+
+ if (opt.eq.0) then
+ rh = rh*100.
+ rh at units = "%"
+ end if
+ return (rh)
+ end
+
+ ; ------------
+
+ undef("crossp3")
+ function crossp3(a[*][3]:numeric,b[*][3]:numeric)
+ ; calculate a cross product: c = a x b
+ begin
+
+ if (typeof(a).eq."double" .or. typeof(b).eq."double") then
+ if (typeof(a).eq."double") then
+ c = new ( dimsizes(a), "double", getFillValue(a))
+ else
+ c = new ( dimsizes(b), "double", getFillValue(b))
+ end if
+ else
+ if (typeof(a).eq."float" .or. typeof(b).eq."float") then
+ if (typeof(a).eq."float") then
+ c = new ( dimsizes(a), "float", getFillValue(a))
+ else
+ c = new ( dimsizes(b), "float", getFillValue(b))
+ end if
+ else
+ c = new ( dimsizes(a), "integer", getFillValue(a))
+ end if
+ end if
+
+ c(:,0) = a(:,1)*b(:,2)-a(:,2)*b(:,1)
+ c(:,1) = a(:,2)*b(:,0)-a(:,0)*b(:,2)
+ c(:,2) = a(:,0)*b(:,1)-a(:,1)*b(:,0)
+
+ return(c)
+ end
+ ; -----------------------------------------------------
+ undef("region_ind")
+ function region_ind(XLAT[*][*]:numeric, XLON[*][*]:numeric
+ ,latS[1]:numeric, latN[1]:numeric
+ ,lonW[1]:numeric, lonE[1]:numeric )
+ ; extract subscript indicies corresponding to region
+ ; described by curvilinear coordinates
+ ; WRF, NARR, REGCM, etc
+
+ local XLAT_1d, XLON_1d, nm_1d, nlml, ijsub
+ begin
+ XLAT_1d = ndtooned( XLAT )
+ XLON_1d = ndtooned( XLON )
+
+ nm_1d = ind(XLAT_1d.ge.latS .and. XLAT_1d.le.latN .and.
+ XLON_1d.ge.lonW .and. XLON_1d.le.lonE)
+ nlml = ind_resolve(nm_1d, dimsizes(XLON))
+
+ ijsub = new( 4, typeof(nlml), "No_FillValue")
+
+ ijsub(0) = min(nlml(:,0)) ; lat start index
+ ijsub(1) = max(nlml(:,0)) ; lat last index
+ ijsub(2) = min(nlml(:,1)) ; lon start index
+ ijsub(3) = max(nlml(:,1)) ; lon Last index
+
+ return(ijsub)
+ end
+ ;-------------------------------------------------------------------------------
+ undef("icObjAnal_1d")
+ function icObjAnal_1d(x[*],y[*],z[*],lon[*],lat[*],dcrit[*]:numeric,opt:logical)
+ ; This should *not* be invoked directly by the user.
+ ; It is called by "function icObjAnal"
+ ;
+ ; Nomenclature
+ ; x,y,z - lon,lat,observation triplets
+ ; lat - lat of returned grid. Need not be equally spaced.
+ ; Should have the units attribute: lat at units="degrees_north"
+ ; lon - lon of returned grid. Need not be equally spaced
+ ; Should have the units attribute: lon at units="degrees_east"
+ ; dcrit - 1D array containing successive radii of influence.
+ ; Must be expressed in degrees latitude and should be
+ ; monotonically decreasing. eg: dcrit = (/10, 5, 3/)
+ ; opt - variable to which optional attributes are attached
+ ; @guess = user supplied 2D guess array [default is no 1st guess]
+ ; Must be same size and shape as grid defined by lat/lon
+ ; @zonal = True: use zonal average of z as 1st guess
+ ; @setmsg= True is default
+ ; @timing= True ; print elapsed time per iteration (scan)
+ ; @count => Return number of observations used in each scan
+ ; @nObs ==> (nscan,:,:)
+ ;
+ local nlat, mlon, nScan, G, dimG, rankG, zonavg, i, j, ij, ns, nl, ml
+ , gcdist, diff, cf, nObs, dc2, nd, flag
+ begin
+ nlat = dimsizes(lat)
+ mlon = dimsizes(lon)
+
+ nScan = dimsizes(dcrit)
+ nObs = new( (/nScan,nlat,mlon/), "integer", "No_FillValue" )
+ nObs = 0
+
+ if (opt .and. isatt(opt,"guess")) then
+
+ G = opt at guess ; 1st guess
+ dimG = dimsizes(G)
+ rankG = dimsizes(dimG)
+ if (.not.(rankG.eq.2)) then
+ print("icObjAnal_1d: rankG="+rankG+" expecting 2D")
+ exit
+ end if
+ if (.not.(nlat*mlon.ne.prod(dimG))) then
+ print("icObjAnal_1d: dimension sizes of G and nlat*mlon must match")
+ print("icObjAnal_1d: dimG="+dimG)
+ print("icObjAnal_1d: nlat="+nlat+" mlon="+mlon)
+ exit
+ end if
+ flag = 2
+ else
+
+ G = new( (/nlat,mlon/), typeof(z), getFillValue(z) ) ; 1st guess
+
+ if (isatt(opt,"zonal") .and. opt at zonal) then ; create zonal avg
+ dlat = max(abs(lat(1:nlat-1)-lat(0:nlat-2)) ) ; nominal
+ ;dlat = 2*dlat ; expand to get more data for zonal average
+ ; bigger range
+ zonavg = new( nlat, typeof(z), z at _FillValue)
+ do nl=0,nlat-1
+ i = ind(y.le.(lat(nl)+dlat) .and. y.ge.(lat(nl)-dlat))
+ if (.not.all(ismissing(i))) then
+ zonavg(nl) = avg( z(i) ) ; zonal avg of all observations
+ end if
+ delete(i)
+ end do
+
+ if (any(ismissing(zonavg))) then
+ zonavg = linmsg(zonavg, -1) ; linearly interpolate
+ end if
+ print("icObjAnal_1d: lat="+lat+" zonavg="+zonavg)
+ ; arbitrary smooth
+ ;;zonavg = wgt_runave(zonavg, (/0.25, 0.50, 0.25/), 1)
+ zonavg = wgt_runave(zonavg, filwgts_normal (7, 1.0, 0) , 1)
+
+ do nl=0,nlat-1
+ G(nl,:) = zonavg(nl)
+ end do
+
+ delete(zonavg)
+ flag = 1
+ else
+ G = 0.0 ; direct ... no 1st guess
+ flag = 0
+ end if
+ end if
+
+ G!0 = "lat"
+ G!1 = "lon"
+ G&lat = lat
+ G&lon = lon
+
+ wcStrt = systemfunc("date")
+
+ do ns=0,nScan-1
+ nsStrt = systemfunc("date")
+ dc2 = dcrit(ns)^2
+
+ do nl=0,nlat-1
+ i = ind( abs(y-lat(nl)).le.dcrit(ns))
+ if (.not.ismissing(i(0)) ) then
+
+ do ml=0,mlon-1
+ if (ns.eq.0 .or. (ns.gt.0 .and. nObs(ns-1,nl,ml).gt.0)) then
+ gcdist = gc_latlon(lat(nl),lon(ml), y(i),x(i), 0,2)
+ nd = num(gcdist.le.dcrit(ns))
+ nObs(ns,nl,ml) = nd ; # observations within radius
+
+ if (nd.gt.0) then
+ j = ind(gcdist.le.dcrit(ns))
+ ij = i(j)
+ diff = z(ij)-G(nl,ml) ; normally interpolate G to z but .....
+ wgt = exp(-4*gcdist(j)^2/dc2)
+ cf = sum(wgt*diff)/sum(wgt) ; correction factor
+ ;print("ns="+ns+" nl="+nl+" ml="+ml+" cf="+cf)
+
+ G(nl,ml) = G(nl,ml) + cf ; update Guess
+
+ delete(j)
+ delete(ij)
+ delete(cf)
+ delete(wgt)
+ delete(diff)
+ end if ; nd
+ delete(gcdist)
+ end if
+ end do ; ml
+ end if
+ delete(i)
+ end do ; nl
+ ; default is to smooth
+ if (.not.isatt(opt,"smooth") .or. opt at smooth) then
+ if (ns.lt.(nScan-1)) then
+ G = smth9(G, 0.50,-0.25, 0) ; light local smoother
+ else
+ G = smth9(G, 0.50, 0.25, 0) ; heavy local smoother
+ end if
+ end if
+ ; set grid pts ouside of
+ if (ns.eq.0) then ; max radius to _FillValue
+ if (.not.isatt(opt,"setmsg") .or. opt at setmsg) then
+ G = where(nObs(ns,:,:).eq.0, G at _FillValue, G)
+ end if
+ end if
+
+ if (isatt(opt,"timing")) then
+ wallClockElapseTime(nsStrt,"icObjAnal_1d: ns="+ns, 0)
+ end if
+
+ end do ; ns`
+
+ if (isatt(opt,"timing")) then
+ wallClockElapseTime(wcStrt,"Total time: icObjAnal_1d: nScan="+nScan , 0)
+ end if
+
+ if (opt .and. isatt(opt,"count") .and. opt at count) then
+ G at nObs = nObs
+ end if
+
+ return(G)
+ end
+ ;-----------------------------------------------------------------------------------
+ undef("icObjAnal_2d")
+ function icObjAnal_2d(x[*],y[*],z[*],lon2d[*][*],lat2d[*][*],dcrit[*]:numeric,opt:logical)
+ ;
+ ; This should not be invoked directly by the user.
+ ; It is called by "function icObjAnal"
+ ;
+ ; Nomenclature
+ ; x,y,z - lon,lat,observation triplets
+ ; lat2d - lat of returned grid.
+ ; lon2d - lon of returned grid
+ ; dcrit - 1D array containing successive radii of influence.
+ ; Must be expressed in degrees latitude and should be
+ ; monotonically de. eg: dcrit = (/10, 5, 3/)
+ ; opt - variable to which optional attributes are attached
+ ; @guess = 2D guess array [default is no 1st guess]
+ ; @timing = True ; print times
+ ; @count => Return number of observations used in each scan
+ ; @nObs ==> (nscan,:,:)
+ ;
+ local nlat, mlon, nScan, G, dimG, rankG, zonavg, i, j, ij, ns, nl, ml
+ , gcdist, diff, cf, nObs, dc2, nd, dimlat, ranklt, LAT, LON, G1D
+ begin
+ dimlat = dimsizes(lat2d)
+ nlat = dimlat(0)
+ mlon = dimlat(1)
+
+ nScan = dimsizes(dcrit)
+ nObs = new( (/nScan,nlat,mlon/), "integer", "No_FillValue" )
+ nObs = 0
+
+ if (opt .and. isatt(opt,"guess")) then
+
+ G = opt at guess ; 1st guess
+ dimG = dimsizes(G)
+ rankG = dimsizes(dimG)
+ ranklt = dimsizes(dimlat)
+ if (.not.(rankG.eq.ranklt)) then
+ print("icObjAnal_2d: rankG="+rankG+" ranklt="+ranklt)
+ exit
+ end if
+ if (.not.all(dimlat.eq.dimG)) then
+ print("icObjAnal_2d: all dimension sizes must be the same")
+ print("icObjAnal_2d: dimltt="+dimlat+" dimG="+dimG)
+ exit
+ end if
+
+ else
+
+ G = new( dimlat, typeof(z), getFillValue(z) ) ; 1st guess
+
+ if (isatt(opt,"zonal") .and. opt at zonal) then ; create zonal avg
+ mnlat = min(lat2d)
+ mxlat = max(lat2d)
+ lat1d = fspan(mnlat,mxlat,nlat) ; nominal
+ dlat = (mxlat-mnlat)/(nlat-1) ; nominal
+ dlat = 4*dlat ; expand to get more data for zonal average
+ ; bigger range
+ zonavg = new( nlat, typeof(z), z at _FillValue)
+ do nl=0,nlat-1
+ i = ind(y.le.(lat1d(nl)+dlat) .and. y.ge.(lat1d(nl)-dlat))
+ if (.not.all(ismissing(i))) then
+ zonavg(nl) = avg( z(i) ) ; zonal avg of all observations
+ end if
+ delete(i)
+ end do
+
+ if (any(ismissing(zonavg))) then
+ zonavg = linmsg(zonavg, -1) ; linearly interpolate
+ end if
+
+ ;;zonavg = wgt_runave(zonavg, (/0.25, 0.50, 0.25/), 1) ;smooth
+ zonavg = wgt_runave(zonavg, filwgts_normal (7, 1.0, 0) , 1) ;smooth
+
+ LAT = ndtooned(lat2d)
+ G1D = ndtooned(G)
+
+ do nl=0,nlat-1
+ i = ind(LAT.le.(lat1d(nl)+dlat) .and. LAT.ge.(lat1d(nl)-dlat))
+ G1D(i) = zonavg(nl)
+ delete(i)
+ end do
+
+ delete(zonavg)
+ delete(lat1d)
+ delete(LAT)
+
+ G = onedtond(G1D, dimlat)
+ delete(G1D)
+ else
+ G = 0.0 ; direct ... no 1st guess
+ end if
+ end if
+
+ G at lat2d = lat2d
+ G at lon2d = lon2d
+
+ LAT = ndtooned( lat2d )
+ LON = ndtooned( lon2d )
+
+ wcStrt = systemfunc("date")
+ do ns=0,nScan-1
+ nsStrt = systemfunc("date")
+ dc2 = dcrit(ns)^2
+
+ do nl=0,nlat-1
+
+ do ml=0,mlon-1
+ if (ns.eq.0 .or. (ns.gt.0 .and. nObs(ns-1,nl,ml).gt.0)) then
+ i = ind( abs(y-lat2d(nl,ml)).le.dcrit(ns) )
+ if (.not.any(ismissing(i)) ) then
+ gcdist = gc_latlon(lat2d(nl,ml),lon2d(nl,ml), y(i),x(i), 0,2)
+
+ nd = num(gcdist.le.dcrit(ns))
+ nObs(ns,nl,ml) = nd ; # observations within radius
+
+ if (nd.gt.0) then
+ j = ind(gcdist.le.dcrit(ns))
+ ij = i(j)
+ diff = z(ij)-G(nl,ml) ; normally interpolate G to z but .....
+ wgt = exp(-4*gcdist(j)^2/dc2)
+ cf = sum(wgt*diff)/sum(wgt)
+ ;print("ns="+ns+" nl="+nl+" ml="+ml+" cf="+cf)
+
+ G(nl,ml) = G(nl,ml) + cf
+
+ delete(j)
+ delete(ij)
+ delete(cf)
+ delete(wgt)
+ delete(diff)
+ end if
+ delete(gcdist)
+ end if
+ delete(i)
+ end if
+ end do ; ml
+ end do ; nl
+ ; default is to smooth
+ if (.not.isatt(opt,"smooth") .or. opt at smooth) then
+ if (ns.lt.(nScan-1)) then
+ G = smth9(G, 0.50,-0.25, 0) ; light local smoother
+ else
+ G = smth9(G, 0.50, 0.25, 0) ; heavy local smoother
+ end if
+ end if
+
+ if (isatt(opt,"timing")) then
+ wallClockElapseTime(nsStrt,"icObjAnal_2d: ns="+ns , 0)
+ end if
+ end do ; ns`
+
+ if (isatt(opt,"count")) then
+ G at nObs = nObs
+ end if
+
+ if (isatt(opt,"timing")) then
+ wallClockElapseTime(wcStrt,"Total time: icObjAnal_2d: nScan="+nScan , 0)
+ end if
+
+ return(G)
+ end
+ ;----------------------------------------------------------------------------
+ undef("obj_anal_ic_deprecated")
+ function obj_anal_ic_deprecated(X[*],Y[*],Z[*], lon:numeric,lat:numeric
+ ,dcrit[*]:numeric,opt:logical)
+ ; Perform Barnes [ Cressman ] type iterative correction objective analysis
+ ;
+ ; Nomenclature
+ ; x,y,z - lon,lat,observation triplets
+ ; lat - lat of returned grid. Need not be equally spaced
+ ; but must be monotonically increasing. Should have the
+ ; units attribute assigned: lat at units="degrees_north"
+ ; lon - lon of returned grid. Need not be equally spaced
+ ; but must be monotonically increasing. Should have the
+ ; units attribute assigned: lon at units="degrees_east"
+ ; dcrit - 1D array containing successive radii of influence.
+ ; Must be expressed in degrees latitude and should be
+ ; monotonically de. eg: dcrit = (/10, 5, 3/)
+ ; dims = dimsizes(dcrit) , nscan = dims(0)
+ ; opt - variable to which optional attributes are attached
+ ; @guess = 2D guess array [input]
+ ; @timing = print times
+ ; @count = number of observation used in each scan
+ ; Return @nObs ==> (nscan,:,:)
+ ;
+ local wcStrt, i, XX, YY, ZZ, k, x, y, z, dimLat, dimLon, rankLat, rankLon
+ begin
+ wcStrt = systemfunc("date")
+
+ if (.not.isatt(Z,"_FillValue")) then
+ Z at _FillVlaue = 1e20
+ end if
+ ; eliminate missing values
+ i = ind(.not.ismissing(Z))
+ if (ismissing(i(0))) then
+ print("icObjAnal: all input data are missing")
+ end if
+ XX = X(i)
+ YY = Y(i)
+ ZZ = Z(i)
+ delete(i)
+
+ ;k = dim_pqsort(YY, 1) ; sort obs in ascending latitude order
+ ;x = XX(k) ; not used here ... too lazy to change code
+ ;y = YY(k)
+ ;z = ZZ(k)
+ ;delete(k)
+
+ ;delete(XX)
+ ;delete(YY)
+ ;delete(ZZ)
+
+ ;print("icObjAnal: z="+z+" lon="+x+" lat="+y )
+
+ dimLat = dimsizes(lat)
+ dimLon = dimsizes(lon)
+ rankLat = dimsizes(dimLat)
+ rankLon = dimsizes(dimLon)
+ if (rankLat.ne.rankLon) then
+ print("icObjAnal: ranks of lat and lon must match")
+ print("icObjAnal: rankLat="+rankLat)
+ print("icObjAnal: rankLon="+rankLon)
+ end if
+ if (rankLat.gt.2) then
+ print("icObjAnal: ranks of lat and lon must be 1 or 2")
+ print("icObjAnal: rankLat="+rankLat)
+ end if
+
+ if (rankLat.eq.1) then
+ ;zGrid = icObjAnal_1d(X ,Y , Z,lon,lat,dcrit,opt)
+ zGrid = icObjAnal_1d(XX,YY,ZZ,lon,lat,dcrit,opt)
+ else
+ zGrid = icObjAnal_2d(X ,Y , Z,lon,lat,dcrit,opt)
+ ;zGrid = icObjAnal_2d(XX,YY,ZZ,lon,lat,dcrit,opt)
+ end if
+ if (isatt(opt,"timing")) then
+ wallClockElapseTime(wcStrt,"icObjAnal", 0)
+ end if
+
+ if (isatt(Z,"long_name")) then
+ zGrid at long_name = Z at long_name
+ end if
+ if (isatt(Z,"units")) then
+ zGrid at units = Z at units
+ end if
+
+ return(zGrid)
+ end
+ ;****************************************************************************
+ ; Calculate a 'bunch' of dispersion statistics
+ ; This was originally developed for looking at satellite swath data
+ ; which has many points but, often, many missing values and outliers.
+ ; It can be used to ascertain the best values to use for
+ ; contour resources: min/max/interval
+ ;
+ ; *This can be slow for big 'x'*
+ ;
+ undef("stat_dispersion")
+ function stat_dispersion (x:numeric, opt[1]:logical )
+ ; Robust dispersion statistics
+ ;
+ local nStat, nx, sFillV, nFill, one, statx, work, nwork, x1d, ivalid, allFill, nValid
+ begin
+ nx = product( dimsizes(x) )
+ nStat = 30
+ nFill = 0
+ allFill = False
+
+ if (typeof(x).eq."double") then
+ sFillV = 1d20
+ else
+ sFillV = 1e20
+ end if
+
+ if (isatt(x,"_FillValue")) then
+ nFill = num(ismissing(x))
+ if (nFill.gt.0) then
+ x1d = ndtooned(x)
+ ivalid = ind(.not.ismissing(x1d))
+ if (.not.ismissing(ivalid(0))) then
+ work = x1d(ivalid)
+ else
+ allFill= True
+ work = new ( 1, typeof(sFillV), sFillV)
+ end if
+ delete(x1d)
+ else
+ work = ndtooned(x)
+ end if
+ else
+ work = ndtooned(x)
+ end if
+
+ if (typeof(x).eq."double") then
+ one = 1.0d
+ moment = (/0.0d, 0.0d ,0.0d ,0.0d /)
+ else
+ one = 1.0
+ moment = (/0.0 , 0.0 ,0.0 ,0.0 /)
+ end if
+
+ nValid = 0l ; force 'long' int
+ nValid = nx-nFill
+
+ nwork = 0l ; force nwork as 'long' int
+ nwork = dimsizes(work)
+
+ statx = new ( nStat, typeof(sFillV), sFillV)
+ if (nwork.gt.1) then
+ ;statx(0) = avg(x) ; mean
+ ;statx(1) = stddev(x) ; std. deviation
+ moment = dim_stat4( work )
+ statx(0) = moment(0) ; mean
+ statx(1) = sqrt(moment(1)) ; sample std. deviation
+ ; fixed 15 Oct 2014; had returned variance
+
+ qsort( work ) ; sort into ascending order
+ statx(2) = work(0) ; min ( work )
+
+ ; Daniel Leuenberger (Meteo Swiss) suggested the small
+ ; sample size granularity (10/2013)
+ ; -1 ... NCL zero based
+ if (nwork.ge.10) then
+ statx(3) = work( nwork/10-1 ) ; lower dectile
+ statx(13)= work((nwork*9)/10-1) ; upper dectile
+ end if
+
+ if (nwork.ge.8) then
+ statx(4) = work( nwork/8 -1 ) ; lower octtile
+ statx(12)= work((nwork*7)/8 -1) ; upper octtile
+ end if
+
+ if (nwork.ge.6) then
+ statx(5) = work( nwork/6 -1 ) ; lower sextile
+ statx(11)= work((nwork*5)/6 -1) ; upper sextile
+ end if
+
+ if (nwork.ge.4) then
+ statx(6) = work( nwork/4 -1 ) ; lower quartile
+ statx(10)= work((nwork*3)/4 -1) ; upper quartile
+ end if
+
+ if (nwork.ge.3) then
+ statx(7) = work( nwork/3 -1 ) ; lower 3tile
+ statx(9) = work((nwork*2)/3 -1) ; upper 3tile
+ end if
+
+ if (nwork.ge.2) then
+ if (nwork%2 .eq.0) then ; median even
+ statx(8) = (work(nwork/2-1)+work(nwork/2))*0.5
+ else
+ statx(8) = work( nwork/2 ) ; median odd
+ end if
+ end if
+
+ statx(14)= work(nwork-1) ; max ( work )
+ statx(15)= statx(14)-statx(2) ; range
+ if (statx(1).gt.0) then
+ if (.not.ismissing(statx(1)) .and. statx(1).gt.0) then
+ statx(16)= statx(15)/statx(1); a measure of dispersion
+ end if
+ statx(17)= sqrt(sum((work-statx(0))^2)/nwork) ; root mean sq anomaly
+ end if ; nwork.ge.10
+ end if ; .not.allFill
+ statx(18)= nx
+ statx(19)= nValid
+ statx(20)= nFill
+ statx(21)= 100*(one - (one*(nx-nFill))/nx)
+
+ if (nwork.gt.1000) then
+ ;JBuzan [Purdue]
+ statx(22) = work( max((/ 0, nwork/1000-1 /)) ) ; lower 99.9%
+ statx(23) = work( max((/ 0, nwork/100-1 /)) ) ; lower 99.%
+ statx(24) = work( max((/ 0, nwork/20-1 /)) ) ; lower 95%
+
+ statx(25) = work( min((/nwork-1, (nwork*19)/20-1 /)) ) ; upper 95%
+ statx(26) = work( min((/nwork-1, (nwork*99)/100-1 /)) ) ; upper 99.%
+ statx(27) = work( min((/nwork-1, (nwork*999)/1000-1 /)) ) ; upper 99.9%
+ ;JBuzan
+ end if
+
+ ;Arne Melsom (Norwegian Meteorological Institute)
+ statx(28) = moment(2) ; skewness
+ statx(29) = moment(3) ; kurtosis
+ ;Arne Melsom
+
+ statx at long_name = "Robust Dispersion Statistics"
+ if (isatt(x,"long_name")) then
+ statx at long_name = statx at long_name +": "+ x at long_name
+ else
+ if (isatt(x,"hdfeos5_name")) then
+ statx at long_name = statx at long_name +": "+ x at hdfeos5_name
+ end if
+ end if
+ if (isatt(x,"units")) then
+ statx at units = x at units
+ end if
+
+ if (isatt(statx,"No_FillValue")) then
+ if (typeof(x).eq."double") then
+ statx at _FillValue = 1d20
+ else
+ statx at _FillValue = 1e20
+ end if
+ end if
+
+ if (opt .and. opt at PrintStat) then
+ print(" ")
+ print(" ===> "+statx at long_name+" <===")
+ print(" [0] Mean="+statx(0) )
+ print(" [1] StdDev="+statx(1) )
+ print(" [2] Min="+statx(2) )
+ print(" [3] LowDec="+statx(3) )
+ print(" [4] LowOct="+statx(4) )
+ print(" [5] LowSex="+statx(5) )
+ print(" [6] LowQuartile="+statx(6) )
+ print(" [7] LowTri="+statx(7) )
+ print(" [8] Median="+statx(8) )
+ print(" [9] HighTri="+statx(9) )
+ print(" [10] HighQuartile="+statx(10) )
+ print(" [11] HighSex="+statx(11) )
+ print(" [12] HighOct="+statx(12) )
+ print(" [13] HighDec="+statx(13) )
+ print(" [14] Max="+statx(14) )
+ print(" [15] Range="+statx(15) )
+ print(" [16] Dispersion="+statx(16) )
+ print(" [17] RMS Anomaly="+statx(17) )
+ print(" [18] # Total="+statx(18) )
+ print(" [19] # Used="+statx(19) )
+ print(" [20] # Missing="+statx(20) )
+ print(" [21] % Missing="+statx(21) )
+ print(" [22] Lower 0.1%="+statx(22) )
+ print(" [23] Lower 1.0%="+statx(23) )
+ print(" [24] Lower 5.0%="+statx(24) )
+ print(" [25] Upper 5.0%="+statx(25) )
+ print(" [26] Upper 1.0%="+statx(26) )
+ print(" [27] Upper 0.1%="+statx(27) )
+ print(" [28] Skewness="+statx(28) )
+ print(" [29] Kurtosis="+statx(29) )
+ print(" ")
+ end if
+
+ return(statx)
+ end
+ ; **********************************************************************
+ ; D. Shea
+ ; wrapper for NCL procedure "int2p" that copies attributes and coordinate
+ ; vars. It adds the longitude and latitude coordinates.
+ ;
+ ; Modified by Seah 1/1/2010 to handle multi-d xo.
+
+ undef("int2p_Wrap")
+ function int2p_Wrap (xi:numeric, fi:numeric, xo:numeric, linlog[1]:integer)
+
+ ; wrapper for NCL function "int2p" that copies attributes and coordinate vars.
+ local fo, dimfi, nDim, n, nD
+ begin
+
+ fo = int2p (xi,fi, xo, linlog) ; perform interpolation
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fo)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ copy_VarCoords_1 (fi, fo) ; copy coord variables
+ ; except for rightmost
+ nD = nDim-1 ; last dimension (rightmost)
+ rnkxo = dimsizes( dimsizes(xo) )
+
+ if (rnkxo.eq.1) then
+ if (isdimnamed(xo,0)) then ; create a new coord for
+ fo!nD = xo!0 ; if present, use xo name
+ else
+ if (isdimnamed(fi,nD)) then
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ ;;fo!nD = changeCaseChar(fi!nD) ; if present, use same name
+ else ; but change case
+ fo!nD = "X" ; default dimension name
+ end if
+ end if
+
+ fo&$fo!nD$ = xo ; assign coords [1D only]
+
+ else ; must be multi-d
+ if (isdimnamed(xo,nD)) then ; is xo rightmost named?
+ fo!nD = xo!nD ; if present, use xo name
+ else
+ if (isdimnamed(fi,nD)) then
+ fo!nD = str_switch(fi!nD) ; if present, use same name
+ ;;fo!nD = changeCaseChar(fi!nD) ; if present, use same name
+ else ; but change case
+ fo!nD = "X" ; default dimension name
+ end if
+ end if
+ end if
+
+ return (fo)
+ end
+ ; **********************************************************************
+ ; M. Haley
+ ; wrapper for NCL procedure "int2p_n" that copies attributes and
+ ; coordinate vars. It adds the longitude and latitude coordinates.
+ ;
+ ; Based on int2p_Wrap.
+ ; Added Oct 25, 2009
+
+ undef("int2p_n_Wrap")
+ function int2p_n_Wrap (xi:numeric, fi:numeric, xo:numeric,
+ linlog[1]:integer, pdim[1]:integer)
+
+ ; wrapper for NCL function "int2p_n" that copies attributes and
+ ; coordinate vars.
+ local fo, dimfi, nDim, n, nD
+ begin
+
+ fo = int2p_n (xi,fi, xo, linlog, pdim) ; perform interpolation
+ ; shea_misc functions
+ dimfi= dimsizes(fi)
+ nDim = dimsizes(dimsizes(fo)) ; number of dimensions
+
+ copy_VarAtts (fi, fo) ; copy variable attributes
+ copy_VarCoords_not_n (fi, fo, pdim) ; copy coord variables
+ ; except for pdim-th
+
+ ; create a new coord for
+ ; level dimension
+ dimxo = dimsizes(xo) ; check if multi-d
+ rnkxo = dimsizes(dimxo)
+ if (rnkxo.eq.1.and.isdimnamed(xo,0)) then
+ fo!pdim = xo!0 ; if present, use xo name
+ else
+ if(rnkxo.gt.1.and.isdimnamed(xo,pdim)) then
+ fo!pdim = xo!pdim ; if present, use xo name
+ else
+ if (isdimnamed(fi,pdim)) then
+ fo!pdim = str_switch(fi!pdim) ; if present, use same name
+ ;;fo!pdim = changeCaseChar(fi!pdim) ; if present, use same name
+ else ; but change case
+ fo!pdim = "X" ; default dimension name
+ end if
+ end if
+ end if
+ ; assign coordinates
+ if (rnkxo.eq.1) then
+ fo&$fo!pdim$ = xo
+ end if
+
+ return (fo)
+ end
+ ;------------------------------------------------
+ undef("numBinOneRuns")
+ function numBinOneRuns ( a[*]:integer, nCrit:integer)
+ ;
+ ; Give a binary series [0s and 1s], calculate the
+ ; number of 'runs' of 1s that meet lengths specified by 'nCrit'
+ ; Nomenclature:
+ ; a[*] => integer ... eg (/ 1,1,1,0,0,0,1,0,0,1,1,1,1 /)
+ ; nCrit => integer ... scalar [eg, 3] or of length 2 [eg: (/4,6/) ]
+ ; scalar: count the number of runs .ge.3
+ ; [2]: count the number of runs .ge.4 and .le. 6
+ ; : if nCrit[0]=nCrit[1] ( eg : (/5,5/) ]
+ ; [2]: count the number of runs .ge.5 and .le. 5
+ ; : this would yield the number of runs of
+ ; ; exactly length 5
+ ;
+ ; Primary source:
+ ; David Allured: CU/CIRES Climate Diagnostics Center (CDC)
+
+ local inds, ni, deltas, starts, ends, lengths
+ begin
+ dim_nCrit = dimsizes(nCrit)
+ if (dim_nCrit.gt.2) then
+ print("numBinOneRuns: nCrit size must be .le. 2: nCrit="+dim_nCrit)
+ return(default_fillvalue("integer"))
+ end if
+
+ inds = ind (a .eq. 1)
+ ni = dimsizes (inds)
+ deltas = new (ni+1, integer)
+ deltas = 0
+ deltas(1:ni-1) = (inds(1:ni-1) - inds(0:ni-2))
+ starts = inds(ind (deltas(0:ni-1).ne.1 .and. deltas(1:ni).eq.1))
+ ends = inds(ind (deltas(0:ni-1).eq.1 .and. deltas(1:ni).ne.1))
+ lengths = ends - starts + 1
+
+ if (dim_nCrit.eq.1) then
+ return(num (lengths.ge.nCrit) )
+ else
+ return(num (lengths.ge.nCrit(0) .and. lengths.le.nCrit(1)) )
+ end if
+ end
+ ;---------------------------------
+ ; undocumented and unsupported
+ ;---------------------------------
+ undef ("calculate_monthly_values")
+ function calculate_monthly_values (x:numeric, arith:string, nDim[1]:integer, opt[1]:logical)
+
+ ; calculate monthly values [avg, sum, min, max]
+ ; x: numeric array of 5D or less [eg: time,lev,lat,lon]
+ ; *must* have time coordinate recognized by cd_calendar
+ ; if 5D [case,time,lev,lat,lon]
+ ; arith: "avg" [also, "ave"], "sum","min","max" others may be added later
+ ; nDim : scalar integer that specifies the 'time' dimension [generally, 0]
+ ; opt : only used to eliminate a warning message
+ ; opt= 0 ... default ... print Warning
+ ; opt=-1 ... do not print Warning
+ ;
+ ; Sample usage: x(time,lat,lon) where time are n-hrly or daily values.
+ ; xMonthAvg = calculate_monthly_values(x, "avg", 0, False)
+ ; xMonthSum = calculate_monthly_values(x, "sum", 0, False)
+ ; xMonthMin = calculate_monthly_values(x, "min", 0, False)
+ ; xMonthMax = calculate_monthly_values(x, "max", 0, False)
+ ;
+ ; It is assumed that there will be multiple elements for the dim_avg_n
+ ; calculation.
+ ;
+ local dimx, rankx, utc_date, year, month, day, hour, ntim
+ , yrStrt, yrLast, nyrs, NTIM, dAvg, xReturn, xMonth
+ , NT, nmo, ii, NMOS, MON1, MON2
+ begin
+ dimx = dimsizes( x )
+ rankx = dimsizes( dimx )
+
+ if (rankx.gt.5) then
+ print("calculate_monthly_values: rankx="+rankx +" [only 5D or fewer supported]")
+ exit
+ end if
+
+ utc_date = cd_calendar(x&time, 0)
+
+ year = toint(utc_date(:,0))
+ month = toint(utc_date(:,1))
+ day = toint(utc_date(:,2))
+ hour = toint(utc_date(:,3))
+ ;minute = toint(utc_date(:,4))
+ ;second = utc_date(:,5)
+
+ if (rankx.le.4) then
+ ntim = dimx(0)
+ else
+ ntim = dimx(1)
+ end if
+
+ yrStrt = year(0)
+ yrLast = year(ntim-1)
+ nyrs = yrLast-yrStrt+1
+
+ NMOS = 12
+ ;NTIM = NMOS*nyrs ; total number of months
+ if (yrStrt.eq.yrLast) then
+ NTIM = month(ntim-1) - month(0) + 1
+ else
+ MON1 = NMOS-month(0)+1 ; "Sebi" generalization
+ MON2 = month(ntim-1)
+ NTIM = NMOS*(nyrs-2)+MON1+MON2
+ ;;NTIM = NMOS*(nyrs-2)+(12-(month(0)-1))+month(ntim-1) ; "Sebi" generalization
+ end if
+ dAvg = dimx
+ if (rankx.le.4) then
+ dAvg(0)= NTIM
+ else
+ dAvg(1)= NTIM
+ end if
+
+ if (typeof(x).eq."float" .or. typeof(x).eq."double") then
+ xReturn= new ( dAvg , typeof(x), getFillValue(x))
+ else
+ xReturn= new ( dAvg , "float", tofloat(getFillValue(x)))
+ end if
+
+ xMonth = new ( NTIM , typeof(x&time), "No_FillValue")
+ ;;printVarSummary(xMonth)
+
+ NT = -1
+ do yr=yrStrt,yrLast
+
+ nmoStrt = 0 ; index to start
+ nmoLast = NMOS-1 ; index to end
+ if (yr.eq.yrStrt) then
+ nmoStrt = month(0)-1 ; possible partial year
+ end if
+ if (yr.eq.yrLast) then
+ nmoLast = month(ntim-1)-1 ; possible partial year
+ end if
+
+ do nmo=nmoStrt,nmoLast
+ NT = NT+1
+ if (isvar("ii")) then ; keep this here!!
+ delete(ii)
+ end if
+ ii = ind(yr.eq.year .and. (nmo+1).eq.month)
+
+ if (.not.ismissing(ii(0))) then
+
+ dimii = dimsizes(ii) ; should be > 1
+ if (dimii.eq.1 .and. opt.ne.-1 ) then
+ print("calculate_monthly_values: Warning: there should be more than one element")
+ ; print("This is unsupported code. ")
+ ; exit
+ end if
+
+ iStrt = ii(0)
+ iLast = ii(dimii-1)
+
+ xMonth(NT) = (/ x&time(ii(0)) /)
+
+ if (rankx.eq.1) then
+ if (arith.eq."avg" .or. arith.eq."ave") then
+ xReturn(NT) = dim_avg_n(x(iStrt:iLast) , nDim)
+ end if
+ if (arith.eq."sum") then
+ xReturn(NT) = dim_sum_n(x(iStrt:iLast) , nDim)
+ end if
+ if (arith.eq."min") then
+ xReturn(NT) = dim_min_n(x(iStrt:iLast) , nDim)
+ end if
+ if (arith.eq."max") then
+ xReturn(NT) = dim_max_n(x(iStrt:iLast) , nDim)
+ end if
+ end if
+
+ if (rankx.eq.2) then
+ if (arith.eq."avg" .or. arith.eq."ave") then
+ xReturn(NT,:) = dim_avg_n(x(iStrt:iLast,:) , nDim)
+ end if
+ if (arith.eq."sum") then
+ xReturn(NT,:) = dim_sum_n(x(iStrt:iLast,:) , nDim)
+ end if
+ if (arith.eq."min") then
+ xReturn(NT,:) = dim_min_n(x(iStrt:iLast,:) , nDim)
+ end if
+ if (arith.eq."max") then
+ xReturn(NT,:) = dim_max_n(x(iStrt:iLast,:) , nDim)
+ end if
+ end if
+
+ if (rankx.eq.3) then
+ if (arith.eq."avg" .or. arith.eq."ave") then
+ xReturn(NT,:,:) = dim_avg_n(x(iStrt:iLast,:,:) , nDim)
+ end if
+ if (arith.eq."sum") then
+ xReturn(NT,:,:) = dim_sum_n(x(iStrt:iLast,:,:) , nDim)
+ end if
+ if (arith.eq."min") then
+ xReturn(NT,:,:) = dim_min_n(x(iStrt:iLast,:,:) , nDim)
+ end if
+ if (arith.eq."max") then
+ xReturn(NT,:,:) = dim_max_n(x(iStrt:iLast,:,:) , nDim)
+ end if
+ end if
+
+ if (rankx.eq.4) then
+ if (arith.eq."avg" .or. arith.eq."ave") then
+ xReturn(NT,:,:,:) = dim_avg_n(x(iStrt:iLast,:,:,:) , nDim)
+ end if
+ if (arith.eq."sum") then
+ xReturn(NT,:,:,:) = dim_sum_n(x(iStrt:iLast,:,:,:) , nDim)
+ end if
+ if (arith.eq."min") then
+ xReturn(NT,:,:,:) = dim_min_n(x(iStrt:iLast,:,:,:) , nDim)
+ end if
+ if (arith.eq."max") then
+ xReturn(NT,:,:,:) = dim_max_n(x(iStrt:iLast,:,:,:) , nDim)
+ end if
+ end if
+
+ if (rankx.eq.5) then ; note the location of time
+ if (arith.eq."avg" .or. arith.eq."ave") then
+ xReturn(:,NT,:,:,:) = dim_avg_n(x(:,iStrt:iLast,:,:,:) , nDim)
+ end if
+ if (arith.eq."sum") then
+ xReturn(:,NT,:,:,:) = dim_sum_n(x(:,iStrt:iLast,:,:,:) , nDim)
+ end if
+ if (arith.eq."min") then
+ xReturn(:,NT,:,:,:) = dim_min_n(x(:,iStrt:iLast,:,:,:) , nDim)
+ end if
+ if (arith.eq."max") then
+ xReturn(:,NT,:,:,:) = dim_max_n(x(:,iStrt:iLast,:,:,:) , nDim)
+ end if
+ end if
+ end if
+
+ delete(ii)
+ end do ; month
+ end do ; year
+
+ if (rankx.le.4) then
+ xReturn!0= "time"
+ else
+ xReturn!1= "time"
+ end if
+
+ xMonth at units = x&time at units
+ xReturn&time = xMonth
+
+ if (isatt(x,"long_name")) then
+ xReturn at long_name = x at long_name
+ end if
+
+ if (isatt(x,"units")) then
+ xReturn at units = x at units
+ end if
+
+ if (rankx.eq.2) then
+ copy_VarCoords(x(0,:), xReturn(0,:))
+ end if
+ if (rankx.eq.3) then
+ copy_VarCoords(x(0,:,:), xReturn(0,:,:))
+ end if
+ if (rankx.eq.4) then
+ copy_VarCoords(x(0,:,:,:), xReturn(0,:,:,:))
+ end if
+ if (rankx.eq.5) then
+ copy_VarCoords(x(:,0,:,:,:), xReturn(:,0,:,:,:))
+ end if
+
+ xReturn at operation_tag = "calculate_monthly_values: "+arith
+
+ return( xReturn )
+ end
+ ;**********************************************************
+ undef("merge_levels_sfc")
+ function merge_levels_sfc (x, xsfc, levind[1]:integer)
+ ; levind .ge. 0 top-to-bot ordering
+ ; levind .lt. 0 bot-to-top ordering
+ ;
+ ; rank 1: x(lev), xsfc(1)
+ ; rank 2: x(time,lev), xsfc(time)
+ ; rank 3: x(lev,lat,lon), xsfc(lat,lon)
+ ; rank 4: x(time,lev,lat,lon), xsfc(time,lat,lon)
+ ; rank 5: x(case,time,lev,lat,lon), xsfc(case,time,lat,lon)
+ ;
+ local dimx, dimxs, rankx, rankxs, klev, k1, k2, mono, fudge
+ begin
+ dimx = dimsizes(x)
+ rankx = dimsizes(dimx)
+ dimxs = dimsizes(xsfc)
+ rankxs = dimsizes(dimxs)
+
+ if (rankx.gt.1 .and. .not.(rankx.eq.(rankxs+1)) ) then
+ print("merge_levels_sfc: xsfc must have one less dimension than x")
+ print(" rank(x)="+rankx+" rank(xs)="+rankxs )
+ exit
+ end if
+
+ if (rankx.eq.1 .and. (rankxs.ne.1 .or. dimxs(0).gt.1) ) then
+ print("merge_levels_sfc: For x[*], then xsfc must be a scalar")
+ print(" rank(x)="+rankx+" rank(xs)="+rankxs+" dimxs="+dimxs )
+ exit
+ end if
+
+ momo = 1
+ fudge = 1.02 ; completely arbitrary > 1
+
+ ; rank 5: x(case,time,lev,lat,lon), xsfc(case,time,lat,lon)
+ if (rankx.eq.5 .and. rankxs.eq.4) then
+ klev = dimx(2)+1
+
+ if (iscoord(x, x!2) ) then
+ lv = x&$x!2$
+ mono = isMonotonic(lv)
+ lvNew = new (klev, typeof(lv))
+ else
+ lv = ispan(0,klev-2,1)*1.0
+ lvNew = ispan(0,klev-1,1)*1.0
+ end if
+
+ dimx(2) = klev
+ xNew = new( dimx, typeof(x), getFillValue(x) )
+ if (levind.lt.0) then
+ xNew(:,:, 1: ,:,:) = (/ x /)
+ xNew(:,:, 0:0 ,:,:) = (/ xsfc /)
+ lvNew(1:) = (/ lv /)
+ ;lvNew(0 ) = lv(0)*fudge
+ lvNew(0 ) = 2*lv(0) - lv(1)
+ else
+ k1 = klev-1
+ k2 = klev-2
+ xNew(:,:, 0:k2,:,:) = (/ x /)
+ xNew(:,:,k1:k1,:,:) = (/ xsfc /)
+ lvNew(0:k2) = (/ lv /)
+ ;lvNew(k1) = lv(k2)*fudge
+ lvNew(k1) = 2*lv(k2) - lv(k2-1)
+ end if
+ copy_VarAtts(lv, lvNew)
+
+ if (isdimnamed(x, 0)) then
+ xNew!0 = x!0
+ else
+ x!0 = "case"
+ xNew!0 = "case"
+ end if
+ xNew!1 = x!1
+ xNew!2 = str_switch(x!2) ; new name
+ xNew!3 = x!3
+ xNew!4 = x!4
+
+ if (iscoord(x, x!0) ) then
+ xNew&$xNew!0$ = x&$x!0$ ; case
+ end if
+ if (iscoord(x, x!1) ) then
+ xNew&$xNew!1$ = x&$x!1$ ; time
+ end if
+ if (iscoord(x, x!2) ) then
+ xNew&$xNew!2$ = lvNew ; level of merged
+ end if
+ if (iscoord(x, x!3) ) then
+ xNew&$xNew!3$ = x&$x!3$ ; lat
+ end if
+ if (iscoord(x, x!4) ) then
+ xNew&$xNew!4$ = x&$x!4$ ; lon
+ end if
+ end if
+
+ ; rank 4: x(time,lev,lat,lon), xsfc(time,lat,lon)
+ if (rankx.eq.4 .and. rankxs.eq.3) then
+ klev = dimx(1)+1
+ if (iscoord(x, x!1) ) then
+ lv = x&$x!1$
+ mono = isMonotonic(lv)
+ lvNew = new (klev, typeof(lv))
+ else
+ lv = ispan(0,klev-2,1)
+ lvNew = ispan(0,klev-1,1)
+ end if
+
+ dimx(1) = klev
+ xNew = new( dimx, typeof(x), getFillValue(x) )
+ if (levind.lt.0) then
+ xNew(:, 1: ,:,:) = (/ x /)
+ xNew(:, 0:0 ,:,:) = (/ xsfc /)
+ lvNew(1:) = (/ lv /)
+ ;lvNew(0) = lv(0)*fudge
+ lvNew(0 ) = 2*lv(0) - lv(1)
+ else
+ k1 = klev-1
+ k2 = klev-2
+ xNew(:, 0:k2,:,:) = (/ x /)
+ xNew(:,k1:k1,:,:) = (/ xsfc /)
+ lvNew(0:k2) = (/ lv /)
+ ;lvNew(k1) = lv(k2)*fudge
+ lvNew(k1) = 2*lv(k2) - lv(k2-1)
+ end if
+ copy_VarAtts(lv, lvNew)
+
+ xNew!0 = x!0
+ xNew!1 = str_switch(x!1) ; new name
+ xNew!2 = x!2
+ xNew!3 = x!3
+ if (iscoord(x, x!0) ) then
+ xNew&$xNew!0$ = x&$x!0$ ; time
+ end if
+ if (iscoord(x, x!1) ) then
+ xNew&$xNew!1$ = lvNew ; level of merged
+ end if
+ if (iscoord(x, x!2) ) then
+ xNew&$xNew!2$ = x&$x!2$ ; lat
+ end if
+ if (iscoord(x, x!3) ) then
+ xNew&$xNew!3$ = x&$x!3$ ; lon
+ end if
+ end if
+
+ ; rank 3: x(lev,lat,lon), xsfc(lat,lon)
+ if (rankx.eq.3 .and. rankxs.eq.2) then
+ klev = dimx(0)+1
+ if (iscoord(x, x!0) ) then
+ lv = x&$x!0$
+ mono = isMonotonic(lv)
+ lvNew = new (klev, typeof(lv))
+ else
+ lv = ispan(0,klev-2,1)
+ lvNew = ispan(0,klev-1,1)
+ end if
+
+ dimx(0) = klev
+ xNew = new( dimx, typeof(x), getFillValue(x) )
+ if (levind.lt.0) then
+ xNew( 1: ,:,:) = (/ x /)
+ xNew( 0:0 ,:,:) = (/ xsfc /)
+ lvNew(1:) = (/ lv /)
+ ;lvNew(0) = lv(0)*fudge
+ lvNew(0 ) = 2*lv(0) - lv(1)
+ else
+ k1 = klev-1
+ k2 = klev-2
+ xNew( 0:k2,:,:) = (/ x /)
+ xNew(k1:k1,:,:) = (/ xsfc /)
+ lvNew(0:k2) = (/ lv /)
+ ;lvNew(k1) = lv(k2)*fudge
+ lvNew(k1) = 2*lv(k2) - lv(k2-1)
+ end if
+ copy_VarAtts(lv, lvNew)
+
+ xNew!0 = str_switch(x!0) ; new name
+ xNew!1 = x!1
+ xNew!2 = x!2
+ if (iscoord(x, x!0) ) then
+ xNew&$xNew!0$ = lvNew ; level of merged
+ end if
+ if (iscoord(x, x!1) ) then
+ xNew&$xNew!1$ = x&$x!1$ ; lat
+ end if
+ if (iscoord(x, x!2) ) then
+ xNew&$xNew!2$ = x&$x!2$ ; lon
+ end if
+ end if
+
+ ; rank 1: x(lev), xsfc(1)
+ if (rankx.eq.1 .and. rankxs.eq.1) then
+ klev = dimx(0)+1
+ if (iscoord(x, x!0) ) then
+ lv = x&$x!0$
+ mono = isMonotonic(lv)
+ lvNew = new (klev, typeof(lv))
+ else
+ lv = ispan(0,klev-2,1)
+ lvNew = ispan(0,klev-1,1)
+ end if
+
+ dimx(0) = klev
+ xNew = new( dimx, typeof(x), getFillValue(x) )
+ if (levind.lt.0) then
+ xNew( 1: ) = (/ x /)
+ xNew( 0:0 ) = (/ xsfc /)
+ lvNew(1:) = (/ lv /)
+ ;lvNew(0) = lv(0)*fudge
+ lvNew(0 ) = 2*lv(0) - lv(1)
+ else
+ k1 = klev-1
+ k2 = klev-2
+ xNew( 0:k2) = (/ x /)
+ xNew(k1:k1) = (/ xsfc /)
+ lvNew(0:k2) = (/ lv /)
+ ;lvNew(k1) = lv(k2)*fudge
+ lvNew(k1) = 2*lv(k2) - lv(k2-1)
+ end if
+ copy_VarAtts(lv, lvNew)
+
+ xNew!0 = str_switch(x!0) ; new name
+ if (iscoord(x, x!0) ) then
+ xNew&$xNew!0$ = lvNew ; level of merged
+ end if
+ end if
+
+ ; rank 2: x(time,lev), xsfc(time)
+ if (rankx.eq.2 .and. rankxs.eq.1) then
+ klev = dimx(1)+1
+ if (iscoord(x, x!1) ) then
+ lv = x&$x!1$
+ mono = isMonotonic(lv)
+ lvNew = new (klev, typeof(lv))
+ else
+ lv = ispan(0,klev-2,1)
+ lvNew = ispan(0,klev-1,1)
+ end if
+
+ dimx(1) = klev
+ xNew = new( dimx, typeof(x), getFillValue(x) )
+ if (levind.lt.0) then
+ xNew(:, 1: ) = (/ x /)
+ xNew(:, 0:0 ) = (/ xsfc /)
+ lvNew(1:) = (/ lv /)
+ ;lvNew(0) = lv(0)*fudge
+ lvNew(0 ) = 2*lv(0) - lv(1)
+ else
+ k1 = klev-1
+ k2 = klev-2
+ xNew(:, 0:k2) = (/ x /)
+ xNew(:,k1:k1) = (/ xsfc /)
+ lvNew(0:k2) = (/ lv /)
+ ;lvNew(k1) = lv(k2)*fudge
+ lvNew(k1) = 2*lv(k2) - lv(k2-1)
+ end if
+
+ xNew!0 = x!0
+ xNew!1 = str_switch(x!1) ; new name
+ if (iscoord(x, x!0) ) then
+ xNew&$xNew!0$ = x&$x!0$ ; time
+ end if
+ if (iscoord(x, x!1) ) then
+ xNew&$xNew!1$ = lvNew ; level of merged
+ end if
+ end if
+
+ copy_VarAtts(x, xNew)
+
+ return(xNew)
+ end
+ ; --------------------------
+ undef("time_to_newtime")
+ function time_to_newtime(time[*]:numeric, new_time_units[1]:string)
+ ; change a "udunits" recognized time unit to a new (different)\
+ ; "udunits" recognized time unit.
+ ;
+ ; Example:
+ ; TIME = time_to_newtime(time, "days since 1950-01-01 00:00" ) ; Time(time)
+ ; time = time_to_newtime(time, "hours since 1800-01-01 00:00") ; time(time)
+ begin
+ ntim = dimsizes(time)
+ date = cd_calendar( time, 0)
+ ;print(date(:,0)+" "+date(:,1)+" "+date(:,2)+" "+date(:,3))
+ TIME = cd_inv_calendar(toint(date(:,0)),toint(date(:,1))
+ ,toint(date(:,2)),toint(date(:,3))
+ ,toint(date(:,4)),todouble(date(:,5)),new_time_units, 0)
+
+ if (isatt(time,"calendar")) then
+ TIME at calendar = time at calendar
+ end if
+
+ TIME!0 = "time"
+ TIME&time = TIME
+ ; delete attributes that may no longer be appropriate
+ if (isatt(TIME,"actual_range")) then
+ delete(TIME at actual_range)
+ end if
+ if (isatt(TIME,"delta_t")) then
+ delete(TIME at delta_t)
+ end if
+ if (isatt(TIME,"avg_period")) then
+ delete(TIME at avg_period)
+ end if
+ if (isatt(TIME,"prev_avg_period")) then
+ delete(TIME at prev_avg_period)
+ end if
+
+ if (typeof(time).eq."float") then
+ return(dble2flt(TIME)) ; retain meta data
+ else
+ return(TIME)
+ end if
+ end
+
+ undef("sigma_interface")
+ function sigma_interface (sigma[*]:numeric, sigma_top[1]:numeric)
+ ; -------------------------------------------------
+ ; create "interface" sigma levels to mimic the
+ ; CAM models interface hybrid levels
+ ; -------------------------------------------------
+ local ksig, SIGMA, sigmai, sigName
+ begin
+
+ ksig = dimsizes(sigma)
+ if (sigma_top.gt.sigma(0)) then
+ print("sigma_interface: sigma_top must be less than/equal to sigma(0)")
+ print(" sigma_top= "+sigma_top+" ; sigma(0)="+sigma(0))
+ exit
+ end if
+ ; 'super' sigma .. include top and bottom
+ SIGMA = new(ksig+2, typeof(sigma),"No_FillValue")
+ SIGMA(0) = sigma_top ; anything less than sigma(0)
+ SIGMA(1:ksig) = (/ sigma /)
+ SIGMA(ksig+1) = 1.0
+ ;;print(SIGMA)
+ ; interface sigma levels
+ sigmai = (SIGMA(1:) + SIGMA(0:ksig))*0.5
+ sigmai(0) = SIGMA(0) ; force top for full thickness
+ sigmai(ksig) = 1.0 ; force bot
+ copy_VarAtts(sigma, sigmai)
+ sigmai at long_name = "Sigma at model interface layers"
+
+ return(sigmai)
+ end
+
+ undef("dpres_sigma")
+ function dpres_sigma (ps:numeric, sigma[*]:numeric, sigma_top[1]:numeric)
+ ; -------------------------------------------------
+ ; use the dpres_hybrid_ccm function to get layer thicknesses
+ ; -------------------------------------------------
+
+ local sigmai, A, P0, dp_sigma, rank_ps, nd, psName, sigName
+ begin
+ sigmai = sigma_interface (sigma, sigma_top)
+ A = sigmai
+ A = 0.0
+ P0 = 0.0
+
+ dp_sigma = dpres_hybrid_ccm(ps,P0,A,sigmai)
+ dp_sigma at long_name = "pressure thickness"
+ if (isatt(ps, "units")) then
+ dp_sigma at units = ps at units
+ end if
+
+ rank_ps = dimsizes( dimsizes(ps) )
+ if (rank_ps.eq.3) then
+ psName = getvardims(ps) ; dimension names
+ dp_sigma!0 = ps!0
+ dp_sigma!2 = ps!1
+ dp_sigma!3 = ps!2
+ do nd=0,2
+ if (.not.ismissing(psName(nd)) .and.
+ iscoord(ps,psName(nd))) then
+ dp_sigma&$psName(nd)$ = ps&$psName(nd)$
+ end if
+ end do
+
+ sigName = getvardims(sigma)
+ if (.not.ismissing(sigName) .and. iscoord(sigma,sigName)) then
+ dp_sigma!1 = sigName
+ dp_sigma&$sigName$ = sigma&$sigName$
+ else
+ dp_sigma!1 = "sigma"
+ dp_sigma&sigma = sigma
+ end if
+ end if
+
+ return(dp_sigma)
+ end
+ ;---------------------------------------------------------------------------
+ undef("dpres_plevel_Wrap")
+ function dpres_plevel_Wrap(plev[*]:numeric, psfc:numeric, ptop[1]:numeric, opt:integer)
+ ; -------------------------------------------------
+ ; use the dpres_plevel function to get layer thicknesses
+ ; -------------------------------------------------
+
+ begin
+ dp_plevel = dpres_plevel(plev, psfc, ptop, 0)
+
+ ; add meta data
+
+ dp_plevel at long_name = "pressure thickness"
+ if (isatt(psfc, "units")) then
+ dp_plevel at units = psfc at units
+ end if
+
+ plevName = getvardims(plev)
+ psfcName = getvardims(psfc) ; dimension names
+ rank_psfc = dimsizes( dimsizes(psfc) )
+
+ if (rank_psfc.eq.1) then
+ if (.not.ismissing(plevName)) then
+ dp_plevel!0 = plevName
+ if (iscoord(plev,plevName)) then
+ dp_plevel&$plevName$ = plev&$plevName$
+ end if
+ else
+ dp_plevel!0 = "plev"
+ dp_plevel&plev= plev
+ end if
+ end if
+
+ if (rank_psfc.eq.2) then ; (lat,lon) => (0,1)
+ do nd=0,1
+ if (.not.ismissing(psfcName(nd))) then
+ dp_plevel!(nd+1) = psfcName(nd) ; psfc!nd
+ if (iscoord(psfc,psfcName(nd))) then
+ dp_plevel&$psfcName(nd)$ = psfc&$psfcName(nd)$
+ end if
+ end if
+ end do
+
+ if (.not.ismissing(plevName)) then
+ dp_plevel!0 = plevName
+ if (iscoord(plev,plevName)) then
+ dp_plevel&$plevName$ = plev&$plevName$
+ end if
+ else
+ dp_plevel!0 = "plev"
+ dp_plevel&plev= plev
+ end if
+ end if
+
+ if (rank_psfc.eq.3) then ; (time,lat,lon) => (0,1,2)
+ if (.not.ismissing(psfcName(0))) then
+ dp_plevel!0 = psfcName(0) ; psfc!0
+ if (iscoord(psfc,psfcName(0))) then
+ dp_plevel&$psfcName(0)$ = psfc&$psfcName(0)$
+ end if
+
+ do nd=1,2
+ if (.not.ismissing(psfcName(0))) then
+ dp_plevel!(nd+1) = psfcName(nd) ; psfc!nd
+ dp_plevel&$psfcName(nd)$ = psfc&$psfcName(nd)$
+ end if
+ end do
+
+ if (.not.ismissing(plevName) .and. iscoord(plev,plevName)) then
+ dp_plevel!1 = plevName
+ dp_plevel&$plevName$ = plev&$plevName$
+ else
+ dp_plevel!1 = "plev"
+ dp_plevel&plev= plev
+ end if
+ end if
+ end if
+
+ return(dp_plevel)
+ end
+ ;---------------------------------------------------
+ ; Rob Nicholas [U. Washington] & D. Shea
+ undef("pattern_cor2")
+ function pattern_cor2 (x[*][*],y[*][*],w, opt:integer)
+ ; This function should NOT be called directly by users.
+ ; Please use "pattern_cor"
+ ; --
+ ; Compute the pattern correlation between two fields
+ ; (lat,lon) .... wgt(lat)
+
+ local dimx, dimy, dimw, wgt, WGT, sumWGT, xAvgArea, xAnom, yAnom
+ , i, j, W1D, z1d, xyCov, xAnom2, yAnom2, r, rFill
+ begin
+ if (isatt(x,"_FillValue")) then
+ if (all(ismissing(x))) then
+ rFill = (/ x at _FillValue /)
+ rFill at _FillValue = rFill
+ return(rFill)
+ end if
+ end if
+ if (isatt(y,"_FillValue")) then
+ if (all(ismissing(y))) then
+ rFill = (/ y at _FillValue /)
+ rFill at _FillValue = rFill
+ return(rFill)
+ end if
+ end if
+ ; x and y must have the same sizes
+ dimx = dimsizes(x)
+ dimy = dimsizes(y)
+ if (.not.all(dimx.eq.dimy)) then
+ print("pattern_cor: Fatal: x and y do not have the same dimension sizes")
+ print(" dimx: "+dimx+" dimy="+dimy)
+ exit
+ end if
+
+ dimw = dimsizes(w)
+ rankw = dimsizes(dimw)
+ if (rankw.gt.2) then
+ print("pattern_cor: Fatal: w can be a scalar, w[*] or w[*][*]")
+ print(" rankw: "+rankw)
+ exit
+ end if
+
+ if (rankw.eq.2 .and. .not.all(dimx.eq.dimw)) then
+ print("pattern_cor: Fatal: w[*][*] must have the same dimensions as x[*][*]")
+ print(" dimx: "+dimx+" dimw="+dimw)
+ exit
+ end if
+ ; w can be w[1], w[*] or w[*][*]
+ if (rankw.eq.1) then
+ if (dimw.eq.1) then ; if w is w(1) (scalar) set to 1.0
+ WGT = new(dimx, typeof(w),"No_FillValue")
+ WGT = 1.0
+ end if
+ if (dimx(0).eq.dimw .and. .not.isvar("WGT")) then
+ WGT = conform(x, w, 0) ; broadcast dimensions to match x/y
+ end if
+ else ; must be 2D
+ WGT = w
+ end if
+
+ ; if x/y has _Fillvalue attribute; set WGT=0.0 where x or y = _FillValue
+
+ if (isatt(x,"_FillValue") .or. isatt(y,"_FillValue")) then
+ W1D = ndtooned(WGT)
+ if (isatt(x,"_FillValue") .and. any(ismissing(x)) ) then
+ z1d = ndtooned(x)
+ i = ind(ismissing(z1d))
+ W1D(i) = 0.0
+ end if
+ if (isatt(y,"_FillValue") .and. any(ismissing(y)) ) then
+ z1d = ndtooned(y)
+ j = ind(ismissing(z1d))
+ W1D(j) = 0.0
+ end if
+ WGT = onedtond(W1D, dimx)
+ end if
+
+ if (opt.eq.0) then ; centered correlation
+ sumWGT = sum(WGT)
+ xAvgArea = sum(x*WGT)/sumWGT ; weighted area average
+ yAvgArea = sum(y*WGT)/sumWGT
+
+ xAnom = x - xAvgArea ; anomalies
+ yAnom = y - yAvgArea
+
+ xyCov = sum(WGT*xAnom*yAnom)
+ xAnom2 = sum(WGT*xAnom^2)
+ yAnom2 = sum(WGT*yAnom^2)
+ else
+ xyCov = sum(WGT*x*y)
+ xAnom2 = sum(WGT*x^2)
+ yAnom2 = sum(WGT*y^2)
+ end if
+
+
+ if (xAnom2.gt.0.0 .and. yAnom2.gt.0.0) then
+ r = xyCov/(sqrt(xAnom2)*sqrt(yAnom2))
+ else
+ if (isatt(x,"_FillValue")) then
+ r = x at _FillValue
+ else
+ if (isatt(y,"_FillValue")) then
+ r = y at _FillValue
+ else
+ r = -999.0
+ end if
+ end if
+ end if
+
+ if (opt.eq.0) then
+ r at long_name = "pattern correlation (centered)"
+ else
+ r at long_name = "pattern correlation (uncentered)"
+ end if
+ ;r at units = ""
+
+ return(r)
+ end
+ ;---------------------------------------------------
+ ; Rob Nichols [U. Washington] & D. Shea
+ undef("pattern_cor")
+ function pattern_cor (x, y, w, opt:integer)
+ ; Compute the centered or uncentered pattern correlation
+ ; between two fields
+ ; (lat,lon) .... wgt(1) or wgt(lat) or wgt(lat,lon)
+
+ local dimx, dimy, rankx, ranky, nt, kl, xc, rpc, rFill
+ begin
+ if (isatt(x,"_FillValue")) then
+ if (all(ismissing(x))) then
+ rFill = (/ x at _FillValue /)
+ rFill at _FillValue = rFill
+ return(rFill)
+ end if
+ end if
+ if (isatt(y,"_FillValue")) then
+ if (all(ismissing(y))) then
+ rFill = (/ y at _FillValue /)
+ rFill at _FillValue = rFill
+ return(rFill)
+ end if
+ end if
+ ; x and y must have the same sizes
+ dimx = dimsizes(x)
+ dimy = dimsizes(y)
+ dimw = dimsizes(w) ; if w is scalar set to 1.0
+
+ rankx = dimsizes(dimx)
+ ranky = dimsizes(dimy)
+ rankw = dimsizes(dimw)
+
+ if (rankx.ne.ranky) then
+ print("pattern_cor: Fatal: x and y do not have the same rank")
+ print(" rankx: "+rankx+" ranky="+ranky)
+ exit
+ end if
+ if (rankx.ge.5) then
+ print("pattern_cor: Fatal: function only works with 2D, 3D or 4D")
+ print(" rank: "+rankx+"D")
+ exit
+ end if
+ if (.not.all(dimx.eq.dimy)) then
+ print("pattern_cor: Fatal: x and y do not have the same dimension sizes")
+ print(" dimx: "+dimx+" dimy="+dimy)
+ exit
+ end if
+ if (rankw.gt.2) then
+ print("pattern_cor: Fatal: w can be a scalar, w[*] or w[*][*]")
+ print(" rankw: "+rankw)
+ exit
+ end if
+
+ if (rankx.eq.2) then
+ return( pattern_cor2 (x,y,w,opt) ) ; scalar returned
+ end if
+
+ if (rankx.eq.3) then
+ rpc = new ( dimx(0), typeof(x), "No_FillValue")
+ do nt=0,dimx(0)-1
+ rpc(nt) = pattern_cor2 (x(nt,:,:),y(nt,:,:),w,opt)
+ end do
+ xc = x(:,0,0)
+ copy_VarCoords(xc, rpc)
+ return( rpc )
+ end if
+
+ if (rankx.eq.4) then
+ rpc = new ( (/dimx(0),dimx(1)/), typeof(x), "No_FillValue")
+ do nt=0,dimx(0)-1
+ do kl=0,dimx(1)-1
+ rpc(nt,kl) = pattern_cor2 (x(nt,kl,:,:),y(nt,kl,:,:),w,opt)
+ end do
+ end do
+ xc = x(:,:,0,0)
+ copy_VarCoords(xc, rpc)
+ return( rpc )
+ end if
+ end
+ ; ----------------------------------------------------
+ undef ("rm_single_dims")
+ function rm_single_dims (x)
+ ; remove singleton (degenerate) dimensions. A singleton dimension is size 1.
+ ; NCL philosophy: do not 'lose' information.
+ local dimx, dimy, rankx, dnamx, y, m, n
+ begin
+ dimx = dimsizes(x)
+
+ if (.not.any(dimx.eq.1)) then
+ return(x) ; no degenerate dimensions
+ end if
+
+ rankx = dimsizes(dimx)
+ dnamx = getvardims(x) ; dim names
+
+ if (all(dimx.eq.1)) then
+ dimy = 1 ; all degenerate dimensions
+ else
+ dimy = dimx(ind(dimx.ne.1))
+ end if
+ y = onedtond(ndtooned(x), dimy)
+
+ m = -1
+ do n=0,rankx-1
+ if (.not.ismissing(dnamx(n))) then
+ if (iscoord(x, dnamx(n))) then
+ if (dimx(n).ne.1) then
+ m = m+1
+ y!m = dnamx(n)
+ y&$dnamx(n)$ = x&$dnamx(n)$ ; attach coord &
+ else ; do not 'lose' information
+ y@$dnamx(n)$ = x&$dnamx(n)$ ; attach singleton coord as attribute @
+ end if
+ end if
+ end if
+ end do
+ copy_VarAtts(x,y)
+
+ return(y)
+ end
+ ;------
+ ; Thirteen pt (decadal)
+ undef("smth13_n")
+ function smth13_n (x:numeric, ndim) ; smth13
+ local wgts, smX
+ begin
+ wgts = (/ 1,6,19,42,71,96,106,96,71,42,19,6,1 /)*1.0
+ wgts = wgts/sum(wgts)
+ smX = wgt_runave_n_Wrap(x, wgts, 1, ndim) ; reflective end pts
+ return(smX)
+ end
+
+ ;------
+ ; Names and abbreviations for months
+ undef("month_name")
+ function month_name (opt[1]:integer)
+ ; monName = month_name(-1) ; return with extra January
+ begin
+ if (opt.eq.0) then
+ return((/"Jan","Feb","Mar","Apr","May","Jun"
+ ,"Jul","Aug","Sep","Oct","Nov","Dec"/)) ; len=12
+ else if (opt.eq.-1) then
+ return((/"Jan","Feb","Mar","Apr","May","Jun"
+ ,"Jul","Aug","Sep","Oct","Nov","Dec","Jan"/)); len=13
+ else if (opt.eq.1) then
+ return((/"January","February","March","April"
+ ,"May","June","July","August"
+ ,"September","October","November","December"/)) ; len=12
+ end if ; opt= 1
+ end if ; opt=-1
+ end if ; opt= 0
+ end
+
+ ;------
+ ; Names and abbreviations for seasons
+ undef("season_name")
+ function season_name (opt[1]:integer)
+ ; seaName = season_name(1) ; 5-month season
+ begin
+ if (opt.eq.0) then
+ return((/"DJF","JFM","FMA","MAM","AMJ","MJJ"
+ ,"JJA","JAS","ASO","SON","OND","NDJ"/)) ; length 12
+ else if (opt.eq.-1) then
+ return((/"DJF","JFM","FMA","MAM","AMJ","MJJ"
+ ,"JJA","JAS","ASO","SON","OND","NDJ","DJF"/)) ; length 13
+ else if (opt.eq.1) then
+ return((/"NDJFM","DJFMA","JFMAM","FMAMJ","MAMJJ","AMJJA"
+ ,"MJJAS","JJASO","JASON","ASOND","SONDJ","ONDJF" /)) ; len 12
+ else if (opt.eq.2) then
+ return((/"DJF","MAM","JJA","SON"/)) ; len 4
+ else if (opt.eq.3) then
+ return((/"Winter","Spring","Autumn","Summer"/)) ; len 4
+ else if (opt.eq.4) then
+ return((/"Summer","Autumn","Winter","Spring"/)) ; len4
+ end if ; opt= 4
+ end if ; opt= 3
+ end if ; opt= 2
+ end if ; opt= 1
+ end if ; opt=-1
+ end if ; opt= 0
+ end
+ ;---------------------------------------------------
+ undef("mon_fullyear")
+ function mon_fullyear(x:numeric, opt)
+ ;
+ ; Expand a variable containing monthly data to full (12 month) years
+ ; The added months will be set to _FillValue.
+ ;
+ ; Example: Take a variable that may span (say)
+ ; 190308 to 201105 and expand it to span 190301 to 201112.
+ ; The extra values will be filled with _FillValue.
+ ;
+ ; This assumes that the input variable will have a
+ ; time coordinate variable with units acceptable to cd_calendar
+ ;
+ ; generically: Only the 'time' dimension must be present.
+ ; It does not have to be named 'time'
+ ; All other meta data are preserved.
+ ; x(time), x(time,J), x(time,N,M), x(time,K,N,M)
+ ;
+ ; If the input is already full years, the variable is returned unaltered.
+ ;
+ ; f = addfile(...)
+ ; x = mon_fullyear( f->X, 0)
+
+ begin
+ dimx = dimsizes(x) ; dimsizes x
+ rankx = dimsizes(dimx) ; rank of x
+
+ if (rankx.gt.4) then
+ print("mon_fullyear_n: currently this function only works up to rank 4")
+ exit
+ end if
+
+ dnamx = getvardims( x ) ; dimension names
+
+ ntimx = dimx(0) ; # input time steps
+ ymdhms= cd_calendar(x&$dnamx(0)$, 0)
+
+ if (isatt(x&$dnamx(0)$, "calendar")) then
+ ymdhms at calendar = x&$dnamx(0)$@calendar
+ end if
+
+ yyyy = toint( ymdhms(:,0) )
+ mm = toint( ymdhms(:,1) )
+
+ nmos = 12
+ if ((ntimx%nmos).eq.0 .and. mm(0).eq.1 .and. mm(ntimx-1).eq.nmos) then
+ ;x at year_mon = YYYY*100 + MM
+ return(x) ; must be full years
+ end if
+ ; must be partial year
+ dd = toint( ymdhms(:,2) )
+ hh = toint( ymdhms(:,3) )
+ mn = toint( ymdhms(:,4) )
+ sc = ymdhms(:,5)
+
+ tunits= x&$dnamx(0)$@units
+
+ yrStrt= yyyy(0)
+ yrLast= yyyy(ntimx-1)
+
+ mmStrt= mm(0)
+ mmLast= mm(ntimx-1)
+
+ NYRS = yrLast-yrStrt+1
+ NTIM = NYRS*nmos ; full year-month
+
+ YYYY = new( NTIM, "integer" , "No_FillValue")
+ MM = new( NTIM, "integer" , "No_FillValue")
+ DD = new( NTIM, "integer" , "No_FillValue")
+ HH = new( NTIM, "integer" , "No_FillValue")
+ MN = new( NTIM, "integer" , "No_FillValue")
+ SC = new( NTIM, typeof(sc), "No_FillValue")
+
+ nStrt = 0
+ nLast = nmos-1
+ do year=yrStrt,yrLast
+ YYYY(nStrt:nLast) = year
+ MM(nStrt:nLast) = ispan(1,nmos,1)
+ DD(nStrt:nLast) = 1
+ HH(nStrt:nLast) = 0
+ MN(nStrt:nLast) = 0
+ SC(nStrt:nLast) = 0
+
+ nStrt = nStrt+nmos
+ nLast = nLast+nmos
+ end do
+
+ TIME = (/ cd_inv_calendar(YYYY,MM,DD,HH,MN,SC,tunits, 0) /)
+ TIME at units = tunits
+ TIME!0 = dnamx(0)
+ TIME&$dnamx(0)$ = TIME ; make coordinate variable
+
+ if (isatt(x&$dnamx(0)$, "calendar")) then
+ TIME at calendar = x&$dnamx(0)$@calendar
+ end if
+
+ DIMX = dimx
+ DIMX(0) = NTIM
+ X = new (DIMX, typeof(x), getFillValue(x))
+
+ nStrt = ind(YYYY.eq.yrStrt .and. MM.eq.mmStrt)
+ nLast = ind(YYYY.eq.yrLast .and. MM.eq.mmLast)
+
+ if (rankx.eq.1) then
+ X(nStrt:nLast) = (/ x /)
+ else if (rankx.eq.2) then
+ X(nStrt:nLast,:) = (/ x /)
+ copy_VarCoords(x(0,:), X(0,:))
+ else if (rankx.eq.3) then
+ X(nStrt:nLast,:,:) = (/ x /)
+ copy_VarCoords(x(0,:,:), X(0,:,:))
+ else if (rankx.eq.4) then
+ X(nStrt:nLast,:,:,:) = (/ x /)
+ copy_VarCoords(x(0,:,:,:), X(0,:,:,:))
+ end if
+ end if
+ end if
+ end if
+
+ copy_VarAtts(x, X)
+ X!0 = dnamx(0)
+ X&$dnamx(0)$ = TIME
+
+ return(X)
+
+ end
+ ;----------------------------------------------------------
+ undef("stat_mode")
+ function stat_mode(A[*]:numeric)
+ ;
+ ; returns mode value(s) with attributes which indicate the
+ ; number of modes (@nmode)
+ ; count of mode occurences (@count)
+ ; number of non-missing values in 'A' (@npts)
+ ;---
+ ; 'A' need not be in ascending order. The function will sort.
+ ; Care should be used when A is type float or double.
+ ; A value of 12.34567 is not the same as 12.34568
+ ; A suggestion is to preprocess the data. Say that
+ ; 2 decimal places is 'close enough'.
+ ; scale = 100.0
+ ; A = toint(A*scale)/scale
+ ; or
+ ; A = round(A*scale, 0)/scale
+ ;---
+ ; Examples:
+ ;
+ ; a0 = (/ -1, 7, 7, 2, 2, 2, -1, 7, -3, -3 /)
+ ; mode0 = (/2,7/), mode0 at nmode=2, mode0 at count=3, mode0 at npts=10
+ ;
+ ; a1 = (/123, -1, 7, 7, 2, 2, 2, -1, 7, -3, -3, -456 /)
+ ; mode1 = (/2,7/), mode1 at nmode=2, mode1 at count=3, mode1 at npts=12
+ ;
+ ; a2 = (/ 1, 1, 1, 1, 1, 0, 2, 2, 2, 2 /)
+ ; mode2 = 1 , mode2 at nmode=1, mode1 at count=5, mode1 at npts=10
+ ;
+ ; a3 = (/ 0, 0,-1,-1, 9, 9, 3, 3, 7, 7 /)
+ ; mode3 = (/-1, 0, 3, 7, 9/), mode3 at nmode=5, mode3 at count=2, mode3 at npts=10
+ ;
+ ; a4 = ispan(1,10,1)
+ ; mode4 = (/1,2,3,4,5,6,7,8,9,10/), mode4 at nmode=10, mode4 at count=1, mode4 at npts=10
+ ;
+ ; a5 = (/1,2,3,4, 5,5, 7,8,9,10/)
+ ; mode5 = 5, mode5 at nmode=1, mode5 at count=2, mode5 at npts=10
+ ;
+ local i, ni, a, na, freq, FREQ, n, nm, ii, nseq
+ , node, nmode, mode_count, val, ifmx
+ begin
+
+ if (all(ismissing(A))) then
+ mode = -999
+ mode at npts = 0
+ mode at nmode = -999
+ mode at freq = -999
+ mode at _FillValue = -999
+ return (mode)
+ end if
+
+ i = ind(.not.ismissing(A))
+ ni = dimsizes(i)
+ if (ni.eq.1) then
+ mode = A(i(0))
+ mode at npts = 1
+ mode at nmode = 1
+ mode at count = 1
+ return (mode)
+ end if
+
+ a = A(i) ; local
+ na = ni ; # of sorted non-missing value
+ qsort( a )
+
+
+ freq = new (na, "integer","No_FillValue")
+ nm = new (na, "integer","No_FillValue")
+ val = new (na, typeof(a),"No_FillValue")
+
+ freq = 1 ; initialize (array syntax)
+ nm = 0 ; number of unique numbers
+ ii = 0 ; index
+
+
+ do n=1,na-1
+ if (a(n-1).eq.a(n)) then
+ freq(ii) = freq(ii) + 1
+ val(ii) = a(n)
+ else
+ nm(ii) = n-1
+ ii = ii+1
+ end if
+ end do
+
+ nm(ii) = n -1
+ nseq = ii+1
+
+ FREQ = freq(:ii) ; convenience
+ mode_cnt = max(FREQ)
+ ifmx = ind(FREQ.eq.mode_cnt)
+ if (all(FREQ.eq.1)) then
+ mode = a
+ else
+ mode = val(ifmx) ; mode values
+ end if
+ mode at npts = na ; number of pts used
+ mode at nmode = dimsizes(mode) ; num(FREQ.eq.mode_cnt)
+ mode at count = mode_cnt
+
+ return(mode)
+ end
+ ;============================================
+ undef ("reg_multlin_stats")
+ function reg_multlin_stats(Y[*]:numeric, XP:numeric, opt)
+ ;
+ ; Nomenclature:
+ ; Y - dependent variable (size NY)
+ ; missing values (_FillValue) are not allowed.
+ ; XP - one [*] or more [*][*] independent variables.
+ ; Missing values (_FillValue) are not allowed.
+ ; The size of the leftmost dimension of XP must be the
+ ; same size as Y[*]. The rightmost dimension for [*][*]
+ ; contains the independent variables.
+ ; opt - options [type logical: ie, True or False]
+ ; opt = False .... no options
+ ; opt = True
+ ; opr at print_data = True .... print input Y and XP in table form
+ ; opr at print_anova= True .... print ANOVA information
+ ;
+ ; See:
+ ; Wilks, D.S. (2006): Statistical Methods in the Atmospheric Sciences
+ ; Academic Press (2nd Edition)
+ ; Davis, J.C. (2002): Statistics and Data Analysis in Geology
+ ; Wiley (3rd Edition) ; pgs 462-470
+ ;
+ ; Very readable discussions:
+ ; http://www.ltrr.arizona.edu/~dmeko/notes_11.pdf
+ ; http://reliawiki.org/index.php/Multiple_Linear_Regression_Analysis
+ ; http://homepages.rpi.edu/~tealj2/stat03.pdf
+ ; ---
+ ;
+ local dimXP, N, NP, NY, M, T, Y, X, b, B, rankXP
+ , Yavg, Yvar, Ystd, Xavg, Xvar, Xstd, Yest, n, m
+ , Yres, SST, SSE, SSR, MST, MSE, MSR, SE, Frat
+ , r2, ra, r, fuv, XXt, XXTi, varcovx, df, stderr, tval, pval
+ , opt_wm, fmt_XXt, fmt_XXti, fmt_covx, opt_pd, fmt_data
+ begin
+
+ dimXP = dimsizes(XP)
+ NX = dimXP(0) ; number of rows ('observations')
+ N = dimsizes(Y)
+
+ rankXP = dimsizes(dimXP)
+
+ ; error checks on input
+
+ if (N.NE.NX) then
+ print("reg_multlin_stats: number of rows of Y and XP must match")
+ print(" NY="+N +" NXP="+NX )
+ exit
+ end if
+
+ if (rankXP.gt.2) then
+ print("reg_multlin_stats: rank of XP > 2: rankXP="+rankXP)
+ exit
+ end if
+
+ if (isatt(Y,"_FillValue") .and. any(ismissing(Y))) then
+ print("reg_multlin_stats: Y has missing values. Not allowed!")
+ exit
+ end if
+
+ if (isatt(XP,"_FillValue") .and. any(ismissing(XP))) then
+ print("reg_multlin_stats: XP has missing values. Not allowed!")
+ exit
+ end if
+
+ ; input OK: onward
+
+ if (rankXP.eq.2) then
+ NP = dimXP(1) ; number predictor variables
+ else
+ NP = 1 ; one predictor
+ end if
+
+ if (opt .and. isatt(opt,"print_data") .and. opt at print_data) then
+ print(" ")
+ opt_pd = True
+ opt_pd at title = "----- reg_multlin_stats: Y, XP -----"
+ data = new( (/N,NP+1/), typeof(Y))
+ data(:,0) = (/ Y /)
+
+ if (NP.eq.1) then
+ data(:,1) = (/ XP /)
+ else
+ data(:,1:) = (/ XP /)
+ end if
+
+ fmt_data = "f11.2"
+ if (isatt(opt,"fmt_data")) then
+ fmt_data = opt at fmt_data ; eg: "f8.3", "e13.5",....
+ end if
+ write_matrix (data, (NP+1)+fmt_data , opt_pd)
+ print(" ")
+ delete(data) ; not needed
+ end if
+
+ ; Create the necessary arrays. X is a "design matrix"
+ ; http://en.wikipedia.org/wiki/Design_matrix
+ ;
+ ; Most multiple regression models include a constant term.
+ ; This ensures that the model will be "unbiased"
+ ; --i.e., the mean of the residuals will be exactly zero.
+
+ M = NP+1 ; extra column for design matrix
+ ; required ordering for reg_multlin
+ X = new ( (/M,N/) , typeof(XP), getFillValue(XP))
+ X(0,:) = 1.0
+
+ if (NP.eq.1) then
+ X(1,:) = XP ; one predictor
+ else
+ do m=0,NP-1
+ X(m+1,:) = XP(:,m) ; m refers to predictor variables
+ end do
+ end if
+
+ ; Calculate the partial regression coefficients: b->beta_hat
+ ; b = (X'X)^-1 X'y (theoretically)
+ ; http://www.ncl.ucar.edu/Document/Functions/Built-in/reg_multlin.shtml
+
+ b = reg_multlin(Y,X,False) ; partial regression coef
+ ; unstandardized...depend on units
+ delete(b at constant) ; extraneous attribute
+
+ ; Assorted calculations
+
+ Yavg = avg(Y)
+ Yvar = variance(Y) ; Unbiased estimate the variance
+ Ystd = sqrt(Yvar)
+
+ Xavg = new(NP, typeof(b), "No_FillValue")
+ Xvar = new(NP, typeof(b), "No_FillValue")
+ Xstd = new(NP, typeof(b), "No_FillValue")
+
+ bstd = new(M, typeof(b), "No_FillValue") ; standardized regression coef
+ ; describe what the partial regression coef.
+ ; would equal if all variables had the same
+ ; standard deviation.
+ do n=0,NP-1
+ Xavg(n) = avg(X(n+1,:))
+ Xvar(n) = variance(X(n+1,:))
+ Xstd(n) = sqrt(Xvar(n))
+ bstd(n+1) = b(n+1)*Xstd(n)/Ystd ; don't do b(0)
+ end do
+
+ ; Calculate model estimates: Yest = b(0) + b(1)* + b(2)* + .....
+
+ Yest = new(N,typeof(Y),getFillValue(Y))
+ do n=0,N-1
+ Yest(n) = b(0) + sum(b(1:)*X(1:,n)) ; array syntax
+ end do
+
+ ; ANOVA table info. (Eg, Wilks pg 185 & pg 197)
+ ; Sums of squares , degrees of freedom, mean squares, F statistic
+ ; Other statistics are also calculated.
+ ;
+ ; http://reliawiki.org/index.php/ANOVA_Calculations_in_Multiple_Linear_Regression
+ ; Mean squares are obtained by dividing the sum of squares
+ ; with their associated degrees of freedom.
+
+ dof = N-NP-1
+
+ Yres = Yest-Y ; residuals (array operation)
+
+ ; SS ==> Sum of Squares
+ SST = sum((Y-Yavg)^2) ; total SS [dof=N-1]
+ SSR = sum((Yest-Yavg)^2) ; regression SS [dof=NP] ; (aka: model explained SS=>SSM)
+ SSE = sum(Yres^2) ; residual SS [dof=N-NP-1]
+
+ MST = SST/(N-1) ; Mean SST [dof=N-1]
+ MSR = SSR/NP ; Mean SSR [dof=NP]
+ MSE = SSE/dof ; Mean SSE [dof=(N-NP-1)]
+
+ RSE = sqrt(MSE) ; residual standard error
+
+ Frat = MSR/MSE ; R dof=(M,N-NP-1)
+ ; F-Test is an overall (global) test of the model���s fit.
+ ; If at least one variable has a significant coefficient,
+ ; then the model fit should be significant.
+ ; The F-statistic might be interpreted as the variation
+ ; explained by the regression relative to the variation
+ ; not explained by the regression.
+
+ r2 = SSR/SST ; r2 = coefficient of determination. It is
+ ; the square of the Pearson correlation
+ ; coefficient between the observed
+ ; and modeled (predicted) data values
+ ; of the dependent variable. It is
+ ; another measure of 'goodness of fit.'
+ ; biased high, particularly for small N
+
+ r2a = r2-(1-r2)*NP/tofloat(dof) ; adjusted r2... better for small N
+ r = sqrt(r2) ; multiple (overall) correlation
+ fuv = 1.0-r2 ; fraction of variance *unexplained*
+
+ ; Determine (a) standard error of coefficients; (b) t-values; (c) p-values
+
+ XXt = X#transpose(X) ; (M,M); opposite of text books
+ XXti = inverse_matrix(XXt)
+ varcovx = MSE*XXti ; variance-covariance matrix
+ ; of estimated regression coefficients
+
+ if (opt .and. isatt(opt,"debug") .and. opt at debug) then ; used for debugging only
+ print(" ")
+ print("----- DEBUG ---------")
+ print(" ")
+ opt_wm = True
+ opt_wm at title = "----- XXt ---------"
+ fmt_XXt = "f11.2"
+ if (isatt(opt,"fmt_XXt")) then
+ fmt_XXt = opt at fmt_XXt ; "f8.2", "f12.4", "e13.5", ...
+ end if
+ write_matrix (XXt, M+fmt_XXt , opt_wm)
+
+ opt_wm at title = "----- XXti ---------"
+ fmt_XXti = "f11.2"
+ if (isatt(opt,"fmt_XXti")) then
+ fmt_XXti = opt at fmt_XXti
+ end if
+ write_matrix (XXti, M+fmt_XXti , opt_wm)
+
+ opt_wm at title = "----- varcovx --------"
+ fmt_covx = "f11.2"
+ if (isatt(opt,"fmt_covx")) then
+ fmt_covx = opt at fmt_covx
+ end if
+ write_matrix (varcovx, M+fmt_covx , opt_wm)
+
+ print(" ")
+ end if
+
+ stderr = new( M, typeof(Y))
+ tval = new( M, typeof(Y))
+ pval = new( M, typeof(Y))
+
+ df = N-NP
+
+ do m=0,M-1
+ stderr(m) = sqrt(varcovx(m,m))
+ tval(m) = b(m)/stderr(m)
+ pval(m) = betainc( df/(df+tval(m)^2), df/2.0, 0.5)
+ end do
+
+ if (opt .and. isatt(opt,"print_anova") .and. opt at print_anova) then
+ print(" ")
+ print("------- ANOVA information-------- ")
+ print(" ")
+ print("SST="+SST+" SSR="+SSR+" SSE="+SSE)
+ print("MST="+MST+" MSR="+MSR+" MSE="+MSE+" RSE="+RSE)
+ print("F-statistic="+Frat +" dof=("+NP+","+(N-NP-1)+")")
+ print(" ------- ")
+ ;;print("r2="+r2+" r="+r+" ra="+ra+" fuv="+fuv)
+ ;;print(" ------- ")
+ ;;print("stderr, tval, pval: "+stderr+" "+tval+" "+pval)
+ print(" ")
+ end if
+
+ ; associate assorted information as attributes of 'b'
+
+ b at long_name = "multiple regression coefficients"
+ b at model = "Yest = b(0) + b(1)*X1 + b(2)*X2 + ...+b(M)*XM"
+
+ b at N = N ; # of 'observations'
+ b at NP = NP ; # of predictors
+ b at M = M ; design matrix size
+ b at bstd = bstd ; standardized coefficients
+
+ b at SST = SST ; [1]
+ b at SSE = SSE
+ b at SSR = SSR
+
+ b at MST = MST
+ b at MSE = MSE
+ b at MSE_dof = dof
+ b at MSR = MSR
+
+ b at RSE = RSE ; [1]
+ b at RSE_dof= N-M-1 ; [1]
+
+ b at F = Frat ; [1]
+ b at F_dof = (/NP,dof/) ; [2]
+
+ df1 = b at F_dof(0)
+ df2 = b at F_dof(1)
+ b at F_pval = ftest(MSR, df1+1, MSE, df2+1, 0)*0.5 ; [1]
+
+ b at r2 = r2 ; [1]
+ b at r = r ; [1]
+ b at r2a = r2a ; [1]
+
+ b at fuv = fuv
+
+ b at Yest = Yest ; [NY]
+ b at Yavg = Yavg ; [1]
+ b at Ystd = Ystd ; [1]
+
+ b at Xavg = Xavg ; [1]
+ b at Xstd = Xstd ; [1]
+
+ b at stderr = stderr ; [M]
+ b at tval = tval ; [M]
+ b at pval = pval ; [M]
+
+ return(b)
+ end
+ ;============================================
+ undef("regline_stats")
+ function regline_stats(x[*]:numeric, y[*]:numeric)
+ ;
+ ; rc = regline_stats(x, y)
+ ;
+ ; Nomenclature:
+ ; x - independent variable.
+ ; y - dependent variable (same size as <em>x</em>)
+ ;
+ ; Missing values (_FillValue) are allowed. They are ignored.
+ ;
+ ; See:
+ ; Wilks, D.S. (2006): Statistical Methods in the Atmospheric Sciences
+ ; Academic Press (2nd Edition) ; pgs 180-204
+ ; Davis, J.C. (2002): Statistics and Data Analysis in Geology
+ ; Wiley (3rd Edition) ; pgs 215-218
+
+ local nx, ny, ii, nii, RC, rc
+ begin
+
+ ; Get the lengths of the x and y arrays.
+ nx = dimsizes(x)
+ ny = dimsizes(y)
+
+ ; Check if those lengths match.
+ if (nx.ne.ny)then
+ print("regline_stats: x and y must be the same length!")
+ print(" nx="+nx+" ny="+ny)
+ exit
+ end if
+
+ if (any(ismissing(x)) .or. any(ismissing(y))) then
+ ii = ind(.not.ismissing(x) .and. .not.ismissing(y))
+ nii = dimsizes(ii)
+ if (nii.gt.2) then
+ RC = reg_multlin_stats(y(ii),x(ii),False)
+ else
+ RC = new(1,typeof(y),getVarFillValue(y))
+ RC at info = "Not enough non-missing values: nii="+nii
+ print("regline_stats: Not enough non-missing values: nii="+nii)
+ return(RC)
+ end if
+ else
+ RC = reg_multlin_stats(y,x,False)
+ end if
+ rc = RC(1) ; transfers all attributes
+
+ rc at long_name = "simple linear regression"
+ rc at model = "Yest = b(0) + b(1)*X"
+
+ rc at nptxy = rc at N ; attributes for backward compatibility
+ rc at xave = rc at Xavg ; with the original 'regline'
+ rc at yave = rc at Yavg
+ rc at rstd = rc at RSE
+ rc at yintercept = RC(0)
+ rc at b = RC
+
+ return(rc)
+ end
+
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; print_clock.ncl
+ ;; Carl Schreck (carl at cicsnc.org)
+ ;; July 2011
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;; Description: Print timestamp along with a string
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ undef( "print_clock" )
+ procedure print_clock(
+ i_message
+ )
+ local None
+ begin
+
+ maxCols = 44
+
+ wallClock = systemfunc( "date +' | %F %T %Z'" )
+
+ if( isstring( i_message ) ) then
+ chMessage = stringtochar(i_message)
+
+ if( dimsizes(chMessage).gt.maxCols ) then
+ firstLine = chartostring(chMessage(:maxCols-1))
+ restOfMsg = chartostring(chMessage(maxCols-1:))
+ print( firstLine + wallClock )
+ print( (/ restOfMsg /) )
+ else
+ blank = stringtochar(" ")
+ chPadding = new( maxCols +1 - dimsizes(chMessage), character )
+ chPadding = blank(0)
+ stPadding = chartostring(chPadding)
+ firstLine = str_concat( (/ i_message, stPadding /) )
+ print( firstLine + wallClock )
+ end if
+
+ else
+ ;; Message is not a string
+ print( i_message + wallClock )
+ end if
+
+ end
+
+ ;==========================
+ undef("sign_matlab")
+ function sign_matlab( X:numeric )
+ ;
+ ; Mimic Matlab 'sign' function: sign_matlab(X) returns the sign of each element of 'X'
+ ; There are 3 possible return values for non _FillValue elements: -1, 0, 1
+ ; The return value type will be the same type as 'X'
+ ;
+ local typex, zero, onePos, oneNeg, result
+ begin
+ typex = typeof(X)
+
+ zero = totype( 0, typex)
+ onePos = totype( 1, typex)
+ oneNeg = totype(-1, typex)
+
+ result = X ; same size, shape and type as 'X'
+
+ result = where(X.eq.zero, zero , result)
+ result = where(X.gt.zero, onePos, result)
+ result = where(X.lt.zero, oneNeg, result)
+
+ return(result)
+ end
+ ;==========================
+ undef("sign_f90")
+ function sign_f90( X:numeric, Y:numeric )
+ ;
+ ; X and Y must be the same shape and size.
+ ; They may be different numeric types (eg:, byte, short, int, float, double)
+ ;
+ ; Mimic the f90 'sign' function: sign(X,Y) returns the
+ ; absolute value of X times the sign of Y.
+ ; This is a transfer of sign from Y to X.
+ ; Note: Fortran 90 does not allow a processor to distinguish between a
+ ; positive and a negative zero, whereas Fortran 95 does.
+ ;
+ ; Note: NCL can not test for -0 .... this will test positive.
+ ;
+ local typey, zero, result, dimX, dimY, rankX, rankY
+ begin
+ dimX = dimsizes(X)
+ dimY = dimsizes(Y)
+ rankX = dimsizes(dimX)
+ rankY = dimsizes(dimY)
+
+ ier = 0
+ if (rankX.ne.rankY) then
+ print("sign_f90: rank mismatch: rankX="+rankX+"; rankY="+rankY)
+ ier = 1
+ end if
+ if (.not.all(dimX.eq.dimY)) then
+ print("sign_f90: dimension size mismatch")
+ print(" dimX="+dimX)
+ print(" dimY="+dimY)
+ ier = ier+10
+ end if
+ if (ier.ne.0) then
+ exit
+ end if
+
+ typeY = typeof(Y)
+ zero = totype( 0, typeY) ; make 0 same numeric type as Y
+
+ result = abs(X) ; same size, shape and type as 'X'; all positive
+ result = where(Y.lt.zero, -result, result)
+ return(result)
+ end
+ ; *****************************************************************
+ ; Generate latitudes for a Fixed (Rectilinear) grid
+ ; lat = latGridF (latStrt[1]:numeric, latLast[1]:numeric, nlat, "lat", "latitude", "degrees_north")
+ ;
+ undef ("latGridF")
+ function latGridF(latStrt[1]:numeric, latLast[1]:numeric, nlat[1]:integer
+ ,dimName[1]:string,longName[1]:string,units[1]:string)
+ local lat
+ begin
+ lat = fspan(latStrt, latLast, nlat)
+ lat!0 = dimName
+ lat at long_name = longName
+ lat at units = units
+ lat&$dimName$ = lat
+ return (lat)
+ end
+ ; *****************************************************************
+ ; Generate longitudes for a Fixed (Rectilinear) grid
+ ; lon = lonGridF (lonStrt[1]:numeric, lonLast[1]:numeric, nlon, "lon", "longitude", "degrees_east")
+ ;
+ undef ("lonGridF")
+ function lonGridF(lonStrt[1]:numeric, lonLast[1]:numeric, nlon[1]:integer
+ ,dimName[1]:string,longName[1]:string,units[1]:string)
+ local lon
+ begin
+ lon = fspan(lonStrt, lonLast, nlon)
+ lon!0 = dimName
+ lon at long_name = longName
+ lon at units = units
+ lon&$dimName$ = lon
+ return (lon)
+ end
+ ; *****************************************************************
+ ; Generate index values that can be used for sampling
+ ;
+ undef("generate_sample_indices")
+ function generate_sample_indices(N[1], method[1]:integer)
+ ;
+ ; simple function to generate indices
+ ; N = sample size
+ ; method = 0 ==> sample *without* replacement; reshuffle the order
+ ; mean/std/... unchanged
+ ; use when the order of sampling may be important
+ ;
+ ; method = 1 ==> sample *with* replacement
+ ; mean/std/... will change
+ local k
+ begin
+ if (method.lt.0 .or. method.gt.1) then
+ print("generate_resample_indices: method="+method+": only 0 or 1 allowed")
+ exit
+ end if
+
+ if (method.eq.0) then
+ k = generate_unique_indices( N )
+ else
+ k = round(random_uniform(-0.499999,N-0.500001,N), 3)
+ end if
+
+ return(k)
+ end
+ ;==========================
+ undef("getTimeFromBnds")
+ function getTimeFromBnds(f, opt[1]:logical) ; f is of type 'list' or 'file'
+ local ftype, TIME, DATE, YEAR, nt
+ begin
+ ftype = typeof(f)
+
+ if (.not.(ftype.eq."file" .or. ftype.eq."list")) then
+ print("getTimeFromBnds: argument f must be type file or list: ftype="+ftype)
+ exit
+ end if
+
+ if (ftype.eq."file" .and. isfilevar(f,"time_bnds")) then
+ TIME = f->time_bnds(:, 0) ; address 'off-by-one' time
+ TIME at units = f->time at units ; appropriate for CESM
+ TIME at calendar = f->time at calendar
+ else if (isfilevar(f[0],"time_bnds")) then ; must be type 'list'
+ TIME = f[:]->time_bnds(:, 0) ; address 'off-by-one' time
+ TIME at units = f->time at units ; appropriate for CESM
+ TIME at calendar = f->time at calendar
+ end if
+ end if
+
+ DATE = cd_calendar(TIME, -2) ; YYYYMMDD
+ DATE at long_name = "current date (YYYYMMDD)"
+ DATE!0 = "time"
+
+ if (opt) then
+ if (isatt(opt,"yrStrtEnd")) then
+ YEAR = DATE
+ YEAR = DATE/10000
+ YEAR at long_name = "YYYY"
+ nt = ind(YEAR.ge.yrStrtEnd(0) .and. YEAR.le.yrStrtEnd(1))
+ nt at long_name = "indices for Start/End period: "+yrStrtEnd(0)+"-"+yrStrtEnd(1)
+ return( [/TIME(nt), DATE(nt), nt/] )
+ end if
+ else
+ return([/TIME, DATE/])
+ end if
+
+ end
+ ;==========================
+ undef("pot_temp")
+ function pot_temp (p:numeric, t:numeric, npr[*]:integer, opt[1]:logical)
+ ;
+ ; Compute potential temperature
+ ; Nomenclature
+ ; p - pressure levels (default: Pa)
+ ; if a 'units' attribute is present this may be altered
+ ; t - temperature (K)
+ ; Also: equivalent temperature (teqv) could be input
+ ; teqv = temperature of an air parcel from which all the water vapor
+ ; has been extracted by an adiabatic process.
+ ; teqv = t + (Lv/cpd)*r ;
+ ; cpd = 1004. or 1005.7 ; specific heat dry air [J/kg/K]
+ ; Lv = 2.5104e6 ; [J/kg]=[m2/s2] Latent Heat of Vaporization of Water
+ ; r = mixing ratio
+ ; npr - dimension number(s) of 'p' corresponding to temperature
+ ; npr=-1 means that p and t have the same ranks and sizes
+ ; In this case this argument is ignored.
+ ; opt - options: Currently, not use, Set to False
+ ;
+ local dimp, dimt, rankp, rankt, theta, p0
+ begin
+ dimp = dimsizes(p)
+ dimt = dimsizes(t)
+ rankp = dimsizes(dimp)
+ rankt = dimsizes(dimt)
+
+ p0 = 100000. ; default [units = Pa]
+ if (isatt(p,"units") .and. (p at units.eq."mb" .or.
+ p at units.eq."MB" .or.
+ p at units.eq."millibar" .or.
+ p at units.eq."millibars" .or.
+ p at units.eq."hPa" .or.
+ p at units.eq."HPA" .or.
+ p at units.eq."hPA" .or.
+ p at units.eq."hpa" ) ) then
+ p0 = 1000.
+ ;else
+ ;print("pot_temp: WARNING: units of pressure not recognized: p0="+p0+" Pa used")
+ end if
+
+ if (isatt(t,"units") .and.
+ .not.(t at units.eq."K" .or. t at units.eq."degK")) then
+ print("pot_temp: WARNING: units of temperature not recognized")
+ end if
+
+ if (rankp.eq.rankt) then
+ if (all(dimp.eq.dimt)) then
+ theta = t*(p0/p)^0.286
+ else
+ print("pot_temp: FATAL error: dimension sizes do not match")
+ print(" dimp="+dimp+" dimt="+dimt)
+ exit
+ end if
+ else
+ theta = t*(p0/conform(t,p,npr))^0.286
+ end if
+
+ theta at long_name = "potential temperature"
+ theta at units = "K"
+ copy_VarCoords(t, theta)
+
+ return( theta )
+ end
+ ;=========================
+ undef("static_stability")
+ function static_stability (p:numeric, t:numeric, npr[1]:integer, sopt[1]:integer)
+ ;
+ ; Compute Static Stability
+ ; Bluestein: Synoptic-Dynamic Meteorology in Midlatitudes
+ ; pg 197
+ ; s = -T*d[log(theta)]/dp = -(T/theta)*d(theta)/dp
+ ;
+ ; Nomenclature
+ ; p - pressure levels (Pa is default)
+ ;
+ ; t - temperature (K)
+ ; Also: equivalent temperature (teqv) could be input
+ ; teqv = temperature of an air parcel from which all the water vapor
+ ; has been extracted by an adiabatic process.
+ ; teqv = t + (Lv/cpd)*r ;
+ ; cpd = 1004. or 1005.7 ; specific heat dry air [J/kg/K]
+ ; Lv = 2.5104e6 ; [J/kg]=[m2/s2] Latent Heat of Vaporization of Water
+ ; r = mixing ratio ; (kg/kg)
+ ;
+ ; npr - dimension number for pressure
+ ;
+ ; sopt - =0, Return static stability only
+ ; - =1, Return static stability, theta, dthdp as type list
+ ;
+ ; Note: In a statically stable atmosphere: d(theta)/dp < 0, hence s > 0
+ ;
+ local dimp, dimt, theta, rankt, rankp, dthdp, s
+ begin
+
+ dimp = dimsizes(p)
+ dimt = dimsizes(t)
+
+ rankp = dimsizes(dimp)
+ rankt = dimsizes(dimt)
+
+ theta = pot_temp(p, t, npr, False) ; rankp=rankt then npr is ignored
+
+ ; dthdp = -T*d[log(theta)]/dp = -(T/theta)*d(theta)/dp
+
+ if (rankp.eq.rankt) then
+ dthdp = center_finite_diff_n (theta,p,False,0, npr)
+ else
+ if (rankp.eq.1) then
+ dthdp = center_finite_diff_n (theta,conform(t,p,npr), False,0, npr)
+ else
+ print("static_stability: rank problem: rankp="+rankp+"; rankt="+rankt)
+ exit
+ end if
+ end if
+
+ s = -(t/theta)*dthdp
+ copy_VarCoords(t,s)
+
+ s at long_name = "static stability"
+ if (isatt(p,"units") .and. (p at units.eq."mb" .or.
+ p at units.eq."MB" .or.
+ p at units.eq."millibar" .or.
+ p at units.eq."millibars" .or.
+ p at units.eq."hPa" .or.
+ p at units.eq."HPA" .or.
+ p at units.eq."hPA" .or.
+ p at units.eq."hpa" ) ) then
+ s at units = "K/hPa"
+ else
+ s at units = "K/Pa" ; or "K-m-s2/kg"
+ end if
+
+ if (sopt.eq.0) then
+ return(s)
+ else
+ dthdp at long_name = "vertical derivative of theta with pressure"
+ dthdp at units = s at units
+ copy_VarCoords(t,dthdp)
+ return( [/ s, theta, dthdp /] )
+ end if
+ end
+ ;=========================
+ undef("pot_vort_hybrid")
+ function pot_vort_hybrid
+ (p:numeric, u:numeric, v:numeric, t:numeric
+ ,lat[*]:numeric, gridType[1]:integer, opt[1]:integer)
+ ;
+ ; Compute Isentropic Potential Vorticity on hybrid levels
+ ; CCM Processor User's Guide: May 1994: page B-19
+ ; Original source P Rasch and B Boville
+ ;
+ ; Nomenclature
+ ; p - pressure levels (Pa) [3D or 4D]
+ ; u - zonal wind (m/s) [3D or 4D]
+ ; v - meridional wind (m/s) [3D or 4D]
+ ; t - temperature (K) [3D or 4D]
+ ; gridType- grid type
+ ; =0 means gaussian grid
+ ; =1 means regular or fixed grid
+ ; lat - latitudes
+ ; opt - options: not used. Set to 0
+ ;
+ ; Note: u,v,t,p MUST:
+ ; [1] be SOUTH-TO-NORTH
+ ; [2] be GLOBAL because spherical harmonics are used
+ ; [3] have named dimensions because data are reordered
+ ;
+ ; Usage:
+ ; f = addfile ("foo.nc", "r")
+ ; U = f->U ; (time,lev,lat,lon) or (lev,lat,lon)
+ ; V = f->V
+ ; T = f->T
+ ; lat = f->lat
+ ; hyam = f->hyam
+ ; hybm = f->hybm
+ ; p0 = f->P0 ; p0=100000
+ ; ps = f->PS ; Pa
+ ; p = pres_hybrid_ccm (ps,p0,hyam,hybm) ; Pa [kg/(m s2)]
+ ; copy_VarCoords(U,p)
+ ;
+ ; ; Potential Vorticity
+ ; PV = pot_vort_hybrid(p,u,v,t,lat, 0, 0)
+ ;
+ ; Note: A nice basic discussion of PV may be found at:
+ ; Mid-Latitude Atmospheric Dynamics: A First Course
+ ; Jonathan E. Martin, Wiley 2006, QC880.M36 , pp276-onward
+ ;
+ local ranku, rankv, rankt, rankp, npr, nlt, dthdp
+ , dudp, dvdp ,theta, W, f, vr, dthdx, dthdy, G, W, rad, pv
+ begin
+ ; ERROR CHECK
+ ranku = dimsizes(dimsizes(u))
+ if (.not.(ranku.eq.3 .or. ranku.eq.4)) then
+ print("pot_vort_hybrid: only 3D and 4D arrays allowed: rank="+ranku)
+ exit
+ end if
+ rankv = dimsizes(dimsizes(v))
+ rankt = dimsizes(dimsizes(t))
+ rankp = dimsizes(dimsizes(p))
+ if (.not.(ranku.eq.rankv .and. ranku.eq.rankt .and. ranku.eq.rankp)) then
+ print("pot_vort_hybrid: u, v, t, p must be the same rank: ranku="
+ +ranku+" rankv="+rankv+" rankt="+rankt+" rankp="+rankp)
+ exit
+ end if
+
+ if (.not.(gridType.eq.0 .or. gridType.eq.1)) then
+ print("pot_vort_hybrid: unrecognized gridType: only 0 and 1 allowed")
+ print(" gridType="+gridType)
+ ier = 1
+ end if
+
+ if ((lat(1)-lat(0)).le.0) then
+ print("pot_vort_hybrid: data must be in S-N order")
+ exit
+ end if
+
+ if (ranku.eq.3) then ; (lev,lat,lon) => (0,1,2) => (npr,nlt,2)
+ npr = 0
+ nlt = 1
+ end if
+ if (ranku.eq.4) then ; (time,lev,lat,lon) => (0,1,2,3) > (0,npr,nlt,2)
+ npr = 1
+ nlt = 2
+ end if
+
+ S = static_stability(p,t,npr,1) ; variable of type list
+
+ s = S[0] ; [...] is list syntax
+ theta = S[1] ; theta = pot_tmp(p, t, npr, 0)
+ dthdp = S[2] ; dthdp = center_finite_diff_n (theta,p,False,0,npr)
+ s at _FillValue= 1e20
+ delete(S)
+
+ ;printVarSummary( s ) ; s not used for this formulation
+ ;printMinMax( s, True )
+ ;printVarSummary( theta )
+ ;printMinMax( theta, True )
+ ;printVarSummary( dthdp )
+ ;printMinMax( dth2p, True )
+ ; compute VERTICAL (pressure) derivatives
+ dudp = center_finite_diff_n ( u,p,False,0,npr)
+ dvdp = center_finite_diff_n ( v,p,False,0,npr)
+ ; compute
+ ; (1) lat/lon temperature gradients [K/m]
+ ; (2) relative vorticity [1/s]
+ dthdx = theta ; create E-W gradient array
+ dthdy = theta ; S-N
+ dthdx at long_name = "longitudinal gradient (derivative)"
+ dthdy at long_name = "latitudinal gradient (derivative)"
+ dthdx at units = "K/m"
+ dthdy at units = "K/m"
+
+ if (gridType.eq.0) then
+ gradsg (theta, dthdx, dthdy)
+ vr = uv2vrG(u,v)
+ end if
+ if (gridType.eq.1) then
+ gradsf (theta, dthdx, dthdy)
+ vr = uv2vrF(u,v)
+ end if
+
+ G = 9.80665 ; m/s2 ; gravity at 45 deg lat used by the WMO
+ W = 7.292e-5 ; (1/s) ; earth ang rotation
+ rad = 4.*atan(1.)/180.
+ if (typeof(lat).eq.typeof(vr)) then
+ f = 2.*W*sin(lat*rad) ; (1/s) ; coriolis parameter
+ else
+ f = 2.*W*sin(tofloat(lat)*rad)
+ end if
+
+ vr = vr + conform(vr,f,nlt) ; absolute vorticity
+ ; G used for commonly used units
+ pv = -G*(vr*dthdp - (dthdx*dvdp-dthdy*dudp) )
+ pv at long_name = "potential vorticity"
+ pv at short_name = "PV"
+ pv at units = "K m2/kg/s" ; common units
+ copy_VarCoords(t,pv)
+
+ if (opt.eq.0) then
+ return( pv )
+ else
+ return( [/pv, s, theta, dthdp, dudp, dvdp, dtdx, dtdy/] )
+ end if
+ end
+
+ ;----------------------------------------------------------------------------
+ undef("pot_vort_isobaric")
+ function pot_vort_isobaric
+ (p[*]:numeric, u:numeric, v:numeric, t:numeric
+ ,lat[*]:numeric, gridType[1]:integer, opt:integer)
+ ;
+ ; Compute Potential Vorticity on constant pressure levels
+ ; Bluestein: Synoptic-Dynamic Meteorology in Midlatitudes
+ ; pg 264 Eq 4.5.93
+ ;
+ ; Nomenclature
+ ; p - pressure levels (Pa) [1D]
+ ; u - zonal wind (m/s) [3D or 4D]
+ ; v - meridional wind (m/s) [3D or 4D]
+ ; t - temperature (K) [3D or 4D]
+ ; lat - latitudes
+ ; gridType- grid type
+ ; =0 means gaussian grid
+ ; =1 means regular or fixed grid
+ ; opt - options: not used
+ ;
+ ; Note: u,v,t MUST be SOUTH-TO-NORTH
+ ; and must be GLOBAL because spherical harmonics are used
+ ;
+ ; Usage:
+ ; f = addfile ("foo.nc", "r")
+ ; U = f->U ; (time,lev,lat,lon) or (lev,lat,lon)
+ ; V = f->V
+ ; T = f->T ; K
+ ; lat = f->lat
+ ; lev = f->lev
+ ; lev = lev*100
+ ; lev at units = "Pa"
+ ; ; Potential Vorticity
+ ; PV = pot_vort_isobaric(lev,u,v,t,lat, 0, 0)
+ ;
+ ; Note: A nice basic discussion of PV may be found at:
+ ; Mid-Latitude Atmospheric Dynamics: A First Course
+ ; Jonathan E. Martin, Wiley 2006, QC880.M36 , pp276-onward
+ ;
+ local ranku, rankv, rankt, npr, nlt, dthdp, dudp, dvdp
+ ,theta, S, s, con, R, W, f, vr, dtdx, dtdy, rad, pv
+ begin
+ ; ERROR CHECK
+ ranku = dimsizes(dimsizes(u))
+ if (.not.(ranku.eq.3 .or. ranku.eq.4)) then
+ print("StaticStabilityP: only 3D and 4D arrays allowed: rank="+ranku)
+ exit
+ end if
+ rankv = dimsizes(dimsizes(v))
+ rankt = dimsizes(dimsizes(t))
+ if (.not.(ranku.eq.rankv .and. ranku.eq.rankt)) then
+ print("pot_vort_isobaric: u, v, t must be the same rank: ranku="
+ +ranku+" rankv="+rankv+" rankt="+rankt)
+ exit
+ end if
+
+ if (.not.(gridType.eq.0 .or. gridType.eq.1)) then
+ print("pot_vort_isobaric: unrecognized gridType: only 0 and 1 allowed")
+ print(" gridType="+gridType)
+ ier = 1
+ end if
+
+ if ((lat(1)-lat(0)).le.0) then
+ print("pot_vort_isobaric: data must be in S-N order")
+ exit
+ end if
+
+ if (ranku.eq.3) then ; (lev,lat,lon) => (0,1,2) > (0,npr,nlt)
+ npr = 0
+ nlt = 1
+ end if
+ if (ranku.eq.4) then ; (time,lev,lat,lon) => (0,1,2,3) > (0,npr,nlt,2)
+ npr = 1
+ nlt = 2
+ end if
+
+ S = static_stability(p,t,npr,1) ; variable of type list
+
+ s = S[0] ; [...] is list syntax
+ theta = S[1]
+ dthdp = S[2]
+ s at _FillValue= 1e20
+ delete(S)
+
+ ;printVarSummary( s )
+ ;printMinMax( s, True )
+ ;printVarSummary( theta )
+ ;printMinMax( theta, True )
+ ;printVarSummary( dthdp )
+ ;printMinMax( dthdp, True )
+ ; compute VERTICAL (pressure) derivatives ; shear
+ dudp = center_finite_diff_n ( u,p,False,0,npr)
+ dvdp = center_finite_diff_n ( v,p,False,0,npr)
+
+ ; compute
+ ; (1) lat/lon temperature gradients [K/m]
+ ; (2) relative vorticity [1/s]
+
+ dtdx = t ; create E-W gradient array with coordinate info
+ dtdy = t ; S-N
+ dtdx at long_name = "longitudinal gradient (derivative)"
+ dtdy at long_name = "latitudinal gradient (derivative)"
+ dtdx at units = "K/m"
+ dtdy at units = "K/m"
+
+ if (gridType.eq.0) then
+ gradsg (t, dtdx, dtdy)
+ vr = uv2vrG(u,v)
+ end if
+ if (gridType.eq.1) then
+ gradsf (t, dtdx, dtdy)
+ vr = uv2vrF(u,v)
+ end if
+
+ G = 9.80665 ; m/s2 ; gravity at 45 deg lat used by the WMO
+ R = 287.04 ; m2/(s2-K) ; gas constant dry air
+ W = 7.292e-5 ; (1/s) ; earth ang rotation
+ rad = 4.*atan(1.)/180.
+ if (typeof(lat).eq.typeof(vr)) then
+ f = 2.*W*sin(lat*rad) ; (1/s) ; coriolis parameter
+ else
+ f = 2.*W*sin(tofloat(lat)*rad)
+ end if
+
+ vr = vr + conform(vr,f,nlt) ; absolute vorticity
+ s = where(s.eq.0, s at _FillValue, s) ; safety
+ con = R/(s*conform(t,p,npr))
+ ; G* added to get common pv units
+ pv = -G*(vr + con*(dvdp*dtdx-dudp*dtdy))*dthdp
+ pv at long_name = "potential vorticity"
+ pv at short_name = "PV"
+ pv at units = "K m2/kg/s" ; common units
+ copy_VarCoords(t,pv)
+
+ if (opt.eq.0) then
+ return( pv )
+ else
+ return( [/pv, s, theta, dthdp, dudp, dvdp, dtdx, dtdy/] )
+ end if
+ end
+ ;====================
+ undef("advect_var")
+ function advect_var (u:numeric, v:numeric, x:numeric,gridType[1]:integer
+ ,long_name:string, units:string, iopt[1]:integer)
+ ;
+ ; compute advection of a variable: UV.GRADIENT(X) ; U*(dX/dlon) + V*(dX/dlat)
+ ;
+ ; Requires:
+ ; (1) grid be global cuz spherical harmonics are used
+ ; (2) required dimension order ([time,[lev,]lat,lon)
+ ; (3) the input grids *must* be ordered South==>North
+ ;
+ ; Nomenclature:
+ ; u, v - zonal and meridional wind components [m/s]
+ ; rightmost dimensions must be ([...,]lat,lon)
+ ; x - scalar quantity to be advected
+ ; rightmost dimensions must be ([...,]lat,lon)
+ ; eg: T, Z, divergence, vorticity, latent energy,..., whatever
+ ; gridType - type of grid: 0=gaussian, 1=fixed
+ ; long_name - descriptive name (eg: "Temperature Advection" )
+ ; units - units of result (eg: "m-K/s" )
+ ; iopt - flag: =0 means return only the advect result
+ ; =1 means return the advect, longitidinal and latitudinal gradient
+ ; as part of a list
+ ; Usage:
+ ; f = addfile ("foo.nc", "r")
+ ; u = f->U ; (time,lev,lat,lon)
+ ; v = f->V
+ ; T = f->T
+ ; ; linear advection of temperature
+ ; Tadv = advect_var(u,v,T,0,"linear advection of temperature","m-K/s",0)
+ ;
+ local dimu, dimv, dimx, ranku, rankv, rankx, ier
+ , x_grad_lon, x_grad_lat, advect
+ begin
+ ; ERROR CHECKING
+ dimu = dimsizes(u)
+ dimv = dimsizes(v)
+ dimx = dimsizes(x)
+ ranku = dimsizes(dimu)
+ rankv = dimsizes(dimv)
+ rankx = dimsizes(dimx)
+
+ ier = 0
+ if (.not.(gridType.eq.0 .or. gridType.eq.1)) then
+ print("advect_var: unrecognized gridType: only 0 and 1 allowed")
+ print(" gridType="+gridType)
+ ier = 1
+ end if
+ if (.not.(ranku.eq.rankv .and. ranku.eq.rankx)) then
+ print("advect_var: all input arguments must have the same rank")
+ print(" ranku="+ranku)
+ print(" rankv="+rankv)
+ print(" rankx="+rankx)
+ ier = ier + 10
+ end if
+ if (.not.(all(dimu.eq.dimv) .and. all(dimu.eq.dimx))) then
+ print("advect_var: all input arguments must have the same dimension sizes")
+ print(" ranku="+ranku)
+ print(" rankv="+rankv)
+ print(" rankx="+rankx)
+ ier = ier + 100
+ end if
+ if (rankx.lt.2) then
+ print("advect_var: variable rank must be at least 2D: ([time,[lev,]lat,plon)")
+ print("advect_var: rank="+rankx+"D")
+ ier = ier + 1000
+ end if
+
+ dnam = getvardims(x) ; dimension names
+ ynam = dnam(rankx-2) ; latitude dimension name
+ if (.not.ismissing(ynam) .and. iscoord(x,ynam)) then
+ yord = isMonotonic(x&$ynam$)
+ if (yord.le.0) then
+ print("advect_var: grid is not in South-to-North order.")
+ ier = ier + 10000
+ end if
+ else
+ print("advect_var: Warning: No named dimensions. Can not check grid order.")
+ end if
+
+ if (ier.ne.0) then
+ print("advect_var fatal error(s) encountered: ier="+ier)
+ exit
+ end if
+
+ x_grad_lon = new( dimx, typeof(x), getFillValue(x) )
+ x_grad_lat = new( dimx, typeof(x), getFillValue(x) )
+
+ if (gridType.eq.0) then
+ gradsg (x, x_grad_lon, x_grad_lat)
+ end if
+ if (gridType.eq.1) then
+ gradsf (x, x_grad_lon, x_grad_lat)
+ end if
+ ; advection
+
+ uxgrad_lon = u*x_grad_lon
+ vxgrad_lat = v*x_grad_lat
+ advect = uxgrad_lon + vxgrad_lat
+ ; add meta data
+ copy_VarCoords(x, advect)
+ advect at long_name = long_name
+ advect at units = units
+
+ if (iopt.eq.0) then
+ return(advect)
+ else
+ copy_VarCoords(x, x_grad_lon)
+ x_grad_lon at long_name = "longitudinal gradient"
+
+ copy_VarCoords(x, x_grad_lat)
+ x_grad_lat at long_name = "latitudinal gradient"
+
+ return([/ advect, x_grad_lon, x_grad_lat /] )
+
+ ;copy_VarCoords(x, ux_grad_lon)
+ ;x_grad_lon at long_name = "zonal advection"
+
+ ;copy_VarCoords(x, vx_grad_lat)
+ ;x_grad_lat at long_name = "meridional advevtion"
+
+ ;return([/ advect, x_grad_lon, x_grad_lat, uxgrad_lon, vxgrad_lat /] )
+ end if
+
+ end
+ ;---
+ undef("log1px")
+ function log1px(x:numeric)
+ ; Common function in other languages
+ local y, Fill
+ begin
+ if (isatt(x,"_FillValue")) then
+ Fill = x at _FillValue
+ else
+ if (typeof(x).eq."double") then
+ Fill = 1d20
+ else
+ Fill = 1e20
+ end if
+ end if
+
+ y = where((1+x).gt.0, log(1+x), Fill)
+
+ if (any(y.eq.Fill)) then
+ y at _FillValue = Fill
+ end if
+ return (y)
+ end
+ ;================
+ undef("dpres_hybrid_ccm_se")
+ function dpres_hybrid_ccm_se(ps:numeric,p0[1]:numeric,hya[*]:numeric,hyb[*]:numeric)
+ local dimNames, dim_ps, ntim, ncol, ps_dumy, dpres_dumy, dpres
+ begin
+
+ dimNames = getvardims(ps) ; (time,ncol)
+ if (dimNames(1).ne."ncol") then
+ print("dpres_hybrid_ccm_se: You are a MORON! This is not an SE grid!")
+ exit
+ end if
+
+ dim_ps = dimsizes(ps)
+ ntim = dim_ps(0)
+ ncol = dim_ps(1)
+
+ ps_dumy = conform_dims( (/ntim,1,ncol/), ps, (/0,2/))
+
+ dpres_dumy = dpres_hybrid_ccm (ps_dumy,p0,hya,hyb) ; (ntim,klev,1,ncol)
+ dpres = dpres_dumy(:,:,0,:) ; (ntim,klev,ncol)
+
+ ; the following is not needed for builtin function
+
+ dpres at long_name = "layer thickness"
+ dpres at units = "Pa" ; [kg/(m s2)]
+
+ copy_VarCoords(ps, dpres(:,0,:))
+ dpres!1 = "lev"
+
+ return(dpres)
+ end
+ ;===================
+ undef ("eofunc_north")
+ function eofunc_north(eval[*]:numeric, N[1]:integer, prinfo[1]:logical)
+ ;
+ ; North, G.R. et al (1982): Sampling Errors in the Estimation of Empirical Orthogonal Functions.
+ ; Mon. Wea. Rev., 110, 699���706.
+ ; doi: http://dx.doi.org/10.1175/1520-0493(1982)110<0699:SEITEO>2.0.CO;2
+ ;
+ ; Usage after 'eofunc'. Here ntim was used,
+ ; prinfo = True
+ ; sig = eval_north(eof at eval, ntim, prinfo)
+ ;
+ local neval, dlam, low, high, sig, n
+ begin
+ neval = dimsizes(eval)
+ if (neval.eq.1)
+ print("eofunc_north: neval=1, no testing can be performed")
+ sig = True
+ sig at long_name = "EOF separation is not testable N=1"
+ sig at N = N
+ return(sig)
+ end if
+
+ dlam = eval * sqrt(2.0/N) ; eq 24
+ low = eval-dlam
+ high = eval+dlam
+
+ sig = new(dimsizes(eval), logical)
+ sig = False ; default is not significantly separated
+
+ ; first and last eigenvalues are special cales
+
+ if (eval(0).gt.high(1)) then
+ sig(0) = True
+ end if
+ if (eval(neval-1).lt.low(neval-2)) then
+ sig(neval-1) = True
+ end if
+
+ ; loop over other eignvalues
+
+ if (N.gt.2) then
+ do n=1,neval-2
+ if (eval(n).lt.low(n-1) .and. eval(n).gt.high(n+1)) then
+ sig(n) = True
+ end if
+ end do
+ end if
+
+ if (prinfo) then
+ print(dlam+" "+low+" "+eval+" "+high+" "+sig)
+ end if
+
+ sig at long_name = "EOF separation"
+ sig at N = N
+ return(sig)
+ end
+ ;-----
+ undef("getfilevaratts_hdf5")
+ function getfilevaratts_hdf5( f, attName[1]:string )
+
+ ; Do this *ONCE* for each global attribute
+
+ local header, cr, delim, strs, nstrs, n, info, hinfo
+ begin
+ header= f@$attName$ ; long string[1]
+
+ cr = str_get_nl() ; carriage return (new line)
+ delim = cr + " ;"
+ strs = str_split(header, delim)
+ nstrs = dimsizes(strs)
+
+ hinfo = new( (/nstrs,2/), "string")
+ do n=0,nstrs-1
+ info := str_split(strs(n), "=")
+ hinfo(n,0) = info(0)
+ if (dimsizes(info) .eq. 2 ) then
+ hinfo(n,1) = info(1)
+ else
+ hinfo(n,1) = ""
+ end if
+ end do
+ hinfo at hdf5_global_attribute_name = attName
+
+ return(hinfo)
+ end
+ ;---
+ undef("extract_filevaratts_hdf5")
+ function extract_filevaratts_hdf5( hinfo[*][2]:string, name_to_extract[1]:string)
+ ; extract the value associated with the attribute which created 'hinfo'
+ ; info is output from function getfilevaratts_hdf5
+ begin
+
+ if (.not.isatt(hinfo,"hdf5_global_attribute_name")) then
+ print("Warning: hdf5_global_attribute_name is missing")
+ end if
+
+ idx = ind(hinfo(:,0) .eq. name_to_extract)
+ if (ismissing(idx(0))) then
+ return("extract_filevaratts_hdf5: "+name_to_extract+" is missing")
+ end if
+
+ return(hinfo(idx(0),1)) ; to the right of = sign
+ end
+ ;--------------------------------------------------------------------------------
+ ; function wrf_user_set_xy( var:numeric, xp:numeric, yp:numeric, x1:numeric, \
+ ; y1:numeric,angle:numeric ,opts )
+ ; function wrf_user_intrp3d( var3d:numeric, z:numeric, plot_type:string, \
+ ; loc_param:numeric, angle:numeric, opts:logical )
+ ; function wrf_user_intrp2d( var2d:numeric, \
+ ; loc_param:numeric, angle:numeric, opts:logical )
+ ; function wrf_user_vert_interp(file_handle,field:float,\
+ ; vert_coordinate[1]:string, \
+ ; interp_levels[*]:numeric,opts[1]:logical)
+ ; function wrf_user_getvar( file_handle, variable:string, time:integer )
+ ; function wrf_user_list_times( file_handle )
+ ; function wrf_user_ll_to_ij( nc_file:file, longitude:numeric, latitude:numeric, \
+ ; opts:logical )
+ ; function wrf_user_ij_to_ll( nc_file:file, i:numeric, j:numeric \
+ ; opts:logical )
+ ; function wrf_contour(nc_file:file,wks[1]: graphic, data[*][*]:numeric, \
+ ; opt_args[1]:logical)
+ ; function wrf_vector(nc_file:file,wks[1]: graphic, data_u[*][*]:numeric, \
+ ; data_v[*][*]:numeric, opt_args[1]:logical)
+ ; function wrf_map_resources(in_file[1]:file,opt_args[1]:logical)
+ ; function wrf_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical)
+ ; function wrf_map_overlays(in_file[1]:file,wks:graphic,base[1]:graphic, \
+ ; plots[*]:graphic,opt_arg[1]:logical,mp_arg[1]:logical)
+ ; function wrf_overlays(in_file[1]:file,wks:graphic, plots[*]:graphic, \
+ ; opt_arg[1]:logical)
+ ; function wrf_user_unstagger( varin:numeric, unstagDim:string )
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ; Thse functions are still experimental
+ ; function wrf_wps_dom(wks[1]:graphic,mpres[1]:logical,lnres[1]:logical,txres[1]:logical)
+ ; function wrf_contour_ps(nc_file:file,wks[1]: graphic, data[*][*]:numeric, \
+ ; opt_args[1]:logical)
+ ; function wrf_vector_ps(nc_file:file,wks[1]: graphic, \
+ ; data_u[*][*]:numeric, data_v[*][*]:numeric, \
+ ; opt_args[1]:logical)
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ; These functions/procedures are obsolete as of version 5.0.1 of NCL.
+ ; Do not use them.
+ ; Use wrf_overlays instead of wrf_overlay
+ ; Use wrf_map_overlays instead of wrf_map_overlay
+ ; Use wrf_user_ll_to_ij instead of wrf_user_latlon_to_ij
+ ;
+ ; function wrf_map_zoom(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical, \
+ ; y1:integer,y2:integer,x1:integer,x2:integer)
+ ; procedure wrf_map_overlay(wks:graphic,base[1]:graphic, \
+ ; plots[*]:graphic, \
+ ; opt_arg[1]:logical)
+ ; procedure wrf_overlay(wks:graphic, plots[*]:graphic, \
+ ; opt_arg[1]:logical)
+ ; function wrf_user_latlon_to_ij( nc_file:file, latitude:numeric,
+ ; longitude:numeric )
+ ;
+ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+ ;
+ ; function add_white_space(str:string,maxlen:integer)
+ ; procedure print_opts(opts_name,opts,debug)
+ ; procedure print_header(icount:integer,debug)
+ ;
+ ;--------------------------------------------------------------------------------
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_user_set_xy")
+ function wrf_user_set_xy( var:numeric, xp:numeric, yp:numeric, x1:numeric,
+ y1:numeric, angle:numeric, opts )
+
+ ; mass coordinate version of ncl user routines
+
+ local dims,x,y,slope,intercept,distance,dx,dy,dxy,npts,xy
+
+ begin
+
+ ; find intersection of line and domain boundaries
+
+ dims = dimsizes(var)
+
+ if (.not. opts) then ; We have a pivot point and location and
+ ; need to calculate the start and end points of
+ ; the cross section
+
+ if ((angle .gt. 315.) .or. (angle .lt. 45.) .or.
+ ((angle .gt. 135.) .and. (angle .lt. 225.)) ) then
+
+ ; x = y*slope + intercept
+
+ slope = -(360.-angle)/45.
+ if( angle .lt. 45. ) then
+ slope = angle/45.
+ end if
+ if( angle .gt. 135.) then
+ slope = (angle-180.)/45.
+ end if
+ intercept = xp - yp*slope
+
+ ; find intersections with domain boundaries
+
+ y0 = 0.
+ x0 = y0*slope + intercept
+
+ if( x0 .lt. 0.) then ; intersect outside of left boundary
+ x0 = 0.
+ y0 = (x0 - intercept)/slope
+ end if
+ if( x0 .gt. dims(2)-1) then ; intersect outside of right boundary
+ x0 = dims(2)-1
+ y0 = (x0 - intercept)/slope
+ end if
+
+ y1 = dims(1)-1. ; need to make sure this will be a float?
+ x1 = y1*slope + intercept
+
+ if( x1 .lt. 0.) then ; intersect outside of left boundary
+ x1 = 0.
+ y1 = (x1 - intercept)/slope
+ end if
+ if( x1 .gt. dims(2)-1) then ; intersect outside of right boundary
+ x1 = dims(2)-1
+ y1 = (x1 - intercept)/slope
+ end if
+
+ else
+
+ ; y = x*slope + intercept
+
+ slope = (90.-angle)/45.
+ if( angle .gt. 225. ) then
+ slope = (270.-angle)/45.
+ end if
+ intercept = yp - xp*slope
+
+ ; find intersections with domain boundaries
+
+ x0 = 0.
+ y0 = x0*slope + intercept
+
+ if( y0 .lt. 0.) then ; intersect outside of bottom boundary
+ y0 = 0.
+ x0 = (y0 - intercept)/slope
+ end if
+ if( y0 .gt. dims(1)-1) then ; intersect outside of top boundary
+ y0 = dims(1)-1
+ x0 = (y0 - intercept)/slope
+ end if
+
+ x1 = dims(2)-1. ; need to make sure this will be a float?
+ y1 = x1*slope + intercept
+
+ if( y1 .lt. 0.) then ; intersect outside of bottom boundary
+ y1 = 0.
+ x1 = (y1 - intercept)/slope
+ end if
+ if( y1 .gt. dims(1)-1) then ; intersect outside of top boundary
+ y1 = dims(1)-1
+ x1 = (y1 - intercept)/slope
+ end if
+
+ end if ; we have beginning and ending points
+
+ end if
+
+
+ if (opts) then ; We have a specified start and end point
+ x0 = xp
+ y0 = yp
+ if ( x1 .gt. dims(2)-1 ) then
+ x1 = dims(2)
+ end if
+ if ( y1 .gt. dims(1)-1 ) then
+ y1 = dims(1)
+ end if
+ end if
+
+ dx = x1 - x0
+ dy = y1 - y0
+ distance = (dx*dx + dy*dy)^0.5
+ npts = tointeger(distance)
+ dxy = new(1,typeof(distance))
+ dxy = distance/npts
+
+ xy = new((/ npts, 2 /),typeof(x1))
+
+ dx = dx/npts
+ dy = dy/npts
+
+ do i=0,npts-1
+ xy(i,0) = x0 + i*dx
+ xy(i,1) = y0 + i*dy
+ end do
+
+ ; print(xy)
+ return(xy)
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_user_intrp3d")
+ function wrf_user_intrp3d( var3d:numeric, z_in:numeric,
+ plot_type:string,
+ loc_param:numeric, angle:numeric, opts:logical )
+
+ ; var3d - 3d field to interpolate (all input fields must be unstaggered)
+ ; z_in - interpolate to this field (either p/z)
+ ; plot_type - interpolate horizontally "h", or vertically "v"
+ ; loc_param - level(s) for horizontal plots (eg. 500hPa ; 3000m - scalar),
+ ; plane for vertical plots (2 values representing an xy point
+ ; on the model domain through which the vertical plane will pass
+ ; OR 4 values specifying start and end values
+ ; angle - 0.0 for horizontal plots, and
+ ; an angle for vertical plots - 90 represent a WE cross section
+ ; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection
+
+ begin
+
+ if(plot_type .eq. "h" ) then ; horizontal cross section needed
+
+ dimL = dimsizes(loc_param)
+
+ dims = dimsizes(var3d)
+ nd = dimsizes(dims)
+
+ dimX = dims(nd-1)
+ dimY = dims(nd-2)
+ dimZ = dims(nd-3)
+ dim4 = 1
+ dim5 = 1
+ if ( nd .eq. 4 ) then
+ dim4 = dims(nd-4)
+ end if
+ if ( nd .eq. 5 ) then
+ dim4 = dims(nd-4)
+ dim5 = dims(nd-5)
+ end if
+
+ var3 = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) )
+ z = new ( (/ dim5, dim4, dimZ, dimY, dimX /) , typeof(var3d) )
+ var2d = new ( (/ dim5, dim4, dimL, dimY, dimX /) , typeof(var3d) )
+
+ if ( nd .eq. 5 ) then
+ var3 = var3d
+ z = z_in
+ end if
+ if ( nd .eq. 4 ) then
+ var3(0,:,:,:,:) = var3d(:,:,:,:)
+ z(0,:,:,:,:) = z_in(:,:,:,:)
+ end if
+ if ( nd .eq. 3 ) then
+ var3(0,0,:,:,:) = var3d(:,:,:)
+ z(0,0,:,:,:) = z_in(:,:,:)
+ end if
+
+
+ if ( z(0,0,dimZ-1,0,0) .lt. z(0,0,dimZ-2,0,0) ) then
+ ; We must be interpolating to pressure
+ ; This routine needs input field and level in hPa - lets make sure of this
+ if ( max(z) .gt. 2000. ) then
+ ; looks like we have Pa as input - make this hPa
+ z = z * 0.01
+ end if
+ if ( loc_param(0) .gt. 2000. ) then
+ ; looks like the input was specified in Pa - change this
+ loc_param = loc_param * 0.01
+ end if
+ end if
+
+ do il = 0,dimL-1
+ var = wrf_interp_3d_z(var3,z,loc_param(il))
+ var2d(:,:,il,:,:) = var(:,:,:,:)
+ end do
+
+ copy_VarAtts(var3d,var3)
+ if(isatt(var3,"description")) then
+ delete_VarAtts(var3,(/"description"/))
+ end if
+ if(isatt(var3,"units")) then
+ delete_VarAtts(var3,(/"units"/))
+ end if
+ if(isatt(var3,"MemoryOrder")) then
+ delete_VarAtts(var3,(/"MemoryOrder"/))
+ end if
+ if(isatt(var3,"_FillValue")) then
+ delete_VarAtts(var3,(/"_FillValue"/))
+ end if
+ copy_VarAtts(var3,var2d)
+
+ nn = nd-2
+ var2d!nn = "plevs"
+
+ if ( dimL .gt. 1 ) then
+ if ( nd .eq. 5 ) then
+ return( var2d )
+ end if
+ if ( nd .eq. 4 ) then
+ return( var2d(0,:,:,:,:) )
+ end if
+ if ( nd .eq. 3 ) then
+ return( var2d(0,0,:,:,:) )
+ end if
+ else
+ if ( z(0,0,dimZ-1,0,0) .lt. z(0,0,dimZ-2,0,0) ) then
+ var2d at PlotLevelID = loc_param + " hPa"
+ else
+ var2d at PlotLevelID = .001*loc_param + " km"
+ end if
+ if ( nd .eq. 5 ) then
+ return( var2d(:,:,0,:,:) )
+ end if
+ if ( nd .eq. 4 ) then
+ return( var2d(0,:,0,:,:) )
+ end if
+ if ( nd .eq. 3 ) then
+ return( var2d(0,0,0,:,:) )
+ end if
+ end if
+
+
+ end if
+
+
+
+
+ if(plot_type .eq. "v" ) then ; vertical cross section needed
+
+ dims = dimsizes(var3d)
+ nd = dimsizes(dims)
+
+ dimX = dims(nd-1)
+ dimY = dims(nd-2)
+ dimZ = dims(nd-3)
+
+ if ( nd .eq. 4 ) then
+ if ( z_in(0,dimZ-1,0,0) .lt. z_in(0,dimZ-2,0,0) ) then
+ ; We must be interpolating to pressure
+ ; This routine needs input field and level in hPa - lets make sure of this
+ if ( max(z_in) .gt. 2000. ) then
+ ; looks like we have Pa as input - make this hPa
+ z_in = z_in * 0.01
+ end if
+ end if
+ z = z_in(0,:,:,:)
+ else
+ if ( z_in(dimZ-1,0,0) .lt. z_in(dimZ-2,0,0) ) then
+ ; We must be interpolating to pressure
+ ; This routine needs input field and level in hPa - lets make sure of this
+ if ( z_in(0,0,0) .gt. 2000. ) then
+ ; looks like we have Pa as input - make this hPa
+ z_in = z_in * 0.01
+ end if
+ end if
+ z = z_in
+ end if
+
+
+ ; set vertical cross section
+ if (opts) then
+ xy = wrf_user_set_xy( z, loc_param(0)-1, loc_param(1)-1,
+ loc_param(2)-1, loc_param(3)-1,
+ angle, opts )
+ else
+ xy = wrf_user_set_xy( z, loc_param(0), loc_param(1),
+ 0.0, 0.0, angle, opts )
+ end if
+ xp = dimsizes(xy)
+
+
+ ; first we interp z
+ var2dz = wrf_interp_2d_xy( z, xy)
+
+ ; interp to constant z grid
+ if(var2dz(0,0) .gt. var2dz(1,0) ) then ; monotonically decreasing coordinate
+ z_max = floor(max(z)/10)*10 ; bottom value
+ z_min = ceil(min(z)/10)*10 ; top value
+ dz = 10
+ nlevels = tointeger( (z_max-z_min)/dz)
+ z_var2d = new( (/nlevels/), typeof(z))
+ z_var2d(0) = z_max
+ dz = -dz
+ else
+ z_max = max(z)
+ z_min = 0.
+ dz = 0.01 * z_max
+ nlevels = tointeger( z_max/dz )
+ z_var2d = new( (/nlevels/), typeof(z))
+ z_var2d(0) = z_min
+ end if
+
+ do i=1, nlevels-1
+ z_var2d(i) = z_var2d(0)+i*dz
+ end do
+
+
+ ; interp the variable
+ if ( dimsizes(dims) .eq. 4 ) then
+ var2d = new( (/dims(0), nlevels, xp(0)/), typeof(var2dz))
+ do it = 0,dims(0)-1
+ var2dtmp = wrf_interp_2d_xy( var3d(it,:,:,:), xy)
+ do i=0,xp(0)-1
+ var2d(it,:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d)
+ end do
+ end do
+ var2d!0 = var3d!0
+ var2d!1 = "Vertical"
+ var2d!2 = "Horizontal"
+ else
+ var2d = new( (/nlevels, xp(0)/), typeof(var2dz))
+ var2dtmp = wrf_interp_2d_xy( var3d, xy)
+ do i=0,xp(0)-1
+ var2d(:,i) = wrf_interp_1d( var2dtmp(:,i), var2dz(:,i), z_var2d)
+ end do
+ var2d!0 = "Vertical"
+ var2d!1 = "Horizontal"
+ end if
+
+
+
+ st_x = tointeger(xy(0,0)) + 1
+ st_y = tointeger(xy(0,1)) + 1
+ ed_x = tointeger(xy(xp(0)-1,0)) + 1
+ ed_y = tointeger(xy(xp(0)-1,1)) + 1
+ if (opts) then
+ var2d at Orientation = "Cross-Section: (" +
+ st_x + "," + st_y + ") to (" +
+ ed_x + "," + ed_y + ")"
+ else
+ var2d at Orientation = "Cross-Section: (" +
+ st_x + "," + st_y + ") to (" +
+ ed_x + "," + ed_y + ") ; center=(" +
+ loc_param(0) + "," + loc_param(1) +
+ ") ; angle=" + angle
+ end if
+
+ return(var2d)
+ end if
+
+
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_user_intrp2d")
+ function wrf_user_intrp2d( var2d:numeric,
+ loc_param:numeric, angle:numeric, opts:logical )
+
+ ; var2d - 2d field to interpolate
+ ; loc_param - plane for vertical plots (2 values representing an xy point
+ ; on the model domain through which the vertical plane will pass
+ ; OR 4 values specifying start and end values
+ ; angle - 0.0 for horizontal plots, and
+ ; an angle for vertical plots - 90 represent a WE cross section
+ ; opts Used IF opts is TRUE, else use loc_param and angle to determine crosssection
+
+ begin
+
+ dims = dimsizes(var2d)
+ nd = dimsizes(dims)
+ dimX = dims(nd-1)
+ dimY = dims(nd-2)
+ dimT = 1
+ if ( nd .eq. 3 ) then
+ dimT = dims(nd-3)
+ end if
+ var2dtmp = new( (/ 1, dimY, dimX /), typeof(var2d) )
+
+
+ ; set vertical cross section
+ if ( nd .eq. 3 ) then
+ var2dtmp(0,:,:) = var2d(0,:,:)
+ else
+ var2dtmp(0,:,:) = var2d(:,:)
+ end if
+ if (opts) then
+ xy = wrf_user_set_xy( var2dtmp,
+ loc_param(0)-1, loc_param(1)-1,
+ loc_param(2)-1, loc_param(3)-1,
+ angle, opts )
+ else
+ xy = wrf_user_set_xy( var2dtmp,
+ loc_param(0), loc_param(1),
+ 0.0, 0.0, angle, opts )
+ end if
+ xp = dimsizes(xy)
+
+ var2dout = new( (/ dimT, xp(0) /), typeof(var2d) )
+
+ var1dtmp = wrf_interp_2d_xy( var2dtmp, xy )
+ var2dout(0,:) = var1dtmp(0,:)
+ if ( dimT .eq. 1 ) then
+ var2dout!1 = "Horizontal"
+ return ( var2dout(0,:) )
+ end if
+
+ do it = 1,dimT-1
+ var2dtmp(0,:,:) = var2d(it,:,:)
+ var1dtmp = wrf_interp_2d_xy( var2dtmp, xy )
+ var2dout(it,:) = var1dtmp(0,:)
+ end do
+ var2dout!0 = "Time"
+ var2dout!1 = "Horizontal"
+ return(var2dout)
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_user_unstagger")
+ function wrf_user_unstagger( varin:numeric, unstagDim:string )
+
+ begin
+
+ dims = dimsizes(varin)
+ nd = dimsizes(dims)
+
+ if ( unstagDim .eq. "X" .or. unstagDim .eq. "U" ) then
+ dimU = dims(nd-1)
+ if ( nd .eq. 5 ) then
+ varout = 0.5*(varin(:,:,:,:,:dimU-2) + varin(:,:,:,:,1:dimU-1))
+ end if
+ if ( nd .eq. 4 ) then
+ varout = 0.5*(varin(:,:,:,:dimU-2) + varin(:,:,:,1:dimU-1))
+ end if
+ if ( nd .eq. 3 ) then
+ varout = 0.5*(varin(:,:,:dimU-2) + varin(:,:,1:dimU-1))
+ end if
+ if ( nd .eq. 2 ) then
+ varout = 0.5*(varin(:,:dimU-2) + varin(:,1:dimU-1))
+ end if
+ do i = 0,nd-2
+ varout!i = varin!i
+ end do
+ i = nd-1
+ varout!i = "west_east"
+ copy_VarAtts(varin,varout)
+ varout at coordinates = "XLONG XLAT"
+ varout at stagger = " "
+ end if
+
+ if ( unstagDim .eq. "Y" .or. unstagDim .eq. "V" ) then
+ dimV = dims(nd-2)
+ if ( nd .eq. 5 ) then
+ varout = 0.5*(varin(:,:,:,:dimV-2,:)+varin(:,:,:,1:dimV-1,:))
+ end if
+ if ( nd .eq. 4 ) then
+ varout = 0.5*(varin(:,:,:dimV-2,:)+varin(:,:,1:dimV-1,:))
+ end if
+ if ( nd .eq. 3 ) then
+ varout = 0.5*(varin(:,:dimV-2,:)+varin(:,1:dimV-1,:))
+ end if
+ if ( nd .eq. 2 ) then
+ varout = 0.5*(varin(:dimV-2,:)+varin(1:dimV-1,:))
+ end if
+ do i = 0,nd-1
+ varout!i = varin!i
+ end do
+ i = nd-2
+ varout!i = "south_north"
+ copy_VarAtts(varin,varout)
+ varout at coordinates = "XLONG XLAT"
+ varout at stagger = " "
+ end if
+
+ if ( unstagDim .eq. "Z" ) then
+ dimW = dims(nd-3)
+ if ( nd .eq. 5 ) then
+ varout = 0.5*(varin(:,:,0:dimW-2,:,:)+varin(:,:,1:dimW-1,:,:))
+ end if
+ if ( nd .eq. 4 ) then
+ varout = 0.5*(varin(:,0:dimW-2,:,:)+varin(:,1:dimW-1,:,:))
+ end if
+ if ( nd .eq. 3 ) then
+ varout = 0.5*(varin(0:dimW-2,:,:)+varin(1:dimW-1,:,:))
+ end if
+ do i = 0,nd-1
+ varout!i = varin!i
+ end do
+ i = nd-3
+ varout!i = "bottom_top"
+ copy_VarAtts(varin,varout)
+ varout at coordinates = "XLONG XLAT"
+ varout at stagger = " "
+ end if
+
+ if( any( unstagDim .eq. (/"X","U","Y","V","Z"/) ) ) then
+ return(varout)
+ else
+ print("NOTE: No unstaggering required, as the input field is already on mass points.")
+ return(varin)
+ end if
+
+ end
+
+ ;--------------------------------------------------------------------------------
+ ; This function was modified in May 2011 to allow a list of files.
+ ;
+ undef("wrf_user_getvar")
+ function wrf_user_getvar( file_handle, varin[*]:string, time_in:integer )
+ local variable, time, var, u, v, u_in, v_in, pii, radians_per_degree,
+ dims, nd, latitude, longitude, rank
+ begin
+
+ ;---As of NCL V6.0.0, wrf_user_getvar can now handle a file or a list of files.
+ if(typeof(file_handle).eq."file") then
+ ISFILE = True
+ nc_file = file_handle
+ else if(typeof(file_handle).eq."list") then
+ ISFILE = False
+ nc_file = file_handle[0]
+ else
+ print("wrf_user_getvar: error: the first argument must be a file or a list of files opened with addfile or addfiles")
+ return
+ end if
+ end if
+
+ variable = varin(0)
+ time = time_in(0)
+
+ if( (variable .eq. "uvmet") .or. (variable .eq. "uvmet10") ) then
+ ;; Calculate winds rotated to earth coord.
+
+ pii = 3.14159265
+ radians_per_degree = pii/180.
+
+ if( (variable .eq. "uvmet") ) then
+ getU = "U"
+ getV = "V"
+ if(.not. isfilevar(nc_file,"U")) then
+ if(isfilevar(nc_file,"UU")) then
+ getU = "UU"
+ getV = "VV"
+ end if
+ end if
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ u_in = nc_file->$getU$
+ v_in = nc_file->$getV$
+ else
+ u_in = file_handle[:]->$getU$
+ v_in = file_handle[:]->$getV$
+ end if
+ u = wrf_user_unstagger(u_in,u_in at stagger)
+ v = wrf_user_unstagger(v_in,v_in at stagger)
+ else
+ if(ISFILE) then
+ u_in = nc_file->$getU$(time_in,:,:,:)
+ v_in = nc_file->$getV$(time_in,:,:,:)
+ else
+ u_in = file_handle[:]->$getU$(time_in,:,:,:)
+ v_in = file_handle[:]->$getV$(time_in,:,:,:)
+ end if
+ u = wrf_user_unstagger(u_in,u_in at stagger)
+ v = wrf_user_unstagger(v_in,v_in at stagger)
+ end if
+ end if
+
+ if( (variable .eq. "uvmet10") ) then
+ if(isfilevar(nc_file,"U10")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ u_in = nc_file->U10
+ v_in = nc_file->V10
+ else
+ u_in = file_handle[:]->U10
+ v_in = file_handle[:]->V10
+ end if
+ u = wrf_user_unstagger(u_in,u_in at stagger)
+ v = wrf_user_unstagger(v_in,v_in at stagger)
+ else
+ if(ISFILE) then
+ u_in = nc_file->U10(time_in,:,:)
+ v_in = nc_file->V10(time_in,:,:)
+ else
+ u_in = file_handle[:]->U10(time_in,:,:)
+ v_in = file_handle[:]->V10(time_in,:,:)
+ end if
+ u = wrf_user_unstagger(u_in,u_in at stagger)
+ v = wrf_user_unstagger(v_in,v_in at stagger)
+ end if
+ else ; may be a met file, so get lowest level of UU and VV
+ if(isfilevar(nc_file,"UU")) then
+ print("wrf_user_getvar: Assume this is a met_em file - getting lowest level from UU and VV fields")
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ u_in = nc_file->UU(:,0,:,:)
+ v_in = nc_file->VV(:,0,:,:)
+ else
+ u_in = file_handle[:]->UU(:,0,:,:)
+ v_in = file_handle[:]->VV(:,0,:,:)
+ end if
+ u = wrf_user_unstagger(u_in,u_in at stagger)
+ v = wrf_user_unstagger(v_in,v_in at stagger)
+ else
+ if(ISFILE) then
+ u_in = nc_file->UU(time_in,0,:,:)
+ v_in = nc_file->VV(time_in,0,:,:)
+ else
+ u_in = file_handle[:]->UU(time_in,0,:,:)
+ v_in = file_handle[:]->VV(time_in,0,:,:)
+ end if
+ u = wrf_user_unstagger(u_in,u_in at stagger)
+ v = wrf_user_unstagger(v_in,v_in at stagger)
+ end if
+ end if
+ end if
+ end if
+
+
+ map_projection = nc_file at MAP_PROJ
+
+
+ if( any(map_projection.eq.(/0,3,6/)) ) then ; no rotation needed
+ dims = dimsizes(u)
+ nd = dimsizes(dims)
+ if ( nd .eq. 5 ) then
+ uvmet = new( (/ 2, dims(0), dims(1), dims(2), dims(3), dims(4) /), typeof(u))
+ uvmet(0,:,:,:,:,:) = u(:,:,:,:,:)
+ uvmet(1,:,:,:,:,:) = v(:,:,:,:,:)
+ end if
+ if ( nd .eq. 4 ) then
+ uvmet = new( (/ 2, dims(0), dims(1), dims(2), dims(3) /), typeof(u))
+ uvmet(0,:,:,:,:) = u(:,:,:,:)
+ uvmet(1,:,:,:,:) = v(:,:,:,:)
+ end if
+ if ( nd .eq. 3 ) then
+ uvmet = new( (/ 2, dims(0), dims(1), dims(2) /), typeof(u))
+ uvmet(0,:,:,:) = u(:,:,:)
+ uvmet(1,:,:,:) = v(:,:,:)
+ end if
+ if ( nd .eq. 2 ) then
+ uvmet = new( (/ 2, dims(0), dims(1) /), typeof(u))
+ uvmet(0,:,:) = u(:,:)
+ uvmet(1,:,:) = v(:,:)
+ end if
+ delete_VarAtts(u,(/"description","units"/))
+ copy_VarAtts(u,uvmet)
+ uvmet at description = " u,v met velocity"
+ uvmet!0 = "u_v"
+ end if
+
+
+ if( any(map_projection.eq.(/1,2/)) ) then ; no rotation needed
+ cen_lat = nc_file at CEN_LAT
+ if(isatt(nc_file,"STAND_LON")) then
+ cen_long = nc_file at STAND_LON
+ else
+ cen_long = nc_file at CEN_LON
+ end if
+ true_lat1 = nc_file at TRUELAT1
+ true_lat2 = nc_file at TRUELAT2
+
+ getLAT = "XLAT"
+ getLON = "XLONG"
+ if(.not. isfilevar(nc_file,"XLAT")) then
+ if(isfilevar(nc_file,"XLAT_M")) then
+ getLAT = "XLAT_M"
+ getLON = "XLONG_M"
+ end if
+ end if
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ latitude = nc_file->$getLAT$
+ longitude = nc_file->$getLON$
+ else
+ latitude = file_handle[:]->$getLAT$
+ longitude = file_handle[:]->$getLON$
+ end if
+ else
+ if(ISFILE) then
+ latitude = nc_file->$getLAT$(time_in,:,:)
+ longitude = nc_file->$getLON$(time_in,:,:)
+ else
+ latitude = file_handle[:]->$getLAT$(time_in,:,:)
+ longitude = file_handle[:]->$getLON$(time_in,:,:)
+ end if
+ end if
+
+ cone = 1.
+ if( map_projection .eq. 1) then ; Lambert Conformal mapping
+ if( (fabs(true_lat1 - true_lat2) .gt. 0.1) .and.
+ (fabs(true_lat2 - 90. ) .gt. 0.1) ) then
+ cone = log(cos(true_lat1*radians_per_degree))
+ -log(cos(true_lat2*radians_per_degree))
+ cone = cone/( log(tan(( 45. -fabs(true_lat1/2.))*radians_per_degree)) -
+ log(tan((45. -fabs(true_lat2/2.))*radians_per_degree)) )
+ else
+ cone = sin(fabs(true_lat1)*radians_per_degree)
+ end if
+ end if
+ if(map_projection .eq. 2) then ; polar stereographic
+ cone = 1.
+ end if
+ if(map_projection .eq. 3) then ; Mercator
+ cone = 0.
+ end if
+
+ uvmet = wrf_uvmet( u, v, latitude, longitude, cen_long, cone )
+ delete_VarAtts(u,(/"description","units"/))
+ copy_VarAtts(u,uvmet)
+
+ end if
+
+ if( (variable .eq. "uvmet10") ) then
+ uvmet at description = " u10,v10 met velocity"
+ end if
+ return(uvmet)
+
+ end if
+
+
+
+ if( variable .eq. "ua" ) then
+ ; U interpolated to mass points
+ getTHIS = "U"
+ if(.not. isfilevar(nc_file,"U")) then
+ if(isfilevar(nc_file,"UU")) then
+ getTHIS = "UU"
+ end if
+ end if
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->$getTHIS$
+ else
+ var = file_handle[:]->$getTHIS$
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->$getTHIS$(time_in,:,:,:)
+ else
+ var = file_handle[:]->$getTHIS$(time_in,:,:,:)
+ end if
+ end if
+
+ ua = wrf_user_unstagger(var,var at stagger)
+
+ return(ua)
+ end if
+
+
+
+ if( variable .eq. "va" ) then
+ ; V interpolated to mass points
+ getTHIS = "V"
+ if(.not. isfilevar(nc_file,"V")) then
+ if(isfilevar(nc_file,"VV")) then
+ getTHIS = "VV"
+ end if
+ end if
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->$getTHIS$
+ else
+ var = file_handle[:]->$getTHIS$
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->$getTHIS$(time_in,:,:,:)
+ else
+ var = file_handle[:]->$getTHIS$(time_in,:,:,:)
+ end if
+ end if
+
+ va = wrf_user_unstagger(var,var at stagger)
+
+ return(va)
+ end if
+
+
+
+ if( variable .eq. "wa" ) then
+ ; W interpolated to mass points
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->W
+ else
+ var = file_handle[:]->W
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->W(time_in,:,:,:)
+ else
+ var = file_handle[:]->W(time_in,:,:,:)
+ end if
+ end if
+
+ wa = wrf_user_unstagger(var,var at stagger)
+
+ return(wa)
+ end if
+
+
+
+ if( any( variable .eq. (/"p","pres","pressure"/) ) ) then
+ ; Full model pressure [=base pressure (PB) + pertubation pressure (P)]
+ if(isfilevar(nc_file,"P")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->P
+ PB = nc_file->PB
+ else
+ var = file_handle[:]->P
+ PB = file_handle[:]->PB
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ else
+ var = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ end if
+ end if
+ var = var + PB
+ else
+ ;; may be a met_em file - see if we can get PRES
+ if(isfilevar(nc_file,"PRES")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->PRES
+ else
+ var = file_handle[:]->PRES
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->PRES(time_in,:,:,:)
+ else
+ var = file_handle[:]->PRES(time_in,:,:,:)
+ end if
+ end if
+ end if
+ end if
+ var at description = "Pressure"
+ if( variable .eq. "pressure" ) then
+ var = var * 0.01
+ var at units = "hPa"
+ end if
+ return(var)
+ end if
+
+
+
+ if( any( variable .eq. (/"geopt","geopotential","z","height"/) ) ) then
+ ; Height [=full geopotentail height / 9.81]
+ if(isfilevar(nc_file,"PH")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->PH
+ PHB = nc_file->PHB
+ else
+ var = file_handle[:]->PH
+ PHB = file_handle[:]->PHB
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->PH(time,:,:,:)
+ PHB = nc_file->PHB(time,:,:,:)
+ else
+ var = file_handle[:]->PH(time,:,:,:)
+ PHB = file_handle[:]->PHB(time,:,:,:)
+ end if
+ end if
+
+ var = var + PHB
+ z = wrf_user_unstagger(var,var at stagger)
+ z at description = "Geopotential"
+
+ else
+ ;; may be a met_em file - see if we can get GHT - data in met_em file is Height in M
+ if(isfilevar(nc_file,"GHT")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ z = nc_file->GHT
+ else
+ z = file_handle[:]->GHT
+ end if
+ else
+ if(ISFILE) then
+ z = nc_file->GHT(time,:,:,:)
+ else
+ z = file_handle[:]->GHT(time,:,:,:)
+ end if
+ end if
+ z = z * 9.81
+ z at description = "Geopotential"
+ z at units = "m2 s-2"
+ end if
+ end if
+
+ if( any( variable .eq. (/"z","height"/) ) ) then
+ z = z / 9.81
+ z at description = "Height"
+ z at units = "m"
+ end if
+ return(z)
+ end if
+
+
+
+ if( any( variable .eq. (/"th","theta"/) ) ) then
+ ; Potentail Temperature is model output T + 300K
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->T
+ else
+ var = file_handle[:]->T
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->T(time_in,:,:,:)
+ else
+ var = file_handle[:]->T(time_in,:,:,:)
+ end if
+ end if
+ var = var + 300.
+ var at description = "Potential Temperature (theta) "
+ return(var)
+ end if
+
+
+
+ if( any( variable .eq. (/"tk","tc"/) ) ) then
+ ;; function wrf_tk needs theta and pressure (Pa) on input and returns temperature in K on return
+ if(isfilevar(nc_file,"T")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ t = wrf_tk( P , T )
+ delete_VarAtts(T,(/"description"/))
+ copy_VarAtts(T,t)
+ else
+ ;; may be a met_em file - see if we can get TT
+ if(isfilevar(nc_file,"TT")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ t = nc_file->TT
+ else
+ t = file_handle[:]->TT
+ end if
+ else
+ if(ISFILE) then
+ t = nc_file->TT(time_in,:,:,:)
+ else
+ t = file_handle[:]->TT(time_in,:,:,:)
+ end if
+ end if
+ end if
+ end if
+ if( variable .eq. "tc" ) then
+ t = t - 273.16
+ t at units = "C" ; Overwrite return units
+ end if
+ return(t)
+ end if
+
+
+
+ if( variable .eq. "eth" ) then
+ ;Equivalent Potential Temperature in degrees K
+ if(isfilevar(nc_file,"T")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ QV = nc_file->QVAPOR
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QV = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QV = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QV = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300. ; potential temperature in K.
+ P = P + PB ; full pressure in Pa.
+ tk = wrf_tk( P , T ) ; temperature in K.
+ eth = wrf_eth ( QV, tk, P )
+ delete_VarAtts(T,(/"description"/))
+ copy_VarAtts(T,eth)
+ return(eth)
+ else
+ print("This diagnostic only for with WRF data file and not for WPS files")
+ exit
+ end if
+
+ end if
+
+
+
+ if( variable .eq. "td" ) then
+ ;; function wrf_td needs qv and pressure (Pa) on input and returns dewpoint temperature on return
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ P = nc_file->P
+ PB = nc_file->PB
+ QVAPOR = nc_file->QVAPOR
+ else
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QVAPOR = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QVAPOR = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QVAPOR = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+ P = P + PB
+ td = wrf_td( P , QVAPOR )
+ delete_VarAtts(QVAPOR,(/"description","units"/))
+ copy_VarAtts(QVAPOR,td)
+ return(td)
+ end if
+
+
+
+ if( variable .eq. "td2" ) then
+ ;; function wrf_td needs qv and pressure (Pa) on input and returns dewpoint temperature on return
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ PSFC = nc_file->PSFC
+ Q2 = nc_file->Q2
+ else
+ PSFC = file_handle[:]->PSFC
+ Q2 = file_handle[:]->Q2
+ end if
+ else
+ if(ISFILE) then
+ PSFC = nc_file->PSFC(time_in,:,:)
+ Q2 = nc_file->Q2(time_in,:,:)
+ else
+ PSFC = file_handle[:]->PSFC(time_in,:,:)
+ Q2 = file_handle[:]->Q2(time_in,:,:)
+ end if
+ end if
+ td = wrf_td( PSFC , Q2 )
+ delete_VarAtts(Q2,(/"description","units"/))
+ copy_VarAtts(Q2,td)
+ td at description = "2m Dewpoint Temperature" ; Overwrite return description
+ return(td)
+ end if
+
+
+
+ if( variable .eq. "slp" ) then
+ if(isfilevar(nc_file,"T")) then
+ ;; first compute theta - function wrf_tk needs theta and pressure (Pa) on input
+ ;; THEN compute sea level pressure, from qv, p (Pa), tk, z
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ QVAPOR = nc_file->QVAPOR
+ PH = nc_file->PH
+ PHB = nc_file->PHB
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QVAPOR = file_handle[:]->QVAPOR
+ PH = file_handle[:]->PH
+ PHB = file_handle[:]->PHB
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QVAPOR = nc_file->QVAPOR(time_in,:,:,:)
+ PH = nc_file->PH(time_in,:,:,:)
+ PHB = nc_file->PHB(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QVAPOR = file_handle[:]->QVAPOR(time_in,:,:,:)
+ PH = file_handle[:]->PH(time_in,:,:,:)
+ PHB = file_handle[:]->PHB(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ QVAPOR = QVAPOR > 0.000
+ PH = ( PH + PHB ) / 9.81
+ z = wrf_user_unstagger(PH,PH at stagger)
+
+ tk = wrf_tk( P , T ) ; calculate TK
+ slp = wrf_slp( z, tk, P, QVAPOR ) ; calculate slp
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,slp)
+ else
+ ;; may be a met_em file - see if we can get PMSL
+ if(isfilevar(nc_file,"PMSL")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ slp = nc_file->PMSL
+ else
+ slp = file_handle[:]->PMSL
+ end if
+ else
+ if(ISFILE) then
+ slp = nc_file->PMSL(time_in,:,:)
+ else
+ slp = file_handle[:]->PMSL(time_in,:,:)
+ end if
+ end if
+ end if
+ end if
+
+ return(slp)
+ end if
+
+
+
+ if( variable .eq. "rh" ) then
+ if(isfilevar(nc_file,"T")) then
+ ;; first compute theta - function wrf_tk needs theta and pressure (Pa) on input
+ ;; THEN compute rh, using tk, p (Pa), QVAPOR
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ QVAPOR = nc_file->QVAPOR
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QVAPOR = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QVAPOR = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QVAPOR = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ QVAPOR = QVAPOR > 0.000
+ tk = wrf_tk( P , T )
+ rh = wrf_rh( QVAPOR, P, tk )
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,rh)
+ else
+ ;; may be a met_em file - see if we can get RH
+ if(isfilevar(nc_file,"RH")) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ rh = nc_file->RH
+ else
+ rh = file_handle[:]->RH
+ end if
+ else
+ if(ISFILE) then
+ rh = nc_file->RH(time_in,:,:,:)
+ else
+ rh = file_handle[:]->RH(time_in,:,:,:)
+ end if
+ end if
+ end if
+ end if
+ return(rh)
+ end if
+
+
+
+ if( variable .eq. "rh2" ) then
+ if(isfilevar(nc_file,"T2")) then
+ ;; Compute rh2, using T2, PSFC, Q2
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T2 = nc_file->T2
+ PSFC = nc_file->PSFC
+ Q2 = nc_file->Q2
+ else
+ T2 = file_handle[:]->T2
+ PSFC = file_handle[:]->PSFC
+ Q2 = file_handle[:]->Q2
+ end if
+ else
+ if(ISFILE) then
+ T2 = nc_file->T2(time_in,:,:)
+ PSFC = nc_file->PSFC(time_in,:,:)
+ Q2 = nc_file->Q2(time_in,:,:)
+ else
+ T2 = file_handle[:]->T2(time_in,:,:)
+ PSFC = file_handle[:]->PSFC(time_in,:,:)
+ Q2 = file_handle[:]->Q2(time_in,:,:)
+ end if
+ end if
+ Q2 = Q2 > 0.000
+ rh = wrf_rh( Q2, PSFC, T2 )
+ delete_VarAtts(T2,(/"description","units"/))
+ copy_VarAtts(T2,rh)
+ rh at description = "2m Relative Humidity"
+ else
+ ;; may be a met_em file - see if we can get RH
+ if(isfilevar(nc_file,"RH")) then
+ print("Probably a met_em file - get lowerst level from RH field")
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ rh2 = nc_file->RH(:,0,:,:)
+ else
+ rh2 = file_handle[:]->RH(:,0,:,:)
+ end if
+ else
+ if(ISFILE) then
+ rh2 = nc_file->RH(time_in,0,:,:)
+ else
+ rh2 = file_handle[:]->RH(time_in,0,:,:)
+ end if
+ end if
+ end if
+ end if
+ return(rh)
+ end if
+
+
+
+ if( variable .eq. "pvo" ) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ U = nc_file->U
+ V = nc_file->V
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ MSFU = nc_file->MAPFAC_U
+ MSFV = nc_file->MAPFAC_V
+ MSFM = nc_file->MAPFAC_M
+ COR = nc_file->F
+ else
+ U = file_handle[:]->U
+ V = file_handle[:]->V
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ MSFU = file_handle[:]->MAPFAC_U
+ MSFV = file_handle[:]->MAPFAC_V
+ MSFM = file_handle[:]->MAPFAC_M
+ COR = file_handle[:]->F
+ end if
+ else
+ if(ISFILE) then
+ U = nc_file->U(time_in,:,:,:)
+ V = nc_file->V(time_in,:,:,:)
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ MSFU = nc_file->MAPFAC_U(time_in,:,:)
+ MSFV = nc_file->MAPFAC_V(time_in,:,:)
+ MSFM = nc_file->MAPFAC_M(time_in,:,:)
+ COR = nc_file->F(time_in,:,:)
+ else
+ U = file_handle[:]->U(time_in,:,:,:)
+ V = file_handle[:]->V(time_in,:,:,:)
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ MSFU = file_handle[:]->MAPFAC_U(time_in,:,:)
+ MSFV = file_handle[:]->MAPFAC_V(time_in,:,:)
+ MSFM = file_handle[:]->MAPFAC_M(time_in,:,:)
+ COR = file_handle[:]->F(time_in,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ DX = nc_file at DX
+ DY = nc_file at DY
+
+ pvo = wrf_pvo( U, V, T, P, MSFU, MSFV, MSFM, COR, DX, DY, 0)
+
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,pvo)
+ return(pvo)
+ end if
+
+
+
+ if( variable .eq. "avo" ) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ U = nc_file->U
+ V = nc_file->V
+ MSFU = nc_file->MAPFAC_U
+ MSFV = nc_file->MAPFAC_V
+ MSFM = nc_file->MAPFAC_M
+ COR = nc_file->F
+ else
+ U = file_handle[:]->U
+ V = file_handle[:]->V
+ MSFU = file_handle[:]->MAPFAC_U
+ MSFV = file_handle[:]->MAPFAC_V
+ MSFM = file_handle[:]->MAPFAC_M
+ COR = file_handle[:]->F
+ end if
+ else
+ if(ISFILE) then
+ U = nc_file->U(time_in,:,:,:)
+ V = nc_file->V(time_in,:,:,:)
+ MSFU = nc_file->MAPFAC_U(time_in,:,:)
+ MSFV = nc_file->MAPFAC_V(time_in,:,:)
+ MSFM = nc_file->MAPFAC_M(time_in,:,:)
+ COR = nc_file->F(time_in,:,:)
+ else
+ U = file_handle[:]->U(time_in,:,:,:)
+ V = file_handle[:]->V(time_in,:,:,:)
+ MSFU = file_handle[:]->MAPFAC_U(time_in,:,:)
+ MSFV = file_handle[:]->MAPFAC_V(time_in,:,:)
+ MSFM = file_handle[:]->MAPFAC_M(time_in,:,:)
+ COR = file_handle[:]->F(time_in,:,:)
+ end if
+ end if
+ DX = nc_file at DX
+ DY = nc_file at DY
+
+ avo = wrf_avo( U, V, MSFU, MSFV, MSFM, COR, DX, DY, 0)
+
+ delete_VarAtts(COR,(/"description","units"/))
+ copy_VarAtts(COR,avo)
+ return(avo)
+ end if
+
+
+
+ if( variable .eq. "dbz" .or. variable .eq. "mdbz" ) then
+ ; calculate dbz
+ ivarint = 0
+ iliqskin = 0
+ dim_vars = dimsizes(varin)
+ do idims = 1,dim_vars-1
+ if ( idims .eq. 1 ) then
+ if ( varin(idims) .eq. "1" ) then
+ ivarint = 1
+ end if
+ end if
+ if ( idims .eq. 2 ) then
+ if ( varin(idims) .eq. "1" ) then
+ iliqskin = 1
+ end if
+ end if
+ end do
+
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ qv = nc_file->QVAPOR
+ qr = nc_file->QRAIN
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ qv = file_handle[:]->QVAPOR
+ qr = file_handle[:]->QRAIN
+ end if
+ if(isfilevar(nc_file,"QSNOW"))
+ if(ISFILE) then
+ qs = nc_file->QSNOW
+ else
+ qs = file_handle[:]->QSNOW
+ end if
+ end if
+ if(isfilevar(nc_file,"QGRAUP"))
+ if(ISFILE) then
+ qg = nc_file->QGRAUP
+ else
+ qg = file_handle[:]->QGRAUP
+ end if
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ qv = nc_file->QVAPOR(time_in,:,:,:)
+ qr = nc_file->QRAIN(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ qv = file_handle[:]->QVAPOR(time_in,:,:,:)
+ qr = file_handle[:]->QRAIN(time_in,:,:,:)
+ end if
+ if(isfilevar(nc_file,"QSNOW"))
+ if(ISFILE) then
+ qs = nc_file->QSNOW(time_in,:,:,:)
+ else
+ qs = file_handle[:]->QSNOW(time_in,:,:,:)
+ end if
+ end if
+ if(isfilevar(nc_file,"QGRAUP"))
+ if(ISFILE) then
+ qg = nc_file->QGRAUP(time_in,:,:,:)
+ else
+ qg = file_handle[:]->QGRAUP(time_in,:,:,:)
+ end if
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ tk = wrf_tk( P , T )
+
+ if ( .not. isvar("qs") ) then
+ qs = qv
+ qs = 0.0
+ end if
+ if ( .not. isvar("qg") ) then
+ qg = qv
+ qg = 0.0
+ end if
+
+ dbz = wrf_dbz ( P, tk, qv, qr, qs, qg, ivarint, iliqskin)
+ delete(qs)
+ delete(qg)
+
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,dbz)
+
+
+ if ( variable .eq. "mdbz") then
+ dims = getvardims(dbz)
+ rank = dimsizes(dims)
+ if ( rank .eq. 5 ) then
+ mdbz = dim_max ( dbz($dims(0)$|:,$dims(1)$|:,$dims(3)$|:,$dims(4)$|:,$dims(2)$|:) )
+ mdbz!0 = dbz!0
+ mdbz!1 = dbz!1
+ end if
+ if ( rank .eq. 4 ) then
+ mdbz = dim_max ( dbz($dims(0)$|:,$dims(2)$|:,$dims(3)$|:,$dims(1)$|:) )
+ mdbz!0 = dbz!0
+ end if
+ if ( rank .eq. 3 ) then
+ mdbz = dim_max ( dbz($dims(1)$|:,$dims(2)$|:,$dims(0)$|:) )
+ end if
+ nn = rank-1
+ nm = rank-2
+ mdbz!nm = dbz!nn
+ nn = rank-2
+ nm = rank-3
+ mdbz!nm = dbz!nn
+ copy_VarAtts(dbz,mdbz)
+ mdbz at description = "Max Reflectivity"
+ return(mdbz)
+ else
+ return(dbz)
+ end if
+
+ end if
+
+
+
+ if( any( variable .eq. (/"cape_3d","cape_2d"/) ) ) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ QV = nc_file->QVAPOR
+ PH = nc_file->PH
+ PHB = nc_file->PHB
+ HGT = nc_file->HGT
+ PSFC = nc_file->PSFC
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QV = file_handle[:]->QVAPOR
+ PH = file_handle[:]->PH
+ PHB = file_handle[:]->PHB
+ HGT = file_handle[:]->HGT
+ PSFC = file_handle[:]->PSFC
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QV = nc_file->QVAPOR(time_in,:,:,:)
+ PH = nc_file->PH(time_in,:,:,:)
+ PHB = nc_file->PHB(time_in,:,:,:)
+ HGT = nc_file->HGT(time_in,:,:)
+ PSFC = nc_file->PSFC(time_in,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QV = file_handle[:]->QVAPOR(time_in,:,:,:)
+ PH = file_handle[:]->PH(time_in,:,:,:)
+ PHB = file_handle[:]->PHB(time_in,:,:,:)
+ HGT = file_handle[:]->HGT(time_in,:,:)
+ PSFC = file_handle[:]->PSFC(time_in,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ tk = wrf_tk( P , T )
+ PH = PH + PHB
+ z = wrf_user_unstagger(PH,PH at stagger)
+ z = z/9.81
+
+ if( variable .eq. "cape_3d" ) then
+ cape = wrf_cape_3d( P, tk, QV, z, HGT, PSFC, True )
+ cape at description = "cape ; cin"
+ end if
+ if( variable .eq. "cape_2d" ) then
+ cape = wrf_cape_2d( P, tk, QV, z, HGT, PSFC, True )
+ delete_VarAtts(T,(/"MemoryOrder"/))
+ cape at MemoryOrder = "XY"
+ cape at description = "mcape ; mcin ; lcl ; lfc"
+ end if
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,cape)
+
+ return(cape)
+ end if
+
+
+
+ if( any( variable .eq. (/"pw"/) ) ) then
+ ;Precipitable Water
+ print("calculating precipitable water")
+ gas_const = 287. ; J/K/kg
+ Cp = 1004. ; J/K/kg
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ PH = nc_file->PH
+ PHB = nc_file->PHB
+ QV = nc_file->QVAPOR
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ PH = file_handle[:]->PH
+ PHB = file_handle[:]->PHB
+ QV = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ PH = nc_file->PH(time_in,:,:,:)
+ PHB = nc_file->PHB(time_in,:,:,:)
+ QV = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ PH = file_handle[:]->PH(time_in,:,:,:)
+ PHB = file_handle[:]->PHB(time_in,:,:,:)
+ QV = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+
+ pres = P + PB
+ height = (PH + PHB)/9.8 ; height at full levels
+ theta = T + 300.
+ temp = theta * (pres/100000) ^ (gas_const/Cp)
+ vtemp = (1 + 0.61*QV) * temp ; virtual temp
+
+ dims = dimsizes(T)
+ nd = dimsizes(dims)
+
+ if ( nd .eq. 4 ) then
+ zdiff = height(:,0,:,:)
+ zdiff = 0.
+ pw_sfc_ptop = height(:,0,:,:)
+ pw_sfc_ptop = 0.
+ do k = 0,dims(1)-1
+ zdiff(:,:,:) = (height(:,k+1,:,:) - height(:,k,:,:))
+ pw_sfc_ptop(:,:,:) = pw_sfc_ptop(:,:,:) + ((pres(:,k,:,:)/(gas_const * vtemp(:,k,:,:))) * QV(:,k,:,:) * zdiff(:,:,:))
+ end do
+ end if
+ if ( nd .eq. 3 ) then
+ zdiff = height(0,:,:)
+ zdiff = 0.
+ pw_sfc_ptop = height(0,:,:)
+ pw_sfc_ptop = 0.
+ do k = 0,dims(0)-1
+ zdiff(:,:) = (height(k+1,:,:) - height(k,:,:))
+ pw_sfc_ptop(:,:) = pw_sfc_ptop(:,:) + ((pres(k,:,:)/(gas_const * vtemp(k,:,:))) * QV(k,:,:) * zdiff(:,:))
+ end do
+ end if
+
+ pw_sfc_ptop at description = "Precipitable Water"
+ return(pw_sfc_ptop)
+ end if
+
+
+
+ if( any( variable .eq. (/"helicity"/) ) ) then
+ getU = "U"
+ getV = "V"
+ if(.not. isfilevar(nc_file,"U")) then
+ if(isfilevar(nc_file,"UU")) then
+ getU = "UU"
+ getV = "VV"
+ end if
+ end if
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ u_in = nc_file->$getU$
+ v_in = nc_file->$getV$
+ PH = nc_file->PH
+ geopt = nc_file->PHB
+ ter = nc_file->HGT
+ else
+ u_in = file_handle[:]->$getU$
+ v_in = file_handle[:]->$getV$
+ PH = file_handle[:]->PH
+ geopt = file_handle[:]->PHB
+ ter = file_handle[:]->HGT
+ end if
+ else
+ if(ISFILE) then
+ u_in = nc_file->$getU$(time_in,:,:,:)
+ v_in = nc_file->$getV$(time_in,:,:,:)
+ PH = nc_file->PH(time_in,:,:,:)
+ geopt = nc_file->PHB(time_in,:,:,:)
+ ter = nc_file->HGT(time_in,:,:)
+ else
+ u_in = file_handle[:]->$getU$(time_in,:,:,:)
+ v_in = file_handle[:]->$getV$(time_in,:,:,:)
+ PH = file_handle[:]->PH(time_in,:,:,:)
+ geopt = file_handle[:]->PHB(time_in,:,:,:)
+ ter = file_handle[:]->HGT(time_in,:,:)
+ end if
+ end if
+
+ ua = wrf_user_unstagger(u_in,u_in at stagger)
+ va = wrf_user_unstagger(v_in,v_in at stagger)
+ geopt = geopt + PH
+ za = wrf_user_unstagger(geopt,geopt at stagger)
+ za = za / 9.81 ; change to height
+
+ ua1 = ua(::-1,:,:)
+ va1 = va(::-1,:,:)
+ za1 = za(::-1,:,:)
+
+ top_ok = 0
+ top = 3000.
+
+ dim_vars = dimsizes(varin)
+ if(dim_vars .eq. 2) then
+ if( varin(1) .eq. "3000" ) then
+ top = 3000.
+ top_ok = 1
+ end if
+
+ if( varin(1) .eq. "1000" ) then
+ top = 1000.
+ top_ok = 1
+ end if
+
+ if(top_ok .eq. 0) then
+ print("Top values of 1000 or 3000 are accepted.")
+ top = 3000.
+ end if
+ end if
+
+ print("Calculations are done with a top of " + top)
+ sreh = wrf_helicity(ua1, va1, za1, ter, top)
+ return(sreh)
+ end if
+
+
+
+ if( any(variable .eq. (/"updraft_helicity"/) ) )then
+ getU = "U"
+ getV = "V"
+ if(.not. isfilevar(nc_file,"U")) then
+ if(isfilevar(nc_file,"UU")) then
+ getU = "UU"
+ getV = "VV"
+ end if
+ end if
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ u_in = nc_file->$getU$
+ v_in = nc_file->$getV$
+ w = nc_file->W
+ ph = nc_file->PH
+ phb = nc_file->PHB
+ else
+ u_in = file_handle[:]->$getU$
+ v_in = file_handle[:]->$getV$
+ w = file_handle[:]->W
+ ph = file_handle[:]->PH
+ phb = file_handle[:]->PHB
+ end if
+ else
+ if(ISFILE) then
+ u_in = nc_file->$getU$(time_in,:,:,:)
+ v_in = nc_file->$getV$(time_in,:,:,:)
+ w = nc_file->W(time_in,:,:,:)
+ ph = nc_file->PH(time_in,:,:,:)
+ phb = nc_file->PHB(time_in,:,:,:)
+ else
+ u_in = file_handle[:]->$getU$(time_in,:,:,:)
+ v_in = file_handle[:]->$getV$(time_in,:,:,:)
+ w = file_handle[:]->W(time_in,:,:,:)
+ ph = file_handle[:]->PH(time_in,:,:,:)
+ phb = file_handle[:]->PHB(time_in,:,:,:)
+ end if
+ end if
+ ua = wrf_user_unstagger(u_in,u_in at stagger)
+ va = wrf_user_unstagger(v_in,v_in at stagger)
+ mapfct = nc_file->MAPFAC_M(0,:,:)
+ zp = ph + phb
+ dx = nc_file at DX
+ dy = nc_file at DY
+
+ uh_opt = True
+ uh_opt at uhmnhgt = 2000.
+ uh_opt at uhmxhgt = 5000.
+ dim_vars = dimsizes(varin)
+
+ print("Calculating updraft helicity")
+ if(dim_vars .eq. 1) then
+ print(" Using defaults for the integration limits")
+ end if
+
+ if(dim_vars .eq. 2) then
+ print(" Please enter both the minimum and maximum integration limits")
+ print(" Going to use defaults for the integration limits")
+ end if
+
+ if(dim_vars .eq. 3) then
+ if ( stringtofloat(varin(1)) .lt. 1000. ) then
+ print(" Integration limits needs to be greater than 1000 meter")
+ print(" Going to use defaults for the integration limits")
+ else
+ uh_opt at uhmnhgt = stringtofloat(varin(1))
+ uh_opt at uhmxhgt = stringtofloat(varin(2))
+ print(" Setting custom integration limits")
+ end if
+ end if
+
+ print(" min = "+uh_opt at uhmnhgt+" max = "+uh_opt at uhmxhgt)
+ uh = wrf_updraft_helicity(zp, mapfct, ua, va, w, dx, dy, uh_opt)
+ delete(uh_opt)
+
+ return(uh)
+ end if
+
+
+ if( variable .eq. "twb" ) then
+ ; Wet bulb temperature
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ QV = nc_file->QVAPOR
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QV = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QV = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QV = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ t = wrf_tk(P,T)
+
+ twb = wrf_wetbulb(P,t,QV)
+
+ delete_VarAtts(T,(/"description"/))
+ copy_VarAtts(T,twb)
+ return(twb)
+ end if
+
+
+ if( variable .eq. "omg" ) then
+ ; Omega
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ W = nc_file->W
+ PB = nc_file->PB
+ QV = nc_file->QVAPOR
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ W = file_handle[:]->W
+ PB = file_handle[:]->PB
+ QV = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ W = nc_file->W(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QV = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ W = file_handle[:]->W(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QV = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ t = wrf_tk(P,T)
+ wa = wrf_user_unstagger(W,W at stagger)
+
+ omg = wrf_omega(QV,t,wa,P)
+
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,omg)
+ return(omg)
+ end if
+
+
+ if( variable .eq. "tv" ) then
+ ; Virtual temperature
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ T = nc_file->T
+ P = nc_file->P
+ PB = nc_file->PB
+ QV = nc_file->QVAPOR
+ else
+ T = file_handle[:]->T
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ QV = file_handle[:]->QVAPOR
+ end if
+ else
+ if(ISFILE) then
+ T = nc_file->T(time_in,:,:,:)
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ QV = nc_file->QVAPOR(time_in,:,:,:)
+ else
+ T = file_handle[:]->T(time_in,:,:,:)
+ P = file_handle[:]->P(time_in,:,:,:)
+ PB = file_handle[:]->PB(time_in,:,:,:)
+ QV = file_handle[:]->QVAPOR(time_in,:,:,:)
+ end if
+ end if
+ T = T + 300.
+ P = P + PB
+ t = wrf_tk(P,T)
+
+ tv = wrf_virtual_temp(t,QV)
+
+ delete_VarAtts(T,(/"description"/))
+ copy_VarAtts(T,tv)
+ return(tv)
+ end if
+
+ if( variable .eq. "ctt") then
+ if ( time .eq. -1 ) then
+ explicit_time = 0
+ if(ISFILE) then
+ P = nc_file->P
+ PB = nc_file->PB
+ T = nc_file->T
+
+ ;geopotential height
+ PHB = nc_file->PHB
+ PH = nc_file->PH
+
+ if(isfilevar(nc_file,"QVAPOR")) then
+ qvp = nc_file->QVAPOR * 1000. ; kg/kg -> g/kg
+ else
+ print("wrf_user_getvar: QVAPOR is needed to calculate the cloud top temperature.")
+ print("It has not been found in the data set.")
+ exit
+ end if
+
+
+ haveqci = 1
+ if(isfilevar(nc_file,"QICE")) then
+ qci = nc_file->QICE * 1000. ; kg/kg -> g/kg
+ else
+ qci = new( (/Pdims(0),Pdims(1),Pdims(2),Pdims(3)/),float)
+ haveqci = 0
+ end if
+
+
+ if(isfilevar(nc_file,"QCLOUD")) then
+ qcw = nc_file->QCLOUD * 1000. ; kg/kg -> g/kg
+ else
+ print("wrf_user_getvar: QCLOUD is needed to calculate the cloud top temperature.")
+ print("It has not been found in the data set.")
+ exit
+ end if
+
+ ter = nc_file->HGT(0,:,:)
+
+ else ; the else for ISFILE
+ P = file_handle[:]->P
+ PB = file_handle[:]->PB
+ T = file_handle[:]->T
+ PHB = file_handle[:]->PHB
+ PH = file_handle[:]->PH
+ nc_file = file_handle[0]
+ ter = nc_file->HGT(0,:,:)
+ if(isfilevar(nc_file,"QVAPOR")) then
+ qvp = file_handle[:]->QVAPOR * 1000. ; kg/kg -> g/kg
+ else
+ print("wrf_user_getvar: QVAPOR is needed to calculate the cloud top temperature.")
+ print("It has not been found in the data set.")
+ exit
+ end if
+
+ haveqci = 1
+ if(isfilevar(nc_file,"QICE")) then
+ qci = file_handle[:]->QICE * 1000. ; kg/kg -> g/kg
+ else
+ qci = new( (/Pdims(0),Pdims(1),Pdims(2),Pdims(3)/),float)
+ haveqci = 0
+ end if
+
+
+ if(isfilevar(nc_file,"QCLOUD")) then
+ qcw = file_handle[:]->QCLOUD * 1000. ; kg/kg -> g/kg
+ else
+ print("wrf_user_getvar: QCLOUD is needed to calculate the cloud top temperature.")
+ print("It has not been found in the data set.")
+ exit
+ end if
+
+ end if ;if ISFILE
+ else ;the else for time = -1
+ if(ISFILE) then
+ explicit_time = 1
+ P = nc_file->P(time_in,:,:,:)
+ PB = nc_file->PB(time_in,:,:,:)
+ T = nc_file->T(time_in,:,:,:)
+
+ ;geopotential height
+ PHB = nc_file->PHB(time_in,:,:,:)
+ PH = nc_file->PH(time_in,:,:,:)
+
+ if(isfilevar(nc_file,"QVAPOR")) then
+ qvp = nc_file->QVAPOR(time_in,:,:,:) * 1000. ; kg/kg -> g/kg
+ else
+ print("wrf_user_getvar: QVAPOR is needed to calculate the cloud top temperature.")
+ print("It has not been found in the data set")
+ exit
+ end if
+
+
+ haveqci = 1
+ if(isfilevar(nc_file,"QICE")) then
+ qci = nc_file->QICE(time_in,:,:,:) * 1000. ; kg/kg -> g/kg
+ else
+ qci = new( (/Pdims(0),Pdims(1),Pdims(2),Pdims(3)/),float)
+ haveqci = 0
+ end if
+
+
+ if(isfilevar(nc_file,"QCLOUD")) then
+ qcw = nc_file->QCLOUD(time_in,:,:,:) * 1000. ; kg/kg -> g/kg
+ else
+ print("wrf_user_getvar: QCLOUD is needed to calculate the cloud top temperature.")
+ print("It has not been found in the data set.")
+ exit
+ end if
+
+ ter = nc_file->HGT(0,:,:)
+ end if ;end if for ISFILE
+ end if ;time = -1
+
+
+ ;Get total pressure
+ Pdims = dimsizes(P)
+ pres = P + PB
+ pres = pres * 0.01
+
+ ;Get temperature in degrees K
+ T = T +300.
+ tk = wrf_tk( pres , T )
+
+ ;Get geopotential height on mass points
+ stag_ght = PH
+ stag_ght = (PHB + PH)/9.81
+ ght = wrf_user_unstagger(stag_ght,PHB at stagger)
+
+ fctt = wrf_ctt(pres,tk,qci,qcw,qvp,ght,ter,haveqci)
+ ; fctt will have description, units, and dimension names attached
+ delete_VarAtts(T,(/"description","units"/))
+ copy_VarAtts(T,fctt)
+ return(fctt)
+ end if ;variable is ctt
+
+
+ if( any( variable .eq. (/"ter","HGT","HGT_M"/) ) ) then
+ variable = "HGT"
+ if(.not. isfilevar(nc_file,"HGT")) then
+ variable = "HGT_M"
+ end if
+ end if
+
+
+ if( any( variable .eq. (/"lat","XLAT","XLAT_M"/) ) ) then
+ variable = "XLAT"
+ if(.not. isfilevar(nc_file,"XLAT")) then
+ variable = "XLAT_M"
+ end if
+ end if
+
+
+ if( any( variable .eq. (/"lon","long","XLONG","XLONG_M"/) ) ) then
+ variable = "XLONG"
+ if(.not. isfilevar(nc_file,"XLONG")) then
+ variable = "XLONG_M"
+ end if
+ end if
+
+
+ if( any( variable .eq. (/"times"/) ) ) then
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->Times
+ else
+ var = file_handle[:]->Times
+ end if
+ else
+ if(ISFILE) then
+ var = nc_file->Times(time_in,:)
+ else
+ var = file_handle[:]->Times(time_in,:)
+ end if
+ end if
+ dims = dimsizes(var)
+ times = new(dims(0),string)
+ do i=0,dims(0)-1
+ times(i) = chartostring(var(i,:))
+ end do
+ times at description = "times in file"
+ return (times)
+ end if
+
+
+
+ ; end of diagnostic variable list - we must want a variable already in the file.
+
+ if ( time .eq. -1 ) then
+ if(ISFILE) then
+ var = nc_file->$variable$
+ else
+ var = file_handle[:]->$variable$
+ end if
+ else
+ ; check variable dimensionality and pull proper time out of file
+ ndims = dimsizes(filevardimsizes(nc_file,variable))
+ if( ndims .eq. 4) then
+ if(ISFILE) then
+ var = nc_file->$variable$(time_in,:,:,:)
+ else
+ var = file_handle[:]->$variable$(time_in,:,:,:)
+ end if
+ end if
+ if( ndims .eq. 3) then
+ if(ISFILE) then
+ var = nc_file->$variable$(time_in,:,:)
+ else
+ var = file_handle[:]->$variable$(time_in,:,:)
+ end if
+ end if
+ if( ndims .eq. 2) then
+ if(ISFILE) then
+ var = nc_file->$variable$(time_in,:)
+ else
+ var = file_handle[:]->$variable$(time_in,:)
+ end if
+ end if
+ if( ndims .eq. 1) then
+ if(ISFILE) then
+ var = nc_file->$variable$(time_in)
+ else
+ var = file_handle[:]->$variable$(time_in)
+ end if
+ end if
+ end if
+
+ return(var)
+
+ end
+
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_user_getvar_from_files")
+ function wrf_user_getvar_from_files( nc_files:string, varin[*]:string, time[*]:integer, opts_args:logical )
+
+ begin
+
+ numFiles = dimsizes(nc_files)
+ f = addfiles(nc_files,"r")
+
+ var_tmp = wrf_user_getvar(f[0],varin,-1)
+ varDims = dimsizes(var_tmp)
+ varRank = dimsizes(varDims)
+ time_req = 0
+ time_inc = 1
+ time_end = varDims(0)*numFiles
+ if ( dimsizes(time) .eq. 1 ) then
+ if ( time(0) .ge. 0 ) then
+ numTimes = 1
+ time_req = time(0)
+ time_end = time(0)
+ time_inc = 1
+ else
+ numTimes = varDims(0)*numFiles
+ end if
+ end if
+ if ( dimsizes(time) .eq. 2 ) then
+ if ( time(0) .ge. 0 ) then
+ numTimes = (time(1)-time(0))+1
+ time_req = time(0)
+ time_end = time(1)
+ time_inc = 1
+ else
+ numTimes = varDims(0)*numFiles
+ end if
+ end if
+ if ( dimsizes(time) .eq. 3 ) then
+ if ( time(0) .ge. 0 ) then
+ numTimes = ((time(1)-time(0))+1)/time(2)
+ time_req = time(0)
+ time_end = time(1)
+ time_inc = time(2)
+ else
+ numTimes = varDims(0)*numFiles
+ end if
+ end if
+ outtime = 0
+ outtime_avail = 0
+
+
+ if ( varRank .eq. 4 )
+ varout = new ( (/numTimes,varDims(1),varDims(2),varDims(3)/), typeof(var_tmp) )
+ varout = 0
+ do it = 0,varDims(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime,:,:,:) = var_tmp(it,:,:,:)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ do ifil = 1,numFiles-1
+ var_tmp = wrf_user_getvar(f[ifil],varin,-1)
+ dimLoop = dimsizes(var_tmp)
+ do it = 0,dimLoop(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime,:,:,:) = var_tmp(it,:,:,:)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ end do
+ end if
+ if ( varRank .eq. 3 )
+ varout = new ( (/numTimes,varDims(1),varDims(2)/), typeof(var_tmp) )
+ varout = 0
+ do it = 0,varDims(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime,:,:) = var_tmp(it,:,:)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ do ifil = 1,numFiles-1
+ var_tmp = wrf_user_getvar(f[ifil],varin,-1)
+ dimLoop = dimsizes(var_tmp)
+ do it = 0,dimLoop(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime,:,:) = var_tmp(it,:,:)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ end do
+ end if
+ if ( varRank .eq. 2 )
+ varout = new ( (/numTimes,varDims(1)/), typeof(var_tmp) )
+ if ( typeof(var_tmp) .eq. "float" .or. typeof(var_tmp) .eq. "integer" ) then
+ varout = 0
+ end if
+ do it = 0,varDims(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime,:) = var_tmp(it,:)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ do ifil = 1,numFiles-1
+ var_tmp = wrf_user_getvar(f[ifil],varin,-1)
+ dimLoop = dimsizes(var_tmp)
+ do it = 0,dimLoop(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime,:) = var_tmp(it,:)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ end do
+ end if
+ if ( varRank .eq. 1 )
+ varout = new ( (/numTimes/), typeof(var_tmp) )
+ if ( typeof(var_tmp) .eq. "float" .or. typeof(var_tmp) .eq. "integer" ) then
+ varout = 0
+ end if
+ do it = 0,varDims(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime) = var_tmp(it)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ do ifil = 1,numFiles-1
+ var_tmp = wrf_user_getvar(f[ifil],varin,-1)
+ dimLoop = dimsizes(var_tmp)
+ do it = 0,dimLoop(0)-1
+ if ( (outtime_avail.eq.time_req) .and. (time_req.le.time_end) ) then
+ varout(outtime) = var_tmp(it)
+ outtime = outtime + 1
+ time_req = time_req + time_inc
+ end if
+ outtime_avail = outtime_avail + 1
+ end do
+ delete(var_tmp)
+ end do
+ end if
+
+ return(varout)
+ end
+
+
+
+
+ ;--------------------------------------------------------------------------------
+ ; This function was modified in May 2011 to allow a list of files.
+ ;
+ undef("wrf_user_list_times")
+ function wrf_user_list_times( nc_file )
+
+ local times, times_in_file, dims, i
+ begin
+
+ ;---As of NCL V6.0.0, wrf_user_getvar can now handle a file or a list of files.
+ if(all(typeof(nc_file).ne.(/"file","list"/))) then
+ print("wrf_user_list_times: error: the input argument must be a file or a list of files opened with addfile or addfiles")
+ return
+ end if
+
+ if(typeof(nc_file).eq."file") then
+ times_in_file = nc_file->Times
+ else
+ times_in_file = nc_file[:]->Times
+ end if
+ dims = dimsizes(times_in_file)
+ times = new(dims(0),string)
+ do i=0,dims(0)-1
+ times(i) = chartostring(times_in_file(i,:))
+ end do
+ times at description = "times in file"
+ print(times)
+ return(times)
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_user_latlon_to_ij")
+ function wrf_user_latlon_to_ij( nc_file:file, latitude:numeric,
+ longitude:numeric )
+
+ begin
+ WE = "WEST-EAST_GRID_DIMENSION"
+ SN = "SOUTH-NORTH_GRID_DIMENSION"
+ wedim = nc_file@$WE$
+ sndim = nc_file@$SN$
+
+ if(isfilevar(nc_file,"XLAT"))
+ XLAT = nc_file->XLAT(0,:,:)
+ XLONG = nc_file->XLONG(0,:,:)
+ else
+ XLAT = nc_file->XLAT_M(0,:,:)
+ XLONG = nc_file->XLONG_M(0,:,:)
+ end if
+
+ loc = wrf_latlon_to_ij( XLAT, XLONG, latitude, longitude )
+
+ loc!0 = "j & i locations"
+ return(loc)
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_user_ll_to_ij")
+ function wrf_user_ll_to_ij( file_handle, longitude:numeric, latitude:numeric,
+ opts_args:logical )
+
+ begin
+ ;
+ ; As of NCL V6.0.0, wrf_user_ll_to_ij can now handle a file
+ ; or a list of files.
+ ;
+ if(typeof(file_handle).eq."file") then
+ ISFILE = True
+ nc_file = file_handle
+ else if(typeof(file_handle).eq."list") then
+ ISFILE = False
+ nc_file = file_handle[0]
+ else
+ print("wrf_user_ll_to_ij: error: the first argument must be a file or a list of files opened with addfile or addfiles")
+ return
+ end if
+ end if
+
+ opts = opts_args
+ useT = get_res_value(opts,"useTime",0)
+ returnI= get_res_value(opts,"returnInt",True)
+
+ res = True
+ res at MAP_PROJ = nc_file at MAP_PROJ
+ res at TRUELAT1 = nc_file at TRUELAT1
+ res at TRUELAT2 = nc_file at TRUELAT2
+ res at STAND_LON = nc_file at STAND_LON
+ res at DX = nc_file at DX
+ res at DY = nc_file at DY
+
+ if (res at MAP_PROJ .eq. 6) then
+ res at POLE_LAT = nc_file at POLE_LAT
+ res at POLE_LON = nc_file at POLE_LON
+ res at LATINC = (res at DY*360.)/2.0/3.141592653589793/6370000.
+ res at LONINC = (res at DX*360.)/2.0/3.141592653589793/6370000.
+ else
+ res at POLE_LAT = 90.0
+ res at POLE_LON = 0.0
+ res at LATINC = 0.0
+ res at LONINC = 0.0
+ end if
+
+ if(isfilevar(nc_file,"XLAT"))
+ if(ISFILE) then
+ XLAT = nc_file->XLAT(useT,:,:)
+ XLONG = nc_file->XLONG(useT,:,:)
+ else
+ XLAT = file_handle[useT]->XLAT
+ XLONG = file_handle[useT]->XLONG
+ end if
+ else
+ if(ISFILE) then
+ XLAT = nc_file->XLAT_M(useT,:,:)
+ XLONG = nc_file->XLONG_M(useT,:,:)
+ else
+ XLAT = file_handle[useT]->XLAT_M
+ XLONG = file_handle[useT]->XLONG_M
+ end if
+ end if
+
+
+ if(dimsizes(dimsizes(XLAT)).eq.2) then
+ ; Rank 2
+ res at REF_LAT = XLAT(0,0)
+ res at REF_LON = XLONG(0,0)
+ else
+ ; Rank 3
+ res at REF_LAT = XLAT(0,0,0)
+ res at REF_LON = XLONG(0,0,0)
+ end if
+ res at KNOWNI = 1.0
+ res at KNOWNJ = 1.0
+
+ loc = wrf_ll_to_ij (longitude, latitude, res)
+
+ if ( returnI ) then
+ loci = new(dimsizes(loc),integer)
+ ;loci at _FillValue = default_fillvalue("integer") ; was -999
+ loci = tointeger(loc + .5)
+ loci!0 = loc!0
+ return(loci)
+ else
+ return(loc)
+ end if
+
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_user_ij_to_ll")
+ function wrf_user_ij_to_ll( file_handle, i:numeric, j:numeric,
+ opts_args:logical )
+
+ begin
+ ;
+ ; As of NCL V6.0.0, wrf_user_ll_to_ij can now handle a file
+ ; or a list of files.
+ ;
+ if(typeof(file_handle).eq."file") then
+ ISFILE = True
+ nc_file = file_handle
+ else if(typeof(file_handle).eq."list") then
+ ISFILE = False
+ nc_file = file_handle[0]
+ else
+ print("wrf_user_ij_to_ll: error: the first argument must be a file or a list of files opened with addfile or addfiles")
+ return
+ end if
+ end if
+
+ opts = opts_args
+ useT = get_res_value(opts,"useTime",0)
+
+ res = True
+ res at MAP_PROJ = nc_file at MAP_PROJ
+ res at TRUELAT1 = nc_file at TRUELAT1
+ res at TRUELAT2 = nc_file at TRUELAT2
+ res at STAND_LON = nc_file at STAND_LON
+ res at DX = nc_file at DX
+ res at DY = nc_file at DY
+
+ if (res at MAP_PROJ .eq. 6) then
+ res at POLE_LAT = nc_file at POLE_LAT
+ res at POLE_LON = nc_file at POLE_LON
+ res at LATINC = (res at DY*360.)/2.0/3.141592653589793/6370000.
+ res at LONINC = (res at DX*360.)/2.0/3.141592653589793/6370000.
+ else
+ res at POLE_LAT = 90.0
+ res at POLE_LON = 0.0
+ res at LATINC = 0.0
+ res at LONINC = 0.0
+ end if
+
+
+ if(isfilevar(nc_file,"XLAT")) then
+ if(ISFILE) then
+ XLAT = nc_file->XLAT(useT,:,:)
+ XLONG = nc_file->XLONG(useT,:,:)
+ else
+ XLAT = file_handle[useT]->XLAT
+ XLONG = file_handle[useT]->XLONG
+ end if
+ else
+ if(ISFILE) then
+ XLAT = nc_file->XLAT_M(useT,:,:)
+ XLONG = nc_file->XLONG_M(useT,:,:)
+ else
+ XLAT = file_handle[useT]->XLAT_M
+ XLONG = file_handle[useT]->XLONG_M
+ end if
+ end if
+
+ if(dimsizes(dimsizes(XLAT)).eq.2) then
+ ; Rank 2
+ res at REF_LAT = XLAT(0,0)
+ res at REF_LON = XLONG(0,0)
+ else
+ ; Rank 3
+ res at REF_LAT = XLAT(0,0,0)
+ res at REF_LON = XLONG(0,0,0)
+ end if
+ res at KNOWNI = 1.0
+ res at KNOWNJ = 1.0
+
+ loc = wrf_ij_to_ll (i,j,res)
+
+ return(loc)
+
+
+ end
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_user_vert_interp")
+ function wrf_user_vert_interp(file_handle,field:numeric,
+ vert_coordinate[1]:string,
+ interp_levels[*]:numeric,opts[1]:logical)
+ local valid_vert_coords, nc_file, valid_field_types
+ begin
+
+ valid_vert_coords = (/"pressure","pres","ght_msl","ght_agl","theta","theta-e"/)
+ if(.not.any(vert_coordinate.eq.valid_vert_coords)) then
+ print("wrf_user_vert_interp: Unrecognized vertical coordinate.")
+ print(" Accepted vertical coordinates are:")
+ print( "pressure, pres hPa")
+ print( "ght_msl km")
+ print( "ght_agl km")
+ print( "theta K")
+ print( "theta-e K")
+ exit
+ end if
+
+ if(typeof(file_handle).eq."file") then
+ ISFILE = True
+ nc_file = file_handle
+ else if(typeof(file_handle).eq."list") then
+ ISFILE = False
+ nc_file = file_handle[0]
+ else
+ print("wrf_user_vert_interp: error: the first argument must be a file or a list of files opened with addfile or addfiles")
+ return
+ end if
+ end if
+
+ rgas = 287.04 ;J/K/kg
+ ussalr = .0065 ; deg C per m
+ sclht = rgas*256./9.81
+
+ ;read grid sizes from the nc_file. Check to make
+ ;sure that we don't have a staggered field.
+ dNames = getvardims(nc_file)
+ dSizes = getfiledimsizes(nc_file)
+ thedims = dimsizes(dSizes)
+ number_dims = thedims(0)
+
+ ew = dSizes(ind(dNames .eq. "west_east"))
+ ns = dSizes(ind(dNames .eq. "south_north"))
+ nz = dSizes(ind(dNames .eq. "bottom_top"))
+
+ field_dims = dimsizes(field)
+ num_field_dims = dimsizes(field_dims)
+
+ if(num_field_dims .lt. 3 .or. num_field_dims .gt. 4) then
+ print("wrf_user_vert_interp: We can only interpolate a 3D or 4D field")
+ exit
+ end if
+
+ ; Check to see if the field comes in unstaggered.
+ if(field_dims(num_field_dims-3) .ne. nz) then
+ print("wrf_user_vert_interp: Please unstagger the field in the vertical")
+ exit
+ end if
+
+ if(field_dims(num_field_dims-2) .ne. ns .or.
+ field_dims(num_field_dims-1) .ne. ew) then
+ print("wrf_user_vert_interp: Please unstagger the field")
+ exit
+ end if
+
+ ; See what options we have
+ extrap_field = get_res_value_keep(opts,"extrapolate",False)
+ field_type = str_lower(get_res_value_keep(opts,"field_type","none"))
+ log_of_Pressure = get_res_value_keep(opts,"logP",False)
+ debug = get_res_value_keep(opts,"debug",False)
+
+ valid_field_types = (/"none","pressure","pres","p","z","t","ght"/)
+ if(.not.any(field_type.eq.valid_field_types)) then
+ print("wrf_user_vert_interp: Unrecognized field type.")
+ print("Valid field types are: " + str_join(valid_field_types,", "))
+ exit
+ end if
+
+ if(log_of_Pressure) then
+ logP = 1 ; this is for passing into Fortran
+ else
+ logP = 0
+ end if
+
+ icase = 0
+ extrap = 0 ; This is for passing into Fortran
+ if(extrap_field) then
+ extrap = 1
+ if(any(field_type .eq. (/"p","pres","pressure"/))) then
+ icase = 1
+ end if
+
+ if(field_type .eq. "z") then
+ icase = 2
+ end if
+
+ if(field_type .eq. "ght") then
+ icase = 2
+ end if
+ ;
+ ; For temperature we may have just temperature, potential temperature
+ ; or equivalent potential temperature. Check the field description attribute
+ ; to see which one we have.
+ ;
+ if(field_type .eq. "t") then
+ if(isatt(field,"description")) then
+
+ if(field at description .eq. "Temperature") then
+ if(field at units .eq. "C") then
+ icase = 3
+ else
+ icase = 4
+ end if
+ end if
+
+ if(field at description .eq. "Potential Temperature (theta) ") then
+ icase = 5
+ end if
+
+ if(field at description .eq. "Equivalent Potential Temperature") then
+ icase = 6
+ end if
+ end if ;the endif for checking for the field description attribute
+
+ end if;end if for the field_type being T or t
+
+
+ end if; the endif for extrap_field .eq. True
+
+
+ numlevels = dimsizes(interp_levels)
+
+ ;We will need some basic fields for the interpolation
+ ;regardless of the field requested. Get all time periods
+ ;of the fields.
+ if(ISFILE) then
+ P = nc_file->P + nc_file->PB
+ Pdims = dimsizes(P)
+ ght = wrf_user_getvar(nc_file,"height",-1)
+ tk = wrf_user_getvar(nc_file,"tk",-1)
+ qvp = nc_file->QVAPOR
+ terht = nc_file->HGT
+ sfp = nc_file->PSFC * 0.01
+ else
+ P = file_handle[:]->P + file_handle[:]->PB
+ Pdims = dimsizes(P)
+ tmpz = file_handle[:]->PH
+ PHB = file_handle[:]->PHB
+ tmpz = (tmpz + PHB)/9.81
+ ght = wrf_user_unstagger(tmpz,"Z")
+ T = file_handle[:]->T
+ T = T + 300.
+ tk = wrf_tk( P , T )
+ qvp = file_handle[:]->QVAPOR
+ terht = file_handle[:] ->HGT
+ sfp = file_handle[:] ->PSFC * 0.01
+ end if
+ smsfp = sfp
+ wrf_smooth_2d(smsfp,3)
+
+
+ ;Initialize an array for the vertical coordinate
+ ntimes = Pdims(0)
+
+ ;Get the vertical coordinate type
+ vcor = 0
+ logp = 0
+ if(any(vert_coordinate .eq. (/"pressure","pres"/))) then
+ vcor = 1
+ vcord_array = P * 0.01
+ end if
+
+ if(vert_coordinate .eq. "ght_msl") then
+ vcor = 2
+ vcord_array = exp(-ght/sclht)
+ end if
+
+ if(vert_coordinate .eq. "ght_agl") then
+ vcor = 3
+ rtemp = new( (/nz,ns,ew/),float)
+ vcord_array = new((/ntimes,nz,ns,ew/),float)
+ do it = 0, ntimes - 1
+ do ilev = 0,nz-1
+ rtemp(ilev,:,:) = ght(it,ilev,:,:) - terht(0,:,:)
+ end do
+ vcord_array(it,:,:,:) = exp(-rtemp/sclht)
+ end do
+ delete(rtemp)
+ end if
+
+ if(vert_coordinate .eq. "theta") then
+ vcor = 4
+ idir = 1
+ icorsw = 0
+ delta = 0.01
+ if(ISFILE) then
+ coriolis = nc_file->F(0,:,:)
+ theta = wrf_user_getvar(nc_file,"theta",-1)
+ else
+ coriolis = file_handle[0]->F(0,:,:)
+ theta = T
+ end if
+ preshPa = P * 0.01
+ vcord_array = wrf_monotonic(theta,preshPa,coriolis,idir,delta,icorsw)
+ ;
+ ; We only extrapolate temperature fields below ground if we are interpolating
+ ; to pressure or height vertical surfaces.
+ ;
+ icase = 0
+ end if
+
+ if(vert_coordinate .eq. "theta-e") then
+ vcor = 5
+ icorsw = 0
+ idir = 1
+ delta = 0.01
+ if(ISFILE) then
+ coriolis = nc_file->F(0,:,:)
+ eqpot = wrf_user_getvar(nc_file,"eth",-1)
+ else
+ coriolis = file_handle[0]->F(0,:,:)
+ eqpot = wrf_eth ( qvp, tk, P )
+ end if
+ preshPa = P * 0.01
+
+ vcord_array = wrf_monotonic(eqpot,preshPa,coriolis,idir,delta,icorsw)
+ ; We only extrapolate temperature fields below ground if we are interpolating
+ ; to pressure or height vertical surfaces.
+ icase = 0
+ end if
+
+ if(debug) then
+ print("icase = " + icase + " extrap = " + extrap + " vcor = " + vcor + " logP = " + logP)
+ end if
+
+ field_out = wrf_vintrp(field,P,tk,qvp,ght,terht(0,:,:),sfp,smsfp,
+ vcord_array,interp_levels,icase,extrap,vcor,logP)
+
+ ; Add metadata to return array
+ copy_VarMeta(field,field_out)
+
+ ; Add new levels as a coordinate array
+ lev_field = num_field_dims-3
+ field_out!lev_field = "interp_levels"
+ field_out&$field_out!lev_field$ = interp_levels(::-1)
+ field_out at vert_interp_type = vert_coordinate
+
+ return(field_out)
+ end
+
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+
+ undef("write_wrf_debug_info")
+ procedure write_wrf_debug_info(wks[1]:graphic,data1,data2,
+ debug_file[1]:string,
+ wrf_opts,wrf_func_name[1]:string)
+ ;
+ ; This procedure writes resources and data variables used to
+ ; create a WRF plot to a NetCDF file. This file can be read
+ ; in later to recreate the NCL script that created that plot,
+ ; using gsn_xxx functions. This is for debug purposes. You can't
+ ; tell what resources a WRF script is using, so this is a way
+ ; of seeing them all in a NetCDF file.
+ ;
+ begin
+ if(.not.isatt(wks,"WRFDebug")) then
+ first_time = True
+ wks at WRFDebug = True
+ else
+ first_time = False
+ end if
+ ;
+ ; The default will be "wrfdebug.ncl" and "wrfdebug.nc"
+ ; unless otherwise specified.
+ ;
+ cdf_debug_file = debug_file + ".nc"
+ ncl_debug_file = debug_file + ".ncl"
+ res_debug_file = debug_file + ".res"
+
+ ;
+ ; If this is the first time writing debug information to the file,
+ ; then create the file and add the first set of information.
+ ;
+ ; Make sure the files don't already exist.
+ ;
+ if(first_time) then
+ if(fileexists(cdf_debug_file).or.fileexists(ncl_debug_file).or.
+ fileexists(res_debug_file)) then
+ print("write_wrf_debug_info: error: debug files '" + cdf_debug_file + "',")
+ print("'" + ncl_debug_file + "' and/or " + res_debug_file + " exist.")
+ print("Please remove file(s) and start script again.")
+ exit
+ end if
+ dbgfile = addfile(cdf_debug_file,"c")
+ else
+ ;
+ ; If this is not the first time, open the file as read/write.
+ ;
+ dbgfile = addfile(cdf_debug_file,"w")
+ end if
+
+ ;
+ ; If this is not the first time, then we need to append the information.
+ ;
+ if(.not.first_time) then
+ ;
+ ; The variables should be wrf_var_1, wrf_var_2, etc. We need to get the
+ ; highest one already in use, so we can create the next highest one.
+ ;
+ wrf_debug_vars = getfilevarnames(dbgfile)
+ max_num = max(stringtointeger(str_get_field(wrf_debug_vars,3,"_"))) + 1
+ else
+ max_num = 1
+ end if
+
+ ; This will be name of the logical variable to hold all the resources
+ ; for this dataset.
+ wrf_res_name = "wrf_res_" + max_num
+
+ ;
+ ; Write the plot data to the netCDF file. If the data contains the
+ ; special 2D lat2d/lon2d arrays, we have to write these as 1D arrays
+ ; and reconstruct them as 2D later.
+ ;
+ if(typeof(data1).ne."logical".and.typeof(data2).eq."logical") then
+ ; For non u,v data
+ wrf_data_name = "wrf_data_" + max_num
+ add_latlon2d_debug_info(data1)
+ dbgfile->$wrf_data_name$ = (/data1/) ; Write the data
+ end if
+ if(typeof(data1).ne."logical".and.typeof(data2).ne."logical") then
+ ; For u,v data
+ add_latlon2d_debug_info(data1)
+ add_latlon2d_debug_info(data2)
+ wrf_data_name = "wrf_udata_" + max_num
+ dbgfile->$wrf_data_name$ = (/data1/) ; Write the U data
+ wrf_data_name = "wrf_vdata_" + max_num
+ dbgfile->$wrf_data_name$ = (/data2/) ; Write the V data
+ end if
+
+ ; Retain the name of the wrf function that called this routine.
+ tmp = "wrf_func_name_" + max_num
+ dbgfile@$tmp$ = wrf_func_name
+
+ ;
+ ; Get plot resources, if any.
+ ;
+ wattnames = getvaratts(wrf_opts)
+ if(.not.any(ismissing(wattnames))) then
+ natt = dimsizes(wattnames)
+ else
+ natt = 0
+ end if
+
+ ;
+ ; Check if any of the plot attributes are ones that can contain
+ ; big data arrays, like sfXArray, vfYArray, etc.
+ ;
+ ; If so, then write these to the netCDF file. Otherwise, write them
+ ; to the file as attributes.
+ ;
+ array_resources = (/"sfXArray","sfYArray","vfXArray","vfYArray"/)
+
+ if(natt.gt.0) then
+ tmp_opts = 1
+ do i=0,natt-1
+ if(any(wattnames(i).eq.array_resources)) then
+ tmp = "wrf_data_coord_name_" + wattnames(i) + "_" + max_num
+ dbgfile->$tmp$ = wrf_opts@$wattnames(i)$
+ else
+ ; Can't write "logical" to a NetCDF file.
+ if(typeof(wrf_opts@$wattnames(i)$).eq."logical") then
+ if(wrf_opts@$wattnames(i)$) then
+ tmp_opts@$wattnames(i)$ = 1
+ else
+ tmp_opts@$wattnames(i)$ = 0
+ end if
+ else
+ ; Just write the resource.
+ tmp_opts@$wattnames(i)$ = wrf_opts@$wattnames(i)$
+ end if
+ end if
+ end do
+ dbgfile->$wrf_res_name$ = tmp_opts
+ end if
+
+ ; Close the NetCDF file
+ delete(dbgfile)
+ end
+
+ undef("write_wrf_debug_script")
+ procedure write_wrf_debug_script(wks,debug_file,wrf_func_name)
+ begin
+ dbgfile = addfile(debug_file+".nc","r")
+ print(getvaratts(dbgfile))
+ end
+
+ undef("delete_attrs")
+ procedure delete_attrs(opts:logical)
+
+ ; This procedure does some cleanup by removing unneeded attributes
+ ; so they don't get passed to other routines by accident.
+
+ begin
+ list_attrs = (/"MainTitle","MainTitlePos","MainTitlePosF",
+ "InitTime","ValidTime","TimePos","TimePosF",
+ "NoHeaderFooter","TimeLabel","LevelLabel",
+ "FieldTitle","UnitLabel","NumVectors","AspectRatio",
+ "SubFieldTitle","PlotOrientation","PlotLevelID",
+ "mpNestTime","ContourParameters","FontHeightF","Footer",
+ "start_lat","start_lon","end_lat","end_lon",
+ "proj","map_proj","stand_lon","truelat1","truelat2","cenlat",
+ "pole_lat","pole_lon","ref_lat","ref_lon","ref_x","ref_y",
+ "e_we","e_sn","parent_id","parent_grid_ratio",
+ "i_parent_start","j_parent_start",
+ "dx","dy","max_dom"
+ /)
+
+ do i=0,dimsizes(list_attrs)-1
+ if(isatt(opts,list_attrs(i))) then
+ delete(opts@$list_attrs(i)$)
+ end if
+ end do
+ end
+
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ undef("set_cn_resources")
+ function set_cn_resources (data[*][*]:numeric, res:logical)
+
+ begin
+
+ opts = res
+
+ ; The ContourParameters resource can either be a scalar that
+ ; represents the contour level spacing, or it can be an array
+ ; of three elements that represent the minimum level, the maximum
+ ; level, and the level spacing.
+ ;
+ mx = max(data)
+ mn = min(data)
+
+ if(mn.ne.mx.and.opts.and.isatt(opts,"ContourParameters")) then
+ if(dimsizes(opts at ContourParameters) .eq. 1) then
+
+ ; Only the contour interval is specified.
+ nlev = tointeger((mx-mn)/opts at ContourParameters)+1
+ levels = nice_mnmxintvl(mn,mx,nlev,True)
+ if(levels(0) .lt. 0.) then
+ ; Set a zero contour.
+ nlev = tointeger(levels(0)/opts at ContourParameters) - 1
+ levels(0) = nlev*opts at ContourParameters
+ end if
+ nlev = tointeger((levels(1)-levels(0))/opts at ContourParameters)+1
+ levels(1) = levels(0) + nlev*opts at ContourParameters
+ levels(2) = opts at ContourParameters
+
+ ; Min level, max level, and level spacing are specified by user.
+ else
+ if(dimsizes(opts at ContourParameters) .eq. 3) then
+ levels = opts at ContourParameters
+ else
+ print("wrf_contour: Warning: illegal setting for ContourParameters attribute")
+ end if
+ end if
+
+ end if
+
+ ; Contour levels
+ if(isvar("levels")) then
+ opts at cnLevelSelectionMode = get_res_value_keep(opts, "cnLevelSelectionMode", "ManualLevels")
+ opts at cnMinLevelValF = get_res_value_keep(opts, "cnMinLevelValF", levels(0))
+ opts at cnMaxLevelValF = get_res_value_keep(opts, "cnMaxLevelValF", levels(1))
+ opts at cnLevelSpacingF = get_res_value_keep(opts, "cnLevelSpacingF",levels(2))
+ delete(levels)
+ end if
+
+
+ ; Set the default zero line thickness to 2, and the negative contour
+ ; line dash pattern to 1 (0 is solid).
+ opts at gsnContourZeroLineThicknessF = get_res_value_keep(opts, "gsnContourZeroLineThicknessF",2.0)
+ opts at gsnContourNegLineDashPattern = get_res_value_keep(opts, "gsnContourNegLineDashPattern",1)
+
+
+ ; Set resources that apply for both filled and line contour plots.
+ opts at cnFillDrawOrder = get_res_value_keep(opts,"cnFillDrawOrder", "PreDraw")
+
+
+ opts at cnLineLabelAngleF = get_res_value_keep(opts,"cnLineLabelAngleF", 0.0)
+ opts at cnLineLabelFontHeightF = get_res_value_keep(opts,"cnLineLabelFontHeightF", 0.015)
+ opts at cnInfoLabelFontHeightF = get_res_value_keep(opts,"cnInfoLabelFontHeightF", 0.015)
+ opts at cnLineLabelPerimOn = get_res_value_keep(opts,"cnLineLabelPerimOn", True)
+ opts at cnInfoLabelPerimOn = get_res_value_keep(opts,"cnInfoLabelPerimOn", False)
+ opts at cnLineLabelBackgroundColor = get_res_value_keep(opts,"cnLineLabelBackgroundColor", -1)
+ opts at cnHighLabelBackgroundColor = get_res_value_keep(opts,"cnHighLabelBackgroundColor", -1)
+ opts at cnLowLabelBackgroundColor = get_res_value_keep(opts,"cnLowLabelBackgroundColor", -1)
+ opts at cnLineColor = get_res_value_keep(opts,"cnLineColor", "Black")
+ opts at cnLineLabelFontColor = opts at cnLineColor
+ opts at cnLineLabelPerimColor = opts at cnLineColor
+ opts at cnInfoLabelFontColor = opts at cnLineColor
+ opts at cnHighLabelFontColor = opts at cnLineColor
+ opts at cnLowLabelFontColor = opts at cnLineColor
+
+
+ ; Set field Title and levels if available
+ if(.not.isatt(opts,"cnInfoLabelString")) then
+ info_string = " Contours: $CMN$ to $CMX$ by $CIU$"
+ if(isatt(opts,"FieldTitle")) then
+ opts at cnInfoLabelString = opts at FieldTitle + info_string
+ else if(isatt(data,"description")) then
+ opts at cnInfoLabelString = data at description + info_string
+ else
+ opts at cnInfoLabelString = info_string
+ end if
+ end if
+ end if
+
+
+ return(opts)
+ end
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ undef("set_lb_resources")
+ function set_lb_resources (data[*][*]:numeric, res:logical)
+
+ begin
+
+ opts = res
+
+
+ ; Somewhat convoluted way to see if a labelbar is not desired.
+ if(check_attr(opts,"pmTickMarkDisplayMode","Never",True).or.
+ check_attr(opts,"pmTickMarkDisplayMode",-1,False).or.
+ check_attr(opts,"pmTickMarkDisplayMode",0,False).or.
+ check_attr(opts,"lbLabelBarOn",False,False).or.
+ check_attr(opts,"lbLabelBarOn",0,False)) then
+ lbar_on = False
+ else
+ lbar_on = True
+ end if
+ atmp = get_res_value(opts,"lbLabelBarOn",True) ; Remove this resource
+ delete(atmp) ; just in case.
+
+
+ ; Possible title for the labelbar
+ if(isatt(opts,"FieldTitle")) then
+ lb_desc = opts at FieldTitle
+ else
+ if(isatt(data,"description")) then
+ lb_desc = data at description
+ else
+ lb_desc = ""
+ end if
+ end if
+
+ if(isatt(opts,"UnitLabel") ) then
+ lb_desc = lb_desc + " (" + opts at UnitLabel + ")"
+ else
+ if(isatt(data,"units") .and. .not.(data at units.eq."")) then
+ lb_desc = lb_desc + " (" + data at units + ")"
+ end if
+ end if
+
+
+ if(.not.isatt(opts,"cnFillColors")) then
+ opts at gsnSpreadColors = get_res_value_keep(opts, "gsnSpreadColors", True)
+ end if
+ opts at cnInfoLabelOn = get_res_value_keep(opts,"cnInfoLabelOn", False)
+ opts at cnLinesOn = get_res_value_keep(opts,"cnLinesOn", False)
+ opts at cnLineLabelsOn = get_res_value_keep(opts,"cnLineLabelsOn", False)
+
+ ; Labelbar resources
+ if(lbar_on) then
+ opts at pmLabelBarDisplayMode = get_res_value_keep(opts,"pmLabelBarDisplayMode", "Always")
+ opts at pmLabelBarSide = get_res_value_keep(opts,"pmLabelBarSide", "Bottom")
+ opts at lbAutoManage = get_res_value_keep(opts,"lbAutoManage",False)
+ opts at lbOrientation = get_res_value_keep(opts,"lbOrientation", "Horizontal")
+ opts at lbPerimOn = get_res_value_keep(opts,"lbPerimOn", False)
+ opts at lbLabelJust = get_res_value_keep(opts,"lbLabelJust", "BottomCenter")
+ opts at lbLabelAutoStride = get_res_value_keep(opts,"lbLabelAutoStride",True)
+ opts at lbBoxMinorExtentF = get_res_value_keep(opts,"lbBoxMinorExtentF", 0.13)
+ opts at lbTitleFontHeightF = get_res_value_keep(opts,"lbTitleFontHeightF", 0.015)
+ opts at lbLabelFontHeightF = get_res_value_keep(opts,"lbLabelFontHeightF", 0.015)
+ opts at pmLabelBarOrthogonalPosF = get_res_value_keep(opts,"pmLabelBarOrthogonalPosF", -0.1)
+
+ opts at lbTitleOn = get_res_value_keep(opts,"lbTitleOn", True)
+ if(lb_desc.ne."" .and. opts at lbTitleOn) then
+ opts at lbTitleOn = get_res_value_keep(opts,"lbTitleOn", True)
+ opts at lbTitleString = get_res_value_keep(opts,"lbTitleString", lb_desc)
+ opts at lbTitleJust = get_res_value_keep(opts,"lbTitleJust", "BottomCenter")
+ opts at lbTitleOffsetF = get_res_value_keep(opts,"lbTitleOffsetF", -0.5)
+ else
+ opts at lbTitleOn = False
+ end if
+ end if
+
+
+ return(opts)
+ end
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ undef("set_title_resources")
+ function set_title_resources (data[*][*]:numeric, res:logical)
+
+ begin
+
+ opts = res
+
+ ; Set field Title and levels if available
+ if(isatt(opts,"FieldTitle")) then
+ SubTitles = opts at FieldTitle
+ else
+ if(isatt(data,"description")) then
+ SubTitles = data at description
+ else
+ SubTitles = "UnKnown"
+ end if
+ end if
+
+ if(isatt(opts,"SubFieldTitle")) then
+ SubTitles = SubTitles + " " + opts at SubFieldTitle
+ end if
+ if(isatt(opts,"UnitLabel")) then
+ SubTitles = SubTitles + " (" + opts at UnitLabel + ")"
+ else
+ if(isatt(data,"units") .and. .not.(data at units.eq."")) then
+ SubTitles = SubTitles + " (" + data at units + ")"
+ end if
+ end if
+ if (isatt(opts,"PlotLevelID")) then
+ SubTitles = SubTitles + " at " + opts at PlotLevelID
+ else
+ if (isatt(data,"PlotLevelID")) then
+ SubTitles = SubTitles + " at " + data at PlotLevelID
+ end if
+ end if
+ opts at tiMainString = SubTitles
+
+ return(opts)
+ end
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ undef("set_vc_resources")
+ function set_vc_resources (res:logical)
+
+ begin
+
+ opts = res
+
+ if ( isatt(opts,"vpWidthF") ) then
+ ; num_vectors is used for vcMinDistanceF and vcRefLengthF
+ width = opts at vpWidthF
+ num_vectors = get_res_value(opts,"NumVectors",25.0)
+ opts at vcMinDistanceF = get_res_value_keep(opts,"vcMinDistanceF", width/num_vectors)
+ opts at vcRefLengthF = get_res_value_keep(opts,"vcRefLengthF", width/num_vectors)
+ else
+ opts at vcMinDistanceF = get_res_value_keep(opts,"vcMinDistanceF", 0.02)
+ opts at vcRefLengthF = get_res_value_keep(opts,"vcRefLengthF", 0.02)
+ end if
+
+
+ opts at vcGlyphStyle = get_res_value_keep(opts,"vcGlyphStyle", "WindBarb")
+ opts at vcWindBarbColor = get_res_value_keep(opts,"vcWindBarbColor", "Black")
+ opts at vcRefAnnoOn = get_res_value_keep(opts,"vcRefAnnoOn", False)
+ opts at vcMinFracLengthF = get_res_value_keep(opts,"vcMinFracLengthF", .2)
+
+ return(opts)
+ end
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ undef("set_mp_resources")
+ function set_mp_resources (res:logical)
+
+ begin
+
+ opts = res
+
+ ; "LowRes" is the default that NCL uses, so you don't need to
+ ; set it here. However, if you want a higher resolution, use
+ ; "MediumRes". If you want higher resolution for the coastlines,
+ ; then set it to "HighRes", but then you also need to download
+ ; the RANGS-GSHHS database. Higher resolutions take longer to
+ ; draw.
+
+ opts at mpDataBaseVersion = get_res_value_keep(opts, "mpDataBaseVersion","MediumRes")
+ ;opts at mpOutlineBoundarySets = get_res_value_keep(opts, "mpOutlineBoundarySets", "AllBoundaries")
+ opts at mpOutlineBoundarySets = get_res_value_keep(opts, "mpOutlineBoundarySets", "GeophysicalAndUSStates")
+ opts at mpPerimLineThicknessF = get_res_value_keep(opts, "mpPerimLineThicknessF", 1.0)
+ opts at tmXBLabelFontHeightF = get_res_value_keep(opts, "tmXBLabelFontHeightF", 0.01)
+ opts at tmYLLabelFontHeightF = get_res_value_keep(opts, "tmYLLabelFontHeightF", 0.01)
+
+ ; Select portion of the map to view.
+ opts at mpLimitMode = get_res_value_keep(opts, "mpLimitMode","Corners")
+ opts at mpLeftCornerLatF = get_res_value_keep(opts, "mpLeftCornerLatF", opts at start_lat)
+ opts at mpLeftCornerLonF = get_res_value_keep(opts, "mpLeftCornerLonF", opts at start_lon)
+ opts at mpRightCornerLatF = get_res_value_keep(opts, "mpRightCornerLatF",opts at end_lat)
+ opts at mpRightCornerLonF = get_res_value_keep(opts, "mpRightCornerLonF",opts at end_lon)
+
+ if ( opts at mpRightCornerLonF .lt. 0.0 ) then
+ opts at mpRightCornerLonF = opts at mpRightCornerLonF + 360.0
+ end if
+
+ ; Set some other resources for line colors and grid spacing.
+
+ opts at mpGeophysicalLineColor = get_res_value_keep(opts, "mpGeophysicalLineColor","Gray")
+ opts at mpGeophysicalLineThicknessF = get_res_value_keep(opts, "mpGeophysicalLineThicknessF",0.5)
+ opts at mpGridLineColor = get_res_value_keep(opts, "mpGridLineColor","Gray")
+ opts at mpGridLineThicknessF = get_res_value_keep(opts, "mpGridLineThicknessF",0.5)
+ ;opts at mpGridMaskMode = get_res_value_keep(opts, "mpGridMaskMode",3)
+ opts at mpGridSpacingF = get_res_value_keep(opts, "mpGridSpacingF",5)
+ opts at mpLimbLineColor = get_res_value_keep(opts, "mpLimbLineColor","Gray")
+ opts at mpLimbLineThicknessF = get_res_value_keep(opts, "mpLimbLineThicknessF",0.5)
+ opts at mpNationalLineColor = get_res_value_keep(opts, "mpNationalLineColor","Gray")
+ opts at mpNationalLineThicknessF = get_res_value_keep(opts, "mpNationalLineThicknessF",0.5)
+ opts at mpPerimLineColor = get_res_value_keep(opts, "mpPerimLineColor","Gray")
+ opts at mpPerimOn = get_res_value_keep(opts, "mpPerimOn",True)
+ opts at mpUSStateLineColor = get_res_value_keep(opts, "mpUSStateLineColor","Gray")
+ opts at mpUSStateLineThicknessF = get_res_value_keep(opts, "mpUSStateLineThicknessF",0.5)
+ opts at pmTickMarkDisplayMode = get_res_value_keep(opts, "pmTickMarkDisplayMode","Always")
+
+ ; Tick mark resources
+
+ ;opts at tmXBMajorLengthF = get_res_value(opts, "tmXBMajorLengthF",-0.03)
+ ;opts at tmYLMajorLengthF = get_res_value(opts, "tmYLMajorLengthF",-0.03)
+ opts at tmXTOn = get_res_value(opts,"tmXTOn",False)
+ opts at tmYROn = get_res_value(opts,"tmYROn",False)
+ opts at tmYRLabelsOn = get_res_value(opts,"tmYRLabelsOn",True)
+ opts at tmXBBorderOn = get_res_value(opts,"tmXBBorderOn",True)
+ opts at tmXTBorderOn = get_res_value(opts,"tmXTBorderOn",True)
+ opts at tmYLBorderOn = get_res_value(opts,"tmYLBorderOn",True)
+ opts at tmYRBorderOn = get_res_value(opts,"tmYRBorderOn",True)
+
+ return(opts)
+ end
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+
+ undef("_SetMainTitle")
+ procedure _SetMainTitle(nc_file:file,wks[1]:graphic,cn[1]:graphic,opts)
+
+ ; This procedure checks the input data for certain attributes, and
+ ; based on those, sets MainTitle, InitTime and ValidTime
+ ;
+ ; Attributes recognized by this procedure:
+ ; MainTitle (main title - top left)
+ ; (with Init time top right)
+ ; TimeLabel (valid time - right under init time)
+ ; NoHeaderFooter (switch all headers and footers off - mainly for panels)
+ ;
+ ; If the "NoHeaderFooter" attribute exists and is set True, then
+ ; don't create any titles.
+
+ begin
+ ;
+ if(opts.and.isatt(opts,"NoHeaderFooter").and.opts at NoHeaderFooter) then
+ return
+ end if
+
+ ;
+ ; Set basic plot font
+ ;
+ font_height = get_res_value_keep(opts,"FontHeightF",0.01)
+ ;
+ ;
+ ; If a MainTitle attribute hasn't been set, then set to "WRF"
+ ; Also set an Initial time
+ ;
+ ; MAIN Header of plot
+ opts at MainTitle = get_res_value_keep(opts,"MainTitle", " ")
+ opts at MainTitlePos = get_res_value_keep(opts,"MainTitlePos", "Left")
+ opts at InitTime = get_res_value_keep(opts,"InitTime", True)
+ opts at ValidTime = get_res_value_keep(opts,"ValidTime", True)
+ opts at TimePos = get_res_value_keep(opts,"TimePos", "Right")
+ opts at Footer = get_res_value_keep(opts,"Footer", True)
+
+
+ if (opts at MainTitlePos .eq. "Left")
+ opts at MainTitlePos = "CenterLeft"
+ opts at MainTitlePosF = 0.0
+ end if
+ if (opts at MainTitlePos .eq. "Center")
+ opts at MainTitlePos = "CenterCenter"
+ opts at MainTitlePosF = 0.5
+ end if
+ if (opts at MainTitlePos .eq. "Right")
+ opts at MainTitlePos = "CenterRight"
+ opts at MainTitlePosF = 1.0
+ end if
+
+ if (opts at TimePos .eq. "Left")
+ MTOPosF = 0.30
+ else
+ MTOPosF = 0.20
+ end if
+
+ txt0 = create "MainPlotTitle" textItemClass wks
+ "txString" : opts at MainTitle
+ "txFontHeightF" : font_height*1.5
+ end create
+ anno = NhlAddAnnotation(cn,txt0)
+ setvalues anno
+ "amZone" : 3
+ "amSide" : "Top"
+ "amJust" : opts at MainTitlePos
+ "amParallelPosF" : opts at MainTitlePosF
+ "amOrthogonalPosF" : MTOPosF
+ "amResizeNotify" : False
+ end setvalues
+
+ ; Time information on plot
+ if (opts at TimePos .eq. "Left")
+ opts at TimePos = "CenterLeft"
+ opts at TimePosF = 0.0
+ if (opts at MainTitlePos .eq. "CenterLeft")
+ MTOPosF = MTOPosF - 0.05
+ end if
+ end if
+ if (opts at TimePos .eq. "Right")
+ opts at TimePos = "CenterRight"
+ opts at TimePosF = 1.0
+ if (opts at MainTitlePos .eq. "CenterRight")
+ MTOPosF = MTOPosF - 0.05
+ end if
+ end if
+
+ if( isatt(nc_file,"START_DATE") ) then
+ model_start_time = nc_file at START_DATE
+ else
+ if( isatt(nc_file,"SIMULATION_START_DATE") ) then
+ model_start_time = nc_file at SIMULATION_START_DATE
+ else
+ opts at InitTime = False
+ end if
+ end if
+ if( opts at InitTime ) then
+ InitTime = "Init: " + model_start_time
+ txt1 = create "InitTime" textItemClass wks
+ "txString" : InitTime
+ "txFontHeightF" : font_height
+ end create
+ anno = NhlAddAnnotation(cn,txt1)
+ setvalues anno
+ "amZone" : 3
+ "amSide" : "Top"
+ "amJust" : opts at TimePos
+ "amParallelPosF" : opts at TimePosF
+ "amOrthogonalPosF" : MTOPosF
+ "amResizeNotify" : False
+ end setvalues
+ end if
+
+ plot_narrow = False
+ if((opts).and.(isatt(opts,"vpWidthF")).and.(isatt(opts,"vpHeightF"))) then
+ ph = opts at vpHeightF
+ pw = opts at vpWidthF
+ phw = ph/pw
+ if ( phw .gt. 1.8 ) then
+ plot_narrow = True
+ end if
+ end if
+
+ if( opts at ValidTime .and. isatt(opts,"TimeLabel") ) then
+
+ ValidTime = "Valid: " + opts at TimeLabel
+
+ MTOPosF = MTOPosF - 0.03
+ txt2 = create "ValidTime" textItemClass wks
+ "txString" : ValidTime
+ "txFontHeightF" : font_height
+ end create
+ anno = NhlAddAnnotation(cn,txt2)
+ setvalues anno
+ "amZone" : 3
+ "amSide" : "Top"
+ "amJust" : opts at TimePos
+ "amParallelPosF" : opts at TimePosF
+ "amOrthogonalPosF" : MTOPosF
+ "amResizeNotify" : False
+ end setvalues
+ end if
+
+
+ ; Add Footer if called for
+ if( opts at Footer ) then
+ footer1 = nc_file at TITLE
+ dis = nc_file at DX / 1000.0
+ WE = "WEST-EAST_GRID_DIMENSION"
+ SN = "SOUTH-NORTH_GRID_DIMENSION"
+ BT = "BOTTOM-TOP_GRID_DIMENSION"
+ footer2 = " WE = " + nc_file@$WE$ +
+ " ; SN = " + nc_file@$SN$ +
+ " ; Levels = " + nc_file@$BT$ +
+ " ; Dis = " + dis + "km"
+ if ( isatt(nc_file,"MP_PHYSICS")) then
+ footer2 = footer2 + " ; Phys Opt = " + nc_file at MP_PHYSICS
+ end if
+ if ( isatt(nc_file,"BL_PBL_PHYSICS")) then
+ footer2 = footer2 + " ; PBL Opt = " + nc_file at BL_PBL_PHYSICS
+ end if
+ if ( isatt(nc_file,"CU_PHYSICS")) then
+ footer2 = footer2 + " ; Cu Opt = " + nc_file at CU_PHYSICS
+ end if
+ Footer = footer1 + "~C~" + footer2
+ else
+ Footer = " "
+ end if
+ txt3 = create "Footer" textItemClass wks
+ "txString" : Footer
+ "txFontHeightF" : font_height*.9
+ end create
+ anno = NhlAddAnnotation(cn,txt3)
+ setvalues anno
+ "amZone" : 1
+ ; "amZone" : 7
+ "amJust" : "TopLeft"
+ "amSide" : "Bottom"
+ "amParallelPosF" : 0.0
+ "amOrthogonalPosF" : -0.55
+ "amResizeNotify" : False
+ end setvalues
+
+
+ ; Add X-setion information if needed
+ if(opts.and.isatt(opts,"PlotOrientation")) then
+ ;Xsection = "Cross-Section Orientation : " + opts at PlotOrientation
+ Xsection = opts at PlotOrientation
+ txt4 = create "Xsection" textItemClass wks
+ "txString" : Xsection
+ "txFontHeightF" : font_height*.9
+ end create
+ anno = NhlAddAnnotation(cn,txt4)
+ setvalues anno
+ "amZone" : 3
+ "amSide" : "Top"
+ "amJust" : "CenterRight"
+ "amParallelPosF" : 1.0
+ "amOrthogonalPosF" : 0.005
+ "amResizeNotify" : False
+ end setvalues
+ end if
+
+ end
+
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ ;--------------------------------------------------------------------------------
+ undef("set_mp_wrf_map_resources")
+ function set_mp_wrf_map_resources(in_file[1]:file,opt_args[1]:logical)
+
+ begin
+ ;
+ opts = opt_args ; Make a copy of the resource list
+
+ ; Set some resources depending on what kind of map projection is
+ ; chosen.
+ ;
+ ; MAP_PROJ = 0 : "CylindricalEquidistant"
+ ; MAP_PROJ = 1 : "LambertConformal"
+ ; MAP_PROJ = 2 : "Stereographic"
+ ; MAP_PROJ = 3 : "Mercator"
+ ; MAP_PROJ = 6 : "Lat/Lon"
+
+ if(isatt(in_file,"MAP_PROJ"))
+
+ ; CylindricalEquidistant
+ if(in_file at MAP_PROJ .eq. 0)
+ projection = "CylindricalEquidistant"
+ opts at mpProjection = projection
+ opts at mpGridSpacingF = 45
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 0.0)
+ if(isatt(in_file,"STAND_LON"))
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; LambertConformal projection
+ if(in_file at MAP_PROJ .eq. 1)
+ projection = "LambertConformal"
+ opts at mpProjection = projection
+ opts at mpLambertParallel1F = get_res_value_keep(opts, "mpLambertParallel1F",in_file at TRUELAT1)
+ opts at mpLambertParallel2F = get_res_value_keep(opts, "mpLambertParallel2F",in_file at TRUELAT2)
+ if(isatt(in_file,"STAND_LON"))
+ opts at mpLambertMeridianF = get_res_value_keep(opts, "mpLambertMeridianF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ opts at mpLambertMeridianF = get_res_value_keep(opts, "mpLambertMeridianF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; Stereographic projection
+ if(in_file at MAP_PROJ .eq. 2)
+ projection = "Stereographic"
+ opts at mpProjection = projection
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", in_file at CEN_LAT)
+ if(isatt(in_file,"STAND_LON"))
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; Mercator projection
+ if(in_file at MAP_PROJ .eq. 3)
+ projection = "Mercator"
+ opts at mpProjection = projection
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 0.0)
+ if(isatt(in_file,"STAND_LON"))
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; global WRF CylindricalEquidistant
+ if(in_file at MAP_PROJ .eq. 6)
+ projection = "CylindricalEquidistant"
+ opts at mpProjection = projection
+ opts at mpGridSpacingF = 45
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",in_file at CEN_LON)
+ if( isatt(in_file,"POLE_LAT") ) then
+ opts at mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF", 90.0 - in_file at POLE_LAT)
+ delete(opts at mpCenterLonF)
+ calcen = -190.
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF", calcen )
+ end if
+ end if
+
+ end if
+
+ return(opts) ; Return.
+
+ end
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_contour_ps")
+ function wrf_contour_ps(nc_file:file,wks[1]: graphic, data[*][*]:numeric,
+ opt_args[1]:logical)
+
+ begin
+
+ callFrame = True
+ if ( isatt(opt_args,"FrameIT") ) then
+ if ( .not.opt_args at FrameIT ) then
+ callFrame = False
+ end if
+ delete (opt_args at FrameIT)
+ end if
+
+ lat2U = nc_file->XLAT_U(0,:,:)
+ lon2U = nc_file->XLONG_U(0,:,:)
+
+ opts = opt_args
+ opts at sfXArray = lon2U
+ opts at sfYArray = lat2U
+ opts at sfDataArray = data
+ opts at mpProjection = "Stereographic"
+ opts at mpEllipticalBoundary = True
+ opts at mpFillOn = False
+
+ opts at mpGeophysicalLineColor = get_res_value_keep(opts, "mpGeophysicalLineColor","Gray")
+ opts at mpGeophysicalLineThicknessF = get_res_value_keep(opts, "mpGeophysicalLineThicknessF",2.0)
+
+
+ ; Set the contour resources
+ opts = set_cn_resources(data,opts)
+ opts at cnInfoLabelFontHeightF = 0.012
+ opts at cnLineLabelPerimOn = False
+ opts at cnInfoLabelPerimOn = True
+
+
+ ; Find out if we are working with a contour or a shaded plot
+ ; fill_on = False : line contour plot
+ ; fill_on = True : filled contour plot
+ fill_on = get_res_value_keep(opts,"cnFillOn",False)
+ if(fill_on) then ; set lb resources if needed
+ opts at pmLabelBarDisplayMode = get_res_value_keep(opts,"pmLabelBarDisplayMode", "Never")
+ opts = set_lb_resources(data,opts)
+ opts at pmLabelBarOrthogonalPosF = 0.0
+ opts at lbTitleJust = "BottomLeft"
+ end if
+
+
+
+ opts at gsnDraw = False
+ opts at gsnFrame = False
+ opts at gsnMaximize = False
+ delete_attrs(opts)
+ cn = gsn_csm_contour_map_polar(wks,data,opts) ; Create the plot.
+
+ draw(cn)
+
+
+ if ( callFrame ) then
+ frame(wks)
+ end if
+
+ return (cn)
+ end
+ ;--------------------------------------------------------------------------------
+ undef("wrf_vector_ps")
+ function wrf_vector_ps(nc_file:file,wks[1]: graphic,
+ data_u[*][*]:numeric, data_v[*][*]:numeric,
+ opt_args[1]:logical)
+
+ begin
+
+ callFrame = True
+ if ( isatt(opt_args,"FrameIT") ) then
+ if ( .not.opt_args at FrameIT ) then
+ callFrame = False
+ end if
+ delete (opt_args at FrameIT)
+ end if
+
+ if(isfilevar(nc_file,"XLAT"))
+ lat2T = nc_file->XLAT(0,:,:)
+ lon2T = nc_file->XLONG(0,:,:)
+ else
+ lat2T = nc_file->XLAT_M(0,:,:)
+ lon2T = nc_file->XLONG_M(0,:,:)
+ end if
+
+ opts = opt_args
+ opts at vfXArray = lon2T
+ opts at vfYArray = lat2T
+ opts at vfUDataArray = data_u
+ opts at vfVDataArray = data_v
+ opts at mpProjection = "Stereographic"
+ opts at mpEllipticalBoundary = True
+ opts at mpFillOn = False
+
+ opts at mpGeophysicalLineColor = get_res_value_keep(opts, "mpGeophysicalLineColor","Gray")
+ opts at mpGeophysicalLineThicknessF = get_res_value_keep(opts, "mpGeophysicalLineThicknessF",2.0)
+
+
+ ; Set vector resources
+ opts = set_vc_resources(opts)
+
+
+ opts at gsnDraw = False
+ opts at gsnFrame = False
+ opts at gsnMaximize = False
+ delete_attrs(opts)
+ cn = gsn_csm_vector_map_polar(wks,data_u,data_v,opts) ; Create the plot.
+
+ draw(cn)
+
+
+ if ( callFrame ) then
+ frame(wks)
+ end if
+
+ return (cn)
+ end
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_contour")
+ function wrf_contour(nc_file:file,wks[1]: graphic, data[*][*]:numeric,
+ opt_args[1]:logical)
+
+ ; This function creates a contour plot and adds some titles to it.
+ ;
+ ; 1. Determine width to height ratio of plot.
+ ;
+ ; 2. First determine if this is to be a filled or line
+ ; contour plot (fill_on)
+ ;
+ ; 3. If the ContourParameters attribute is set, then calculate
+ ; the contour levels.
+ ;
+ ; 4. Set two resources for setting the zero contour line to
+ ; a larger thickness, and for changing the negative contour
+ ; lines to a dashed pattern.
+ ;
+ ; 5. If doing a filled contour plot, set a title for the labelbar
+ ; based on whether a units attribute is set.
+ ;
+ ; 6. Make a copy of the resource list, and set some additional
+ ; resources for filled contour plots.
+ ;
+ ; 7. Create the contour plot, attach the titles, and draw
+ ; and advance the frame (if requested).
+
+ local dims
+ begin
+ opts = opt_args ; Make a copy of the resource list.
+
+ if(opts.and.isatt(opts,"gsnDebugWriteFileName")) then
+ wrf_debug_file = get_res_value(opts,"gsnDebugWriteFileName", "")
+ end if
+
+ if(opts.and.isatt(opts,"mpOutlineBoundarySets")) then
+ delete(opts at mpOutlineBoundarySets)
+ end if
+
+
+ ; Calculate ratio of plot width and height. Note that this doesn't
+ ; affect the setting of gsnMaximize to True, because gsnMaximize will
+ ; retain the aspect ratio of the plot.
+
+ if(opts.and.isatt(opts,"AspectRatio")) then
+ ratio = opts at AspectRatio
+ else
+ dims = dimsizes(data)
+ ratio = 1.*dims(0)/dims(1)
+ if(ratio .gt. 1.2) then
+ ratio = 1.2
+ end if
+ if(ratio .lt. 0.6667) then
+ ratio = 0.6667
+ end if
+ end if
+
+ if(ratio .gt. 1)
+ width = 0.65 * 1.0/ratio
+ height = 0.65
+ else
+ width = 0.85
+ height = 0.85 * ratio
+ end if
+
+ opts at vpWidthF = get_res_value_keep(opts,"vpWidthF", width)
+ opts at vpHeightF = get_res_value_keep(opts,"vpHeightF", height)
+
+
+ ; Set some basic contour resources
+ opts = set_cn_resources(data,opts)
+
+
+ ; Find out if we are working with a contour or a shaded plot
+ ; fill_on = False : line contour plot
+ ; fill_on = True : filled contour plot
+ fill_on = get_res_value_keep(opts,"cnFillOn",False)
+ if(fill_on) then ; set lb resources if needed
+ opts = set_lb_resources(data,opts)
+ atmp = get_res_value(opts,"lbLabelBarOn",True) ; Remove this resource
+ delete(atmp) ; just in case.
+ end if
+
+
+ ; Set Title resources
+ opts = set_title_resources(data,opts)
+
+
+ ; Setting gsnScale to True ensures that the tickmark lengths and labels
+ ; will be the same size on both axes.
+ opts at gsnScale = get_res_value_keep(opts,"gsnScale", True)
+
+
+ ; The default is not to draw the plot or advance the frame, and
+ ; to maximize the plot in the frame.
+ opts at gsnDraw = False ; Make sure don't draw or frame or,
+ opts at gsnFrame = False ; maximize, b/c we'll do this later.
+ opts at gsnMaximize = False
+
+
+ opts2 = opts
+ delete_attrs(opts2) ; Clean up.
+ cn = gsn_contour(wks,data,opts2) ; Create the plot.
+ _SetMainTitle(nc_file,wks,cn,opts) ; Set some titles
+
+ if(isvar("wrf_debug_file")) then
+ write_wrf_debug_info(wks,data,False,wrf_debug_file,opts2,"wrf_contour")
+ end if
+
+ opts2 at gsnDraw = get_res_value_keep(opts2,"gsnDraw", False)
+ opts2 at gsnFrame = get_res_value_keep(opts2,"gsnFrame", False)
+ opts2 at gsnMaximize = get_res_value_keep(opts2,"gsnMaximize", True)
+ draw_and_frame(wks,cn,opts2 at gsnDraw,opts2 at gsnFrame,False,opts2 at gsnMaximize)
+
+ return(cn) ; Return
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_vector")
+ function wrf_vector(nc_file:file,wks[1]: graphic, data_u[*][*]:numeric,
+ data_v[*][*]:numeric, opt_args[1]:logical)
+ ;
+ ; This function creates a vector plot and adds some titles to it.
+ ;
+ ; 1. Determine width to height ratio of plot. Will also be use
+ ; to calculate values for vector resources later.
+ ;
+ ; 2. Make a copy of the resource list, and set some additional
+ ; resources.
+ ;
+ ; 3. Create the vector plot, attach the titles, and draw
+ ; and advance the frame (if requested).
+
+ local dims
+ begin
+ opts = opt_args ; Make a copy of the resource list.
+
+ if(opts.and.isatt(opts,"gsnDebugWriteFileName")) then
+ wrf_debug_file = get_res_value(opts,"gsnDebugWriteFileName", "")
+ end if
+
+ if(opts.and.isatt(opts,"mpOutlineBoundarySets")) then
+ delete(opts at mpOutlineBoundarySets)
+ end if
+ ;
+ ; The ratio is used to determine the width and height of the
+ ; plot, and also to determine the value for the vcMinDistanceF
+ ; resource.
+ ;
+ if(opts.and.isatt(opts,"AspectRatio")) then
+ ratio = get_res_value(opts,"AspectRatio",0.)
+ else
+ dims = dimsizes(data_u)
+ ratio = 1.*dims(0)/dims(1)
+ if(ratio .gt. 1.2) then
+ ratio = 1.2
+ end if
+ if(ratio .lt. 0.6667) then
+ ratio = 0.6667
+ end if
+ end if
+
+ if(ratio .gt. 1)
+ width = 0.65/ratio
+ height = 0.65
+ else
+ width = 0.95
+ height = 0.95 * ratio
+ end if
+
+ opts at vpWidthF = get_res_value_keep(opts,"vpWidthF", width)
+ opts at vpHeightF = get_res_value_keep(opts,"vpHeightF", height)
+
+
+ ; Set Title resources
+ opts = set_title_resources(data_u,opts)
+
+
+ ; Set vector resources
+ opts = set_vc_resources(opts)
+
+
+ ; Setting gsnScale to True ensures that the tickmark lengths and labels
+ ; will be the same size on both axes.
+ opts at gsnScale = get_res_value_keep(opts,"gsnScale", True)
+
+
+ ; The default is not to draw the plot or advance the frame, and
+ ; to maximize the plot in the frame.
+ opts at gsnDraw = False ; Make sure don't draw or frame or,
+ opts at gsnFrame = False ; maximize, b/c we'll do this later.
+ opts at gsnMaximize = False
+
+ opts2 = opts
+ delete_attrs(opts2) ; Clean up.
+ vct = gsn_vector(wks,data_u,data_v,opts2) ; Create vector plot.
+ _SetMainTitle(nc_file,wks,vct,opts)
+
+ if(isvar("wrf_debug_file")) then
+ write_wrf_debug_info(wks,data_u,data_v,wrf_debug_file,opts2,"wrf_vector")
+ end if
+
+ opts2 at gsnDraw = get_res_value_keep(opts2,"gsnDraw", False)
+ opts2 at gsnFrame = get_res_value_keep(opts2,"gsnFrame", False)
+ opts2 at gsnMaximize = get_res_value_keep(opts2,"gsnMaximize", True)
+ draw_and_frame(wks,vct,opts2 at gsnDraw,opts2 at gsnFrame,False,
+ opts2 at gsnMaximize)
+
+ return(vct) ; Return.
+ end
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_wps_map")
+ function wrf_wps_map(wks[1]:graphic,opt_args[1]:logical)
+
+ begin
+ ;
+ ; 1. Make a copy of the resource list, and set some resources
+ ; common to all map projections.
+ ;
+ ; 2. Determine the projection being used, and set resources based
+ ; on that projection.
+ ;
+ ; 3. Create the map plot, and draw and advance the frame
+ ; (if requested).
+
+ opts = opt_args ; Make a copy of the resource list
+ opts = True
+
+ ; Set some resources depending on what kind of map projection is
+ ; chosen.
+ ;
+ ; MAP_PROJ = 0 : "CylindricalEquidistant"
+ ; MAP_PROJ = 1 : "LambertConformal"
+ ; MAP_PROJ = 2 : "Stereographic"
+ ; MAP_PROJ = 3 : "Mercator"
+ ; MAP_PROJ = 6 : "Lat/Lon"
+
+ ; CylindricalEquidistant
+ if(opts at map_proj .eq. 0)
+ projection = "CylindricalEquidistant"
+ opts at mpGridSpacingF = 45
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 0.0)
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",opts at stand_lon)
+ end if
+
+ ; LambertConformal projection
+ if(opts at map_proj .eq. 1)
+ projection = "LambertConformal"
+ opts at mpLambertParallel1F = get_res_value_keep(opts, "mpLambertParallel1F",opts at truelat1)
+ opts at mpLambertParallel2F = get_res_value_keep(opts, "mpLambertParallel2F",opts at truelat2)
+ opts at mpLambertMeridianF = get_res_value_keep(opts, "mpLambertMeridianF",opts at stand_lon)
+ end if
+
+ ; Stereographic projection
+ if(opts at map_proj .eq. 2)
+ projection = "Stereographic"
+ if( isatt(opts,"cenlat") ) then
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF",opts at cenlat)
+ else
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF",opts at ref_lat)
+ end if
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",opts at stand_lon)
+ end if
+
+ ; Mercator projection
+ if(opts at map_proj .eq. 3)
+ projection = "Mercator"
+ opts at mpCenterLatF = get_res_value_keep(opts, "mpCenterLatF", 0.0)
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",opts at stand_lon)
+ end if
+
+ ; global WRF CylindricalEquidistant
+ if(opts at map_proj .eq. 6)
+ projection = "CylindricalEquidistant"
+ opts at mpGridSpacingF = 45
+ if( isatt(opts,"cenlon") ) then
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",opts at cenlon)
+ else
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF",opts at ref_lon)
+ end if
+ if( isatt(opts,"pole_lat") ) then
+ delete(opts at mpCenterLonF)
+ opts at mpCenterLonF = get_res_value_keep(opts, "mpCenterLonF", - 190. )
+ opts at mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF", 90.0 - opts at pole_lat)
+ else
+ opts at mpCenterRotF = get_res_value_keep(opts, "mpCenterRotF", 0.0)
+ end if
+ end if
+
+ ; Set some resources common to all map projections.
+ opts = set_mp_resources(opts)
+
+ ; The default is not to draw the plot or advance the frame, and
+ ; to maximize the plot in the frame.
+
+ opts at gsnDraw = get_res_value_keep(opts,"gsnDraw", False)
+ opts at gsnFrame = get_res_value_keep(opts,"gsnFrame", False)
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ delete_attrs(opts) ; Clean up.
+ mp = gsn_map(wks,projection,opts) ; Create map plot.
+ return(mp) ; Return.
+
+ end
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_wps_dom")
+ function wrf_wps_dom(wks[1]:graphic,opt_args[1]:logical,lnres[1]:logical,txres[1]:logical)
+
+ begin
+
+ mpres = opt_args
+ ;BPR BEGIN
+ ;grid_to_plot = 0 => plot using the corner mass grid points
+ ;grid_to_plot = 1 => plot using the edges of the corner grid cells
+ ; This uses the locations of the corner mass grid points +/- 0.5 grid cells
+ ; to get from the mass grid point to the edge of the grid cell
+ grid_to_plot = 1
+ ;grid_to_plot = mpres at grid_to_plot
+ if(grid_to_plot.eq.0) then
+ ; print("Plotting using corner mass grid points")
+ else if(grid_to_plot.eq.1) then
+ ; print("Plotting using edges of the corner grid cells")
+ else
+ print("ERROR: Invalid value for grid_to_plot = "+grid_to_plot)
+ end if
+ end if
+ ;BPR END
+
+ res = True
+ res at DX = mpres at dx
+ res at DY = mpres at dy
+ res at LATINC = 0.0
+ res at LONINC = 0.0
+ if ( mpres at map_proj .eq. "lambert") then
+ mpres at map_proj = 1
+ res at MAP_PROJ = 1
+ end if
+ if ( mpres at map_proj .eq. "polar") then
+ mpres at map_proj = 2
+ res at MAP_PROJ = 2
+ end if
+ if ( mpres at map_proj .eq. "mercator") then
+ mpres at map_proj = 3
+ res at MAP_PROJ = 3
+ end if
+ if ( mpres at map_proj .eq. "lat-lon") then
+ mpres at map_proj = 6
+ res at MAP_PROJ = 6
+ res at LATINC = mpres at dy
+ res at LONINC = mpres at dx
+ end if
+ res at TRUELAT1 = mpres at truelat1
+ res at TRUELAT2 = mpres at truelat2
+ res at STAND_LON = mpres at stand_lon
+
+ res at REF_LAT = mpres at ref_lat
+ res at REF_LON = mpres at ref_lon
+ if ( isatt(mpres,"ref_x") ) then
+ res at KNOWNI = mpres at ref_x
+ else
+ res at KNOWNI = int2flt(mpres at e_we(0))/2.
+ end if
+ if ( isatt(mpres,"ref_y") ) then
+ res at KNOWNJ = mpres at ref_y
+ else
+ res at KNOWNJ = int2flt(mpres at e_sn(0))/2.
+ end if
+
+ if ( isatt(mpres,"pole_lat") ) then
+ res at POLE_LAT = mpres at pole_lat
+ else
+ res at POLE_LAT = 90.0
+ end if
+ if ( isatt(mpres,"pole_lon") ) then
+ res at POLE_LON = mpres at pole_lon
+ else
+ res at POLE_LON = 0.0
+ end if
+
+ ;BPR BEGIN
+ ;Determine adjustment needed to convert from mass grid to chosen grid
+ if(grid_to_plot.eq.0) then
+ adjust_grid = 0.0
+ else if(grid_to_plot.eq.1) then
+ adjust_grid = 0.5
+ else
+ print("ERROR: Invalid value for grid_to_plot = "+grid_to_plot)
+ adjust_grid = 0.0
+ end if
+ end if
+
+ xx = 1.0 - adjust_grid
+ yy = 1.0 - adjust_grid
+ ;xx = 1.0
+ ;yy = 1.0
+ ;BPR END
+ loc = wrf_ij_to_ll (xx,yy,res)
+ start_lon = loc(0)
+ start_lat = loc(1)
+ ;BPR BEGIN
+ ;e_we is the largest U grid point and e_sn the largest V gridpoint
+ ;xx = int2flt(mpres at e_we(0))
+ ;yy = int2flt(mpres at e_sn(0))
+ ;Change it so it is in terms of mass grid points since wrf_ij_to_ll is
+ ;in terms of mass grid points
+ xx = int2flt(mpres at e_we(0)-1) + adjust_grid
+ yy = int2flt(mpres at e_sn(0)-1) + adjust_grid
+ ;BPR END
+ loc = wrf_ij_to_ll (xx,yy,res)
+ end_lon = loc(0)
+ end_lat = loc(1)
+
+ mpres at start_lat = start_lat
+ mpres at start_lon = start_lon
+ mpres at end_lat = end_lat
+ mpres at end_lon = end_lon
+
+
+ mp = wrf_wps_map(wks,mpres)
+ draw(mp)
+
+
+ if ( mpres at max_dom .gt. 1 ) then
+
+ numLineColors = 0
+ if ( isatt(lnres,"domLineColors") ) then
+ numLineColors = dimsizes(lnres at domLineColors)
+ end if
+
+ do idom = 1,mpres at max_dom-1
+
+ if ( numLineColors .gt. 0 ) then
+ if ( numLineColors .ge. idom ) then
+ lnres at gsLineColor = lnres at domLineColors(idom-1)
+ txres at txFontColor = lnres at domLineColors(idom-1)
+ else
+ lnres at gsLineColor = lnres at domLineColors(numLineColors-1)
+ txres at txFontColor = lnres at domLineColors(numLineColors-1)
+ end if
+ end if
+
+
+ ; nest start and end points in large domain space
+ if ( mpres at parent_id(idom) .eq. 1) then
+ ; corner value
+ ;BPR BEGIN
+ ;Due to the alignment of nests we need goffset in order to
+ ;find the location of (1,1) in the fine domain in coarse domain
+ ;coordinates
+ ;i_start = mpres at i_parent_start(idom)
+ ;j_start = mpres at j_parent_start(idom)
+ goffset = 0.5*(1-(1.0/mpres at parent_grid_ratio(idom)))
+ i_start = mpres at i_parent_start(idom)-goffset
+ j_start = mpres at j_parent_start(idom)-goffset
+ ; end point
+ ;Change to mass point
+ ;i_end = (mpres at e_we(idom)-1)/mpres at parent_grid_ratio(idom) + i_start
+ ;j_end = (mpres at e_sn(idom)-1)/mpres at parent_grid_ratio(idom) + j_start
+ i_end = (mpres at e_we(idom)-2)/(1.0*mpres at parent_grid_ratio(idom)) + i_start
+ j_end = (mpres at e_sn(idom)-2)/(1.0*mpres at parent_grid_ratio(idom)) + j_start
+
+ if(grid_to_plot.eq.0) then
+ adjust_grid = 0.0
+ else if(grid_to_plot.eq.1) then
+ adjust_grid = 0.5/(1.0*mpres at parent_grid_ratio(idom))
+ else
+ print("ERROR: Invalid value for grid_to_plot = "+grid_to_plot)
+ adjust_grid = 0.0
+ end if
+ end if
+
+ ;BPR END
+ end if
+ if ( mpres at parent_id(idom) .ge. 2) then
+ ; corner value
+ nd = mpres at parent_id(idom)
+ ;BPR BEGIN
+ ;i_points = ((mpres at e_we(idom)-1)/mpres at parent_grid_ratio(idom))
+ ;j_points = ((mpres at e_sn(idom)-1)/mpres at parent_grid_ratio(idom))
+ i_points = ((mpres at e_we(idom)-2)/(1.0*mpres at parent_grid_ratio(idom)))
+ j_points = ((mpres at e_sn(idom)-2)/(1.0*mpres at parent_grid_ratio(idom)))
+ goffset = 0.5*(1-(1.0/(1.0*mpres at parent_grid_ratio(idom))))
+ ai_start = mpres at i_parent_start(idom)*1.0-goffset
+ aj_start = mpres at j_parent_start(idom)*1.0-goffset
+ ;ai_start = mpres at i_parent_start(idom)*1.0
+ ;aj_start = mpres at j_parent_start(idom)*1.0
+
+ if(grid_to_plot.eq.0) then
+ adjust_grid = 0.0
+ else if(grid_to_plot.eq.1) then
+ adjust_grid = 0.5/(1.0*mpres at parent_grid_ratio(idom))
+ else
+ print("ERROR: Invalid value for grid_to_plot = "+grid_to_plot)
+ adjust_grid = 0.0
+ end if
+ end if
+
+ do while ( nd .gt. 1)
+ ;Note that nd-1 is used in the following because the WPS namelist is
+ ;one-based but arrays in NCL are zero-based
+ goffset = 0.5*(1-(1.0/(1.0*mpres at parent_grid_ratio(nd-1))))
+ ;ai_start = ai_start/mpres at parent_grid_ratio(nd-1) + mpres at i_parent_start(nd-1)
+ ;aj_start = aj_start/mpres at parent_grid_ratio(nd-1) + mpres at j_parent_start(nd-1)
+ ai_start = (ai_start-1)/(1.0*mpres at parent_grid_ratio(nd-1)) + mpres at i_parent_start(nd-1)-goffset
+ aj_start = (aj_start-1)/(1.0*mpres at parent_grid_ratio(nd-1)) + mpres at j_parent_start(nd-1)-goffset
+ ;i_points = (i_points/mpres at parent_grid_ratio(nd-1))
+ ;j_points = (j_points/mpres at parent_grid_ratio(nd-1))
+ i_points = (i_points/(1.0*mpres at parent_grid_ratio(nd-1)))
+ j_points = (j_points/(1.0*mpres at parent_grid_ratio(nd-1)))
+ if(grid_to_plot.eq.0) then
+ adjust_grid = 0.0
+ else if(grid_to_plot.eq.1) then
+ adjust_grid = adjust_grid/(1.0*mpres at parent_grid_ratio(nd-1))
+ else
+ print("ERROR: Invalid value for grid_to_plot = "+grid_to_plot)
+ adjust_grid = 0.0
+ end if
+ end if
+
+ ;nd = nd - 1
+ nd = mpres at parent_id(nd-1)
+ end do
+ ;i_start = tointeger(ai_start + .5 )
+ ;j_start = tointeger(aj_start + .5 )
+ i_start = ai_start
+ j_start = aj_start
+ ; end point
+ ;i_end = i_points + i_start + 1
+ ;j_end = j_points + j_start + 1
+ i_end = i_points + i_start
+ j_end = j_points + j_start
+ ;BPR END
+ end if
+
+ ; get the four corners
+
+ xx = i_start - adjust_grid
+ yy = j_start - adjust_grid
+ ;xx = int2flt(i_start)
+ ;yy = int2flt(j_start)
+ loc = wrf_ij_to_ll (xx,yy,res)
+ lon_SW = loc(0)
+ lat_SW = loc(1)
+
+ xx = i_end + adjust_grid
+ yy = j_start - adjust_grid
+ ;xx = int2flt(i_end)
+ ;yy = int2flt(j_start)
+ loc = wrf_ij_to_ll (xx,yy,res)
+ lon_SE = loc(0)
+ lat_SE = loc(1)
+
+ xx = i_start - adjust_grid
+ yy = j_end + adjust_grid
+ ;xx = int2flt(i_start)
+ ;yy = int2flt(j_end)
+ loc = wrf_ij_to_ll (xx,yy,res)
+ lon_NW = loc(0)
+ lat_NW = loc(1)
+
+ ;xx = int2flt(i_end)
+ ;yy = int2flt(j_end)
+ xx = i_end + adjust_grid
+ yy = j_end + adjust_grid
+ ;BPR END
+ loc = wrf_ij_to_ll (xx,yy,res)
+ lon_NE = loc(0)
+ lat_NE = loc(1)
+
+ xbox = (/lon_SW, lon_SE, lon_NE, lon_NW, lon_SW /)
+ ybox = (/lat_SW, lat_SE, lat_NE, lat_NW, lat_SW /)
+ x_out = new(dimsizes(xbox),typeof(xbox))
+ y_out = new(dimsizes(ybox),typeof(ybox))
+ datatondc(mp, xbox, ybox, x_out, y_out)
+ gsn_polyline_ndc(wks, x_out, y_out, lnres)
+
+ idd = idom + 1
+ dom_text = "d0"+idd
+ if ( txres at txJust .eq. "BottomLeft" ) then
+ gsn_text(wks,mp,dom_text,lon_NW,lat_NW,txres)
+ else
+ gsn_text_ndc(wks,dom_text,x_out(3)+0.01,y_out(3)-0.01,txres)
+ end if
+
+ end do
+
+ end if
+
+ return(mp)
+
+ end
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_map_resources")
+ function wrf_map_resources(in_file[1]:file,map_args[1]:logical)
+ local lat, lon, x1, x2, y1, y2, dims, ii, jj
+ begin
+ ;
+ ; This function sets resources for a WRF map plot, basing the projection on
+ ; the MAP_PROJ attribute in the given file. It's intended to be callable
+ ; by users who need to set mpXXXX resources for other plotting scripts.
+ ;
+
+ ; Set some resources depending on what kind of map projection is
+ ; chosen.
+ ;
+ ; MAP_PROJ = 0 : "CylindricalEquidistant"
+ ; MAP_PROJ = 1 : "LambertConformal"
+ ; MAP_PROJ = 2 : "Stereographic"
+ ; MAP_PROJ = 3 : "Mercator"
+ ; MAP_PROJ = 6 : "Lat/Lon"
+
+ if(isatt(in_file,"MAP_PROJ"))
+
+ ; CylindricalEquidistant
+ if(in_file at MAP_PROJ .eq. 0)
+ map_args at mpProjection = "CylindricalEquidistant"
+ map_args at mpGridSpacingF = 45
+ map_args at mpCenterLatF = get_res_value_keep(map_args, "mpCenterLatF", 0.0)
+ if(isatt(in_file,"STAND_LON"))
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; LambertConformal projection
+ if(in_file at MAP_PROJ .eq. 1)
+ map_args at mpProjection = "LambertConformal"
+ map_args at mpLambertParallel1F = get_res_value_keep(map_args, "mpLambertParallel1F",in_file at TRUELAT1)
+ map_args at mpLambertParallel2F = get_res_value_keep(map_args, "mpLambertParallel2F",in_file at TRUELAT2)
+ if(isatt(in_file,"STAND_LON"))
+ map_args at mpLambertMeridianF = get_res_value_keep(map_args, "mpLambertMeridianF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ map_args at mpLambertMeridianF = get_res_value_keep(map_args, "mpLambertMeridianF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; Stereographic projection
+ if(in_file at MAP_PROJ .eq. 2)
+ map_args at mpProjection = "Stereographic"
+ map_args at mpCenterLatF = get_res_value_keep(map_args, "mpCenterLatF", in_file at CEN_LAT)
+ if(isatt(in_file,"STAND_LON"))
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; Mercator projection
+ if(in_file at MAP_PROJ .eq. 3)
+ map_args at mpProjection = "Mercator"
+ map_args at mpCenterLatF = get_res_value_keep(map_args, "mpCenterLatF", 0.0)
+ if(isatt(in_file,"STAND_LON"))
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at STAND_LON)
+ else
+ if(isatt(in_file,"CEN_LON"))
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at CEN_LON)
+ else
+ print("ERROR: Found neither STAND_LON or CEN_LON in file")
+ end if
+ end if
+ end if
+
+ ; global WRF CylindricalEquidistant
+ if(in_file at MAP_PROJ .eq. 6)
+ map_args at mpProjection = "CylindricalEquidistant"
+ map_args at mpGridSpacingF = 45
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF",in_file at CEN_LON)
+ if( isatt(in_file,"POLE_LAT") ) then
+ map_args at mpCenterRotF = get_res_value_keep(map_args, "mpCenterRotF", 90.0 - in_file at POLE_LAT)
+ delete(map_args at mpCenterLonF)
+ calcen = -190.
+ map_args at mpCenterLonF = get_res_value_keep(map_args, "mpCenterLonF", calcen )
+ end if
+ end if
+
+ else
+
+ return(map_args)
+
+ end if
+
+ map_args at mpNestTime = get_res_value_keep(map_args, "mpNestTime",0)
+
+ if(isfilevar(in_file,"XLAT"))
+ lat = in_file->XLAT(map_args at mpNestTime,:,:)
+ lon = in_file->XLONG(map_args at mpNestTime,:,:)
+ else
+ lat = in_file->XLAT_M(map_args at mpNestTime,:,:)
+ lon = in_file->XLONG_M(map_args at mpNestTime,:,:)
+ end if
+ dims = dimsizes(lat)
+
+ do ii = 0, dims(0)-1
+ do jj = 0, dims(1)-1
+ if ( lon(ii,jj) .lt. 0.0) then
+ lon(ii,jj) = lon(ii,jj) + 360.
+ end if
+ end do
+ end do
+
+ map_args at start_lat = lat(0,0)
+ map_args at start_lon = lon(0,0)
+ map_args at end_lat = lat(dims(0)-1,dims(1)-1)
+ map_args at end_lon = lon(dims(0)-1,dims(1)-1)
+
+
+ ; Set some resources common to all map projections.
+ map_args = set_mp_resources(map_args)
+
+ if ( isatt(map_args,"ZoomIn") .and. map_args at ZoomIn ) then
+ y1 = 0
+ x1 = 0
+ y2 = dims(0)-1
+ x2 = dims(1)-1
+ if ( isatt(map_args,"Ystart") ) then
+ y1 = map_args at Ystart
+ delete(map_args at Ystart)
+ end if
+ if ( isatt(map_args,"Xstart") ) then
+ x1 = map_args at Xstart
+ delete(map_args at Xstart)
+ end if
+ if ( isatt(map_args,"Yend") ) then
+ if ( map_args at Yend .le. y2 ) then
+ y2 = map_args at Yend
+ end if
+ delete(map_args at Yend)
+ end if
+ if ( isatt(map_args,"Xend") ) then
+ if ( map_args at Xend .le. x2 ) then
+ x2 = map_args at Xend
+ end if
+ delete(map_args at Xend)
+ end if
+
+ map_args at mpLeftCornerLatF = lat(y1,x1)
+ map_args at mpLeftCornerLonF = lon(y1,x1)
+ map_args at mpRightCornerLatF = lat(y2,x2)
+ map_args at mpRightCornerLonF = lon(y2,x2)
+
+ if ( map_args at mpRightCornerLonF .lt. 0.0 ) then
+ map_args at mpRightCornerLonF = map_args at mpRightCornerLonF + 360.0
+ end if
+
+ delete(map_args at ZoomIn)
+ end if
+
+ return(map_args)
+ end
+
+ ;--------------------------------------------------------------------------------
+ undef("wrf_map")
+ function wrf_map(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical)
+
+ begin
+ ;
+ ; This function creates a map plot, and bases the projection on
+ ; the MAP_PROJ attribute in the given file.
+ ;
+ ; 1. Make a copy of the resource list, and call a function to set
+ ; some resources common to all map projections.
+ ;
+ ; 2. Determine the projection being used, and set resources based
+ ; on that projection.
+ ;
+ ; 3. Create the map plot, and draw and advance the frame
+ ; (if requested).
+
+ if(opt_args.and.isatt(opt_args,"gsnDebugWriteFileName")) then
+ wrf_debug_file = get_res_value(opt_args,"gsnDebugWriteFileName", "")
+ end if
+
+ opts = opt_args ; Make a copy of the resource list
+ opts = True
+
+ ;---Set some map resources based on parameters and variables in input file.
+ opts = wrf_map_resources(in_file,opts)
+
+ if(.not.isatt(opts,"mpProjection")) then
+ print("wrf_map: Error: no MAP_PROJ attribute in input file")
+ return(new(1,graphic))
+ else
+ projection = opts at mpProjection
+ end if
+
+ ; The default is not to draw the plot or advance the frame, and
+ ; to maximize the plot in the frame.
+
+ opts at gsnDraw = get_res_value_keep(opts,"gsnDraw", False)
+ opts at gsnFrame = get_res_value_keep(opts,"gsnFrame", False)
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ delete_attrs(opts) ; Clean up.
+ mp = gsn_map(wks,projection,opts) ; Create map plot.
+
+ if(isvar("wrf_debug_file")) then
+ opts at mpProjection = projection
+ write_wrf_debug_info(wks,False,False,wrf_debug_file,opts,"wrf_map")
+ end if
+
+ return(mp) ; Return.
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_map_overlays")
+ function wrf_map_overlays(in_file[1]:file,
+ wks:graphic,
+ plots[*]:graphic,
+ opt_arg[1]:logical,
+ opt_mp[1]:logical)
+
+ ; This procedure takes an array of plots and overlays them on a
+ ; base plot - map background.
+ ;
+ ; It will advance the plot and cleanup, unless you set the
+ ; PanelPlot resource to True.
+ ;
+ ; Attributes recognized by this procedure:
+ ; FramePlot
+ ; PanelPlot
+ ; NoTitles (don't do any titles)
+ ; CommonTitle & PlotTitle is used to overwrite field titles
+ ; CommonTitle will supercede NoTitles
+ ; LatLonOverlay
+ ;
+ ; If FramePlot False, then Draw the plot but do not Frame.
+ ; In this case a user want to add to the drawing, and will
+ ; have to advance the Frame manually in the script.
+ ;
+ ; If the "NoTitles" attribute exists and is set True, then
+ ; don't create the top-left titles, and leave the main titles alone.
+ ; This resource can be useful if you are planning to panel
+ ; the plots.
+ ;
+ ; If PanelPlot is set to True, then this flags to wrf_map_overlays
+ ; that these plots are going to be eventually paneled (likely
+ ; by gsn_panel), and hence 1) draw and frame should not be called
+ ; (unless gsnDraw and/or gsnFrame are explicitly set to True),
+ ; and 2) the overlays and titles should not be removed with
+ ; NhlRemoveOverlay and NhlRemoveAnnotation.
+ ;
+ ; If LatLonOverlay is set to True, then this means the user is
+ ; using the 2D lat/lon coordinates to do the overlay, and hence
+ ; tfDoNDCOverlay should not be set to True. (The default is False.)
+ ;
+ begin
+
+ opts = opt_arg ; Make a copy of the resource lists
+ opt_mp_2 = opt_mp
+
+ if(opts.and.isatt(opts,"gsnDebugWriteFileName")) then
+ opt_mp_2 at gsnDebugWriteFileName = get_res_value(opts,
+ "gsnDebugWriteFileName", "")
+ wrf_debug_file = opt_mp_2 at gsnDebugWriteFileName
+ end if
+
+ ; Let's make the map first
+ base = wrf_map(wks,in_file,opt_mp_2)
+
+ no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles?
+ com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title?
+ if ( com_title ) then
+ plot_title = get_res_value(opts,"PlotTitle"," ")
+ no_titles = True
+ end if
+
+ call_draw = True
+ call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot?
+ panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling?
+ latlon_overlay = get_res_value(opts,"LatLonOverlay",False) ; Lat/lon Overlay?
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ nplots = dimsizes(plots)
+ ; font_color = "Black"
+
+ do i=0,nplots-1
+ if(.not.ismissing(plots(i))) then
+ ; class_name = NhlClassName(plots(i))
+ ; print(class_name)
+ ; if(class_name.eq."contourPlotClass") then
+ ; getvalues plots(i)
+ ; "cnFillOn" : fill_on
+ ; "cnLineColor" : line_color
+ ; end getvalues
+ ; if (.not.fill_on) then
+ ; font_color = line_color
+ ; end if
+ ; end if
+ if(.not.no_titles) then
+ getvalues plots(i)
+ "tiMainString" : SubTitle
+ end getvalues
+ if(i.eq.0) then
+ SubTitles = SubTitle
+ else
+ SubTitles = SubTitles + "~C~" + SubTitle
+ end if
+ end if
+ if(com_title .and. i .eq. nplots-1) then
+ getvalues plots(i)
+ "tiMainString" : SubTitle
+ end getvalues
+ SubTitles = plot_title
+ end if
+ if(.not.latlon_overlay) then
+ setvalues plots(i)
+ "tfDoNDCOverlay" : True
+ "tiMainOn" : False
+ end setvalues
+ else
+ setvalues plots(i)
+ "tiMainOn" : False
+ end setvalues
+ end if
+ overlay(base,plots(i))
+ else
+ print("wrf_map_overlays: Warning: overlay plot #" + i + " is not valid.")
+ end if
+ end do
+
+ if(.not.no_titles .or. com_title) then
+ font_height = get_res_value_keep(opts,"FontHeightF",0.01)
+ txt = create "map_titles" textItemClass wks
+ "txString" : SubTitles
+ "txFontHeightF" : font_height
+ ;"txFontColor" : font_color
+ end create
+ anno = NhlAddAnnotation(base,txt)
+ setvalues anno
+ "amZone" : 3
+ "amJust" : "BottomLeft"
+ "amSide" : "Top"
+ "amParallelPosF" : 0.005
+ "amOrthogonalPosF" : 0.03
+ "amResizeNotify" : False
+ end setvalues
+ base at map_titles = anno
+ end if
+ ;
+ ; gsnDraw and gsnFrame default to False if panel plot.
+ ;
+ if(panel_plot) then
+ call_draw = False
+ call_frame= False
+ end if
+
+
+ opts at gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw)
+ opts at gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame)
+
+ draw_and_frame(wks,base,opts at gsnDraw,opts at gsnFrame,False,
+ opts at gsnMaximize)
+
+ if(.not.panel_plot) then
+ do i=0,nplots-1
+ if(.not.ismissing(plots(i))) then
+ NhlRemoveOverlay(base,plots(i),False)
+ else
+ print("wrf_remove_map_overlays: Warning: overlay plot #" + i + " is not valid.")
+ print(" Nothing to remove.")
+ end if
+ end do
+ end if
+
+ if(isvar("wrf_debug_file")) then
+ write_wrf_debug_script(wks,wrf_debug_file,"wrf_map_overlays")
+ end if
+
+ if(.not.no_titles.and..not.panel_plot) then
+ if(isatt(base,"map_titles")) then
+ NhlRemoveAnnotation(base,base at map_titles)
+ delete(base at map_titles)
+ end if
+ end if
+
+ return(base)
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_overlays")
+ function wrf_overlays(in_file[1]:file,
+ wks:graphic, plots[*]:graphic,
+ opt_arg[1]:logical)
+
+ ; This procedure takes an array of plots and overlays them.
+ ;
+ ; It will advance the plot and cleanup, unless you set the
+ ; PanelPlot resource to True.
+ ;
+ ; Attributes recognized by this procedure:
+ ; FramePlot
+ ; PanelPlot
+ ; NoTitles (don't do any titles)
+ ; CommonTitle & PlotTile is used to overwrite field titles
+ ; CommonTitle will super-seed NoTitles
+ ;
+ ; If FramePlot False, then Draw the plot but do not Frame.
+ ; In this case a user want to add to the drawing, and will
+ ; have to advance the Frame manually in the script.
+ ;
+ ; If the "NoTitles" attribute exists and is set True, then
+ ; don't create the top-left titles, and leave the main titles alone.
+ ; This resource can be useful if you are planning to panel
+ ; the plots.
+ ;
+ ; If PanelPlot is set to True, then this flags to wrf_overlays
+ ; that these plots are going to be eventually paneled (likely
+ ; by gsn_panel), and hence 1) draw and frame should not be called
+ ; (unless gsnDraw and/or gsnFrame are explicitly set to True),
+ ; and 2) the overlays and titles should not be removed with
+ ; NhlRemoveOverlay and NhlRemoveAnnotation.
+ ;
+ ; If LatLonOverlay is set to True, then this means the user is
+ ; using the 2D lat/lon coordinates to do the overlay, and hence
+ ; tfDoNDCOverlay should not be set to True. (The default is False.)
+ ;
+ begin
+ opts = opt_arg ; Make a copy of the resource list.
+
+ no_titles = get_res_value(opts,"NoTitles",False) ; Do we want field titles?
+ com_title = get_res_value(opts,"CommonTitle",False) ; Do we have a common title?
+ latlon_overlay = get_res_value(opts,"LatLonOverlay",False) ; Lat/lon Overlay?
+ if ( com_title ) then
+ plot_title = get_res_value(opts,"PlotTitle"," ")
+ no_titles = True
+ end if
+
+ call_draw = True
+ call_frame = get_res_value(opts,"FramePlot",True) ; Do we want to frame the plot?
+ panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling?
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ nplots = dimsizes(plots)
+
+ base = plots(0)
+ if(.not.no_titles) then
+ getvalues plots(0)
+ "tiMainString" : SubTitle
+ end getvalues
+ SubTitles = SubTitle
+ if(.not.latlon_overlay) then
+ setvalues plots(0)
+ "tfDoNDCOverlay" : True
+ "tiMainOn" : False
+ end setvalues
+ else
+ setvalues plots(0)
+ "tiMainOn" : False
+ end setvalues
+ end if
+ else
+ if(.not.latlon_overlay) then
+ setvalues plots(0)
+ "tfDoNDCOverlay" : True
+ end setvalues
+ end if
+ end if
+
+ if (nplots.eq.1) then
+ blank = create "BlankPlot" logLinPlotClass wks
+ ;"cnConstFLabelOn" : False
+ end create
+ overlay(base,blank)
+ end if
+
+ do i=1,nplots-1
+ if(.not.ismissing(plots(i))) then
+ if(.not.no_titles) then
+ getvalues plots(i)
+ "tiMainString" : SubTitle
+ end getvalues
+ if(i.eq.0) then
+ SubTitles = SubTitle
+ else
+ SubTitles = SubTitles + "~C~" + SubTitle
+ end if
+ end if
+ if(com_title .and. i .eq. nplots-1) then
+ getvalues plots(i)
+ "tiMainString" : SubTitle
+ end getvalues
+ SubTitles = plot_title
+ end if
+ if(.not.latlon_overlay) then
+ setvalues plots(i)
+ "tfDoNDCOverlay" : True
+ "tiMainOn" : False
+ end setvalues
+ else
+ setvalues plots(i)
+ "tiMainOn" : False
+ end setvalues
+ end if
+ overlay(base,plots(i))
+ else
+ print("wrf_overlays: Warning: overlay plot #" + i + " is not valid.")
+ end if
+ end do
+
+ if(.not.no_titles .or. com_title) then
+ font_height = get_res_value_keep(opts,"FontHeightF",0.01)
+
+ txt = create "map_titles" textItemClass wks
+ "txString" : SubTitles
+ "txFontHeightF" : font_height
+ end create
+ anno = NhlAddAnnotation(base,txt)
+ setvalues anno
+ "amZone" : 3
+ "amJust" : "BottomLeft"
+ "amSide" : "Top"
+ "amParallelPosF" : 0.005
+ "amOrthogonalPosF" : 0.03
+ "amResizeNotify" : False
+ end setvalues
+ base at map_titles = anno
+ end if
+
+ ;
+ ; gsnDraw and gsnFrame should default to True if not a panel plot.
+ ;
+ if(panel_plot) then
+ call_draw = False
+ call_frame= False
+ end if
+
+ opts at gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw)
+ opts at gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame)
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ draw_and_frame(wks,base,opts at gsnDraw,opts at gsnFrame,False,
+ opts at gsnMaximize)
+
+ if(.not.no_titles.and..not.panel_plot) then
+ NhlRemoveAnnotation(base,base at map_titles)
+ delete(base at map_titles)
+ end if
+
+ if(.not.panel_plot) then
+ if ( nplots .ge. 2 ) then
+ do i=1,nplots-1
+ if(.not.ismissing(plots(i))) then
+ NhlRemoveOverlay(base,plots(i),False)
+ else
+ print("wrf_remove_overlays: Warning: overlay plot #" + i + " is not valid.")
+ print(" Nothing to remove.")
+ end if
+ end do
+ end if
+ end if
+
+ return(base)
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_map_zoom")
+ function wrf_map_zoom(wks[1]:graphic,in_file[1]:file,opt_args[1]:logical,
+ y1:integer,y2:integer,x1:integer,x2:integer)
+
+ ; As of version 5.0.1, this routine is redundant. Use the special "ZoomIn"
+ ; resource in wrf_map to accomplish the same thing. This function is
+ ; being kept for backwards capability. There should be no need for it
+ ; except to run old WRF-NCL codes. Do not make any changes to it except
+ ; possibly to fix bugs.
+ ;
+ begin
+ print("wrf_map_zoom: Warning: This function is obsolete. Consider using")
+ print(" the 'ZoomIn' resource in wrf_map instead.")
+ if(isfilevar(in_file,"XLAT"))
+ lat = in_file->XLAT(0,:,:)
+ lon = in_file->XLONG(0,:,:)
+ else
+ lat = in_file->XLAT_M(0,:,:)
+ lon = in_file->XLONG_M(0,:,:)
+ end if
+ opts = opt_args ; Make a copy of the resource list
+ opts = True
+ opts at mpLeftCornerLatF = lat(y1,x1)
+ opts at mpLeftCornerLonF = lon(y1,x1)
+ opts at mpRightCornerLatF = lat(y2,x2)
+ opts at mpRightCornerLonF = lon(y2,x2)
+ mz = wrf_map(wks,in_file,opts)
+ return(mz)
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_map_overlay")
+ procedure wrf_map_overlay(wks:graphic,base[1]:graphic,
+ plots[*]:graphic,
+ opt_arg[1]:logical)
+
+ ; As of version 5.0.1, this procedure is obsolete. Use wrf_map_overlays
+ ; instead. It is being kept for backwards capability. Do not make any
+ ; changes to it except possibly to fix bugs.
+ ;
+ ; This procedure takes an array of plots and overlays them on a
+ ; base plot - map background.
+ ;
+ ; It will advance the plot and cleanup, unless you set the
+ ; PanelPlot resource to True.
+ ;
+ ; Attributes recognized by this procedure:
+ ; NoTitles (don't do any titles)
+ ; PanelPlot
+ ;
+ ; If the "NoTitles" attribute exists and is set True, then
+ ; don't create the top-left titles, and leave the main titles alone.
+ ; This resource can be useful if you are planning to panel
+ ; the plots.
+ ;
+ ; If PanelPlot is set to True, then this flags to wrf_map_overlay
+ ; that these plots are going to be eventually paneled (likely
+ ; by gsn_panel), and hence 1) draw and frame should not be called
+ ; (unless gsnDraw and/or gsnFrame are explicitly set to True),
+ ; and 2) the overlays and titles should not be removed with
+ ; NhlRemoveOverlay and NhlRemoveAnnotation.
+ ;
+ begin
+ print("wrf_map_overlay: Warning: This procedure is obsolete. Consider" )
+ print(" using wrf_map_overlays instead.")
+
+ opts = opt_arg ; Make a copy of the resource list
+ opts = True
+
+ if(opts.and.isatt(opts,"NoTitles").and.opts at NoTitles) then
+ no_titles = True
+ else
+ no_titles = False
+ end if
+
+ panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling?
+ latlon_overlay = get_res_value(opts,"LatLonOverlay",False) ; Lat/lon Overlay?
+
+ nplots = dimsizes(plots)
+ ; font_color = "Black"
+
+ do i=0,nplots-1
+ if(.not.ismissing(plots(i))) then
+ ; class_name = NhlClassName(plots(i))
+ ; print(class_name)
+ ; if(class_name.eq."contourPlotClass") then
+ ; getvalues plots(i)
+ ; "cnFillOn" : fill_on
+ ; "cnLineColor" : line_color
+ ; end getvalues
+ ; if (.not.fill_on) then
+ ; font_color = line_color
+ ; end if
+ ; end if
+ if(.not.no_titles) then
+ getvalues plots(i)
+ "tiMainString" : SubTitle
+ end getvalues
+ if(i.eq.0) then
+ SubTitles = SubTitle
+ else
+ SubTitles = SubTitles + "~C~" + SubTitle
+ end if
+ if(.not.latlon_overlay) then
+ setvalues plots(i)
+ "tfDoNDCOverlay" : True
+ "tiMainOn" : False
+ end setvalues
+ else
+ setvalues plots(i)
+ "tiMainOn" : False
+ end setvalues
+ end if
+ else
+ if(.not.latlon_overlay) then
+ setvalues plots(i)
+ "tfDoNDCOverlay" : True
+ end setvalues
+ end if
+ end if
+ overlay(base,plots(i))
+ else
+ print("wrf_map_overlay: Warning: overlay plot #" + i + " is not valid.")
+ end if
+ end do
+
+ if(.not.no_titles) then
+ font_height = get_res_value_keep(opts,"FontHeightF",0.01)
+ txt = create "map_titles" textItemClass wks
+ "txString" : SubTitles
+ "txFontHeightF" : font_height
+ ;"txFontColor" : font_color
+ end create
+ anno = NhlAddAnnotation(base,txt)
+ setvalues anno
+ "amZone" : 3
+ "amJust" : "BottomLeft"
+ "amSide" : "Top"
+ "amParallelPosF" : 0.005
+ "amOrthogonalPosF" : 0.03
+ "amResizeNotify" : False
+ end setvalues
+ base at map_titles = anno
+ end if
+ ;
+ ; gsnDraw and gsnFrame should default to True if not a panel plot.
+ ; gsnFrame will default to False if opt_arg is False.
+ ;
+ if(panel_plot.or..not.opt_arg) then
+ call_frame = False
+ else
+ call_frame = True
+ end if
+ if(panel_plot) then
+ call_draw = False
+ else
+ call_draw = True
+ end if
+ opts at gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw)
+ opts at gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame)
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ draw_and_frame(wks,base,opts at gsnDraw,opts at gsnFrame,False,
+ opts at gsnMaximize)
+
+ if(.not.panel_plot) then
+ do i=0,nplots-1
+ if(.not.ismissing(plots(i))) then
+ NhlRemoveOverlay(base,plots(i),False)
+ else
+ print("wrf_remove_map_overlay: Warning: overlay plot #" + i + " is not valid.")
+ print(" Nothing to remove.")
+ end if
+ end do
+ end if
+
+ if(.not.no_titles.and..not.panel_plot) then
+ if(isatt(base,"map_titles")) then
+ NhlRemoveAnnotation(base,base at map_titles)
+ delete(base at map_titles)
+ end if
+ end if
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("wrf_overlay")
+ procedure wrf_overlay(wks:graphic, plots[*]:graphic,
+ opt_arg[1]:logical)
+
+ ; As of version 5.0.1, this procedure is obsolete. Use wrf_overlays
+ ; instead. It is being kept for backwards capability. Do not make any
+ ; changes to it except possibly to fix bugs.
+ ;
+ ; This procedure takes an array of plots and overlays them.
+ ;
+ ; It will advance the plot and cleanup, unless you set the
+ ; PanelPlot resource to True.
+ ;
+ ; Attributes recognized by this procedure:
+ ; NoTitles (don't do any titles)
+ ; PanelPlot
+ ;
+ ; If the "NoTitles" attribute exists and is set True, then
+ ; don't create the top-left titles, and leave the main titles alone.
+ ; This resource can be useful if you are planning to panel
+ ; the plots.
+ ;
+ ; If PanelPlot is set to True, then this flags to wrf_overlay
+ ; that these plots are going to be eventually paneled (likely
+ ; by gsn_panel), and hence 1) draw and frame should not be called
+ ; (unless gsnDraw and/or gsnFrame are explicitly set to True),
+ ; and 2) the overlays and titles should not be removed with
+ ; NhlRemoveOverlay and NhlRemoveAnnotation.
+ ;
+ ; If LatLonOverlay is set to True, then this means the user is
+ ; using the 2D lat/lon coordinates to do the overlay, and hence
+ ; tfDoNDCOverlay should not be set to True. (The default is False.)
+ ;
+ begin
+ print("wrf_overlay: Warning: This procedure is obsolete. Consider using")
+ print(" wrf_overlays instead.")
+
+ opts = opt_arg ; Make a copy of the resource list.
+ opts = True
+
+ if(opts.and.isatt(opts,"NoTitles").and.opts at NoTitles) then
+ no_titles = True
+ else
+ no_titles = False
+ end if
+
+ panel_plot = get_res_value(opts,"PanelPlot",False) ; Are we paneling?
+ latlon_overlay = get_res_value(opts,"LatLonOverlay",False) ; lat/lon overlay?
+
+ nplots = dimsizes(plots)
+
+ base = plots(0)
+ if(.not.no_titles) then
+ getvalues plots(0)
+ "tiMainString" : SubTitle
+ end getvalues
+ SubTitles = SubTitle
+ if(.not.latlon_overlay) then
+ setvalues plots(0)
+ "tfDoNDCOverlay" : True
+ "tiMainOn" : False
+ end setvalues
+ else
+ setvalues plots(0)
+ "tiMainOn" : False
+ end setvalues
+ end if
+ else
+ setvalues plots(0)
+ "tfDoNDCOverlay" : True
+ end setvalues
+ end if
+
+ if (nplots.eq.1) then
+ blank = create "BlankPlot" logLinPlotClass wks
+ ;"cnConstFLabelOn" : False
+ end create
+ overlay(base,blank)
+ end if
+
+ do i=1,nplots-1
+ if(.not.ismissing(plots(i))) then
+ if(.not.no_titles) then
+ getvalues plots(i)
+ "tiMainString" : SubTitle
+ end getvalues
+ SubTitles = SubTitles + "~C~" + SubTitle
+ if(.not.latlon_overlay) then
+ setvalues plots(i)
+ "tfDoNDCOverlay" : True
+ "tiMainOn" : False
+ end setvalues
+ else
+ setvalues plots(i)
+ "tiMainOn" : False
+ end setvalues
+ end if
+ else
+ if(.not.latlon_overlay) then
+ setvalues plots(i)
+ "tfDoNDCOverlay" : True
+ end setvalues
+ end if
+ end if
+ overlay(base,plots(i))
+ else
+ print("wrf_overlay: Warning: overlay plot #" + i + " is not valid.")
+ end if
+ end do
+
+ if(.not.no_titles) then
+ font_height = get_res_value_keep(opts,"FontHeightF",0.01)
+
+ txt = create "map_titles" textItemClass wks
+ "txString" : SubTitles
+ "txFontHeightF" : font_height
+ end create
+ anno = NhlAddAnnotation(base,txt)
+ setvalues anno
+ "amZone" : 3
+ "amJust" : "BottomLeft"
+ "amSide" : "Top"
+ "amParallelPosF" : 0.005
+ "amOrthogonalPosF" : 0.03
+ "amResizeNotify" : False
+ end setvalues
+ base at map_titles = anno
+ end if
+
+ ;
+ ; gsnDraw and gsnFrame should default to True if not a panel plot.
+ ; gsnFrame will default to False if opt_arg is False.
+ ;
+ if(panel_plot.or..not.opt_arg) then
+ call_frame = False
+ else
+ call_frame = True
+ end if
+ if(panel_plot) then
+ call_draw = False
+ else
+ call_draw = True
+ end if
+ opts at gsnDraw = get_res_value_keep(opts,"gsnDraw", call_draw)
+ opts at gsnFrame = get_res_value_keep(opts,"gsnFrame", call_frame)
+ opts at gsnMaximize = get_res_value_keep(opts,"gsnMaximize", True)
+
+ draw_and_frame(wks,base,opts at gsnDraw,opts at gsnFrame,False,
+ opts at gsnMaximize)
+
+ if(.not.no_titles.and..not.panel_plot) then
+ NhlRemoveAnnotation(base,base at map_titles)
+ delete(base at map_titles)
+ end if
+
+ if(.not.panel_plot) then
+ if ( nplots .ge. 2 ) then
+ do i=1,nplots-1
+ if(.not.ismissing(plots(i))) then
+ NhlRemoveOverlay(base,plots(i),False)
+ else
+ print("wrf_remove_overlay: Warning: overlay plot #" + i + " is not valid.")
+ print(" Nothing to remove.")
+ end if
+ end do
+ end if
+ end if
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("add_white_space")
+ function add_white_space(str:string,maxlen:integer)
+
+ begin
+ cstr = stringtochar(str)
+ len = dimsizes(cstr)-1
+ ws = ""
+ if(len.lt.maxlen) then
+ do i=1,maxlen-len
+ ws = ws + " "
+ end do
+ end if
+ return(ws)
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("print_opts")
+ procedure print_opts(opts_name,opts,debug)
+
+ begin
+ if(.not.debug) then
+ return
+ end if
+ varatts = getvaratts(opts)
+ ;
+ ; Sort attributes alphabetically/
+ ;
+ sqsort(varatts)
+ ;
+ ; Get length of longest attribute name.
+ ;
+ cvaratts = stringtochar(varatts)
+ cmaxlen = dimsizes(cvaratts(0,:))-1
+
+ print("------------------------------------------------------------")
+ print(opts_name + "...") ; Print name of option variable.
+ ;
+ ; Loop through each attribute in the list. If its value is an array,
+ ; then print out the array with '(/' and '/)' around it.
+ ;
+ ; If the value is a string, then put ticks (') around each string.
+ ;
+ do i=0,dimsizes(varatts)-1
+ x = opts@$varatts(i)$
+ ;
+ ; Use add_white_space to make sure all the equal signs line up.
+ ;
+ tmp_str = " " + varatts(i) +
+ add_white_space(varatts(i),cmaxlen) + " = "
+ ;
+ ; Check if attribute is an array.
+ ;
+ if(dimsizes(x).gt.1) then
+ tmp_str = tmp_str + "(/"
+ do j=0,dimsizes(x)-1
+ if(typeof(x(j)).eq."string") then
+ tmp_str = tmp_str + "'" + x(j) + "'"
+ else
+ tmp_str = tmp_str + x(j)
+ end if
+ if(j.lt.dimsizes(x)-1) then
+ tmp_str = tmp_str + ","
+ else
+ tmp_str = tmp_str + "/)"
+ end if
+ end do
+ else if(typeof(x).eq."string") then
+ tmp_str = tmp_str + "'" + x + "'"
+ else
+ tmp_str = tmp_str + x
+ end if
+ end if
+ print("" + tmp_str)
+ delete(x)
+ end do
+
+ end
+
+ ;--------------------------------------------------------------------------------
+
+ undef("print_header")
+ procedure print_header(icount:integer,debug)
+ begin
+ icount = icount + 1
+ if(.not.debug) then
+ return
+ end if
+ print("END plot #" + icount)
+ print("------------------------------------------------------------")
+
+ end
+
+ ;--------------------------------------------------------------------------------
+ ; arm_sgp_trend_line_diurnal.ncl
+
Loading file "./gsn_code.ncl"
fatal:syntax error: line 12347 in file ./gsn_code.ncl before or near print
print
----^
+
Loading file "/usr/share/ncarg/nclscripts/csm/contributed.ncl"
+
Loading file "./gsn_csm.ncl"
+
Loading file "./plot_arm_sgp_trend_line_diurnal.ncl"
+
+
+ begin
+
+ ; SET UP THE PLOT PLATFORM
+ type = "x11"
+ ; type = "pdf"
+ ; type = "png"
+ plot_pre = "1plt_arm_sgp_trend_line_diurnal_v01_"
+ dir_plot = "./arm_sgp/"
+
+
+ ; DATA DIRECTORY
+ dir_data = "./"
+
+ ; TIME SERIES STRING
+ stime = (/"00:00", "01:00", "02:00", "03:00",
+ "04:00", "05:00", "06:00", "07:00",
+ "08:00", "09:00", "10:00", "11:00",
+ "12:00", "13:00", "14:00", "15:00",
+ "16:00", "17:00", "18:00", "19:00",
+ "20:00", "21:00", "22:00", "23:00"/)
+
+ ; TIME ARRAY EVERY 10 MINS ONE POINT FOR 24 HOURS
+ mint = 0.0
+ maxt = 47
+ intt = 48
+ time = fspan(mint, maxt, intt)
+
+ ; SETUP TIME FRAME
+ start_year = 2017
+ end_year = 2017
+ start_month = 12
+ end_month = 12
+ start_day = 20
+ end_day = 25
+
+ ; VARIABLE LIST
+ variable =
+ (/
+ "co2_flux",
+ "qc_co2_flux"
+ /)
+
+ print("AAA01")
+ ; DO THE FILE LOOP TO READ VARIABLES
+ ; VARIABLE LOOP
+ do ivar = 0, dimsizes(variable)-1
+ do iyear = start_year, end_year
+ siyear = sprinti("%0.4i", iyear)
+ do imonth = start_month, end_month
+ simonth = sprinti("%0.2i", imonth)
+ ; CALCULATE THE NUMBER OF DAYS IN THIS MONTH
+ nday_month = days_in_month(iyear, imonth)
+ do iday = start_day, end_day;nday_month
+ siday = sprinti("%0.2i", iday)
+ sdate = siyear + simonth + siday
+ print("NOW WORKING ON : " + sdate)
+ print("AAA02")
+ wks = gsn_open_wks(type, dir_plot + plot_pre + sdate + "_" + variable(ivar))
+ ; BUILD FILENAME BASED ON TIME
+ filename = "sgpco2flx4mC1.b1." + sdate + ".001500.nc"
+ ; READ VAIRABLE OUT
+ f = addfile(dir_data + filename, "r")
+ data = f->$variable(ivar)$
+
+ print("AAA03")
+ ; CALL SUBROUTINE plot_arm_sgp_trend_line_diurnal.ncl TO PLOT DIURNAL VARIATION
+ plot_arm_sgp_trend_line_diurnal
+ (wks, sdate, time, stime, variable(ivar), data)
+ end do ; iday
+ end do ; imonth
+ end do ; iyear
+ end do ; ivar
+ end
-------------- next part --------------
A non-text attachment was scrubbed...
Name: sgpco2flx4mC1.b1.20171225.001500.nc
Type: application/x-netcdf
Size: 39380 bytes
Desc: not available
URL: <http://mailman.ucar.edu/pipermail/ncl-talk/attachments/20180427/6a2fba37/attachment-0001.nc>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: plot_arm_sgp_trend_line_diurnal.ncl
Type: application/octet-stream
Size: 3196 bytes
Desc: not available
URL: <http://mailman.ucar.edu/pipermail/ncl-talk/attachments/20180427/6a2fba37/attachment-0004.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: gsn_csm.ncl
Type: application/octet-stream
Size: 525757 bytes
Desc: not available
URL: <http://mailman.ucar.edu/pipermail/ncl-talk/attachments/20180427/6a2fba37/attachment-0005.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: gsn_code.ncl
Type: application/octet-stream
Size: 490191 bytes
Desc: not available
URL: <http://mailman.ucar.edu/pipermail/ncl-talk/attachments/20180427/6a2fba37/attachment-0006.obj>
-------------- next part --------------
A non-text attachment was scrubbed...
Name: arm_sgp_trend_line_diurnal.ncl
Type: application/octet-stream
Size: 2383 bytes
Desc: not available
URL: <http://mailman.ucar.edu/pipermail/ncl-talk/attachments/20180427/6a2fba37/attachment-0007.obj>
More information about the ncl-talk
mailing list