21 #include <fms_platform.h> 45 USE netcdf,
ONLY: nf90_int, nf90_float, nf90_char
62 #include<file_version.h> 76 CHARACTER(len=128),
DIMENSION(:),
ALLOCATABLE,
SAVE ::
axis_sets 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
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
176 CALL write_version_number(
"DIAG_AXIS_MOD", version)
179 IF (
PRESENT(tile_count))
THEN 194 IF (
PRESENT(set_name) )
THEN 200 WRITE (emsg, fmt=
'("num_axis_sets (",I2,") exceeds max_num_axis_sets (",I2,"). ")')&
206 CALL error_mesg(
'diag_axis_mod::diag_axis_init',&
207 & trim(emsg)//
' Increase max_num_axis_sets via diag_manager_nml.', fatal)
220 IF ( trim(name) ==
axes(i)%name )
THEN 221 IF ( trim(name) ==
'Stations' .OR. trim(name) ==
'Levels')
THEN 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 231 ELSE IF ( (lowercase(cart_name) /=
'x' .AND. lowercase(cart_name) /=
'y')&
232 & .OR. tile /=
axes(i)%tile_count)
THEN 234 CALL error_mesg(
'diag_axis_mod::diag_axis_init',&
235 &
'axis_name '//trim(name)//
' and axis_set already exist.', fatal)
245 &
'max_axes exceeded, increase via diag_manager_nml', fatal)
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 258 CALL error_mesg(
'diag_axis_mod::diag_axis_init',
'Invalid cart_name name.', fatal)
265 axlen =
SIZE(
DATA(:))
282 IF (
PRESENT(long_name) )
THEN 288 IF (
PRESENT(aux) )
THEN 294 IF (
PRESENT(req) )
THEN 302 IF (
PRESENT(direction) )
THEN 303 IF ( abs(direction) /= 1 .AND. direction /= 0 )&
305 &
CALL error_mesg(
'diag_axis_mod::diag_axis_init',
'direction must be 0, +1 or -1', fatal)
312 IF (
present(domainu) .AND. (
PRESENT(domain2) .OR.
PRESENT(domain)) )
THEN 314 CALL error_mesg(
'diag_axis_mod::diag_axis_init',&
315 &
'Presence of DomainU and another Domain at the same time is prohibited', fatal)
317 ELSE IF (
PRESENT(domain2) .AND.
PRESENT(domain))
THEN 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 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)
328 CALL error_mesg(
'diag_axis_mod::diag_axis_init',&
329 &
'In the unstructured domain, the axis cart_name must be U', fatal)
334 IF (
PRESENT(domain2) )
THEN 336 CALL mpp_get_domain_components(domain2, domain_x, domain_y, tile_count=tile_count)
340 ELSE IF (
PRESENT(domain))
THEN 345 ELSE IF (
present(domainu))
THEN 366 IF (
PRESENT(edges) )
THEN 374 WRITE (emsg,
'("Edges axis does not match axis (code ",I1,").")') ierr
375 CALL error_mesg(
'diag_axis_mod::diag_axis_init', emsg, fatal)
380 CALL error_mesg(
'diag_axis_mod::diag_axis_init',
'Edges axis is not defined', fatal)
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
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
430 subaxis_set = .false.
432 IF (
PRESENT(domain_2d) )
THEN 439 IF ( start_indx ==
axes(axis)%start(i) .AND. end_indx ==
axes(axis)%end(i) )
THEN 440 IF ( hasdomain )
THEN 442 IF ( .NOT.((xbegin == ad_xbegin .AND. xend == ad_xend) .AND.&
443 & (ybegin == ad_ybegin .AND. yend == ad_yend)) )
THEN 449 name = trim(
axes(axis)%subaxis_name(nsub_axis))
454 IF ( nsub_axis == 0 )
THEN 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)
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
470 IF (
axes(axis)%set > 0 )
THEN 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 487 & set_name=trim(
axis_sets(
axes(axis)%set)), direction=direction, domain2=domain_2d)
490 & direction=direction, domain2=domain_2d)
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
537 INTEGER :: i, j, istat
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 550 CALL error_mesg(
'diag_axis_mod::get_diag_axis',
'array data is too small', fatal)
552 DATA(1:
axes(id)%length) =
axes(id)%data(1:
axes(id)%length)
554 IF (
PRESENT(num_attributes) )
THEN 555 num_attributes =
axes(id)%num_attributes
557 IF (
PRESENT(attributes) )
THEN 558 IF ( _allocated(
axes(id)%attributes) )
THEN 559 IF (
ALLOCATED(attributes) )
THEN 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)
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)
571 DO i=1,
axes(id)%num_attributes
573 IF ( _allocated(attributes(i)%fatt) )
THEN 574 DEALLOCATE(attributes(i)%fatt)
576 IF ( _allocated(attributes(i)%iatt) )
THEN 577 DEALLOCATE(attributes(i)%iatt)
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
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)
591 DO j=1,
SIZE(attributes(i)%fatt(:))
592 attributes(i)%fatt(j) =
axes(id)%attributes(i)%fatt(j)
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)
601 DO j=1,
SIZE(attributes(i)%iatt(:))
602 attributes(i)%iatt(j) =
axes(id)%attributes(i)%iatt(j)
624 INTEGER,
INTENT(in) :: id
625 CHARACTER(len=*),
INTENT(out) :: cart_name
628 cart_name =
axes(id)%cart_name
645 INTEGER,
INTENT(in) :: id
646 REAL,
DIMENSION(:),
INTENT(out) :: data
649 IF (
axes(id)%length >
SIZE(
DATA(:)))
THEN 651 CALL error_mesg(
'diag_axis_mod::get_diag_axis_data',
'array data is too small', fatal)
653 DATA(1:
axes(id)%length) =
axes(id)%data
671 INTEGER ,
INTENT(in) :: id
672 CHARACTER(len=*),
INTENT(out) :: name
692 INTEGER,
INTENT(in) :: id
693 CHARACTER(len=*),
INTENT(out) :: name
696 name = mpp_get_domain_name(
axes(id)%domain2)
712 INTEGER,
INTENT(in) :: id
740 INTEGER,
INTENT(in) :: id
759 INTEGER,
INTENT(in) :: id
778 INTEGER,
INTENT(in) :: id
799 INTEGER,
DIMENSION(:),
INTENT(in) :: ids
801 INTEGER :: i, id, flag
803 IF (
SIZE(ids(:)) < 1 )
THEN 805 CALL error_mesg(
'diag_axis_mod::get_tile_count',
'input argument has incorrect size', fatal)
809 DO i = 1,
SIZE(ids(:))
812 IF (
axes(id)%cart_name ==
'X' .OR. &
813 axes(id)%cart_name ==
'Y' ) flag = flag + 1
815 IF ( flag == 2 )
THEN 835 INTEGER,
INTENT(in) :: id
860 INTEGER,
DIMENSION(:),
INTENT(in) :: ids
862 INTEGER :: i, id, flag
864 IF (
SIZE(ids(:)) < 1 )
THEN 866 CALL error_mesg(
'diag_axis_mod::get_domain2d',
'input argument has incorrect size', fatal)
870 DO i = 1,
SIZE(ids(:))
873 IF (
axes(id)%cart_name ==
'X' .OR.
axes(id)%cart_name ==
'Y' ) flag = flag + 1
875 IF ( flag == 2 )
THEN 894 INTEGER,
INTENT(in) :: id
897 IF (
axes(id)%DomainUG .NE. null_domainug)
THEN 920 integer,
dimension(:),
intent(in) :: id
921 character(*),
intent(in),
optional :: varname
922 integer(INT_KIND) :: domain_type
930 logical :: uses_domain2d
931 logical :: uses_domainug
936 uses_domain2d = .false.
937 uses_domainug = .false.
943 "axis_compatible_check")
944 if (
axes(id(n))%cart_name .eq.
"X" .or. &
945 axes(id(n))%cart_name .eq.
"Y")
then 947 elseif (
axes(id(n))%cart_name .eq.
"U")
then 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.
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 " &
964 call error_mesg(
"axis_compatible_check", &
965 "Can not use an unstructured grid with a horizontal "// &
966 "cartesian coordinate", &
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), &
977 call error_mesg(
"axis_compatible_check", &
978 "Can not use an unstructured grid with a"// &
979 "structured grid.", &
983 if (uses_domain2d)
then 985 elseif (uses_domainug)
then 1013 INTEGER,
DIMENSION(:),
INTENT(in) :: ids
1014 INTEGER,
INTENT(out) :: ishift, jshift
1021 DO i = 1,
SIZE(ids(:))
1024 SELECT CASE (
axes(id)%cart_name)
1026 ishift =
axes(id)%shift
1028 jshift =
axes(id)%shift
1048 CHARACTER(len=*),
INTENT(in) :: axis_name
1049 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: set_name
1053 IF (
PRESENT(set_name) )
THEN 1060 IF ( trim(axis_name) == trim(
axes(n)%name) .AND.
axes(n)%set == set )
THEN 1082 CHARACTER(len=*),
INTENT(in) :: set_name
1112 INTEGER,
INTENT(in) :: id
1113 CHARACTER(len=*),
INTENT(in) :: routine_name
1115 CHARACTER(len=5) :: emsg
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)
1130 INTEGER,
INTENT(in) :: diag_axis_id
1131 CHARACTER(len=*) :: name
1132 INTEGER,
INTENT(in) ::
type 1133 CHARACTER(len=*),
INTENT(in),
OPTIONAL :: cval
1134 INTEGER,
DIMENSION(:),
INTENT(in),
OPTIONAL :: ival
1135 REAL,
DIMENSION(:),
INTENT(in),
OPTIONAL :: rval
1137 INTEGER :: istat, length, i, j, this_attribute, out_field
1138 CHARACTER(len=1024) :: err_msg
1140 IF ( .NOT.first_send_data_call )
THEN 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)
1151 IF ( diag_axis_id .LE. 0 )
THEN 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)
1168 DO i=1,
axes(diag_axis_id)%num_attributes
1169 IF ( trim(
axes(diag_axis_id)%attributes(i)%name) .EQ. trim(name) )
THEN 1175 IF ( this_attribute.NE.0 .AND. (type.EQ.nf90_int .OR. type.EQ.nf90_float) )
THEN 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 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)
1194 this_attribute =
axes(diag_axis_id)%num_attributes + 1
1196 IF ( this_attribute .GT. max_axis_attributes )
THEN 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.',&
1207 axes(diag_axis_id)%num_attributes = this_attribute
1209 axes(diag_axis_id)%attributes(this_attribute)%name = name
1210 axes(diag_axis_id)%attributes(this_attribute)%type =
type 1212 axes(diag_axis_id)%attributes(this_attribute)%catt =
'' 1218 IF ( .NOT.
PRESENT(ival) )
THEN 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)
1230 ALLOCATE(
axes(diag_axis_id)%attributes(this_attribute)%iatt(length), stat=istat)
1231 IF ( istat.NE.0 )
THEN 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)
1239 axes(diag_axis_id)%attributes(this_attribute)%len = length
1240 axes(diag_axis_id)%attributes(this_attribute)%iatt = ival
1242 IF ( .NOT.
PRESENT(rval) )
THEN 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)
1254 ALLOCATE(
axes(diag_axis_id)%attributes(this_attribute)%fatt(length), stat=istat)
1255 IF ( istat.NE.0 )
THEN 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)&
1264 axes(diag_axis_id)%attributes(this_attribute)%len = length
1265 axes(diag_axis_id)%attributes(this_attribute)%fatt = rval
1267 IF ( .NOT.
PRESENT(cval) )
THEN 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)
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)
1295 INTEGER,
INTENT(in) :: diag_axis_id
1296 CHARACTER(len=*),
INTENT(in) :: att_name
1297 REAL,
INTENT(in) :: att_value
1308 INTEGER,
INTENT(in) :: diag_axis_id
1309 CHARACTER(len=*),
INTENT(in) :: att_name
1310 INTEGER,
INTENT(in) :: att_value
1321 INTEGER,
INTENT(in) :: diag_axis_id
1322 CHARACTER(len=*),
INTENT(in) :: att_name
1323 CHARACTER(len=*),
INTENT(in) :: att_value
1334 INTEGER,
INTENT(in) :: diag_axis_id
1335 CHARACTER(len=*),
INTENT(in) :: att_name
1336 REAL,
DIMENSION(:),
INTENT(in) :: att_value
1338 INTEGER :: num_attributes, len
1339 CHARACTER(len=512) :: err_msg
1350 INTEGER,
INTENT(in) :: diag_axis_id
1351 CHARACTER(len=*),
INTENT(in) :: att_name
1352 INTEGER,
DIMENSION(:),
INTENT(in) :: att_value
1372 TYPE(diag_axis_type),
INTENT(inout) :: out_axis
1373 CHARACTER(LEN=*),
INTENT(out),
OPTIONAL :: err_msg
1378 IF (
PRESENT(err_msg) ) err_msg =
'' 1381 IF ( .NOT._allocated(out_axis%attributes) )
THEN 1382 ALLOCATE(out_axis%attributes(max_axis_attributes), stat=istat)
1383 IF ( istat.NE.0 )
THEN 1387 IF ( fms_error_handler(
'diag_util_mod::attribute_init_axis',
'Unable to allocate memory for diag axis attributes', err_msg) )
THEN 1392 out_axis%num_attributes = 0
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
1420 INTEGER :: length, i, this_attribute
1421 CHARACTER(len=512) :: err_msg_local
1425 IF (
PRESENT(err_msg) ) err_msg =
'' 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 1437 DO i=1, out_axis%num_attributes
1438 IF ( trim(out_axis%attributes(i)%name) .EQ. trim(att_name) )
THEN 1444 IF ( this_attribute > 0 )
THEN 1445 IF ( out_axis%attributes(this_attribute)%type .NE. nf90_char )
THEN 1449 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_axis',&
1450 &
'Attribute "'//trim(att_name)//
'" is not a character attribute.',&
1458 this_attribute = out_axis%num_attributes + 1
1459 IF ( this_attribute .GT. max_axis_attributes )
THEN 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.',&
1471 out_axis%num_attributes = this_attribute
1473 out_axis%attributes(this_attribute)%name = att_name
1474 out_axis%attributes(this_attribute)%type = nf90_char
1476 out_axis%attributes(this_attribute)%catt =
'' 1481 IF ( index(trim(out_axis%attributes(this_attribute)%catt), trim(prepend_value)).EQ.0 )
THEN 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 1488 IF ( fms_error_handler(
'diag_util_mod::prepend_attribute_file',&
1489 &
'Prepend length for attribute "'//trim(att_name)//
'" is longer than allowed.',&
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
1505 integer,
intent(in) :: id
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 1525 integer,
intent(in) :: id
1526 integer,
intent(out),
allocatable :: r(:)
1528 integer iatt, k, k1, k2, n
1531 character(*),
parameter :: tag =
'get_compressed_axes_ids' 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)
1540 do k = 1,axis%num_attributes
1541 if (trim(axis%attributes(k)%name)==
'compress')
then 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)
1556 do k = 1, len(axis%attributes(iatt)%catt)
1557 if (space.and.(axis%attributes(iatt)%catt(k:k)/=
' '))
then 1560 space = (axis%attributes(iatt)%catt(k:k)==
' ')
1569 do k1 = k2+1, len(axis%attributes(iatt)%catt)
1570 if (axis%attributes(iatt)%catt(k1:k1)/=
' ')
exit 1572 do k2 = k1+1, len(axis%attributes(iatt)%catt)
1573 if (axis%attributes(iatt)%catt(k2:k2)==
' ')
exit 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)
integer(int_kind), parameter, public diag_axis_2ddomain
integer function, public get_tile_count(ids)
subroutine, public get_diag_axis_cart(id, cart_name)
subroutine diag_axis_add_attribute_r1d(diag_axis_id, att_name, att_value)
type(domainug) function, public get_domainug(id)
character(len=128) function, public get_axis_aux(id)
type(domain1d) function, public get_domain1d(id)
integer(int_kind), parameter, public diag_axis_ugdomain
integer max_axis_attributes
Maximum number of user definable attributes per axis.
subroutine, public get_diag_axis_name(id, name)
subroutine diag_axis_add_attribute_scalar_r(diag_axis_id, att_name, att_value)
subroutine diag_axis_add_attribute_scalar_c(diag_axis_id, att_name, att_value)
logical function, public fms_error_handler(routine, message, err_msg)
integer function, public diag_subaxes_init(axis, subdata, start_indx, end_indx, domain_2d)
logical module_is_initialized
subroutine, public get_diag_axis_data(id, DATA)
subroutine, public get_diag_axis(id, name, units, long_name, cart_name, direction, edges, Domain, DomainU, DATA, num_attributes, attributes)
subroutine diag_axis_add_attribute_scalar_i(diag_axis_id, att_name, att_value)
type(diag_axis_type), dimension(:), allocatable, save axes
integer(int_kind), parameter, public diag_axis_nodomain
logical function, public axis_is_compressed(id)
subroutine prepend_attribute_axis(out_axis, att_name, prepend_value, err_msg)
integer, dimension(:), allocatable num_subaxes
integer function, public get_axis_global_length(id)
subroutine, public get_axes_shift(ids, ishift, jshift)
character(len=128), dimension(:), allocatable, save axis_sets
integer max_num_axis_sets
type(domain2d), save, public null_domain2d
subroutine, public get_compressed_axes_ids(id, r)
subroutine, public get_diag_axis_domain_name(id, name)
integer max_axes
Maximum number of independent axes.
subroutine attribute_init_axis(out_axis, err_msg)
integer function, public diag_axis_init(name, DATA, units, cart_name, long_name, direction, set_name, edges, Domain, Domain2, DomainU, aux, req, tile_count)
integer function, public get_axis_length(id)
type(domainug), save, public null_domainug
type(domain2d) function, public get_domain2d(ids)
integer, parameter max_subaxes
integer function get_axis_set_num(set_name)
subroutine diag_axis_attribute_init(diag_axis_id, name, type, cval, ival, rval)
************************************************************************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
subroutine diag_axis_add_attribute_i1d(diag_axis_id, att_name, att_value)
integer(int_kind) function, public axis_compatible_check(id, varname)
character(len=128) function, public get_axis_reqfld(id)
integer function, public get_axis_num(axis_name, set_name)
subroutine valid_id_check(id, routine_name)
subroutine, public error_mesg(routine, message, level)
logical debug_diag_manager
type(domain1d), save, public null_domain1d