FV3 Bundle
diag_axis.F90
Go to the documentation of this file.
1 !***********************************************************************
2 !* GNU Lesser General Public License
3 !*
4 !* This file is part of the GFDL Flexible Modeling System (FMS).
5 !*
6 !* FMS is free software: you can redistribute it and/or modify it under
7 !* the terms of the GNU Lesser General Public License as published by
8 !* the Free Software Foundation, either version 3 of the License, or (at
9 !* your option) any later version.
10 !*
11 !* FMS is distributed in the hope that it will be useful, but WITHOUT
12 !* ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 !* FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
14 !* for more details.
15 !*
16 !* You should have received a copy of the GNU Lesser General Public
17 !* License along with FMS. If not, see <http://www.gnu.org/licenses/>.
18 !***********************************************************************
19 
21 #include <fms_platform.h>
22  ! <CONTACT EMAIL="seth.underwood@noaa.gov">
23  ! Seth Underwood
24  ! </CONTACT>
25 
26  ! <OVERVIEW> <TT>diag_axis_mod</TT> is an integral part
27  ! of diag_manager_mod. It helps to create axis IDs
28  ! that are used in register_diag_field.
29  ! </OVERVIEW>
30 
31  ! <DESCRIPTION> Users first create axis ID by calling
32  ! diag_axis_init, then use this axis ID in
33  ! register_diag_field.
34  ! </DESCRIPTION>
35 
37  & mpp_get_domain_components, null_domain1d, null_domain2d, null_domainug,&
38  & OPERATOR(.NE.), mpp_get_global_domain, mpp_get_domain_name
39  USE fms_mod, ONLY: error_mesg, write_version_number, lowercase, uppercase,&
40  & fms_error_handler, fatal, note
44 #ifdef use_netCDF
45  USE netcdf, ONLY: nf90_int, nf90_float, nf90_char
46 #endif
47 
48  IMPLICIT NONE
49 
50  PRIVATE
58 
59  ! Module variables
60  ! Parameters
61  ! Include variable "version" to be written to log file.
62 #include<file_version.h>
63 
64 !----------
65 !ug support
66  integer(INT_KIND),parameter,public :: diag_axis_nodomain = 0
67  integer(INT_KIND),parameter,public :: diag_axis_2ddomain = 1
68  integer(INT_KIND),parameter,public :: diag_axis_ugdomain = 2
69 !----------
70 
71  ! counter of number of axes defined
72  INTEGER, DIMENSION(:), ALLOCATABLE :: num_subaxes
73  INTEGER :: num_def_axes = 0
74 
75  ! storage for axis set names
76  CHARACTER(len=128), DIMENSION(:), ALLOCATABLE, SAVE :: axis_sets
77  INTEGER :: num_axis_sets = 0
78 
79  ! ---- global storage for all defined axes ----
80  TYPE(diag_axis_type), ALLOCATABLE, SAVE :: axes(:)
81  LOGICAL :: module_is_initialized = .false.
82 
83  ! <INTERFACE NAME="diag_axis_add_attribute">
84  ! <OVERVIEW>
85  ! Add a attribute to the diag axis
86  ! </OVERVIEW>
87  ! <TEMPLATE>
88  ! SUBROUTINE diag_axis_add_attribute(diag_axis_id, att_name, att_value)
89  ! </TEMPLATE>
90  ! <DESCRIPTION>
91  ! Add an arbitrary attribute and value to the diagnostic axis. Any number
92  ! of attributes can be added to a given axis. All attribute addition must
93  ! be done before first <TT>send_data</TT> call.
94  !
95  ! If a real or integer attribute is already defined, a FATAL error will be called.
96  ! If a character attribute is already defined, then it will be prepended to the
97  ! existing attribute value.
98  ! </DESCRIPTION>
99  ! <IN NAME="diag_axis_id" TYPE="INTEGER" />
100  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)" />
101  ! <IN NAME="att_value" TYPE="REAL|INTEGER|CHARACTER(len=*)" />
103  MODULE PROCEDURE diag_axis_add_attribute_scalar_r
104  MODULE PROCEDURE diag_axis_add_attribute_scalar_i
105  MODULE PROCEDURE diag_axis_add_attribute_scalar_c
106  MODULE PROCEDURE diag_axis_add_attribute_r1d
107  MODULE PROCEDURE diag_axis_add_attribute_i1d
108  END INTERFACE diag_axis_add_attribute
109  ! </INTERFACE>
110 
111 CONTAINS
112 
113  ! <FUNCTION NAME="diag_axis_init">
114  ! <OVERVIEW>
115  ! Initialize the axis, and return the axis ID.
116  ! </OVERVIEW>
117  ! <TEMPLATE>
118  ! INTEGER FUNCTION diag_axis_init(name, data, units, cart_name, long_name,
119  ! direction, set_name, edges, Domain, Domain2, aux, req, tile_count)
120  ! </TEMPLATE>
121  ! <DESCRIPTION>
122  ! <TT>diag_axis_init</TT> initializes an axis and returns the axis ID that
123  ! is to be used with <TT>register_diag_field</TT>. This function also
124  ! increments the axis counter and fills in the axes
125  ! </DESCRIPTION>
126  ! <IN NAME="name" TYPE="CHARACTER(len=*)">Short name for axis</IN>
127  ! <IN NAME="data" TYPE="REAL, DIMENSION(:)">Array of coordinate values</IN>
128  ! <IN NAME="units" TYPE="CHARACTER(len=*)">Units for the axis</IN>
129  ! <IN NAME="cart_name" TYPE="CHARACTER(len=*)">
130  ! Cartesian axis ("X", "Y", "Z", "T")
131  ! </IN>
132  ! <IN NAME="direction" TYPE="INTEGER, OPTIONAL" DEFAULT="0">
133  ! Indicates the direction of the axis:
134  ! <UL>
135  ! <LI>Up if +1</LI>
136  ! <LI>Down if -1</LI>
137  ! <LI>Neither up or down if 0</LI>
138  ! </UL>
139  ! </IN>
140  ! <IN NAME="long_name" TYPE="CHARACTER(len=*), OPTIONAL" DEFAULT="name">
141  ! Long name for the axis.
142  ! </IN>
143  ! <IN NAME="edges" TYPE="INTEGER, OPTIONAL">
144  ! Axis ID for the previously defined "edges axis"
145  ! </IN>
146  ! <IN NAME="Domain" TYPE="TYPE(domain1d), OPTIONAL" />
147  ! <IN NAME="Domain2" TYPE="TYPE(domain2d), OPTIONAL" />
148  ! <IN NAME="aux" TYPE="CHARACTER(len=*), OPTIONAL">
149  ! Auxiliary name, can only be <TT>geolon_t</TT> or <TT>geolat_t</TT>
150  ! </IN>
151  ! <IN NAME="req" TYPE="CHARACTER(len=*), OPTIONAL">
152  ! Required field names.
153  ! </IN>
154  ! <IN NAME="tile_count" TYPE="INTEGER, OPTIONAL" />
155  INTEGER FUNCTION diag_axis_init(name, DATA, units, cart_name, long_name, direction,&
156  & set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count)
157  CHARACTER(len=*), INTENT(in) :: name
158  REAL, DIMENSION(:), INTENT(in) :: data
159  CHARACTER(len=*), INTENT(in) :: units
160  CHARACTER(len=*), INTENT(in) :: cart_name
161  CHARACTER(len=*), INTENT(in), OPTIONAL :: long_name, set_name
162  INTEGER, INTENT(in), OPTIONAL :: direction, edges
163  TYPE(domain1d), INTENT(in), OPTIONAL :: domain
164  TYPE(domain2d), INTENT(in), OPTIONAL :: domain2
165  TYPE(domainug), INTENT(in), OPTIONAL :: domainu
166  CHARACTER(len=*), INTENT(in), OPTIONAL :: aux, req
167  INTEGER, INTENT(in), OPTIONAL :: tile_count
168 
169  TYPE(domain1d) :: domain_x, domain_y
170  INTEGER :: ierr, axlen
171  INTEGER :: i, set, tile
172  INTEGER :: isc, iec, isg, ieg
173  CHARACTER(len=128) :: emsg
174 
175  IF ( .NOT.module_is_initialized ) THEN
176  CALL write_version_number("DIAG_AXIS_MOD", version)
177  ENDIF
178 
179  IF ( PRESENT(tile_count)) THEN
180  tile = tile_count
181  ELSE
182  tile = 1
183  END IF
184 
185  ! Allocate the axes
186  IF (.NOT. ALLOCATED(axis_sets)) ALLOCATE(axis_sets(max_num_axis_sets))
187  IF (.NOT. ALLOCATED(axes)) ALLOCATE(axes(max_axes))
188  IF (.NOT. ALLOCATED(num_subaxes)) THEN
189  ALLOCATE(num_subaxes(max_axes))
190  num_subaxes = 0
191  END IF
192 
193  !---- is there an axis set? ----
194  IF ( PRESENT(set_name) ) THEN
195  set = get_axis_set_num(set_name)
196  !---- add new set name ----
197  IF (set == 0) THEN
199  IF ( num_axis_sets > max_num_axis_sets ) THEN
200  WRITE (emsg, fmt='("num_axis_sets (",I2,") exceeds max_num_axis_sets (",I2,"). ")')&
202  ! <ERROR STATUS="FATAL">
203  ! num_axis_sets (<num_axis_sets>) exceeds max_num_axis_sets(<num_axis_sets>).
204  ! Increase max_num_axis_sets via diag_manager_nml.
205  ! </ERROR>
206  CALL error_mesg('diag_axis_mod::diag_axis_init',&
207  & trim(emsg)//' Increase max_num_axis_sets via diag_manager_nml.', fatal)
208  END IF
209  set = num_axis_sets
210  axis_sets(set) = set_name
211  END IF
212  ELSE
213  set = 0
214  END IF
215 
216  !---- see if axis already exists --
217  ! if this is time axis, return the ID of a previously defined
218  ! if this is spatial axis, FATAL error
219  DO i = 1, num_def_axes
220  IF ( trim(name) == axes(i)%name ) THEN
221  IF ( trim(name) == 'Stations' .OR. trim(name) == 'Levels') THEN
222  diag_axis_init = i
223  RETURN
224  ELSE IF ( set == axes(i)%set ) THEN
225  IF ( trim(lowercase(name)) == 'time' .OR.&
226  & trim(lowercase(cart_name)) == 't' .OR.&
227  & trim(lowercase(name)) == 'nv' .OR.&
228  & trim(lowercase(cart_name)) == 'n' ) THEN
229  diag_axis_init = i
230  RETURN
231  ELSE IF ( (lowercase(cart_name) /= 'x' .AND. lowercase(cart_name) /= 'y')&
232  & .OR. tile /= axes(i)%tile_count) THEN
233  ! <ERROR STATUS="FATAL">axis_name <NAME> and axis_set already exist.</ERROR>
234  CALL error_mesg('diag_axis_mod::diag_axis_init',&
235  & 'axis_name '//trim(name)//' and axis_set already exist.', fatal)
236  END IF
237  END IF
238  END IF
239  END DO
240 
241  !---- register axis ----
243  ! <ERROR STATUS="FATAL">max_axes exceeded, increase it via diag_manager_nml</ERROR>
244  IF (num_def_axes > max_axes) CALL error_mesg ('diag_axis_mod::diag_axis_init',&
245  & 'max_axes exceeded, increase via diag_manager_nml', fatal)
247 
248  !---- check and then save cart_name name ----
249  IF ( trim(uppercase(cart_name)) == 'X' .OR.&
250  & trim(uppercase(cart_name)) == 'Y' .OR.&
251  & trim(uppercase(cart_name)) == 'Z' .OR.&
252  & trim(uppercase(cart_name)) == 'T' .OR.&
253  & trim(uppercase(cart_name)) == 'U' .OR.&
254  & trim(uppercase(cart_name)) == 'N' ) THEN
255  axes(diag_axis_init)%cart_name = trim(uppercase(cart_name))
256  ELSE
257  ! <ERROR STATUS="FATAL">Invalid cart_name name.</ERROR>
258  CALL error_mesg('diag_axis_mod::diag_axis_init', 'Invalid cart_name name.', fatal)
259  END IF
260 
261  !---- allocate storage for coordinate values of axis ----
262  IF ( axes(diag_axis_init)%cart_name == 'T' ) THEN
263  axlen = 0
264  ELSE
265  axlen = SIZE(DATA(:))
266  END IF
267  ALLOCATE ( axes(diag_axis_init)%data(1:axlen) )
268 
269  ! Initialize Axes(diag_axis_init)
270  axes(diag_axis_init)%name = trim(name)
271  axes(diag_axis_init)%data = DATA(1:axlen)
272  axes(diag_axis_init)%units = units
273  axes(diag_axis_init)%length = axlen
274  axes(diag_axis_init)%set = set
275  ! start and end are used in subaxes information only
276  axes(diag_axis_init)%start = -1
277  axes(diag_axis_init)%end = -1
278  axes(diag_axis_init)%subaxis_name = ""
279  axes(diag_axis_init)%shift = 0
280  axes(diag_axis_init)%num_attributes = 0
281 
282  IF ( PRESENT(long_name) ) THEN
283  axes(diag_axis_init)%long_name = long_name
284  ELSE
285  axes(diag_axis_init)%long_name = name
286  END IF
287 
288  IF ( PRESENT(aux) ) THEN
289  axes(diag_axis_init)%aux = trim(aux)
290  ELSE
291  axes(diag_axis_init)%aux = 'none'
292  END IF
293 
294  IF ( PRESENT(req) ) THEN
295  axes(diag_axis_init)%req = trim(req)
296  ELSE
297  axes(diag_axis_init)%req = 'none'
298  END IF
299 
300 
301  !---- axis direction (-1, 0, or +1) ----
302  IF ( PRESENT(direction) )THEN
303  IF ( abs(direction) /= 1 .AND. direction /= 0 )&
304  ! <ERROR STATUS="FATAL">direction must be 0, +1, or -1</ERROR>
305  & CALL error_mesg('diag_axis_mod::diag_axis_init', 'direction must be 0, +1 or -1', fatal)
306  axes(diag_axis_init)%direction = direction
307  ELSE
308  axes(diag_axis_init)%direction = 0
309  END IF
310 
311  !---- Handle the DomainU check
312  IF (present(domainu) .AND. (PRESENT(domain2) .OR. PRESENT(domain)) ) THEN
313  ! <ERROR STATUS="FATAL">Presence of DomainU and another Domain at the same time is prohibited</ERROR>
314  CALL error_mesg('diag_axis_mod::diag_axis_init',&
315  & 'Presence of DomainU and another Domain at the same time is prohibited', fatal)
316  !---- domain2d type ----
317  ELSE IF ( PRESENT(domain2) .AND. PRESENT(domain)) THEN
318  ! <ERROR STATUS="FATAL">Presence of both Domain and Domain2 at the same time is prohibited</ERROR>
319  CALL error_mesg('diag_axis_mod::diag_axis_init',&
320  & 'Presence of both Domain and Domain2 at the same time is prohibited', fatal)
321  ELSE IF ( PRESENT(domain2) .OR. PRESENT(domain)) THEN
322  IF ( axes(diag_axis_init)%cart_name /= 'X' .AND. axes(diag_axis_init)%cart_name /= 'Y') THEN
323  ! <ERROR STATUS="FATAL">Domain must not be present for an axis which is not in the X or Y direction.</ERROR>
324  CALL error_mesg('diag_axis_mod::diag_axis_init',&
325  & 'A Structured Domain must not be present for an axis which is not in the X or Y direction', fatal)
326  END IF
327  ELSE IF (present(domainu) .AND. axes(diag_axis_init)%cart_name /= 'U') THEN
328  CALL error_mesg('diag_axis_mod::diag_axis_init',&
329  & 'In the unstructured domain, the axis cart_name must be U', fatal)
330  END IF
331 
332  axes(diag_axis_init)%tile_count = tile
333 
334  IF ( PRESENT(domain2) ) THEN
335  axes(diag_axis_init)%Domain2 = domain2
336  CALL mpp_get_domain_components(domain2, domain_x, domain_y, tile_count=tile_count)
337  IF ( axes(diag_axis_init)%cart_name == 'X' ) axes(diag_axis_init)%Domain = domain_x
338  IF ( axes(diag_axis_init)%cart_name == 'Y' ) axes(diag_axis_init)%Domain = domain_y
339  axes(diag_axis_init)%DomainUG = null_domainug
340  ELSE IF ( PRESENT(domain)) THEN
341  !---- domain1d type ----
342  axes(diag_axis_init)%Domain2 = null_domain2d ! needed since not 2-D domain
343  axes(diag_axis_init)%Domain = domain
344  axes(diag_axis_init)%DomainUG = null_domainug
345  ELSE IF (present(domainu)) THEN
348  axes(diag_axis_init)%DomainUG = domainu
349  ELSE
352  axes(diag_axis_init)%DomainUG = null_domainug
353  END IF
354 
355  !--- set up the shift value for x-y axis
356  IF ( axes(diag_axis_init)%Domain .NE. null_domain1d ) THEN
357  CALL mpp_get_compute_domain(axes(diag_axis_init)%Domain, isc, iec)
358  CALL mpp_get_global_domain(axes(diag_axis_init)%Domain, isg, ieg)
359  IF ( axes(diag_axis_init)%length == ieg - isg + 2 ) THEN
360  axes(diag_axis_init)%shift = 1
361  END IF
362  END IF
363 
364  !---- have axis edges been defined ? ----
365  axes(diag_axis_init)%edges = 0
366  IF (PRESENT(edges) ) THEN
367  IF ( edges > 0 .AND. edges < num_def_axes ) THEN
368  ierr=0
369  IF ( axes(edges)%cart_name /= axes(diag_axis_init)%cart_name) ierr=1
370  IF ( axes(edges)%length /= axes(diag_axis_init)%length+1 ) ierr=ierr+2
371  IF ( axes(edges)%set /= axes(diag_axis_init)%set ) ierr=ierr+4
372  IF ( ierr > 0 ) THEN
373  ! <ERROR STATUS="FATAL">Edges axis does not match axis (code <CODE>).</ERROR>
374  WRITE (emsg,'("Edges axis does not match axis (code ",I1,").")') ierr
375  CALL error_mesg('diag_axis_mod::diag_axis_init', emsg, fatal)
376  END IF
377  axes(diag_axis_init)%edges = edges
378  ELSE
379  ! <ERROR STATUS="FATAL">Edges axis is not defined.</ERROR>
380  CALL error_mesg('diag_axis_mod::diag_axis_init', 'Edges axis is not defined', fatal)
381  END IF
382  END IF
383 
384  ! Module is now initialized
385  module_is_initialized = .true.
386 
387  END FUNCTION diag_axis_init
388  ! </FUNCTION>
389 
390  ! <FUNCTION NAME="diag_subaxes_init">
391  ! <OVERVIEW>
392  ! Create a subaxis on a parent axis.
393  ! </OVERVIEW>
394  ! <TEMPLATE>
395  ! INTEGER FUNCTION diag_subaxes_init(axis, subdata, start_indx, end_indx,
396  ! domain_1d, domain_2d)
397  ! </TEMPLATE>
398  ! <DESCRIPTION>
399  ! Given the ID of a parent axis, create a subaxis and fill it with data,
400  ! and return the ID of the corresponding subaxis.
401  !
402  ! The subaxis is defined on the parent axis from <TT>start_indx</TT>
403  ! to <TT>end_indx</TT>.
404  ! </DESCRIPTION>
405  ! <IN NAME="axis" TYPE="INTEGER">ID of the parent axis</IN>
406  ! <IN NAME="subdata" TYPE="REAL, DIMENSION(:)">Data of the subaxis</IN>
407  ! <IN NAME="start_indx" TYPE="INTEGER">Start index of the subaxis</IN>
408  ! <IN NAME="end_indx" TYPE="INTEGER">End index of the subaxis</IN>
409  ! <IN NAME="domain_1d" TYPE="TYPE(domain1d), OPTIONAL" />
410  ! <IN NAME="domain_2d" TYPE="TYPE(domain2d), OPTIONAL" />
411  INTEGER FUNCTION diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2d)
412  INTEGER, INTENT(in) :: axis
413  REAL, DIMENSION(:), INTENT(in) :: subdata
414  INTEGER, INTENT(in) :: start_indx
415  INTEGER, INTENT(in) :: end_indx
416  TYPE(domain2d), INTENT(in), OPTIONAL :: domain_2d
417 
418  INTEGER :: i, nsub_axis, direction
419  INTEGER :: xbegin, xend, ybegin, yend
420  INTEGER :: ad_xbegin, ad_xend, ad_ybegin, ad_yend
421  CHARACTER(len=128) :: name, nsub_name
422  CHARACTER(len=128) :: units
423  CHARACTER(len=128) :: cart_name
424  CHARACTER(len=128) :: long_name
425  CHARACTER(len=128) :: emsg
426  LOGICAL :: subaxis_set, hasdomain
427 
428  ! there may be more than 1 subaxis on a parent axis, check for redundancy
429  nsub_axis = 0
430  subaxis_set = .false.
431 
432  IF ( PRESENT(domain_2d) ) THEN
433  hasdomain = .true.
434  CALL mpp_get_compute_domain(domain_2d, xbegin, xend, ybegin, yend)
435  ELSE
436  hasdomain = .false.
437  END IF
438  sa_search: DO i = 1, num_subaxes(axis)
439  IF ( start_indx == axes(axis)%start(i) .AND. end_indx == axes(axis)%end(i) ) THEN
440  IF ( hasdomain ) THEN
441  CALL mpp_get_compute_domain(axes(axis)%subaxis_domain2(i), ad_xbegin, ad_xend, ad_ybegin, ad_yend)
442  IF ( .NOT.((xbegin == ad_xbegin .AND. xend == ad_xend) .AND.&
443  & (ybegin == ad_ybegin .AND. yend == ad_yend)) ) THEN
444  cycle sa_search
445  END IF
446  END IF
447  nsub_axis = i
448  subaxis_set = .true. !subaxis already exists
449  name = trim(axes(axis)%subaxis_name(nsub_axis))
450  EXIT sa_search
451  END IF
452  END DO sa_search
453 
454  IF ( nsub_axis == 0 ) THEN ! create new subaxis
455  num_subaxes(axis) = num_subaxes(axis) + 1
456  IF (num_subaxes(axis) > max_subaxes) THEN
457  ! <ERROR STATUS="FATAL">max_subaxes (value <VALUE>) is too small. Consider increasing max_subaxes.</ERROR>
458  WRITE (emsg,'("max_subaxes (value ",I4,") is too small. Consider increasing max_subaxes.")') max_subaxes
459  CALL error_mesg('diag_axis_mod::diag_subaxes_init', emsg, fatal)
460  END IF
461  nsub_axis = num_subaxes(axis)
462  axes(axis)%start(nsub_axis) = start_indx
463  axes(axis)%end(nsub_axis) = end_indx
464  if ( hasdomain ) axes(axis)%subaxis_domain2(nsub_axis) = domain_2d
465  END IF
466 
467  ! Create new name for the subaxis from name of parent axis
468  ! If subaxis already exists, get the index and return
469  IF(subaxis_set) THEN
470  IF ( axes(axis)%set > 0 ) THEN
471  diag_subaxes_init = get_axis_num(name, set_name=trim(axis_sets(axes(axis)%set)))
472  ELSE
474  END IF
475  ELSE
476  ! get a new index for subaxis
477  !::sdu:: Need a check to allow larger numbers in the index number.
478  WRITE (nsub_name,'(I2.2)') nsub_axis
479  name = trim(axes(axis)%name)//'_sub'//trim(nsub_name)
480  axes(axis)%subaxis_name(nsub_axis) = name
481  long_name = trim(axes(axis)%long_name)
482  units = trim(axes(axis)%units)
483  cart_name = trim(axes(axis)%cart_name)
484  direction = axes(axis)%direction
485  IF (axes(axis)%set > 0) THEN
486  diag_subaxes_init = diag_axis_init(trim(name), subdata, trim(units), trim(cart_name), trim(long_name),&
487  & set_name=trim(axis_sets(axes(axis)%set)), direction=direction, domain2=domain_2d)
488  ELSE
489  diag_subaxes_init = diag_axis_init(trim(name), subdata, trim(units), trim(cart_name), trim(long_name),&
490  & direction=direction, domain2=domain_2d)
491  END IF
492  END IF
493  END FUNCTION diag_subaxes_init
494  ! </FUNCTION>
495 
496  ! <SUBROUTINE NAME="get_diag_axis">
497  ! <OVERVIEW>
498  ! Return information about the axis with index ID
499  ! </OVERVIEW>
500  ! <TEMPLATE>
501  ! SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,
502  ! direction, edges, Domain, data, num_attributes, attributes)
503  ! </TEMPLATE>
504  ! <DESCRIPTION>
505  ! Return information about the axis with index ID
506  ! </DESCRIPTION>
507  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
508  ! <OUT NAME="name" TYPE="CHARACTER(len=*)">Short name for axis</OUT>
509  ! <OUT NAME="units" TYPE="CHARACTER(len=*)">Units for axis</OUT>
510  ! <OUT NAME="long_name" TYPE="CHARACTER(len=*)">Long name for axis</OUT>
511  ! <OUT NAME="cart_name" TYPE="CHARACTER(len=*)">
512  ! Cartesian axis ("x", "y", "z", "t", "u").
513  ! </OUT>
514  ! <OUT NAME="direction" TYPE="INTEGER">
515  ! Direction of data. (See <TT>diag_axis_init</TT> for a description of
516  ! allowed values)
517  ! </OUT>
518  ! <OUT NAME="edges" TYPE="INTEGER">
519  ! Axis ID for the previously defined "edges axis".
520  ! </OUT>
521  ! <OUT NAME="Domain" TYPE="TYPE(domain1d)" />
522  ! <OUT NAME="DomainU" TYPE="TYPE(domainUG)" />
523  ! <OUT NAME="data" TYPE="REAL, DIMENSION(:)">
524  ! Array of coordinate values for this axis.
525  ! </OUT>
526  SUBROUTINE get_diag_axis(id, name, units, long_name, cart_name,&
527  & direction, edges, Domain, DomainU, DATA, num_attributes, attributes)
528  CHARACTER(len=*), INTENT(out) :: name, units, long_name, cart_name
529  INTEGER, INTENT(in) :: id
530  TYPE(domain1d), INTENT(out) :: domain
531  TYPE(domainug), INTENT(out) :: domainu
532  INTEGER, INTENT(out) :: direction, edges
533  REAL, DIMENSION(:), INTENT(out) :: data
534  INTEGER, INTENT(out), OPTIONAL :: num_attributes
535  TYPE(diag_atttype), ALLOCATABLE, DIMENSION(:), INTENT(out), OPTIONAL :: attributes
536 
537  INTEGER :: i, j, istat
538 
539  CALL valid_id_check(id, 'get_diag_axis')
540  name = axes(id)%name
541  units = axes(id)%units
542  long_name = axes(id)%long_name
543  cart_name = axes(id)%cart_name
544  direction = axes(id)%direction
545  edges = axes(id)%edges
546  domain = axes(id)%Domain
547  domainu = axes(id)%DomainUG
548  IF ( axes(id)%length > SIZE(DATA(:)) ) THEN
549  ! <ERROR STATUS="FATAL">array data is too small.</ERROR>
550  CALL error_mesg('diag_axis_mod::get_diag_axis', 'array data is too small', fatal)
551  ELSE
552  DATA(1:axes(id)%length) = axes(id)%data(1:axes(id)%length)
553  END IF
554  IF ( PRESENT(num_attributes) ) THEN
555  num_attributes = axes(id)%num_attributes
556  END IF
557  IF ( PRESENT(attributes) ) THEN
558  IF ( _allocated(axes(id)%attributes) ) THEN
559  IF ( ALLOCATED(attributes) ) THEN
560  ! If allocate, make sure attributes is large enough to hold Axis(id)%attributes
561  IF ( axes(id)%num_attributes .GT. SIZE(attributes(:)) ) THEN
562  CALL error_mesg('diag_axis_mod::get_diag_axis', 'array attribute is too small', fatal)
563  END IF
564  ELSE
565  ! Allocate attributes
566  ALLOCATE(attributes(axes(id)%num_attributes), stat=istat)
567  IF ( istat .NE. 0 ) THEN
568  CALL error_mesg('diag_axis_mod::get_diag_axis', 'Unable to allocate memory for attribute', fatal)
569  END IF
570  END IF
571  DO i=1, axes(id)%num_attributes
572  ! Unallocate all att arrays in preparation for new data
573  IF ( _allocated(attributes(i)%fatt) ) THEN
574  DEALLOCATE(attributes(i)%fatt)
575  END IF
576  IF ( _allocated(attributes(i)%iatt) ) THEN
577  DEALLOCATE(attributes(i)%iatt)
578  END IF
579 
580  ! Copy in attribute data
581  attributes(i)%type = axes(id)%attributes(i)%type
582  attributes(i)%len = axes(id)%attributes(i)%len
583  attributes(i)%name = axes(id)%attributes(i)%name
584  attributes(i)%catt = axes(id)%attributes(i)%catt
585  ! Allocate fatt arrays (if needed), and copy in data
586  IF ( _allocated(axes(id)%attributes(i)%fatt) ) THEN
587  ALLOCATE(attributes(i)%fatt(SIZE(axes(id)%attributes(i)%fatt(:))), stat=istat)
588  IF ( istat .NE. 0 ) THEN
589  CALL error_mesg('diag_axis_mod::get_diag_axis', 'Unable to allocate memory for attribute%fatt', fatal)
590  END IF
591  DO j=1, SIZE(attributes(i)%fatt(:))
592  attributes(i)%fatt(j) = axes(id)%attributes(i)%fatt(j)
593  END DO
594  END IF
595  ! Allocate iatt arrays (if needed), and copy in data
596  IF ( _allocated(axes(id)%attributes(i)%iatt) ) THEN
597  ALLOCATE(attributes(i)%iatt(SIZE(axes(id)%attributes(i)%iatt(:))), stat=istat)
598  IF ( istat .NE. 0 ) THEN
599  CALL error_mesg('diag_axis_mod::get_diag_axis', 'Unable to allocate memory for attribute%iatt', fatal)
600  END IF
601  DO j=1, SIZE(attributes(i)%iatt(:))
602  attributes(i)%iatt(j) = axes(id)%attributes(i)%iatt(j)
603  END DO
604  END IF
605  END DO
606  END IF
607  END IF
608  END SUBROUTINE get_diag_axis
609  ! </SUBROUTINE>
610 
611  ! <SUBROUTINE NAME="get_diag_axis_cart">
612  ! <OVERVIEW>
613  ! Return the axis cartesian.
614  ! </OVERVIEW>
615  ! <TEMPLATE>
616  ! SUBROUTINE get_diag_axis_cart(id, cart_name)
617  ! </TEMPLATE>
618  ! <DESCRIPTION>
619  ! Return the axis cartesian ('X', 'Y', 'Z' or 'T') for the axis ID given.
620  ! </DESCRIPTION>
621  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
622  ! <OUT NAME="cart_name" TYPE="CHARACTER(len=*)">Cartesian axis</OUT>
623  SUBROUTINE get_diag_axis_cart(id, cart_name)
624  INTEGER, INTENT(in) :: id
625  CHARACTER(len=*), INTENT(out) :: cart_name
626 
627  CALL valid_id_check(id, 'get_diag_axis_cart')
628  cart_name = axes(id)%cart_name
629  END SUBROUTINE get_diag_axis_cart
630  ! </SUBROUTINE>
631 
632  ! <SUBROUTINE NAME="get_diag_axis_data">
633  ! <OVERVIEW>
634  ! Return the axis data.
635  ! </OVERVIEW>
636  ! <TEMPLATE>
637  ! SUBROUTINE get_diag_axis_data(id, data)
638  ! </TEMPLATE>
639  ! <DESCRIPTION>
640  ! Return the axis data for the axis ID given.
641  ! </DESCRIPTION>
642  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
643  ! <OUT NAME="data" TYPE="REAL, DIMENSION(:)">Axis data</OUT>
644  SUBROUTINE get_diag_axis_data(id, DATA)
645  INTEGER, INTENT(in) :: id
646  REAL, DIMENSION(:), INTENT(out) :: data
647 
648  CALL valid_id_check(id, 'get_diag_axis_data')
649  IF (axes(id)%length > SIZE(DATA(:))) THEN
650  ! <ERROR STATUS="FATAL">array data is too small</ERROR>
651  CALL error_mesg('diag_axis_mod::get_diag_axis_data', 'array data is too small', fatal)
652  ELSE
653  DATA(1:axes(id)%length) = axes(id)%data
654  END IF
655  END SUBROUTINE get_diag_axis_data
656  ! </SUBROUTINE>
657 
658  ! <SUBROUTINE NAME="get_diag_axis_name">
659  ! <OVERVIEW>
660  ! Return the short name of the axis.
661  ! </OVERVIEW>
662  ! <TEMPLATE>
663  ! SUBROUTINE get_diag_axis_name (id, name)
664  ! </TEMPLATE>
665  ! <DESCRIPTION>
666  ! Return the short name for the axis ID given.
667  ! </DESCRIPTION>
668  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
669  ! <OUT NAME="name" TYPE="CHARACTER(len=*)">Axis short name</OUT>
670  SUBROUTINE get_diag_axis_name(id, name)
671  INTEGER , INTENT(in) :: id
672  CHARACTER(len=*), INTENT(out) :: name
673 
674  CALL valid_id_check(id, 'get_diag_axis_name')
675  name = axes(id)%name
676  END SUBROUTINE get_diag_axis_name
677  ! </SUBROUTINE>
678 
679  ! <SUBROUTINE NAME="get_diag_axis_domain_name">
680  ! <OVERVIEW>
681  ! Return the name of the axis' domain
682  ! </OVERVIEW>
683  ! <TEMPLATE>
684  ! SUBROUTINE get_diag_axis_domain_name(id, name)
685  ! </TEMPLATE>
686  ! <DESCRIPTION>
687  ! Retruns the name of the axis' domain.
688  ! </DESCRIPTION>
689  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
690  ! <OUT NAME="name" TYPE="CHARACTER(len=*)">Axis' domain name</OUT>
691  SUBROUTINE get_diag_axis_domain_name(id, name)
692  INTEGER, INTENT(in) :: id
693  CHARACTER(len=*), INTENT(out) :: name
694 
695  CALL valid_id_check(id, 'get_diag_axis_domain_name')
696  name = mpp_get_domain_name(axes(id)%domain2)
697  END SUBROUTINE get_diag_axis_domain_name
698  ! </SUBROUTINE>
699 
700  ! <FUNCTION NAME="get_axis_length">
701  ! <OVERVIEW>
702  ! Return the length of the axis.
703  ! </OVERVIEW>
704  ! <TEMPLATE>
705  ! INTEGER FUNCTION get_axis_length(id)
706  ! </TEMPLATE>
707  ! <DESCRIPTION>
708  ! Return the length of the axis ID given.
709  ! </DESCRIPTION>
710  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
711  INTEGER FUNCTION get_axis_length(id)
712  INTEGER, INTENT(in) :: id
713 
714  INTEGER :: length
715 
716  CALL valid_id_check(id, 'get_axis_length')
717  IF ( axes(id)%Domain .NE. null_domain1d ) THEN
718  CALL mpp_get_compute_domain(axes(id)%Domain,size=length)
719  !---one extra point is needed for some case. ( like symmetry domain )
720  get_axis_length = length + axes(id)%shift
721  ELSE
722  get_axis_length = axes(id)%length
723  END IF
724  END FUNCTION get_axis_length
725  ! </FUNCTION>
726 
727  ! <FUNCTION NAME="get_axis_aux">
728  ! <OVERVIEW>
729  ! Return the auxiliary name for the axis.
730  ! </OVERVIEW>
731  ! <TEMPLATE>
732  ! CHARACTER(len=128) FUNCTION get_axis_aux(id)
733  ! </TEMPLATE>
734  ! <DESCRIPTION>
735  ! Returns the auxiliary name for the axis. The only possible values for
736  ! the auxiliary names is <TT>geolon_t</TT> or <TT>geolat_t</TT>.
737  ! </DESCRIPTION>
738  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
739  CHARACTER(len=128) FUNCTION get_axis_aux(id)
740  INTEGER, INTENT(in) :: id
741 
742  CALL valid_id_check(id, 'get_axis_aux')
743  get_axis_aux = axes(id)%aux
744  END FUNCTION get_axis_aux
745  ! </FUNCTION>
746 
747  ! <FUNCTION NAME="get_axis_reqfld">
748  ! <OVERVIEW>
749  ! Return the required field names for the axis.
750  ! </OVERVIEW>
751  ! <TEMPLATE>
752  ! CHARACTER(len=128) FUNCTION get_axis_reqfld(id)
753  ! </TEMPLATE>
754  ! <DESCRIPTION>
755  ! Returns the required field names for the axis.
756  ! </DESCRIPTION>
757  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
758  CHARACTER(len=128) FUNCTION get_axis_reqfld(id)
759  INTEGER, INTENT(in) :: id
760 
761  CALL valid_id_check(id, 'get_axis_reqfld')
762  get_axis_reqfld = axes(id)%req
763  END FUNCTION get_axis_reqfld
764  ! </FUNCTION>
765 
766  ! <FUNCTION NAME="get_axis_global_length">
767  ! <OVERVIEW>
768  ! Return the global length of the axis.
769  ! </OVERVIEW>
770  ! <TEMPLATE>
771  ! INTEGER FUNCTION get_axis_global_length (id)
772  ! </TEMPLATE>
773  ! <DESCRIPTION>
774  ! Returns the global length of the axis ID given.
775  ! </DESCRIPTION>
776  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
777  INTEGER FUNCTION get_axis_global_length(id)
778  INTEGER, INTENT(in) :: id
779 
780  CALL valid_id_check(id, 'get_axis_global_length')
781  get_axis_global_length = axes(id)%length
782  END FUNCTION get_axis_global_length
783  ! </FUNCTION>
784 
785  ! <FUNCTION NAME="get_tile_count">
786  ! <OVERVIEW>
787  ! Return the tile count for the axis.
788  ! </OVERVIEW>
789  ! <TEMPLATE>
790  ! INTEGER FUNCTION get_tile_count (ids)
791  ! </TEMPLATE>
792  ! <DESCRIPTION>
793  ! Return the tile count for the axis IDs given.
794  ! </DESCRIPTION>
795  ! <IN NAME="ids" TYPE="INTEGER, DIMENSION(:)">
796  ! Axis IDs. Possible dimensions: 1 <= <TT>size(ids(:))</TT> <= 4.
797  ! </IN>
798  INTEGER FUNCTION get_tile_count(ids)
799  INTEGER, DIMENSION(:), INTENT(in) :: ids
800 
801  INTEGER :: i, id, flag
802 
803  IF ( SIZE(ids(:)) < 1 ) THEN
804  ! <ERROR STATUS="FATAL">input argument has incorrect size.</ERROR>
805  CALL error_mesg('diag_axis_mod::get_tile_count', 'input argument has incorrect size', fatal)
806  END IF
807  get_tile_count = 1
808  flag = 0
809  DO i = 1, SIZE(ids(:))
810  id = ids(i)
811  CALL valid_id_check(id, 'get_tile_count')
812  IF ( axes(id)%cart_name == 'X' .OR. &
813  axes(id)%cart_name == 'Y' ) flag = flag + 1
814  ! --- both x/y axes found ---
815  IF ( flag == 2 ) THEN
816  get_tile_count = axes(id)%tile_count
817  EXIT
818  END IF
819  END DO
820  END FUNCTION get_tile_count
821  ! </FUNCTION>
822 
823  ! <FUNCTION NAME="get_domain1d">
824  ! <OVERVIEW>
825  ! Return the 1D domain.
826  ! </OVERVIEW>
827  ! <TEMPLATE>
828  ! TYPE(domain1d) FUNCTION get_domain1d(id)
829  ! </TEMPLATE>
830  ! <DESCRIPTION>
831  ! Retrun the 1D domain for the axis ID given.
832  ! </DESCRIPTION>
833  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
834  TYPE(domain1d) function get_domain1d(id)
835  INTEGER, INTENT(in) :: id
836 
837  CALL valid_id_check(id, 'get_domain1d')
838  IF (axes(id)%Domain .NE. null_domain1d) THEN
839  get_domain1d = axes(id)%Domain
840  ELSE
842  ENDIF
843  END FUNCTION get_domain1d
844  ! </FUNCTION>
845 
846  ! <FUNCTION NAME="get_domain2d">
847  ! <OVERVIEW>
848  ! Return the 2D domain.
849  ! </OVERVIEW>
850  ! <TEMPLATE>
851  ! TYPE(domain2d) FUNCTION get_domain2d(ids)
852  ! </TEMPLATE>
853  ! <DESCRIPTION>
854  ! Return the 2D domain for the axis IDs given.
855  ! </DESCRIPTION>
856  ! <IN NAME="ids" TYPE="INTEGER, DIMENSION(:)">
857  ! Axis IDs. Possible dimensions: 1 <= <TT>size(ids(:))</TT> <= 4.
858  ! </IN>
859  TYPE(domain2d) function get_domain2d(ids)
860  INTEGER, DIMENSION(:), INTENT(in) :: ids
861 
862  INTEGER :: i, id, flag
863 
864  IF ( SIZE(ids(:)) < 1 ) THEN
865  ! <ERROR STATUS="FATAL">input argument has incorrect size.</ERROR>
866  CALL error_mesg('diag_axis_mod::get_domain2d', 'input argument has incorrect size', fatal)
867  END IF
868  get_domain2d = null_domain2d
869  flag = 0
870  DO i = 1, SIZE(ids(:))
871  id = ids(i)
872  CALL valid_id_check(id, 'get_domain2d')
873  IF ( axes(id)%cart_name == 'X' .OR. axes(id)%cart_name == 'Y' ) flag = flag + 1
874  ! --- both x/y axes found ---
875  IF ( flag == 2 ) THEN
876  IF (axes(id)%Domain2 .NE. null_domain2d) get_domain2d = axes(id)%Domain2
877  EXIT
878  END IF
879  END DO
880  END FUNCTION get_domain2d
881 
882  ! <FUNCTION NAME="get_domainUG">
883  ! <OVERVIEW>
884  ! Return the UG domain.
885  ! </OVERVIEW>
886  ! <TEMPLATE>
887  ! TYPE(domainUG) FUNCTION get_domainUG(id)
888  ! </TEMPLATE>
889  ! <DESCRIPTION>
890  ! Retrun the 1D domain for the axis ID given.
891  ! </DESCRIPTION>
892  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
893  TYPE(domainug) function get_domainug(id)
894  INTEGER, INTENT(in) :: id
895 
896  CALL valid_id_check(id, 'get_domainUG')
897  IF (axes(id)%DomainUG .NE. null_domainug) THEN
898  get_domainug = axes(id)%DomainUG
899  ELSE
900  get_domainug = null_domainug
901  ENDIF
902  END FUNCTION get_domainug
903 
904  ! <SUBROUTINE NAME="axis_compatible_check">
905  ! <OVERVIEW>
906  ! Checks if the axes are compatible
907  ! </OVERVIEW>
908  ! <TEMPLATE>
909  ! INTEGER FUNCTION axis_compatible_check(id)
910  ! </TEMPLATE>
911  ! <DESCRIPTION>
912  ! Checks if the axes are compatible
913  ! </DESCRIPTION>
914  ! <IN NAME="id" TYPE="INTEGER">Axis ID</IN>
915 !----------
916 !ug support
917  function axis_compatible_check(id,varname) result(domain_type)
919  !Inputs/Outputs
920  integer,dimension(:),intent(in) :: id !<The array of axis IDs
921  character(*),intent(in),optional :: varname !<The name of the variable
922  integer(INT_KIND) :: domain_type !<DIAG_AXIS_NODOMAIN = no domain.
923  !<DIAG_AXIS_2DDOMAIN = structured domain.
924  !<DIAG_AXIS_UGDOMAIN = unstructured domain.
925 
926  !Local variables
927  logical :: xory !<XorY set to true if X or Y is found as a cart_name.
928  logical :: ug !<UG set to true if U is found as a cart_name.
929  integer :: n !<Looping index.
930  logical :: uses_domain2d !<True if an axis is associated with a 2D domain.
931  logical :: uses_domainug !<True if an axis is associated with an unstructured domain.
932 
933  !Initialize flags.
934  xory = .false.
935  ug = .false.
936  uses_domain2d = .false.
937  uses_domainug = .false.
938 
939  !Make sure that valid set of axes was passed, and determine the domain-type
940  !associated with the axes.
941  do n = 1,size(id)
942  call valid_id_check(id(n), &
943  "axis_compatible_check")
944  if (axes(id(n))%cart_name .eq. "X" .or. &
945  axes(id(n))%cart_name .eq. "Y") then
946  xory = .true.
947  elseif (axes(id(n))%cart_name .eq. "U") then
948  ug = .true.
949  endif
950  if (axes(id(n))%Domain2 .ne. null_domain2d) then
951  uses_domain2d = .true.
952  elseif (axes(id(n))%DomainUG .ne. null_domainug) then
953  uses_domainug = .true.
954  endif
955  enddo
956  if (ug .and. xory) then
957  if (present(varname)) then
958  call error_mesg("axis_compatible_check", &
959  "Can not use an unstructured grid with a "// &
960  "horizontal cartesian coordinate for the field " &
961  //trim(varname), &
962  fatal)
963  else
964  call error_mesg("axis_compatible_check", &
965  "Can not use an unstructured grid with a horizontal "// &
966  "cartesian coordinate", &
967  fatal)
968  endif
969  endif
970  if (uses_domain2d .and. uses_domainug) then
971  if (present(varname)) then
972  call error_mesg("axis_compatible_check", &
973  "Can not use an unstructured grid with a"// &
974  "structured grid for the field "//trim(varname), &
975  fatal)
976  else
977  call error_mesg("axis_compatible_check", &
978  "Can not use an unstructured grid with a"// &
979  "structured grid.", &
980  fatal)
981  endif
982  endif
983  if (uses_domain2d) then
984  domain_type = diag_axis_2ddomain
985  elseif (uses_domainug) then
986  domain_type = diag_axis_ugdomain
987  else
988  domain_type = diag_axis_nodomain
989  endif
990 
991  return
992  end function axis_compatible_check
993 !----------
994 
995  ! </FUNCTION>
996 
997  ! <SUBROUTINE NAME="get_axes_shift">
998  ! <OVERVIEW>
999  ! Return the value of the shift.
1000  ! </OVERVIEW>
1001  ! <TEMPLATE>
1002  ! SUBROUTINE get_axes_shift(ids, ishift, jshift)
1003  ! </TEMPLATE>
1004  ! <DESCRIPTION>
1005  ! Return the value of the shift for the axis IDs given.
1006  ! </DESCRIPTION>
1007  ! <IN NAME="ids" TYPE="INTEGER, DIMENSION(:)">
1008  ! Axis IDs. Possible dimensions: 1 <= <TT>size(ids(:))</TT> <= 4
1009  ! </IN>
1010  ! <OUT NAME="ishift" TYPE="INTEGER">X shift value.</OUT>
1011  ! <OUT NAME="jshift" TYPE="INTEGER">Y shift value.</OUT>
1012  SUBROUTINE get_axes_shift(ids, ishift, jshift)
1013  INTEGER, DIMENSION(:), INTENT(in) :: ids
1014  INTEGER, INTENT(out) :: ishift, jshift
1015 
1016  INTEGER :: i, id
1017 
1018  !-- get the value of the shift.
1019  ishift = 0
1020  jshift = 0
1021  DO i = 1, SIZE(ids(:))
1022  id = ids(i)
1023  CALL valid_id_check(id, 'get_axes_shift')
1024  SELECT CASE (axes(id)%cart_name)
1025  CASE ( 'X' )
1026  ishift = axes(id)%shift
1027  CASE ( 'Y' )
1028  jshift = axes(id)%shift
1029  END SELECT
1030  END DO
1031  END SUBROUTINE get_axes_shift
1032  ! </SUBROUTINE>
1033 
1034  ! <PRIVATE>
1035  ! <FUNCTION NAME="get_axis_num">
1036  ! <OVERVIEW>
1037  ! Returns index into axis table corresponding to a given axis name.
1038  ! </OVERVIEW>
1039  ! <TEMPLATE>
1040  ! INTEGER FUNCTION get_axis_num(axis_name, set_name)
1041  ! </TEMPLATE>
1042  ! <DESCRIPTION>
1043  ! Returns index into axis table corresponding to a given axis name.
1044  ! </DESCRIPTION>
1045  ! <IN NAME="axis_name" TYPE="CHARACTER(len=*)">Axis name.</IN>
1046  ! <IN NAME="set_name" TYPE="CHARACTER(len=*), OPTIONAL">Set name.</IN>
1047  INTEGER FUNCTION get_axis_num(axis_name, set_name)
1048  CHARACTER(len=*), INTENT(in) :: axis_name
1049  CHARACTER(len=*), INTENT(in), OPTIONAL :: set_name
1050 
1051  INTEGER :: set, n
1052 
1053  IF ( PRESENT(set_name) ) THEN
1054  set = get_axis_set_num(trim(set_name))
1055  ELSE
1056  set = 0
1057  END IF
1058  get_axis_num = 0
1059  DO n = 1, num_def_axes
1060  IF ( trim(axis_name) == trim(axes(n)%name) .AND. axes(n)%set == set ) THEN
1061  get_axis_num = n
1062  RETURN
1063  END IF
1064  END DO
1065  END FUNCTION get_axis_num
1066  ! </FUNCTION>
1067  ! </PRIVATE>
1068 
1069  ! <PRIVATE>
1070  ! <FUNCTION NAME="get_axis_set_num">
1071  ! <OVERVIEW>
1072  ! Returns index in axis set table corresponding to a given axis set name.
1073  ! </OVERVIEW>
1074  ! <TEMPLATE>
1075  ! INTEGER FUNCTION get_axis_set_num(set_name)
1076  ! </TEMPLATE>
1077  ! <DESCRIPTION>
1078  ! Returns index in axis set table corresponding to a given axis set name.
1079  ! </DESCRIPTION>
1080  ! <IN NAME="set_name" TYPE="CHARACTER(len=*)">Set name.</IN>
1081  INTEGER FUNCTION get_axis_set_num (set_name)
1082  CHARACTER(len=*), INTENT(in) :: set_name
1083 
1084  INTEGER :: iset
1085 
1086  get_axis_set_num = 0
1087  DO iset = 1, num_axis_sets
1088  IF ( set_name == axis_sets(iset) ) THEN
1089  get_axis_set_num = iset
1090  RETURN
1091  END IF
1092  END DO
1093  END FUNCTION get_axis_set_num
1094  ! </FUNCTION>
1095  ! </PRIVATE>
1096 
1097  ! <PRIVATE>
1098  ! <SUBROUTINE NAME="valid_id_check">
1099  ! <OVERVIEW>
1100  ! Check to see if the axis id is a vaild id.
1101  ! </OVERVIEW>
1102  ! <TEMPLATE>
1103  ! SUBROUTINE valid_id_check(id, routine_name)
1104  ! </TEMPLATE>
1105  ! <DESCRIPTION>
1106  ! Check to see if the given axis id is a valid id. If the axis id is invalid,
1107  ! call a FATAL error. If the ID is valid, just return.
1108  ! </DESCRIPTION>
1109  ! <IN NAME="id" TYPE="INTEGER">Axis id to check for validity</IN>
1110  ! <IN NAME="routine_name" TYPE="CHARACTER(len=*)">Name of the subroutine checking for a valid axis id.</IN>
1111  SUBROUTINE valid_id_check(id, routine_name)
1112  INTEGER, INTENT(in) :: id
1113  CHARACTER(len=*), INTENT(in) :: routine_name
1114 
1115  CHARACTER(len=5) :: emsg
1116 
1117  IF ( id < 1 .OR. id > num_def_axes) THEN
1118  ! <ERROR STATUS="FATAL">
1119  ! Illegal value for axis used (value <VALUE>).
1120  ! </ERROR>
1121  WRITE (emsg, '(I2)') id
1122  CALL error_mesg('diag_axis_mod::'//trim(routine_name),&
1123  & 'Illegal value for axis_id used (value '//trim(emsg)//').', fatal)
1124  END IF
1125  END SUBROUTINE valid_id_check
1126  ! </SUBROUTINE>
1127  ! </PRIVATE>
1128 
1129  SUBROUTINE diag_axis_attribute_init(diag_axis_id, name, type, cval, ival, rval)
1130  INTEGER, INTENT(in) :: diag_axis_id !< input field ID, obtained from diag_axis_mod::diag_axis_init.
1131  CHARACTER(len=*) :: name !< Name of the attribute
1132  INTEGER, INTENT(in) :: type !< NetCDF type (NF_FLOAT, NF_INT, NF_CHAR)
1133  CHARACTER(len=*), INTENT(in), OPTIONAL :: cval !< Character string attribute value
1134  INTEGER, DIMENSION(:), INTENT(in), OPTIONAL :: ival !< Integer attribute value(s)
1135  REAL, DIMENSION(:), INTENT(in), OPTIONAL :: rval !< Real attribute value(s)
1136 
1137  INTEGER :: istat, length, i, j, this_attribute, out_field
1138  CHARACTER(len=1024) :: err_msg
1139 
1140  IF ( .NOT.first_send_data_call ) THEN
1141  ! Call error due to unable to add attribute after send_data called
1142  ! <ERROR STATUS="FATAL">
1143  ! Attempting to add attribute <name> to axis <axis_name>
1144  ! after first send_data call. Too late.
1145  ! </ERROR>
1146  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute', 'Attempting to add attribute "'&
1147  &//trim(name)//'" to axis after first send_data call. Too late.', fatal)
1148  END IF
1149 
1150  ! Simply return if diag_axis_id <= 0 --- not registered
1151  IF ( diag_axis_id .LE. 0 ) THEN
1152  RETURN
1153  ELSE IF ( diag_axis_id .GT. num_def_axes ) THEN
1154  ! Call error axis_id greater than num_def_axes. Axis is unknown
1155  ! <ERROR STATUS="FATAL">
1156  ! Attempting to add attribute <name> to axis ID <axis_ID>, however ID unknown.
1157  ! </ERROR>
1158  WRITE(err_msg, '(I5)') diag_axis_id
1159  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute', 'Attempting to add attribute "'&
1160  &//trim(name)//'" to axis ID "'//trim(err_msg)//'", however ID unknown.', fatal)
1161 
1162  ELSE
1163  ! Allocate memory for the attributes
1164  CALL attribute_init_axis(axes(diag_axis_id))
1165 
1166  ! Check if attribute already exists
1167  this_attribute = 0
1168  DO i=1, axes(diag_axis_id)%num_attributes
1169  IF ( trim(axes(diag_axis_id)%attributes(i)%name) .EQ. trim(name) ) THEN
1170  this_attribute = i
1171  EXIT
1172  END IF
1173  END DO
1174 
1175  IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) ) THEN
1176  ! <ERROR STATUS="FATAL">
1177  ! Attribute <name> already defined for axis <axis_name>.
1178  ! Contact the developers
1179  ! </ERROR>
1180  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute',&
1181  & 'Attribute "'//trim(name)//'" already defined for axis "'&
1182  &//trim(axes(diag_axis_id)%name)//'". Contact the developers.', fatal)
1183  ELSE IF ( this_attribute.NE.0 .AND. type.EQ.nf90_char .AND. debug_diag_manager ) THEN
1184  ! <ERROR STATUS="NOTE">
1185  ! Attribute <name> already defined for axis <axis_name>.
1186  ! Prepending.
1187  ! </ERROR>
1188  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute',&
1189  & 'Attribute "'//trim(name)//'" already defined for axis"'&
1190  &//trim(axes(diag_axis_id)%name)//'". Prepending.', note)
1191  ELSE
1192  ! Defining a new attribute
1193  ! Increase the number of field attributes
1194  this_attribute = axes(diag_axis_id)%num_attributes + 1
1195  ! Checking to see if num_attributes == max_axis_attributes, and return error message
1196  IF ( this_attribute .GT. max_axis_attributes ) THEN
1197  ! <ERROR STATUS="FATAL">
1198  ! Number of attributes exceeds max_axis_attributes for attribute <name> for axis <axis_name>.
1199  ! Increase diag_manager_nml:max_axis_attributes.
1200  ! </ERROR>
1201  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute',&
1202  & 'Number of attributes exceeds max_axis_attributes for attribute "'&
1203  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)&
1204  & //'". Increase diag_manager_nml:max_axis_attributes.',&
1205  & fatal)
1206  ELSE
1207  axes(diag_axis_id)%num_attributes = this_attribute
1208  ! Set name and type
1209  axes(diag_axis_id)%attributes(this_attribute)%name = name
1210  axes(diag_axis_id)%attributes(this_attribute)%type = type
1211  ! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
1212  axes(diag_axis_id)%attributes(this_attribute)%catt = ''
1213  END IF
1214  END IF
1215 
1216  SELECT CASE (type)
1217  CASE (nf90_int)
1218  IF ( .NOT.PRESENT(ival) ) THEN
1219  ! <ERROR STATUS="FATAL">
1220  ! Number type claims INTEGER, but ival not present for attribute <name> for axis <axis_name>.
1221  ! Contact the developers.
1222  ! </ERROR>
1223  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute',&
1224  & 'Attribute type claims INTEGER, but ival not present for attribute "'&
1225  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)&
1226  & //'". Contact the developers.', fatal)
1227  END IF
1228  length = SIZE(ival)
1229  ! Allocate iatt(:) to size of ival
1230  ALLOCATE(axes(diag_axis_id)%attributes(this_attribute)%iatt(length), stat=istat)
1231  IF ( istat.NE.0 ) THEN
1232  ! <ERROR STATUS="FATAL">
1233  ! Unable to allocate iatt for attribute <name> for axis <axis_name>
1234  ! </ERROR>
1235  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute', 'Unable to allocate iatt for attribute "'&
1236  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)//'"', fatal)
1237  END IF
1238  ! Set remaining fields
1239  axes(diag_axis_id)%attributes(this_attribute)%len = length
1240  axes(diag_axis_id)%attributes(this_attribute)%iatt = ival
1241  CASE (nf90_float)
1242  IF ( .NOT.PRESENT(rval) ) THEN
1243  ! <ERROR STATUS="FATAL">
1244  ! Attribute type claims REAL, but rval not present for attribute <name> for axis <axis_name>.
1245  ! Contact the developers.
1246  ! </ERROR>
1247  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute',&
1248  & 'Attribute type claims REAL, but rval not present for attribute "'&
1249  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)&
1250  & //'". Contact the developers.', fatal)
1251  END IF
1252  length = SIZE(rval)
1253  ! Allocate iatt(:) to size of rval
1254  ALLOCATE(axes(diag_axis_id)%attributes(this_attribute)%fatt(length), stat=istat)
1255  IF ( istat.NE.0 ) THEN
1256  ! <ERROR STATUS="FATAL">
1257  ! Unable to allocate fatt for attribute <name> for axis <axis_name>
1258  ! </ERROR>
1259  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute', 'Unable to allocate fatt for attribute "'&
1260  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)&
1261  & //'"', fatal)
1262  END IF
1263  ! Set remaining fields
1264  axes(diag_axis_id)%attributes(this_attribute)%len = length
1265  axes(diag_axis_id)%attributes(this_attribute)%fatt = rval
1266  CASE (nf90_char)
1267  IF ( .NOT.PRESENT(cval) ) THEN
1268  ! <ERROR STATUS="FATAL">
1269  ! Attribute type claims CHARACTER, but cval not present for attribute <name> for axis <axis_name>.
1270  ! Contact the developers.
1271  ! </ERROR>
1272  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute',&
1273  & 'Attribute type claims CHARACTER, but cval not present for attribute "'&
1274  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)&
1275  & //'". Contact the developers.', fatal)
1276  END IF
1277  CALL prepend_attribute_axis(axes(diag_axis_id), trim(name), trim(cval))
1278  CASE default
1279  ! <ERROR STATUS="FATAL">
1280  ! Unknown attribute type for attribute <name> for axis <axis_name>.
1281  ! Contact the developers.
1282  ! </ERROR>
1283  CALL error_mesg('diag_manager_mod::diag_axis_add_attribute', 'Unknown attribute type for attribute "'&
1284  & //trim(name)//'" for axis "'//trim(axes(diag_axis_id)%name)&
1285  & //'". Contact the developers.', fatal)
1286  END SELECT
1287  END IF
1288  END SUBROUTINE diag_axis_attribute_init
1289 
1290  ! <SUBROUTINE NAME="diag_axis_add_attribute_scalar_r" INTERFACE="diag_axis_add_attribute">
1291  ! <IN NAME="diag_axis_id" TYPE="INTEGER" />
1292  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)" />
1293  ! <IN NAME="att_value" TYPE="REAL" />
1294  SUBROUTINE diag_axis_add_attribute_scalar_r(diag_axis_id, att_name, att_value)
1295  INTEGER, INTENT(in) :: diag_axis_id
1296  CHARACTER(len=*), INTENT(in) :: att_name
1297  REAL, INTENT(in) :: att_value
1298 
1299  CALL diag_axis_add_attribute_r1d(diag_axis_id, att_name, (/ att_value /))
1300  END SUBROUTINE diag_axis_add_attribute_scalar_r
1301  ! </SUBROUTINE>
1302 
1303  ! <SUBROUTINE NAME="diag_axis_add_attribute_scalar_i" INTERFACE="diag_axis_add_attribute">
1304  ! <IN NAME="diag_axis_id" TYPE="INTEGER" />
1305  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)" />
1306  ! <IN NAME="att_value" TYPE="INTEGER" />
1307  SUBROUTINE diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value)
1308  INTEGER, INTENT(in) :: diag_axis_id
1309  CHARACTER(len=*), INTENT(in) :: att_name
1310  INTEGER, INTENT(in) :: att_value
1311 
1312  CALL diag_axis_add_attribute_i1d(diag_axis_id, att_name, (/ att_value /))
1313  END SUBROUTINE diag_axis_add_attribute_scalar_i
1314  ! </SUBROUTINE>
1315 
1316  ! <SUBROUTINE NAME="diag_axis_add_attribute_scalar_c" INTERFACE="diag_axis_add_attribute">
1317  ! <IN NAME="diag_axis_id" TYPE="INTEGER" />
1318  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)" />
1319  ! <IN NAME="att_value" TYPE="CHARACTER(len=*)" />
1320  SUBROUTINE diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value)
1321  INTEGER, INTENT(in) :: diag_axis_id
1322  CHARACTER(len=*), INTENT(in) :: att_name
1323  CHARACTER(len=*), INTENT(in) :: att_value
1324 
1325  CALL diag_axis_attribute_init(diag_axis_id, att_name, nf90_char, cval=att_value)
1326  END SUBROUTINE diag_axis_add_attribute_scalar_c
1327  ! </SUBROUTINE>
1328 
1329  ! <SUBROUTINE NAME="diag_axis_add_attribute_r1d" INTERFACE="diag_axis_add_attribute">
1330  ! <IN NAME="diag_axis_id" TYPE="INTEGER" />
1331  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)" />
1332  ! <IN NAME="att_value" TYPE="REAL, DIMENSION(:)" />
1333  SUBROUTINE diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value)
1334  INTEGER, INTENT(in) :: diag_axis_id
1335  CHARACTER(len=*), INTENT(in) :: att_name
1336  REAL, DIMENSION(:), INTENT(in) :: att_value
1337 
1338  INTEGER :: num_attributes, len
1339  CHARACTER(len=512) :: err_msg
1340 
1341  CALL diag_axis_attribute_init(diag_axis_id, att_name, nf90_float, rval=att_value)
1342  END SUBROUTINE diag_axis_add_attribute_r1d
1343  ! </SUBROUTINE>
1344 
1345  ! <SUBROUTINE NAME="diag_axis_add_attribute_i1d" INTERFACE="diag_axis_add_attribute">
1346  ! <IN NAME="diag_axis_id" TYPE="INTEGER" />
1347  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)" />
1348  ! <IN NAME="att_value" TYPE="INTEGER, DIMENSION(:)" />
1349  SUBROUTINE diag_axis_add_attribute_i1d(diag_axis_id, att_name, att_value)
1350  INTEGER, INTENT(in) :: diag_axis_id
1351  CHARACTER(len=*), INTENT(in) :: att_name
1352  INTEGER, DIMENSION(:), INTENT(in) :: att_value
1353 
1354  CALL diag_axis_attribute_init(diag_axis_id, att_name, nf90_int, ival=att_value)
1355  END SUBROUTINE diag_axis_add_attribute_i1d
1356  ! </SUBROUTINE>
1357 
1358  ! <SUBROUTINE NAME="attribute_init_axis" INTERFACE="attribute_init">
1359  ! <OVERVIEW>
1360  ! Allocates the atttype in out_axis
1361  ! </OVERVIEW>
1362  ! <TEMPLATE>
1363  ! SUBROUTINE attribute_init(out_axis, err_msg)
1364  ! </TEMPLATE>
1365  ! <DESCRIPTION>
1366  ! Allocates memory in out_file for the attributes. Will <TT>FATAL</TT> if err_msg is not included
1367  ! in the subroutine call.
1368  ! </DESCRIPTION>
1369  ! <INOUT NAME="out_file" TYPE="TYPE(file_type)">output file to allocate memory for attribute</INOUT>
1370  ! <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">Error message, passed back to calling function</OUT>
1371  SUBROUTINE attribute_init_axis(out_axis, err_msg)
1372  TYPE(diag_axis_type), INTENT(inout) :: out_axis
1373  CHARACTER(LEN=*), INTENT(out), OPTIONAL :: err_msg
1374 
1375  INTEGER :: istat
1376 
1377  ! Initialize err_msg
1378  IF ( PRESENT(err_msg) ) err_msg = ''
1379 
1380  ! Allocate memory for the attributes
1381  IF ( .NOT._allocated(out_axis%attributes) ) THEN
1382  ALLOCATE(out_axis%attributes(max_axis_attributes), stat=istat)
1383  IF ( istat.NE.0 ) THEN
1384  ! <ERROR STATUS="FATAL">
1385  ! Unable to allocate memory for diag axis attributes
1386  ! </ERROR>
1387  IF ( fms_error_handler('diag_util_mod::attribute_init_axis', 'Unable to allocate memory for diag axis attributes', err_msg) ) THEN
1388  RETURN
1389  END IF
1390  ELSE
1391  ! Set equal to 0. It will be increased when attributes added
1392  out_axis%num_attributes = 0
1393  END IF
1394  END IF
1395  END SUBROUTINE attribute_init_axis
1396  ! </SUBROUTINE>
1397 
1398  ! <SUBROUTINE NAME="prepend_attribute_axis">
1399  ! <OVERVIEW>
1400  ! Prepends the attribute value to an already existing attribute. If the
1401  ! attribute isn't yet defined, then creates a new attribute
1402  ! </OVERVIEW>
1403  ! <TEMPLATE>
1404  ! SUBROUTINE prepend_attribute(out_file, attribute, prepend_value)
1405  ! </TEMPLATE>
1406  ! <DESCRIPTION>
1407  ! Checks if the attribute already exists for <TT>out_axis</TT>. If it exists,
1408  ! then prepend the <TT>prepend_value</TT>, otherwise, create the attribute
1409  ! with the <TT>prepend_value</TT>. <TT>err_msg</TT> indicates no duplicates found.
1410  ! </DESCRIPTION>
1411  ! <INOUT NAME="out_axis" TYPE="TYPE(diag_axis_type)">diagnostic axis that will get the attribute</INOUT>
1412  ! <IN NAME="att_name" TYPE="CHARACTER(len=*)">Name of the attribute</IN>
1413  ! <IN NAME="prepend_value" TYPE="CHARACTER(len=*)">Value to prepend</IN>
1414  ! <OUT NAME="err_msg" TYPE="CHARACTER(len=*), OPTIONAL">Error message, passed back to calling routine</OUT>
1415  SUBROUTINE prepend_attribute_axis(out_axis, att_name, prepend_value, err_msg)
1416  TYPE(diag_axis_type), INTENT(inout) :: out_axis
1417  CHARACTER(len=*), INTENT(in) :: att_name, prepend_value
1418  CHARACTER(len=*), INTENT(out) , OPTIONAL :: err_msg
1419 
1420  INTEGER :: length, i, this_attribute
1421  CHARACTER(len=512) :: err_msg_local
1422 
1423  ! Initialize string variables
1424  err_msg_local = ''
1425  IF ( PRESENT(err_msg) ) err_msg = ''
1426 
1427  ! Make sure the attributes for this out file have been initialized
1428  CALL attribute_init_axis(out_axis, err_msg_local)
1429  IF ( trim(err_msg_local) .NE. '' ) THEN
1430  IF ( fms_error_handler('diag_util_mod::prepend_attribute_axis', trim(err_msg_local), err_msg) ) THEN
1431  RETURN
1432  END IF
1433  END IF
1434 
1435  ! Find if attribute exists
1436  this_attribute = 0
1437  DO i=1, out_axis%num_attributes
1438  IF ( trim(out_axis%attributes(i)%name) .EQ. trim(att_name) ) THEN
1439  this_attribute = i
1440  EXIT
1441  END IF
1442  END DO
1443 
1444  IF ( this_attribute > 0 ) THEN
1445  IF ( out_axis%attributes(this_attribute)%type .NE. nf90_char ) THEN
1446  ! <ERROR STATUS="FATAL">
1447  ! Attribute <name> is not a character attribute.
1448  ! </ERROR>
1449  IF ( fms_error_handler('diag_util_mod::prepend_attribute_axis',&
1450  & 'Attribute "'//trim(att_name)//'" is not a character attribute.',&
1451  & err_msg) ) THEN
1452  RETURN
1453  END IF
1454  END IF
1455  ELSE
1456  ! Defining a new attribute
1457  ! Increase the number of file attributes
1458  this_attribute = out_axis%num_attributes + 1
1459  IF ( this_attribute .GT. max_axis_attributes ) THEN
1460  ! <ERROR STATUS="FATAL">
1461  ! Number of attributes exceeds max_axis_attributes for attribute <name>.
1462  ! Increase diag_manager_nml:max_axis_attributes.
1463  ! </ERROR>
1464  IF ( fms_error_handler('diag_util_mod::prepend_attribute_axis',&
1465  & 'Number of attributes exceeds max_axis_attributes for attribute "'&
1466  &//trim(att_name)//'". Increase diag_manager_nml:max_axis_attributes.',&
1467  & err_msg) ) THEN
1468  RETURN
1469  END IF
1470  ELSE
1471  out_axis%num_attributes = this_attribute
1472  ! Set name and type
1473  out_axis%attributes(this_attribute)%name = att_name
1474  out_axis%attributes(this_attribute)%type = nf90_char
1475  ! Initialize catt to a blank string, as len_trim doesn't always work on an uninitialized string
1476  out_axis%attributes(this_attribute)%catt = ''
1477  END IF
1478  END IF
1479 
1480  ! Only add string only if not already defined
1481  IF ( index(trim(out_axis%attributes(this_attribute)%catt), trim(prepend_value)).EQ.0 ) THEN
1482  ! Check if new string length goes beyond the length of catt
1483  length = len_trim(trim(prepend_value)//" "//trim(out_axis%attributes(this_attribute)%catt))
1484  IF ( length.GT.len(out_axis%attributes(this_attribute)%catt) ) THEN
1485  ! <ERROR STATUS="FATAL">
1486  ! Prepend length for attribute <name> is longer than allowed.
1487  ! </ERROR>
1488  IF ( fms_error_handler('diag_util_mod::prepend_attribute_file',&
1489  & 'Prepend length for attribute "'//trim(att_name)//'" is longer than allowed.',&
1490  & err_msg) ) THEN
1491  RETURN
1492  END IF
1493  END IF
1494  ! Set files
1495  out_axis%attributes(this_attribute)%catt =&
1496  & trim(prepend_value)//' '//trim(out_axis%attributes(this_attribute)%catt)
1497  out_axis%attributes(this_attribute)%len = length
1498  END IF
1499  END SUBROUTINE prepend_attribute_axis
1500  ! </SUBROUTINE>
1501 
1502  ! given an axis, returns TRUE if the axis uses compression-by-gathering: that is, if
1503  ! this is an axis for fields on unstructured grid
1504  logical function axis_is_compressed(id)
1505  integer, intent(in) :: id
1506 
1507  integer :: i
1508 
1509  CALL valid_id_check(id, 'axis_is_compressed')
1510 
1511  axis_is_compressed = .false.
1512  if (.not._allocated(axes(id)%attributes)) return
1513  do i = 1, axes(id)%num_attributes
1514  if (trim(axes(id)%attributes(i)%name)=='compress') then
1515  axis_is_compressed = .true.
1516  return
1517  endif
1518  enddo
1519  end function axis_is_compressed
1520 
1521 
1522  ! given an index of compressed-by-gathering axis, return an array of axes used in
1523  ! compression. It is a fatal error to call it on axis that is not compressed
1524  subroutine get_compressed_axes_ids(id, r)
1525  integer, intent(in) :: id
1526  integer, intent(out), allocatable :: r(:)
1527 
1528  integer iatt, k, k1, k2, n
1529  logical :: space
1530 
1531  character(*), parameter :: tag = 'get_compressed_axes_ids'
1532 
1533  CALL valid_id_check(id, tag)
1534 
1535  associate(axis=>axes(id))
1536  if (.not._allocated(axis%attributes)) call error_mesg(tag, &
1537  'attempt to get compression dimensions from axis "'//trim(axis%name)//'" which is not compressed (does not have any attributes)', fatal)
1538 
1539  iatt = 0
1540  do k = 1,axis%num_attributes
1541  if (trim(axis%attributes(k)%name)=='compress') then
1542  iatt = k; exit ! from loop
1543  endif
1544  enddo
1545 
1546  if (iatt == 0) call error_mesg(tag, &
1547  'attempt to get compression dimensions from axis "'//trim(axis%name)//&
1548  '" which is not compressed (does not have "compress" attributes).', fatal)
1549  if (axis%attributes(iatt)%type/=nf90_char) call error_mesg(tag, &
1550  'attempt to get compression dimensions from axis "'//trim(axis%name)//&
1551  '" but the axis attribute "compress" has incorrect type.', fatal)
1552 
1553  ! parse the "compress" attribute
1554  ! calculate the number of compression axes
1555  space = .true.; n=0
1556  do k = 1, len(axis%attributes(iatt)%catt)
1557  if (space.and.(axis%attributes(iatt)%catt(k:k)/=' ')) then
1558  n = n+1
1559  endif
1560  space = (axis%attributes(iatt)%catt(k:k)==' ')
1561  enddo
1562 
1563  allocate(r(n))
1564  ! make array of compression axes indices. Go from the last to the first to get the
1565  ! array in FORTRAN order: they are listed in "compress" attribute C order (fastest
1566  ! dimension last)
1567  k2 = 0
1568  do k = n, 1, -1
1569  do k1 = k2+1, len(axis%attributes(iatt)%catt)
1570  if (axis%attributes(iatt)%catt(k1:k1)/=' ') exit
1571  enddo
1572  do k2 = k1+1, len(axis%attributes(iatt)%catt)
1573  if (axis%attributes(iatt)%catt(k2:k2)==' ') exit
1574  enddo
1575  r(k) = get_axis_num(axis%attributes(iatt)%catt(k1:k2),axis_sets(axis%set))
1576  if (r(k)<=0) call error_mesg(tag, &
1577  'compression dimension "'//trim(axis%attributes(iatt)%catt(k1:k2))//&
1578  '" not found among the axes of set "'//trim(axis_sets(axis%set))//'".', fatal)
1579  enddo
1580  end associate ! axis
1581  end subroutine get_compressed_axes_ids
1582 END MODULE diag_axis_mod
Definition: fms.F90:20
integer(int_kind), parameter, public diag_axis_2ddomain
Definition: diag_axis.F90:67
integer function, public get_tile_count(ids)
Definition: diag_axis.F90:799
subroutine, public get_diag_axis_cart(id, cart_name)
Definition: diag_axis.F90:624
subroutine diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value)
Definition: diag_axis.F90:1334
type(domainug) function, public get_domainug(id)
Definition: diag_axis.F90:894
character(len=128) function, public get_axis_aux(id)
Definition: diag_axis.F90:740
type(domain1d) function, public get_domain1d(id)
Definition: diag_axis.F90:835
integer(int_kind), parameter, public diag_axis_ugdomain
Definition: diag_axis.F90:68
integer max_axis_attributes
Maximum number of user definable attributes per axis.
Definition: diag_data.F90:733
subroutine, public get_diag_axis_name(id, name)
Definition: diag_axis.F90:671
subroutine diag_axis_add_attribute_scalar_r(diag_axis_id, att_name, att_value)
Definition: diag_axis.F90:1295
subroutine diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value)
Definition: diag_axis.F90:1321
logical function, public fms_error_handler(routine, message, err_msg)
Definition: fms.F90:573
integer function, public diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2d)
Definition: diag_axis.F90:412
logical module_is_initialized
Definition: diag_axis.F90:81
subroutine, public get_diag_axis_data(id, DATA)
Definition: diag_axis.F90:645
subroutine, public get_diag_axis(id, name, units, long_name, cart_name, direction, edges, Domain, DomainU, DATA, num_attributes, attributes)
Definition: diag_axis.F90:528
subroutine diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value)
Definition: diag_axis.F90:1308
type(diag_axis_type), dimension(:), allocatable, save axes
Definition: diag_axis.F90:80
integer(int_kind), parameter, public diag_axis_nodomain
Definition: diag_axis.F90:66
logical function, public axis_is_compressed(id)
Definition: diag_axis.F90:1505
subroutine prepend_attribute_axis(out_axis, att_name, prepend_value, err_msg)
Definition: diag_axis.F90:1416
integer, dimension(:), allocatable num_subaxes
Definition: diag_axis.F90:72
integer function, public get_axis_global_length(id)
Definition: diag_axis.F90:778
subroutine, public get_axes_shift(ids, ishift, jshift)
Definition: diag_axis.F90:1013
character(len=128), dimension(:), allocatable, save axis_sets
Definition: diag_axis.F90:76
integer max_num_axis_sets
Definition: diag_data.F90:725
type(domain2d), save, public null_domain2d
subroutine, public get_compressed_axes_ids(id, r)
Definition: diag_axis.F90:1525
subroutine, public get_diag_axis_domain_name(id, name)
Definition: diag_axis.F90:692
integer max_axes
Maximum number of independent axes.
Definition: diag_data.F90:715
subroutine attribute_init_axis(out_axis, err_msg)
Definition: diag_axis.F90:1372
integer function, public diag_axis_init(name, DATA, units, cart_name, long_name, direction, set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count)
Definition: diag_axis.F90:157
integer function, public get_axis_length(id)
Definition: diag_axis.F90:712
integer num_axis_sets
Definition: diag_axis.F90:77
type(domainug), save, public null_domainug
type(domain2d) function, public get_domain2d(ids)
Definition: diag_axis.F90:860
integer, parameter max_subaxes
Definition: diag_data.F90:107
integer function get_axis_set_num(set_name)
Definition: diag_axis.F90:1082
subroutine diag_axis_attribute_init(diag_axis_id, name, type, cval, ival, rval)
Definition: diag_axis.F90:1130
************************************************************************GNU Lesser General Public License **This file is part of the GFDL Flexible Modeling System(FMS). ! *! *FMS is free software without even the implied warranty of MERCHANTABILITY or *FITNESS FOR A PARTICULAR PURPOSE See the GNU General Public License *for more details **You should have received a copy of the GNU Lesser General Public *License along with FMS If see< http:! ***********************************************************************subroutine READ_RECORD_CORE_(unit, field, nwords, data, start, axsiz) integer, intent(in) ::unit type(fieldtype), intent(in) ::field integer, intent(in) ::nwords MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in) ::start(:), axsiz(:) integer(SHORT_KIND) ::i2vals(nwords)!rab used in conjunction with transfer intrinsic to determine size of a variable integer(KIND=1) ::one_byte(8) integer ::word_sz!#ifdef __sgi integer(INT_KIND) ::ivals(nwords) real(FLOAT_KIND) ::rvals(nwords)!#else! integer ::ivals(nwords)! real ::rvals(nwords)!#endif real(DOUBLE_KIND) ::r8vals(nwords) pointer(ptr1, i2vals) pointer(ptr2, ivals) pointer(ptr3, rvals) pointer(ptr4, r8vals) if(mpp_io_stack_size< nwords) call mpp_io_set_stack_size(nwords) call mpp_error(FATAL, 'MPP_READ currently requires use_netCDF option') end subroutine READ_RECORD_CORE_ subroutine READ_RECORD_(unit, field, nwords, data, time_level, domain, position, tile_count, start_in, axsiz_in)!routine that is finally called by all mpp_read routines to perform the read!a non-netCDF record contains:! field ID! a set of 4 coordinates(is:ie, js:je) giving the data subdomain! a timelevel and a timestamp(=NULLTIME if field is static)! 3D real data(stored as 1D)!if you are using direct access I/O, the RECL argument to OPEN must be large enough for the above!in a global direct access file, record position on PE is given by %record.!Treatment of timestamp:! We assume that static fields have been passed without a timestamp.! Here that is converted into a timestamp of NULLTIME.! For non-netCDF fields, field is treated no differently, but is written! with a timestamp of NULLTIME. There is no check in the code to prevent! the user from repeatedly writing a static field. integer, intent(in) ::unit, nwords type(fieldtype), intent(in) ::field MPP_TYPE_, intent(inout) ::data(nwords) integer, intent(in), optional ::time_level type(domain2D), intent(in), optional ::domain integer, intent(in), optional ::position, tile_count integer, intent(in), optional ::start_in(:), axsiz_in(:) integer, dimension(size(field%axes(:))) ::start, axsiz integer ::tlevel !, subdomain(4) integer ::i, error, is, ie, js, je, isg, ieg, jsg, jeg type(domain2d), pointer ::io_domain=> tlevel if(PRESENT(start_in) .AND. PRESENT(axsiz_in)) then if(size(start(! the data domain and compute domain must refer to the subdomain being passed ! In this ! since that attempts to gather all data on PE size(field%axes(:)) axsiz(i)
logical first_send_data_call
Definition: diag_data.F90:795
subroutine diag_axis_add_attribute_i1d(diag_axis_id, att_name, att_value)
Definition: diag_axis.F90:1350
integer(int_kind) function, public axis_compatible_check(id, varname)
Definition: diag_axis.F90:918
character(len=128) function, public get_axis_reqfld(id)
Definition: diag_axis.F90:759
integer function, public get_axis_num(axis_name, set_name)
Definition: diag_axis.F90:1048
subroutine valid_id_check(id, routine_name)
Definition: diag_axis.F90:1112
subroutine, public error_mesg(routine, message, level)
Definition: fms.F90:529
integer num_def_axes
Definition: diag_axis.F90:73
logical debug_diag_manager
Definition: diag_data.F90:718
type(domain1d), save, public null_domain1d