! Copyright (C) GFD Dennou Club, 2000. All rights reserved subroutine ANAttrGetChar(var, name, value, default, stat) use an_types, only: AN_VARIABLE, an_variable_entry use an_vartable, only: vtable_lookup use netcdf_f77 use dc_url, only: GT_PLUS use dc_string, only: toChar use dc_trace, only: beginsub, endsub use dc_error implicit none type(AN_VARIABLE), intent(in):: var character(len = *), intent(in):: name character(len = *), intent(out):: value character(len = *), intent(in):: default integer, intent(out):: stat type(an_variable_entry):: ent character(len = 64):: buffer double precision, allocatable:: dbuf(:) integer, allocatable:: ibuf(:) character, allocatable:: cbuf(:) integer:: xtype, attrlen, i, iname, varid character(len = *), parameter:: subname = "anattrgetchar" continue call beginsub(subname, "var=%d name=%c default=%c", i=(/var%id/), & & c1=trim(name), c2=trim(default)) stat = vtable_lookup(var, ent) if (stat /= NF_NOERR) goto 900 if (name(1:1) == GT_PLUS) then varid = nf_global iname = 2 else varid = ent%varid iname = 1 endif stat = nf_inq_att(ent%fileid, varid, name(iname:), xtype=xtype, len=attrlen) if (stat /= NF_NOERR) goto 900 if (xtype == NF_CHAR .and. attrlen <= len(buffer)) then stat = nf_get_att_text(ent%fileid, varid, name(iname:), buffer) if (stat /= NF_NOERR) goto 900 value = buffer(1: attrlen) if (attrlen > len(value)) stat = GT_ECHARSHORT else if (xtype == NF_CHAR) then ! UNIDATA NetCDF ライブラリでは文字列引数の長さを ! まったく取得していないので先頭が結合していれば OK のはず allocate(cbuf(attrlen)) stat = nf_get_att_text(ent%fileid, varid, name(iname:), cbuf(1)) if (stat /= NF_NOERR) goto 900 do, i = 1, attrlen value(i:i) = cbuf(i) enddo if (attrlen < len(value)) value(attrlen + 1: ) = ' ' if (attrlen > len(value)) stat = GT_ECHARSHORT deallocate(cbuf) else if (xtype == NF_DOUBLE .or. xtype == NF_FLOAT) then allocate(dbuf(attrlen)) stat = nf_get_att_double(ent%fileid, varid, name(iname:), dbuf) if (stat /= NF_NOERR) goto 900 value = toChar(dbuf) deallocate(dbuf) else allocate(ibuf(attrlen)) stat = nf_get_att_int(ent%fileid, varid, name(iname:), ibuf) if (stat /= NF_NOERR) goto 900 value = toChar(ibuf) deallocate(ibuf) endif call endsub(subname) return ! デフォルト処理 900 continue value = default call endsub(subname, "value := default") return end subroutine