From c43391c43aefec357ac1dd56e005b734164b6209 Mon Sep 17 00:00:00 2001 From: Enrico Fucile Date: Fri, 8 Jul 2016 13:54:08 +0100 Subject: [PATCH] bufr_dump -Efortran and codes_set_string_array fortran ECC-292 ECC-295 --- fortran/eccodes_f90_tail.f90 | 39 +- fortran/grib_api_externals.h | 2 +- fortran/grib_fortran.c | 57 ++- src/CMakeLists.txt | 1 + src/grib_dumper_class.h | 1 + src/grib_dumper_class_fortran.c | 633 +++++++++++++++++++++++++ src/grib_dumper_factory.h | 1 + src/grib_expression_class_is_in_dict.c | 6 +- src/grib_expression_class_is_in_list.c | 6 +- src/grib_value.c | 10 +- tools/bufr_dump.c | 2 +- 11 files changed, 743 insertions(+), 15 deletions(-) create mode 100644 src/grib_dumper_class_fortran.c diff --git a/fortran/eccodes_f90_tail.f90 b/fortran/eccodes_f90_tail.f90 index 3e3db239c..d8fda6aca 100644 --- a/fortran/eccodes_f90_tail.f90 +++ b/fortran/eccodes_f90_tail.f90 @@ -818,7 +818,7 @@ subroutine codes_get_string_array ( gribid, key, value, status ) if (present(status)) then status = iret else - call grib_check(iret,'grib_get',key) + call grib_check(iret,'codes_get',key) endif end if @@ -833,11 +833,46 @@ subroutine codes_get_string_array ( gribid, key, value, status ) if (present(status)) then status = iret else - call grib_check(iret,'grib_get',key) + call grib_check(iret,'codes_get',key) endif end subroutine codes_get_string_array +subroutine codes_set_string_array ( gribid, key, value, status ) + integer(kind=kindOfInt), intent(in) :: gribid + character(len=*), intent(in) :: key + character(len=*), dimension(:),allocatable, intent(in) :: value + integer(kind=kindOfInt),optional, intent(out) :: status + + character :: cvalue(size(value)*len(value(0))) + character :: svalue(len(value(0))) + integer(kind=kindOfInt) :: iret + integer(kind=kindOfInt) :: nb_values + integer(kind=kindOfInt) :: slen + integer(kind=kindOfInt) :: i,s,j,l + + nb_values=size(value) + slen=len(value(0)) + j=1 + do i=1,nb_values + cvalue(j:j+slen-1)=transfer(value(i),svalue) + j=j+slen + enddo + + iret=grib_f_set_string_array ( gribid, key, cvalue , nb_values, slen ) + + if (iret /= 0) then + call grib_f_write_on_fail(gribid) + endif + if (present(status)) then + status = iret + else + call grib_check(iret,'codes_set',key) + endif + +end subroutine codes_set_string_array + + ! Note: This function supports the allocatable array attribute ! ------------------------------------------------------------- subroutine codes_get_int_array ( gribid, key, value, status ) diff --git a/fortran/grib_api_externals.h b/fortran/grib_api_externals.h index d7a6d2e8b..ffa1fedf3 100644 --- a/fortran/grib_api_externals.h +++ b/fortran/grib_api_externals.h @@ -57,7 +57,7 @@ integer, external :: grib_f_set_int, grib_f_set_int_array, & grib_f_set_real4, grib_f_set_real4_array, & grib_f_set_real8, grib_f_set_real8_array, & grib_f_set_force_real4_array, grib_f_set_force_real8_array, & - grib_f_set_string, grib_f_set_missing, & + grib_f_set_string, grib_f_set_string_array, grib_f_set_missing, & grib_f_gribex_mode_on,grib_f_gribex_mode_off, & grib_f_find_nearest_single,grib_f_find_nearest_four_single,grib_f_find_nearest_multiple integer, external :: grib_f_get_message_size, grib_f_copy_message, grib_f_count_in_file diff --git a/fortran/grib_fortran.c b/fortran/grib_fortran.c index 9009e8796..72baa838e 100644 --- a/fortran/grib_fortran.c +++ b/fortran/grib_fortran.c @@ -153,6 +153,16 @@ static char* cast_char(char* buf, char* fortstr,int len) return buf; } +static char* cast_char_no_cut(char* buf, char* fortstr,int len) +{ + char *p,*end; + if (len == 0 || fortstr == NULL) return NULL; + memcpy(buf,fortstr,len); + buf[len]='\0'; + + return buf; +} + static void czstr_to_fortran(char* str,int len) { char *p,*end; @@ -2729,10 +2739,10 @@ int grib_f_get_string_array_(int* gid, char* key, char* val,int* nvals,int* slen for (i=0;icontext,cval[i]); p+= *slen; } grib_context_free(h->context,cval); - /*remember to deallocate each string*/ return err; } @@ -2744,6 +2754,45 @@ int grib_f_get_string_array(int* gid, char* key, char* val,int* nvals,int* slen, return grib_f_get_string_array_( gid, key, val, nvals, slen, len); } + +/*****************************************************************************/ +int grib_f_set_string_array_(int* gid, char* key, char* val,int* nvals,int* slen,int len) +{ + grib_handle *h = get_handle(*gid); + int err = GRIB_SUCCESS; + size_t i; + char buf[1024]; + size_t lsize = *nvals; + char** cval=0; + char* p=val; + grib_context* c=h->context; + + if(!h) return GRIB_INVALID_GRIB; + + cval=(char**)grib_context_malloc_clear(h->context,sizeof(char*)*lsize); + for (i=0;i +/* + This is used by make_class.pl + + START_CLASS_DEF + CLASS = dumper + IMPLEMENTS = dump_long;dump_bits + IMPLEMENTS = dump_double;dump_string;dump_string_array + IMPLEMENTS = dump_bytes;dump_values + IMPLEMENTS = dump_label;dump_section + IMPLEMENTS = init;destroy + IMPLEMENTS = header;footer + MEMBERS = long section_offset + MEMBERS = long begin + MEMBERS = long empty + MEMBERS = long end + MEMBERS = long isLeaf + MEMBERS = long isAttribute + MEMBERS = grib_string_list* keys + END_CLASS_DEF + + */ + + +/* START_CLASS_IMP */ + +/* + +Don't edit anything between START_CLASS_IMP and END_CLASS_IMP +Instead edit values between START_CLASS_DEF and END_CLASS_DEF +or edit "dumper.class" and rerun ./make_class.pl + +*/ + +static void init_class (grib_dumper_class*); +static int init (grib_dumper* d); +static int destroy (grib_dumper*); +static void dump_long (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_bits (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_double (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_string (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_string_array (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_bytes (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_values (grib_dumper* d, grib_accessor* a); +static void dump_label (grib_dumper* d, grib_accessor* a,const char* comment); +static void dump_section (grib_dumper* d, grib_accessor* a,grib_block_of_accessors* block); +static void header (grib_dumper*,grib_handle*); +static void footer (grib_dumper*,grib_handle*); + +typedef struct grib_dumper_fortran { + grib_dumper dumper; +/* Members defined in fortran */ + long section_offset; + long begin; + long empty; + long end; + long isLeaf; + long isAttribute; + grib_string_list* keys; +} grib_dumper_fortran; + + +static grib_dumper_class _grib_dumper_class_fortran = { + 0, /* super */ + "fortran", /* name */ + sizeof(grib_dumper_fortran), /* size */ + 0, /* inited */ + &init_class, /* init_class */ + &init, /* init */ + &destroy, /* free mem */ + &dump_long, /* dump long */ + &dump_double, /* dump double */ + &dump_string, /* dump string */ + &dump_string_array, /* dump string array */ + &dump_label, /* dump labels */ + &dump_bytes, /* dump bytes */ + &dump_bits, /* dump bits */ + &dump_section, /* dump section */ + &dump_values, /* dump values */ + &header, /* header */ + &footer, /* footer */ +}; + +grib_dumper_class* grib_dumper_class_fortran = &_grib_dumper_class_fortran; + +/* END_CLASS_IMP */ +static void dump_attributes(grib_dumper* d,grib_accessor* a); + +GRIB_INLINE static int grib_inline_strcmp(const char* a,const char* b) +{ + if (*a != *b) return 1; + while((*a!=0 && *b!=0) && *(a) == *(b) ) {a++;b++;} + return (*a==0 && *b==0) ? 0 : 1; +} + +typedef struct string_count string_count; +struct string_count { + char* value; + int count; + string_count* next; +}; + +static int get_key_rank(grib_handle* h,grib_string_list* keys,const char* key) +{ + grib_string_list* next=keys; + grib_string_list* prev=keys; + int ret=0; + size_t size=0; + grib_context* c=h->context; + + while (next && next->value && grib_inline_strcmp(next->value,key)) { + prev=next; + next=next->next; + } + if (!next) { + prev->next=(grib_string_list*)grib_context_malloc_clear(c,sizeof(grib_string_list)); + next=prev->next; + } + if (!next->value) { + next->value=strdup(key); + next->count=0; + } + + next->count++; + ret=next->count; + if (ret==1) { + char* s=grib_context_malloc_clear(c,strlen(key)+5); + sprintf(s,"#2#%s",key); + if (grib_get_size(h,s,&size)==GRIB_NOT_FOUND) ret=0; + } + + return ret; +} + +static int depth=0; + +static void init_class (grib_dumper_class* c){} + +static int init(grib_dumper* d) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + grib_context* c=d->handle->context; + self->section_offset=0; + self->empty=1; + self->isLeaf=0; + self->isAttribute=0; + self->keys=grib_context_malloc_clear(c,sizeof(grib_string_list)); + + return GRIB_SUCCESS; +} + +static int destroy(grib_dumper* d) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + grib_string_list* next=self->keys; + grib_string_list* cur=self->keys; + grib_context* c=d->handle->context; + while(next) { + cur=next; + next=next->next; + grib_context_free(c,cur->value); + grib_context_free(c,cur); + } + return GRIB_SUCCESS; +} + +static char* dval_to_string(grib_context* c,double v) { + char* sval=grib_context_malloc_clear(c,sizeof(char)*40); + char* p; + sprintf(sval,"%.18e",v); + p=sval; + while (*p !=0 ) { + if (*p == 'e') *p='d'; + p++; + } + return sval; +} + +static void dump_values(grib_dumper* d,grib_accessor* a) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + double value; size_t size = 1; + double *values=NULL; + int err = 0; + int i,r,icount; + int cols=2; + long count=0; + char* sval; + grib_context* c=a->context; + grib_handle* h=grib_handle_of_accessor(a); + + grib_value_count(a,&count); + size=count; + + if ( (a->flags & GRIB_ACCESSOR_FLAG_DUMP) == 0 || (a->flags & GRIB_ACCESSOR_FLAG_READ_ONLY) !=0) + return; + + if (size>1) { + values=(double*)grib_context_malloc_clear(c,sizeof(double)*size); + err=grib_unpack_double(a,values,&size); + } else { + err=grib_unpack_double(a,&value,&size); + } + + self->begin=0; + self->empty=0; + + if (size>1) { + + fprintf(self->dumper.out," if(allocated(rvalues)) deallocate(rvalues)\n"); + fprintf(self->dumper.out," allocate(rvalues(%d))\n",size); + + + fprintf(self->dumper.out," rvalues=(/"); + + icount=0; + for (i=0; icols || i==0) {fprintf(self->dumper.out," &\n ");icount=0;} + sval=dval_to_string(c,values[i]); + fprintf(self->dumper.out,"%s, ", sval); + grib_context_free(c,sval); + icount++; + } + if (icount>cols || i==0) {fprintf(self->dumper.out," &\n ");icount=0;} + sval=dval_to_string(c,values[i]); + fprintf(self->dumper.out,"%s", sval); + grib_context_free(c,sval); + + depth-=2; + fprintf(self->dumper.out,"/)\n"); + grib_context_free(c,values); + + if ((r=get_key_rank(h,self->keys,a->name))!=0) + fprintf(self->dumper.out," call codes_set(ibufr,'#%d#%s',rvalues)\n",r,a->name); + else + fprintf(self->dumper.out," call codes_set(ibufr,'%s',rvalues)\n",a->name); + } else { + r=get_key_rank(h,self->keys,a->name); + if( !grib_is_missing_double(a,value) ) { + + sval=dval_to_string(c,value); + if (r!=0) + fprintf(self->dumper.out," call codes_set(ibufr,'#%d#%s',%s)\n",r,a->name,sval); + else + fprintf(self->dumper.out," call codes_set(ibufr,'%s',%s)\n",a->name,sval); + + grib_context_free(c,sval); + + } + } + + if (self->isLeaf==0) { + dump_attributes(d,a); + depth-=2; + } + + (void)err; /* TODO */ +} + +static void dump_long(grib_dumper* d,grib_accessor* a,const char* comment) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + long value; size_t size = 1; + long *values=NULL; + int err = 0; + int i,r,icount; + int cols=4; + long count=0; + grib_handle* h=grib_handle_of_accessor(a); + + grib_value_count(a,&count); + size=count; + + if ( (a->flags & GRIB_ACCESSOR_FLAG_DUMP) == 0 || (a->flags & GRIB_ACCESSOR_FLAG_READ_ONLY) != 0) + return; + + if (size>1) { + values=(long*)grib_context_malloc_clear(a->context,sizeof(long)*size); + err=grib_unpack_long(a,values,&size); + } else { + err=grib_unpack_long(a,&value,&size); + } + + self->begin=0; + self->empty=0; + + if (size>1) { + fprintf(self->dumper.out," if(allocated(ivalues)) deallocate(ivalues)\n"); + fprintf(self->dumper.out," allocate(ivalues(%d))\n",size); + + + fprintf(self->dumper.out," ivalues=(/"); + icount=0; + for (i=0;icols || i==0) {fprintf(self->dumper.out," &\n ");icount=0;} + fprintf(self->dumper.out,"%ld, ",values[i]); + icount++; + } + if (icount>cols || i==0) {fprintf(self->dumper.out," &\n ");icount=0;} + fprintf(self->dumper.out,"%ld ",values[i]); + + depth-=2; + fprintf(self->dumper.out,"/)\n"); + grib_context_free(a->context,values); + + if ((r=get_key_rank(h,self->keys,a->name))!=0) + fprintf(self->dumper.out," call codes_set(ibufr,'#%d#%s',ivalues)\n",r,a->name); + else + fprintf(self->dumper.out," call codes_set(ibufr,'%s',ivalues)\n",a->name); + + } else { + r=get_key_rank(h,self->keys,a->name); + if( !grib_is_missing_long(a,value) ) { + if (r!=0) + fprintf(self->dumper.out," call codes_set(ibufr,'#%d#%s',",r,a->name); + else + fprintf(self->dumper.out," call codes_set(ibufr,'%s',",a->name); + + fprintf(self->dumper.out,"%ld)\n",value); + } + } + + if (self->isLeaf==0) { + dump_attributes(d,a); + depth-=2; + } + (void)err; /* TODO */ +} + +static void dump_bits(grib_dumper* d,grib_accessor* a,const char* comment) +{ +} + +static void dump_double(grib_dumper* d,grib_accessor* a,const char* comment) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + double value; size_t size = 1; + int r; + char* sval; + grib_handle* h=grib_handle_of_accessor(a); + grib_context* c=h->context; + + grib_unpack_double(a,&value,&size); + if ( (a->flags & GRIB_ACCESSOR_FLAG_DUMP) == 0 || (a->flags & GRIB_ACCESSOR_FLAG_READ_ONLY) != 0) + return; + + self->begin=0; + self->empty=0; + + r=get_key_rank(h,self->keys,a->name); + if( !grib_is_missing_double(a,value) ) { + sval=dval_to_string(c,value); + if (r!=0) + fprintf(self->dumper.out," call codes_set(ibufr,'#%d#%s',%s)\n",r,a->name,sval); + else + fprintf(self->dumper.out," call codes_set(ibufr,'%s',%s)\n",a->name,sval); + + grib_context_free(c,sval); + } + + if (self->isLeaf==0) { + dump_attributes(d,a); + } +} + +static void dump_string_array(grib_dumper* d,grib_accessor* a,const char* comment) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + char **values; + size_t size = 0,i=0; + grib_context* c=NULL; + int err = 0; + long count=0; + int r; + grib_handle* h=grib_handle_of_accessor(a); + + c=a->context; + + if ( (a->flags & GRIB_ACCESSOR_FLAG_DUMP) == 0 || (a->flags & GRIB_ACCESSOR_FLAG_READ_ONLY) != 0) + return; + + grib_value_count(a,&count); + size=count; + if (size==1) { + dump_string(d,a,comment); + return; + } + + fprintf(self->dumper.out," if(allocated(svalues)) deallocate(svalues)\n"); + fprintf(self->dumper.out," allocate(svalues(%d))\n",size); + + fprintf(self->dumper.out," svalues=(/"); + + self->begin=0; + + self->empty=0; + + values=(char**)grib_context_malloc_clear(c,size*sizeof(char*)); + if (!values) { + grib_context_log(c,GRIB_LOG_FATAL,"unable to allocate %d bytes",(int)size); + return; + } + + err = grib_unpack_string_array(a,values,&size); + + for (i=0;idumper.out," \"%s\", &\n",values[i]); + } + fprintf(self->dumper.out," \"%s\" /)\n",values[i]); + + + if (self->isLeaf==0) { + if ((r=get_key_rank(h,self->keys,a->name))!=0) + fprintf(self->dumper.out," call codes_set_string_array(ibufr,'#%d#%s',svalues)\n",r,a->name); + else + fprintf(self->dumper.out," call codes_set_string_array(ibufr,'%s',svalues)\n",a->name); + } + + if (self->isLeaf==0) { + dump_attributes(d,a); + depth-=2; + } + + grib_context_free(c,values); + (void)err; /* TODO */ +} + +static void dump_string(grib_dumper* d,grib_accessor* a,const char* comment) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + char *value=NULL; + char *p = NULL; + size_t size = 0; + grib_context* c=NULL; + int r; + int err = _grib_get_string_length(a,&size); + grib_handle* h=grib_handle_of_accessor(a); + + c=a->context; + if (size==0) return; + + if ( (a->flags & GRIB_ACCESSOR_FLAG_DUMP) == 0 || (a->flags & GRIB_ACCESSOR_FLAG_READ_ONLY) != 0) + return; + + value=(char*)grib_context_malloc_clear(c,size); + if (!value) { + grib_context_log(c,GRIB_LOG_FATAL,"unable to allocate %d bytes",(int)size); + return; + } + + else self->begin=0; + + self->empty=0; + + err = grib_unpack_string(a,value,&size); + p=value; + r=get_key_rank(h,self->keys,a->name); + if (grib_is_missing_string(a,(unsigned char *)value,size)) + return; + + while(*p) { if(!isprint(*p)) *p = '.'; p++; } + + if (self->isLeaf==0) { + depth+=2; + if (r!=0) + fprintf(self->dumper.out," call codes_set(ibufr,'#%d#%s',",r,a->name); + else + fprintf(self->dumper.out," call codes_set(ibufr,'%s',",a->name); + } + fprintf(self->dumper.out,"\'%s\')\n",value); + + + if (self->isLeaf==0) { + dump_attributes(d,a); + depth-=2; + } + + grib_context_free(c,value); + (void)err; /* TODO */ +} + +static void dump_bytes(grib_dumper* d,grib_accessor* a,const char* comment) +{ +} + +static void dump_label(grib_dumper* d,grib_accessor* a,const char* comment) +{ +} + +static void _dump_long_array(grib_handle* h,FILE* f,const char* key,const char* print_key) { + long* val; + size_t size=0,i; + int cols=9,icount=0; + + + if (grib_get_size(h,key,&size)==GRIB_NOT_FOUND) return; + + fprintf(f," if(allocated(ivalues)) deallocate(ivalues)\n"); + fprintf(f," allocate(ivalues(%d))\n",size); + + fprintf(f," ivalues=(/ ",print_key); + + val=grib_context_malloc_clear(h->context,sizeof(long)*size); + grib_get_long_array(h,key,val,&size); + for (i=0;icols || i==0) {fprintf(f," &\n ");icount=0;} + fprintf(f,"%ld, ",val[i]); + icount++; + } + if (icount>cols) {fprintf(f," &\n ");} + fprintf(f,"%ld /)\n",val[size-1]); + + grib_context_free(h->context,val); + fprintf(f," call codes_set(ibufr,'%s',ivalues)\n",print_key); + +} + +static void dump_section(grib_dumper* d,grib_accessor* a,grib_block_of_accessors* block) +{ + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + if (!grib_inline_strcmp(a->name,"BUFR") || + !grib_inline_strcmp(a->name,"GRIB") || + !grib_inline_strcmp(a->name,"META") + ) { + grib_handle* h=grib_handle_of_accessor(a); + depth=2; + self->begin=1; + self->empty=1; + depth+=2; + _dump_long_array(h,self->dumper.out,"dataPresentIndicator","inputDataPresentIndicator"); + _dump_long_array(h,self->dumper.out,"delayedDescriptorReplicationFactor","inputDelayedDescriptorReplicationFactor"); + _dump_long_array(h,self->dumper.out,"shortDelayedDescriptorReplicationFactor","inputShortDelayedDescriptorReplicationFactor"); + _dump_long_array(h,self->dumper.out,"extendedDelayedDescriptorReplicationFactor","inputExtendedDelayedDescriptorReplicationFactor"); + grib_dump_accessors_block(d,block); + depth-=2; + } else if (!grib_inline_strcmp(a->name,"groupNumber")) { + if ( (a->flags & GRIB_ACCESSOR_FLAG_DUMP) == 0) + return; + self->begin=1; + self->empty=1; + depth+=2; + grib_dump_accessors_block(d,block); + depth-=2; + } else { + grib_dump_accessors_block(d,block); + } +} + +static void dump_attributes(grib_dumper* d,grib_accessor* a) +{ + int i=0; + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + /* FILE* out=self->dumper.out; */ + unsigned long flags; + while (a->attributes[i] && i < MAX_ACCESSOR_ATTRIBUTES) { + self->isAttribute=1; + if ( (d->option_flags & GRIB_DUMP_FLAG_ALL_ATTRIBUTES ) == 0 + && (a->attributes[i]->flags & GRIB_ACCESSOR_FLAG_DUMP)== 0 ) + { + i++; + continue; + } + self->isLeaf=a->attributes[i]->attributes[0]==NULL ? 1 : 0; + /* fprintf(self->dumper.out,","); */ + /* fprintf(self->dumper.out,"\n%-*s",depth," "); */ + /* fprintf(out,"\"%s\" : ",a->attributes[i]->name); */ + flags=a->attributes[i]->flags; + a->attributes[i]->flags |= GRIB_ACCESSOR_FLAG_DUMP; + /* switch (grib_accessor_get_native_type(a->attributes[i])) { */ + /* case GRIB_TYPE_LONG: */ + /* dump_long(d,a->attributes[i],0); */ + /* break; */ + /* case GRIB_TYPE_DOUBLE: */ + /* dump_values(d,a->attributes[i]); */ + /* break; */ + /* case GRIB_TYPE_STRING: */ + /* dump_string_array(d,a->attributes[i],0); */ + /* break; */ + /* } */ + a->attributes[i]->flags=flags; + i++; + } + self->isLeaf=0; + self->isAttribute=0; +} + +static void header(grib_dumper* d,grib_handle* h) { + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + fprintf(self->dumper.out,"! This program has been automatically generated with bufr_dump -Efortran\n"); + fprintf(self->dumper.out,"program bufr_create_message\n"); + fprintf(self->dumper.out," use eccodes\n"); + fprintf(self->dumper.out," implicit none\n"); + fprintf(self->dumper.out," integer :: iret\n"); + fprintf(self->dumper.out," integer :: infile,outfile\n"); + fprintf(self->dumper.out," integer :: ibufr\n"); + fprintf(self->dumper.out," integer :: count=0\n"); + fprintf(self->dumper.out," integer(kind=4), dimension(:), allocatable :: ivalues\n"); + fprintf(self->dumper.out," integer :: strsize\n"); + fprintf(self->dumper.out," integer, parameter :: max_strsize = 100\n"); + fprintf(self->dumper.out," character(len=max_strsize) , dimension(:),allocatable :: svalues\n"); + fprintf(self->dumper.out," real(kind=8), dimension(:), allocatable :: rvalues\n"); + fprintf(self->dumper.out,"\n\n call codes_open_file(infile,'infile.bufr','r')\n"); + fprintf(self->dumper.out," call codes_bufr_new_from_file(infile,ibufr,iret)\n"); + fprintf(self->dumper.out," if (iret/=CODES_SUCCESS) then\n"); + fprintf(self->dumper.out," print *,'ERROR reading BUFR from input file'\n"); + fprintf(self->dumper.out," stop 1\n"); + fprintf(self->dumper.out," endif\n"); +} + +static void footer(grib_dumper* d,grib_handle* h) { + grib_dumper_fortran *self = (grib_dumper_fortran*)d; + fprintf(self->dumper.out," call codes_set(ibufr,'pack',1)\n"); + fprintf(self->dumper.out," call codes_open_file(outfile,'outfile.bufr','w')\n"); + fprintf(self->dumper.out," call codes_write(ibufr,outfile)\n"); + fprintf(self->dumper.out," call codes_close_file(outfile)\n"); + fprintf(self->dumper.out," call codes_close_file(infile)\n"); + fprintf(self->dumper.out," call codes_release(ibufr)\n"); + fprintf(self->dumper.out," if(allocated(ivalues)) deallocate(ivalues)\n"); + fprintf(self->dumper.out," if(allocated(rvalues)) deallocate(rvalues)\n"); + fprintf(self->dumper.out," if(allocated(svalues)) deallocate(svalues)\n"); + fprintf(self->dumper.out,"end program bufr_create_message\n"); +} diff --git a/src/grib_dumper_factory.h b/src/grib_dumper_factory.h index 7cdc651f3..5a0bf66dc 100644 --- a/src/grib_dumper_factory.h +++ b/src/grib_dumper_factory.h @@ -3,6 +3,7 @@ { "debug", &grib_dumper_class_debug, }, { "default", &grib_dumper_class_default, }, { "filter", &grib_dumper_class_filter, }, +{ "fortran", &grib_dumper_class_fortran, }, { "json", &grib_dumper_class_json, }, { "keys", &grib_dumper_class_keys, }, { "serialize", &grib_dumper_class_serialize, }, diff --git a/src/grib_expression_class_is_in_dict.c b/src/grib_expression_class_is_in_dict.c index e12a62547..21d0e92a8 100644 --- a/src/grib_expression_class_is_in_dict.c +++ b/src/grib_expression_class_is_in_dict.c @@ -72,9 +72,9 @@ static grib_expression_class _grib_expression_class_is_in_dict = { &init_class, /* init_class */ 0, /* constructor */ 0, /* destructor */ - &print, - &compile, - &add_dependency, + &print, + &compile, + &add_dependency, &native_type, &get_name, diff --git a/src/grib_expression_class_is_in_list.c b/src/grib_expression_class_is_in_list.c index cf1bfbdd4..ec21a0d4a 100644 --- a/src/grib_expression_class_is_in_list.c +++ b/src/grib_expression_class_is_in_list.c @@ -74,9 +74,9 @@ static grib_expression_class _grib_expression_class_is_in_list = { &init_class, /* init_class */ 0, /* constructor */ &destroy, /* destructor */ - &print, - &compile, - &add_dependency, + &print, + &compile, + &add_dependency, &native_type, &get_name, diff --git a/src/grib_value.c b/src/grib_value.c index 8f2c8fa13..2a1027ff5 100644 --- a/src/grib_value.c +++ b/src/grib_value.c @@ -787,7 +787,15 @@ static int _grib_set_long_array(grib_handle* h, const char* name, const long* va { size_t encoded = 0; grib_accessor* a = grib_find_accessor(h, name); - int err = a ?_grib_set_long_array_internal(h,a,val,length,&encoded,check) : GRIB_NOT_FOUND ; + int err =0; + + if (!a) return GRIB_NOT_FOUND ; + if (name[0]=='/' || name[0]=='#' ) { + if(check && (a->flags & GRIB_ACCESSOR_FLAG_READ_ONLY)) + return GRIB_READ_ONLY; + err=grib_pack_long(a, val, &length); + encoded=length; + } else err=_grib_set_long_array_internal(h,a,val,length,&encoded,check); if(err == GRIB_SUCCESS && length > encoded) err = GRIB_ARRAY_TOO_SMALL; diff --git a/tools/bufr_dump.c b/tools/bufr_dump.c index ba27e5790..3157df967 100644 --- a/tools/bufr_dump.c +++ b/tools/bufr_dump.c @@ -21,7 +21,7 @@ grib_option grib_options[]={ "\n\t\tOptions: s->structure, f->flat (only data), a->all attributes" "\n\t\tDefault mode is structure.\n", 1,1,"s"}, - {"E:","filter/Fortran/python","\n\t\tEncoding dump. Provides instructions to create the input message." + {"E:","filter/fortran/python","\n\t\tEncoding dump. Provides instructions to create the input message." "\n\t\tOptions: filter -> filter instructions file to encode input BUFR" "\n\t\t fortran -> fortran program to encode the input BUFR" "\n\t\t python -> python script to encode the input BUFR"